-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module CryptoID.TH where

import ClassyPrelude

import Language.Haskell.TH

import Data.CryptoID.Class.ImplicitNamespace
import Data.UUID.Types (UUID)
import Data.Binary.SerializationLength

import Data.CaseInsensitive (CI)

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import Database.Persist.Sql

import qualified Data.CryptoID.ByteString as CryptoID.BS
import Crypto.Cipher.Types (cipherKeySize, KeySizeSpecifier(..))


decCryptoIDs :: [Name] -> DecsQ
decCryptoIDs = fmap concat . mapM decCryptoID
  where
    decCryptoID :: Name -> DecsQ
    decCryptoID n@(conT -> t) = do
      instances <- [d|
          instance HasFixedSerializationLength $(t) where
            type SerializationLength $(t) = SerializationLength Int64

          instance {-# OVERLAPPING #-} Binary $(t) where
            put = Binary.put . fromSqlKey
            putList = Binary.putList . map fromSqlKey
            get = toSqlKey <$> Binary.get

          type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns)
        |]

      synonyms <- mapM cryptoIDSyn
        [ (ConT ''UUID, "UUID")
        , (ConT ''CI `AppT` ConT ''FilePath, "FileName")
        ]

      return $ concat
        [ instances
        , synonyms
        ]
      where
        ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n
        cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t

decCryptoIDKeySize :: DecsQ
decCryptoIDKeySize = sequence
  [ tySynD (mkName "CryptoIDCipherKeySize") [] . litT . numTyLit $ fromIntegral cryptoIDKeySize
  ]
  where
    cryptoIDKeySize = case cipherKeySize (error "Cipher inspected during cipherKeySize" :: CryptoID.BS.CryptoCipher) of
      KeySizeRange mins maxs -> max mins maxs
      KeySizeEnum  ss        -> maximumEx ss
      KeySizeFixed s         -> s