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

import           Control.Monad
import           Data.Aeson
import           Data.Binary (get, put)
import           Data.Binary.Get
import           Data.Binary.Put
import qualified Data.ByteString.Lazy as BSL
import           Data.KindID.V4 (KindIDV4)
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.V4 (TypeIDV4)
import           Data.TypeID.Class
import           Data.TypeID.Error
import           Data.UUID.Types (nil)
import           Data.UUID.V7 (UUID)
import qualified Data.UUID.V7 as V7
import           Foreign
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 tid = TestDataUUID { name   :: String
                                     , typeid :: tid
                                     , 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 = hspec do
  v7Test
  v4Test

v7Test :: Spec
v7Test = do
  invalid   <- runIO (BSL.readFile "test/invalid.json" >>= throwDecode :: IO [TestData])
  valid     <- runIO (BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestData])
  validUUID <- runIO (BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestDataUUID TypeID])
  describe "Generate TypeID" do
    it "can generate TypeID with prefix" do
      start <- V7.getEpochMilli
      tid   <- withCheck $ genID @TypeID "mmzk"
      getPrefix tid `shouldBe` "mmzk"
      getTime tid `shouldSatisfy` \t -> t >= start
    it "can generate TypeID without prefix" do
      start <- V7.getEpochMilli
      tid   <- withCheck $ genID @TypeID ""
      getPrefix tid `shouldBe` ""
      getTime tid `shouldSatisfy` \t -> t >= start
    it "can generate TypeID with stateless UUIDv7" do
      start <- V7.getEpochMilli
      tid   <- withCheck $ genID' @TypeID "mmzk"
      getPrefix tid `shouldBe` "mmzk"
      getTime tid `shouldSatisfy` \t -> t >= start
    it "can generate in batch with same timestamp and in ascending order" do
      start <- V7.getEpochMilli
      tids  <- withChecks $ genIDs @TypeID "mmzk" 1526
      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
    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 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 KindID with 'Symbol' prefixes" do
    it "can generate KindID with prefix" do
      start <- V7.getEpochMilli
      kid   <- withCheck $ genID @(KindID "mmzk")
      getPrefix kid `shouldBe` "mmzk"
      getTime kid `shouldSatisfy` \t -> start <= t
    it "can generate KindID without prefix" do
      start <- V7.getEpochMilli
      kid   <- withCheck $ genID @(KindID "")
      getPrefix kid `shouldBe` ""
      getTime kid `shouldSatisfy` \t -> start <= t
    it "can generate KindID with stateless UUID v7" do
      start <- V7.getEpochMilli
      kid   <- withCheck $ genID' @(KindID "mmzk")
      getPrefix kid `shouldBe` "mmzk"
      getTime kid `shouldSatisfy` \t -> start <= t
    it "can generate in batch with same timestamp and in ascending order" do
      start <- V7.getEpochMilli
      kids  <- withChecks $ genIDs @(KindID "mmzk") 1526
      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
    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 KindID with custom data kind prefixes" do
    it "can generate KindID with prefix" do
        kid <- withCheck $ genID @(KindID 'Post)
        getPrefix kid `shouldBe` "post"
    it "can parse KindID 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 KindID into wrong prefix" do
      case string2ID @(KindID 'Comment) "user_00041061050r3gg28a1c60t3gf" of
        Left err  -> pure ()
        Right kid -> expectationFailure $ "Parsed KindID: " ++ 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

  describe "Binary instance for TypeID and KindID" do
    it "has correct binary instance for TypeID" do
      tids <- withChecks $ genIDs @TypeID "abcdefghijklmnopqrstuvwxyz" 114
      forM_ tids \tid -> do
        let bytes = runPut (put tid)
        let tid'  = runGet get bytes
        tid' `shouldBe` tid
    it "has correct binary instance for KindID" do
      kids <- withChecks $ genIDs @(KindID "abcdefghijklmnopqrstuvwxyz") 114
      forM_ kids \kid -> do
        let bytes = runPut (put kid)
        let kid'  = runGet get bytes
        kid' `shouldBe` kid

  describe "Storable instance for TypeID and KindID" do
    it "has correct Storable instance for TypeID" do
      tids <- withChecks $ genIDs @TypeID "abcdefghijklmnopqrstuvwxyz" 114
      forM_ tids \tid -> do
        ptr   <- new tid
        tid'  <- peek ptr
        tid' `shouldBe` tid
        poke ptr tid'
        tid'' <- peek ptr
        tid'' `shouldBe` tid'
        free ptr
    it "has correct Storable instance for KindID" do
      kids <- withChecks $ genIDs @(KindID "abcdefghijklmnopqrstuvwxyz") 114
      forM_ kids \kid -> do
        ptr   <- new kid
        kid'  <- peek ptr
        kid' `shouldBe` kid
        poke ptr kid'
        kid'' <- peek ptr
        kid'' `shouldBe` kid'
        free ptr


v4Test :: Spec
v4Test = do
  invalid   <- runIO (BSL.readFile "test/invalid.json" >>= throwDecode :: IO [TestData])
  valid     <- runIO (BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestData])
  validUUID <- runIO (BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestDataUUID TypeIDV4])
  describe "Generate TypeIDV4" do
    it "can generate TypeIDV4 with prefix" do
      tid <- withCheck $ genID @TypeIDV4 "mmzk"
      getPrefix tid `shouldBe` "mmzk"
    it "can generate TypeIDV4 without prefix" do
      tid <- withCheck $ genID @TypeIDV4 ""
      getPrefix tid `shouldBe` ""
    it "can generate TypeIDV4 with insecure UUIDv4" do
      start <- V7.getEpochMilli
      tid   <- withCheck $ genID' @TypeIDV4 "mmzk"
      getPrefix tid `shouldBe` "mmzk"
    it "can parse TypeIDV4 from String" do
      case string2ID @TypeIDV4 "mmzk_5hjpeh96458fct8t49fnf9farw" of
        Left err  -> expectationFailure $ "Parse error: " ++ show err
        Right tid -> getPrefix tid `shouldBe` "mmzk"

  describe "Parse TypeIDV4" 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 @TypeIDV4 prefix `shouldThrow` anyTypeIDError
        case decorate @TypeIDV4 prefix 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 @TypeIDV4 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 @TypeIDV4 tid of
        Left err  -> expectationFailure $ "Parse error: " ++ show err
        Right tid -> show (getUUID tid) `shouldBe` uuid

  describe "TypeIDV4 valid JSON instances" do
    it "Decode and then encode should be identity" do
      tid  <- genID @TypeIDV4 "mmzk"
      tid' <- genID @TypeIDV4 "foo"
      let mapping = M.fromList [(tid, tid')]
      let json    = encode mapping
      decode json `shouldBe` Just mapping
      fmap encode (decode @(Map TypeIDV4 TypeIDV4) json) `shouldBe` Just json
    describe "Valid JSON value" do
      forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do
        case decode @TypeIDV4 (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 TypeIDV4 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 "TypeIDV4 invalid JSON instances" do
    describe "Invalid JSON value" do
      forM_ invalid \(TestData name tid _ _) -> it name do
        case decode @TypeIDV4 (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 TypeIDV4 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 @TypeIDV4 tid of
        Left _    -> pure ()
        Right tid -> expectationFailure $ "Parsed TypeID: " ++ show tid

  describe "Test valid.json (TypeIDV4 as literal)" do
    forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do
      case string2ID @TypeIDV4 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 (TypeIDV4 as JSON)" do
    forM_ validUUID \(TestDataUUID name tid prefix uuid) -> it name do
      getPrefix tid `shouldBe` prefix
      getUUID tid `shouldBe` uuid

  describe "Generate KindIDV4 with 'Symbol' prefixes" do
    it "can generate KindIDV4 with prefix" do
      kid <- withCheck $ genID @(KindIDV4 "mmzk")
      getPrefix kid `shouldBe` "mmzk"
    it "can generate KindIDV4 without prefix" do
      kid <- withCheck $ genID @(KindIDV4 "")
      getPrefix kid `shouldBe` ""
    it "can generate KindIDV4 with stateless UUID v7" do
      kid <- withCheck $ genID' @(KindIDV4 "mmzk")
      getPrefix kid `shouldBe` "mmzk"
    it "can parse KindID from String" do
      case string2ID @(KindIDV4 "mmzk") "mmzk_5hjpeh96458fct8t49fnf9farw" of
        Left err  -> expectationFailure $ "Parse error: " ++ show err
        Right kid -> getPrefix kid `shouldBe` "mmzk"
    it "cannot parse KindID into wrong prefix" do
      case string2ID @(KindIDV4 "foo") "mmzk_5hjpeh96458fct8t49fnf9farw" of
        Left err  -> pure ()
        Right kid -> expectationFailure $ "Parsed TypeID: " ++ show kid

  describe "Generate KindIDV4 with custom data kind prefixes" do
    it "can generate KindIDV4 with prefix" do
        kid <- withCheck $ genID @(KindID 'Post)
        getPrefix kid `shouldBe` "post"
    it "can parse KindIDV4 from String" do
      case string2ID @(KindIDV4 'User) "user_00041061050r3gg28a1c60t3gf" of
        Left err  -> expectationFailure $ "Parse error: " ++ show err
        Right kid -> getPrefix kid `shouldBe` "user"
    it "cannot parse KindIDV4 into wrong prefix" do
      case string2ID @(KindIDV4 'Comment) "user_00041061050r3gg28a1c60t3gf" of
        Left err  -> pure ()
        Right kid -> expectationFailure $ "Parsed KindIDV4: " ++ show kid

  describe "Binary instance for TypeIDV4 and KindIDV4" do
    it "has correct binary instance for TypeIDV4" do
      tids <- withChecks $ genIDs @TypeIDV4 "abcdefghijklmnopqrstuvwxyz" 114
      forM_ tids \tid -> do
        let bytes = runPut (put tid)
        let tid'  = runGet get bytes
        tid' `shouldBe` tid
    it "has correct binary instance for KindIDV4" do
      kids <- withChecks $ genIDs @(KindIDV4 "abcdefghijklmnopqrstuvwxyz") 114
      forM_ kids \kid -> do
        let bytes = runPut (put kid)
        let kid'  = runGet get bytes
        kid' `shouldBe` kid

  describe "Storable instance for TypeIDV4 and KindIDV4" do
    it "has correct Storable instance for TypeIDV4" do
      tids <- withChecks $ genIDs @TypeIDV4 "abcdefghijklmnopqrstuvwxyz" 114
      forM_ tids \tid -> do
        ptr   <- new tid
        tid'  <- peek ptr
        tid' `shouldBe` tid
        poke ptr tid'
        tid'' <- peek ptr
        tid'' `shouldBe` tid'
        free ptr
    it "has correct Storable instance for KindIDV4" do
      kids <- withChecks $ genIDs @(KindIDV4 "abcdefghijklmnopqrstuvwxyz") 114
      forM_ kids \kid -> do
        ptr   <- new kid
        kid'  <- peek ptr
        kid' `shouldBe` kid
        poke ptr kid'
        kid'' <- peek ptr
        kid'' `shouldBe` kid'
        free ptr