90 lines
5.7 KiB
Haskell
90 lines
5.7 KiB
Haskell
module Utils.Workflow
|
|
( _DBWorkflowScope
|
|
, fromRouteWorkflowScope, toRouteWorkflowScope
|
|
, _DBWorkflowGraph
|
|
, _DBWorkflowState
|
|
, decryptWorkflowStateIndex, encryptWorkflowStateIndex
|
|
, isTopWorkflowScope
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
|
import qualified Crypto.MAC.KMAC as Crypto
|
|
import qualified Data.ByteArray as BA
|
|
import qualified Data.Binary as Binary
|
|
import Crypto.Hash.Algorithms (SHAKE256)
|
|
import Language.Haskell.TH (nameBase)
|
|
|
|
|
|
_DBWorkflowScope :: Iso' (WorkflowScope TermId SchoolId CourseId) (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey)
|
|
_DBWorkflowScope = iso toScope' toScope
|
|
where
|
|
toScope' scope = scope
|
|
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermIdentifier SchoolId CourseId)) unTermKey
|
|
& over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolId CourseId) @(WorkflowScope TermIdentifier SchoolShorthand CourseId)) unSchoolKey
|
|
& over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolShorthand CourseId) @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) @CourseId @SqlBackendKey) (view _SqlKey)
|
|
toScope scope' = scope'
|
|
& over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolShorthand SqlBackendKey)) TermKey
|
|
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolId SqlBackendKey)) SchoolKey
|
|
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId SqlBackendKey) @(WorkflowScope TermId SchoolId CourseId) @SqlBackendKey @CourseId) (review _SqlKey)
|
|
|
|
fromRouteWorkflowScope :: ( MonadIO m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
|
|
-> MaybeT (ReaderT backend m) (WorkflowScope TermId SchoolId CourseId)
|
|
fromRouteWorkflowScope rScope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
|
|
toRouteWorkflowScope :: ( MonadIO m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> WorkflowScope TermId SchoolId CourseId
|
|
-> MaybeT (ReaderT backend m) (WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand))
|
|
toRouteWorkflowScope scope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand)
|
|
|
|
|
|
_DBWorkflowGraph :: Iso' (WorkflowGraph FileReference UserId) (WorkflowGraph FileReference SqlBackendKey)
|
|
_DBWorkflowGraph = iso toDB fromDB
|
|
where
|
|
toDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference UserId) @(WorkflowGraph FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)
|
|
fromDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference SqlBackendKey) @(WorkflowGraph FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey)
|
|
|
|
_DBWorkflowState :: Iso' (WorkflowState FileReference UserId) (WorkflowState FileReference SqlBackendKey)
|
|
_DBWorkflowState = iso toDB fromDB
|
|
where
|
|
toDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference UserId) @(WorkflowState FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)
|
|
fromDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference SqlBackendKey) @(WorkflowState FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey)
|
|
|
|
|
|
data WorkflowStateIndexKeyException
|
|
= WorkflowStateIndexCryptoIDKeyCouldNotDecodeRandom
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
workflowStateIndexCryptoIDKey :: (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => WorkflowWorkflowId -> m CryptoIDKey
|
|
workflowStateIndexCryptoIDKey wwId = cryptoIDKey $ \cIDKey -> either (const $ throwM WorkflowStateIndexCryptoIDKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
|
|
Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'workflowStateIndexCryptoIDKey) (toStrict $ Binary.encode wwId) cIDKey
|
|
|
|
encryptWorkflowStateIndex :: ( MonadCrypto m
|
|
, MonadCryptoKey m ~ CryptoIDKey
|
|
, MonadHandler m
|
|
)
|
|
=> WorkflowWorkflowId -> WorkflowStateIndex -> m CryptoUUIDWorkflowStateIndex
|
|
encryptWorkflowStateIndex wwId stIx = do
|
|
cIDKey <- workflowStateIndexCryptoIDKey wwId
|
|
$cachedHereBinary (wwId, stIx) . flip runReaderT cIDKey $ I.encrypt stIx
|
|
|
|
decryptWorkflowStateIndex :: ( MonadCrypto m
|
|
, MonadCryptoKey m ~ CryptoIDKey
|
|
, MonadHandler m
|
|
)
|
|
=> WorkflowWorkflowId -> CryptoUUIDWorkflowStateIndex -> m WorkflowStateIndex
|
|
decryptWorkflowStateIndex wwId cID = do
|
|
cIDKey <- workflowStateIndexCryptoIDKey wwId
|
|
$cachedHereBinary (wwId, cID) . flip runReaderT cIDKey $ I.decrypt cID
|
|
|
|
|
|
isTopWorkflowScope :: WorkflowScope termid schoolid courseid -> Bool
|
|
isTopWorkflowScope = (`elem` [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScope
|