140 lines
5.9 KiB
Haskell
140 lines
5.9 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# 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 Import.NoModel
|
|
import Model
|
|
|
|
import CryptoID.TH
|
|
|
|
import qualified Data.CryptoID as E
|
|
import Data.CryptoID.Poly.ImplicitNamespace hiding (decrypt, encrypt)
|
|
import Data.UUID.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
|
|
import System.FilePath.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Aeson (withText)
|
|
import Data.Aeson.Encoding (text)
|
|
|
|
import Text.Blaze (ToMarkup(..))
|
|
|
|
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
|
|
|
|
|
encrypt :: forall plaintext ciphertext m.
|
|
( I.HasCryptoID ciphertext plaintext m
|
|
, KnownSymbol (CryptoIDNamespace ciphertext plaintext)
|
|
, MonadHandler m
|
|
, Typeable ciphertext
|
|
, PathPiece plaintext
|
|
)
|
|
=> plaintext -> m (I.CryptoID ciphertext plaintext)
|
|
encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain
|
|
|
|
decrypt :: forall plaintext ciphertext m.
|
|
( I.HasCryptoID ciphertext plaintext m
|
|
, MonadHandler m
|
|
, Typeable plaintext
|
|
, PathPiece ciphertext
|
|
)
|
|
=> I.CryptoID ciphertext plaintext -> m plaintext
|
|
decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher
|
|
|
|
|
|
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
|
|
, ''UserId
|
|
, ''SheetId
|
|
, ''SystemMessageId
|
|
, ''SystemMessageTranslationId
|
|
, ''StudyFeaturesId
|
|
, ''ExamId
|
|
, ''ExamOccurrenceId
|
|
, ''ExamPartId
|
|
, ''AllocationId
|
|
, ''CourseApplicationId
|
|
, ''CourseId
|
|
, ''CourseNewsId
|
|
, ''CourseEventId
|
|
, ''TutorialId
|
|
, ''ExternalExamId
|
|
, ''WorkflowInstanceId
|
|
, ''WorkflowWorkflowId
|
|
, ''MaterialFileId
|
|
]
|
|
|
|
type instance CryptoIDNamespace a WorkflowStateIndex = "WorkflowStateIndex"
|
|
type CryptoUUIDWorkflowStateIndex = CryptoUUID WorkflowStateIndex
|
|
|
|
decCryptoIDKeySize
|
|
|
|
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
|
|
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "Submission" (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 #-} ToJSON (E.CryptoID "Submission" (CI FilePath)) where
|
|
toJSON = String . toPathPiece
|
|
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "Submission" (CI FilePath)) where
|
|
toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
|
|
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "Submission" (CI FilePath)) where
|
|
parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
|
|
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "Submission" (CI FilePath)) where
|
|
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
|
|
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where
|
|
toMarkup = toMarkup . toPathPiece
|
|
|
|
-- CryptoIDNamespace (CI FilePath) UserId ~ "User"
|
|
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "User" (CI FilePath)) where
|
|
fromPathPiece (Text.unpack -> piece) = do
|
|
piece' <- (stripPrefix `on` map CI.mk) "uwb" piece
|
|
return . CryptoID . CI.mk $ map CI.original piece'
|
|
toPathPiece = Text.pack . ("uwb" <>) . CI.foldedCase . ciphertext
|
|
|
|
instance {-# OVERLAPS #-} ToJSON (E.CryptoID "User" (CI FilePath)) where
|
|
toJSON = String . toPathPiece
|
|
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "User" (CI FilePath)) where
|
|
toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
|
|
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "User" (CI FilePath)) where
|
|
parseJSON = withText "CryptoFileNameUser" $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece
|
|
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "User" (CI FilePath)) where
|
|
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece
|
|
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "User" (CI FilePath)) where
|
|
toMarkup = toMarkup . toPathPiece
|
|
|
|
|
|
-- CryptoIDNamespace (CI FilePath) WorkflowWorkflowId ~ "WorkflowWorkflow"
|
|
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
|
|
fromPathPiece (Text.unpack -> piece) = do
|
|
piece' <- (stripPrefix `on` map CI.mk) "uww" piece
|
|
return . CryptoID . CI.mk $ map CI.original piece'
|
|
toPathPiece = Text.pack . ("uww" <>) . CI.foldedCase . ciphertext
|
|
|
|
instance {-# OVERLAPS #-} ToJSON (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
|
|
toJSON = String . toPathPiece
|
|
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
|
|
toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
|
|
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
|
|
parseJSON = withText "CryptoFileNameWorkflowWorkflow" $ maybe (fail "Could not parse CryptoFileNameWorkflowWorkflow") return . fromPathPiece
|
|
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
|
|
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameWorkflowWorkflow") return . fromPathPiece
|
|
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
|
|
toMarkup = toMarkup . toPathPiece
|