{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}

import           Control.Monad
import           Data.Aeson
import qualified Data.ByteString.Lazy as BSL
import           Data.KindID
import           Data.KindID.Class
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.String
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.TypeID
import           Data.TypeID.Class
import           Data.TypeID.Error
import           Data.UUID.V7 (UUID)
import qualified Data.UUID.V7 as V7
import           GHC.Generics (Generic)
import           Test.Hspec

data TestData = TestData { name   :: String
                         , typeid :: String
                         , prefix :: Maybe Text
                         , uuid   :: Maybe String }
  deriving (Generic, FromJSON, ToJSON)

data TestDataUUID = TestDataUUID { name   :: String
                                 , typeid :: TypeID
                                 , prefix :: Text
                                 , uuid   :: UUID }
  deriving (Generic, FromJSON, ToJSON)

data Prefix = User | Post | Comment

instance ToPrefix 'User where
  type PrefixSymbol 'User = "user"

instance ToPrefix 'Post where
  type PrefixSymbol 'Post = "post"

instance ToPrefix 'Comment where
  type PrefixSymbol 'Comment = "comment"

anyTypeIDError :: Selector TypeIDError
anyTypeIDError = const True

withCheck :: HasCallStack => (IDConv a, IDGen a) => IO a -> IO a
withCheck action = do
  tid         <- action
  checkResult <- checkIDWithEnv tid
  case checkResult of
    Just _  -> do
      expectationFailure $ concat ["The ID ", id2String tid, " does not pass validity check"]
      undefined
    Nothing -> pure tid

withChecks :: HasCallStack => IDGen a => IO [a] -> IO [a]
withChecks action = do
  tids        <- action
  checkResult <- msum <$> mapM checkIDWithEnv tids
  case checkResult of
    Just _  -> expectationFailure "The IDs do not pass validity check" >> undefined
    Nothing -> pure tids

