65 lines
2.0 KiB
Haskell
65 lines
2.0 KiB
Haskell
-- 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
|