79 lines
3.1 KiB
Haskell
79 lines
3.1 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module CryptoID
|
|
( module CryptoID
|
|
, module Data.CryptoID.Poly.ImplicitNamespace
|
|
, module Data.UUID.Cryptographic.ImplicitNamespace
|
|
, module System.FilePath.Cryptographic.ImplicitNamespace
|
|
) where
|
|
|
|
import CryptoID.TH
|
|
|
|
import ClassyPrelude
|
|
import Model
|
|
|
|
import qualified Data.CryptoID as E
|
|
import Data.CryptoID.Poly.ImplicitNamespace
|
|
import Data.UUID.Cryptographic.ImplicitNamespace
|
|
import System.FilePath.Cryptographic.ImplicitNamespace
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
-- import Data.UUID.Types
|
|
import Web.PathPieces
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Value(..), withText)
|
|
import Data.Aeson.Encoding (text)
|
|
|
|
|
|
instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
|
|
type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey
|
|
cryptoIDKey f = ask >>= f
|
|
|
|
|
|
-- Generates CryptoUUID... and CryptoFileName... Datatypes
|
|
decCryptoIDs [ ''SubmissionId
|
|
, ''FileId
|
|
, ''UserId
|
|
, ''SheetId
|
|
, ''SystemMessageId
|
|
, ''SystemMessageTranslationId
|
|
, ''StudyFeaturesId
|
|
]
|
|
|
|
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
|
|
fromPathPiece (Text.unpack -> piece) = do
|
|
piece' <- (stripPrefix `on` map CI.mk) "uwa" piece
|
|
return . CryptoID . CI.mk $ map CI.original piece'
|
|
toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext
|
|
|
|
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSON (E.CryptoID namespace (CI FilePath)) where
|
|
toJSON = String . toPathPiece
|
|
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSONKey (E.CryptoID namespace (CI FilePath)) where
|
|
toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
|
|
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSON (E.CryptoID namespace (CI FilePath)) where
|
|
parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
|
|
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where
|
|
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
|
|
|
|
|
|
newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
|
|
deriving (Show, Read, Eq)
|
|
|
|
pattern NewSubmission :: SubmissionMode
|
|
pattern NewSubmission = SubmissionMode Nothing
|
|
pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode
|
|
pattern ExistingSubmission cID = SubmissionMode (Just cID)
|
|
|
|
instance PathPiece SubmissionMode where
|
|
fromPathPiece "new" = Just $ SubmissionMode Nothing
|
|
fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s
|
|
|
|
toPathPiece (SubmissionMode Nothing) = "new"
|
|
toPathPiece (SubmissionMode (Just x)) = toPathPiece x
|
|
|
|
|