main :: IO ()
main = do
  invalid   <- BSL.readFile "test/invalid.json" >>= throwDecode :: IO [TestData]
  valid     <- BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestData]
  validUUID <- BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestDataUUID]

  hspec do
    describe "Generate TypeID" do
      it "can generate TypeID with prefix" do
        start <- V7.getEpochMilli
        tid   <- withCheck $ genID @TypeID "mmzk"
        end   <- V7.getEpochMilli
        getPrefix tid `shouldBe` "mmzk"
        getTime tid `shouldSatisfy` \t -> t >= start && t <= end
      it "can generate TypeID without prefix" do
        start <- V7.getEpochMilli
        tid   <- withCheck $ genID @TypeID ""
        end   <- V7.getEpochMilli
        getPrefix tid `shouldBe` ""
        getTime tid `shouldSatisfy` \t -> t >= start && t <= end
      it "can generate TypeID with stateless UUIDv7" do
        start <- V7.getEpochMilli
        tid   <- withCheck $ genID' @TypeID "mmzk"
        end   <- V7.getEpochMilli
        getPrefix tid `shouldBe` "mmzk"
        getTime tid `shouldSatisfy` \t -> t >= start && t <= end
      it "can generate in batch with same timestamp and in ascending order" do
        start <- V7.getEpochMilli
        tids  <- withChecks $ genIDs @TypeID "mmzk" 1526
        end   <- V7.getEpochMilli
        all ((== "mmzk") . getPrefix) tids `shouldBe` True
        let timestamp = getTime $ head tids
        all ((== timestamp) . getTime) tids `shouldBe` True
        all (uncurry (<)) (zip tids $ tail tids) `shouldBe` True
        timestamp `shouldSatisfy` \t -> t >= start && t <= end
      it "can parse TypeID from String" do
        case string2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of
          Left err  -> expectationFailure $ "Parse error: " ++ show err
          Right tid -> getPrefix tid `shouldBe` "mmzk"

    describe "Parse TypeID" do
      let invalidPrefixes = [ ("caps", "PREFIX")
                            , ("numeric", "12323")
                            , ("symbols", "pre.fix")
                            , ("spaces", "  ")
                            , ("long", "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz")
                            , ("ascii", "château") ]
      describe "can detect invalid prefix" do
        forM_ invalidPrefixes \(reason, prefix) -> it reason do
          genID @TypeID prefix `shouldThrow` anyTypeIDError
          case decorate @TypeID prefix V7.nil of
            Left _  -> pure ()
            Right _ -> expectationFailure "Should not be able to decorate with invalid prefix"
      let invalidSuffixes = [ ("spaces", " ")
                            , ("short", "01234")
                            , ("long", "012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789")
                            , ("caps", "00041061050R3GG28A1C60T3GF") -- Would be valid in lowercase
                            , ("hyphens", "00041061050-3gg28a1-60t3gf")
                            , ("crockford_ambiguous", "ooo41o61o5or3gg28a1c6ot3gi") -- Would be valid if we followed Crockford's substitution rules
                            , ("symbols", "00041061050.3gg28a1_60t3gf")
                            , ("wrong_alphabet", "ooooooiiiiiiuuuuuuulllllll") ]
      describe "can detect invalid suffix" do
        forM_ invalidSuffixes \(reason, suffix) -> it reason do
          case string2ID @TypeID suffix of
            Left _    -> pure ()
            Right tid -> expectationFailure $ "Parsed TypeID: " ++ show tid

    describe "Parse special values" do
      let specialValues = [ ("nil", "00000000000000000000000000", "00000000-0000-0000-0000-000000000000")
                          , ("one", "00000000000000000000000001", "00000000-0000-0000-0000-000000000001")
                          , ("ten", "0000000000000000000000000a", "00000000-0000-0000-0000-00000000000a")
                          , ("sixteen", "0000000000000000000000000g", "00000000-0000-0000-0000-000000000010")
                          , ("thirty-two", "00000000000000000000000010", "00000000-0000-0000-0000-000000000020") ]
      forM_ specialValues \(reason, tid, uuid) -> it reason do
        case string2ID @TypeID tid of
          Left err  -> expectationFailure $ "Parse error: " ++ show err
          Right tid -> show (getUUID tid) `shouldBe` uuid

    describe "TypeID valid JSON instances" do
      it "Decode and then encode should be identity" do
        tid  <- genID @TypeID "mmzk"
        tid' <- genID @TypeID "foo"
        let mapping = M.fromList [(tid, tid')]
        let json    = encode mapping
        decode json `shouldBe` Just mapping
        fmap encode (decode @(Map TypeID TypeID) json) `shouldBe` Just json
      describe "Valid JSON value" do
        forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do
          case decode @TypeID (fromString $ show tid) of
            Nothing  -> expectationFailure "Parse JSON failed!"
            Just tid -> do
              getPrefix tid `shouldBe` prefix
              show (getUUID tid) `shouldBe` uuid
      describe "Valid JSON key" do
        forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do
          case decode @(Map TypeID Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of
            Nothing      -> expectationFailure "Parse JSON failed!"
            Just mapping -> do
              let (tid, _) = M.elemAt 0 mapping
              getPrefix tid `shouldBe` prefix
              show (getUUID tid) `shouldBe` uuid

    describe "TypeID invalid JSON instances" do
      describe "Invalid JSON value" do
        forM_ invalid \(TestData name tid _ _) -> it name do
          case decode @TypeID (fromString $ show tid) of
            Nothing  -> pure ()
            Just tid -> expectationFailure $ "Parsed TypeID: " ++ show tid
      describe "Invalid JSON key" do
        forM_ invalid \(TestData name tid _ _) -> it name do
          case decode @(Map TypeID Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of
            Nothing  -> pure ()
            Just tid -> expectationFailure "Invalid TypeID key shouldn't be parsed!"

    describe "Test invalid.json" do
      forM_ invalid \(TestData name tid _ _) -> it name do
        case string2ID @TypeID tid of
          Left _    -> pure ()
          Right tid -> expectationFailure $ "Parsed TypeID: " ++ show tid

    describe "Test valid.json (TypeID as literal)" do
      forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do
        case string2ID @TypeID tid of
          Left err  -> expectationFailure $ "Parse error: " ++ show err
          Right tid -> do
            getPrefix tid `shouldBe` prefix
            show (getUUID tid) `shouldBe` uuid

    describe "Test valid.json (TypeID as JSON)" do
      forM_ validUUID \(TestDataUUID name tid prefix uuid) -> it name do
        getPrefix tid `shouldBe` prefix
        getUUID tid `shouldBe` uuid

    describe "Generate type-level TypeID (KindID) with 'Symbol' prefixes" do
      it "can generate KindID with prefix" do
        start <- V7.getEpochMilli
        kid   <- withCheck $ genID @(KindID "mmzk")
        end   <- V7.getEpochMilli
        getPrefix kid `shouldBe` "mmzk"
        getTime kid `shouldSatisfy` \t -> start <= t && t <= end
      it "can generate KindID without prefix" do
        start <- V7.getEpochMilli
        kid   <- withCheck $ genID @(KindID "")
        end   <- V7.getEpochMilli
        getPrefix kid `shouldBe` ""
        getTime kid `shouldSatisfy` \t -> start <= t && t <= end
      it "can generate KindID with stateless UUID v7" do
        start <- V7.getEpochMilli
        kid   <- withCheck $ genID' @(KindID "mmzk")
        end   <- V7.getEpochMilli
        getPrefix kid `shouldBe` "mmzk"
      it "can generate in batch with same timestamp and in ascending order" do
        start <- V7.getEpochMilli
        kids  <- withChecks $ genIDs @(KindID "mmzk") 1526
        end   <- V7.getEpochMilli
        all ((== "mmzk") . getPrefix) kids `shouldBe` True
        let timestamp = getTime $ head kids
        all ((== timestamp) . getTime) kids `shouldBe` True
        all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True
        timestamp `shouldSatisfy` \t -> start <= t && t <= end
      it "can parse KindID from String" do
        case string2ID @(KindID "mmzk") "mmzk_00041061050r3gg28a1c60t3gf" of
          Left err  -> expectationFailure $ "Parse error: " ++ show err
          Right kid -> getPrefix kid `shouldBe` "mmzk"
      it "cannot parse KindID into wrong prefix" do
        case string2ID @(KindID "foo") "mmzk_00041061050r3gg28a1c60t3gf" of
          Left err  -> pure ()
          Right kid -> expectationFailure $ "Parsed TypeID: " ++ show kid

    describe "Generate type-level TypeID with custom data kind prefixes" do
      it "can generate TypeID with prefix" do
          kid <- withCheck $ genID @(KindID 'Post)
          getPrefix kid `shouldBe` "post"
      it "can parse TypeID from String" do
        case string2ID @(KindID User) "user_00041061050r3gg28a1c60t3gf" of
          Left err  -> expectationFailure $ "Parse error: " ++ show err
          Right kid -> getPrefix kid `shouldBe` "user"
      it "cannot parse TypeID into wrong prefix" do
        case string2ID @(KindID Comment) "user_00041061050r3gg28a1c60t3gf" of
          Left err  -> pure ()
          Right kid -> expectationFailure $ "Parsed TypeID: " ++ show kid
      it "can generate in batch with same timestamp and in ascending order" do
        kids <- withChecks $ genIDs @(KindID 'Comment) 1526
        all ((== "comment") . getPrefix) kids `shouldBe` True
        let timestamp = getTime $ head kids
        all ((== timestamp) . getTime) kids `shouldBe` True
        all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True