171 lines
9.3 KiB
Haskell
171 lines
9.3 KiB
Haskell
module Utils.Workflow
|
|
( RouteWorkflowScope, DBWorkflowScope, IdWorkflowScope, CryptoIDWorkflowScope
|
|
, _DBWorkflowScope
|
|
, fromRouteWorkflowScope, toRouteWorkflowScope
|
|
, DBWorkflowGraph, IdWorkflowGraph
|
|
, _DBWorkflowGraph
|
|
, DBWorkflowState, IdWorkflowState
|
|
, _DBWorkflowState
|
|
, DBWorkflowAction, IdWorkflowAction
|
|
, decryptWorkflowStateIndex, encryptWorkflowStateIndex
|
|
, isTopWorkflowScope, isTopWorkflowScopeSql
|
|
, selectWorkflowInstanceDescription
|
|
, SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph
|
|
, insertSharedWorkflowGraph
|
|
) 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 qualified Crypto.Hash as Crypto
|
|
import Language.Haskell.TH (nameBase)
|
|
import qualified Data.Aeson as Aeson
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
|
|
|
|
|
type RouteWorkflowScope = WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
|
|
type DBWorkflowScope = WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey
|
|
type IdWorkflowScope = WorkflowScope TermId SchoolId CourseId
|
|
type CryptoIDWorkflowScope = WorkflowScope TermId SchoolId CryptoUUIDCourse
|
|
|
|
|
|
_DBWorkflowScope :: Iso' IdWorkflowScope DBWorkflowScope
|
|
_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
|
|
)
|
|
=> RouteWorkflowScope
|
|
-> MaybeT (ReaderT backend m) IdWorkflowScope
|
|
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
|
|
)
|
|
=> IdWorkflowScope
|
|
-> MaybeT (ReaderT backend m) RouteWorkflowScope
|
|
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)
|
|
|
|
|
|
type IdWorkflowGraph = WorkflowGraph FileReference UserId
|
|
type DBWorkflowGraph = WorkflowGraph FileReference SqlBackendKey
|
|
|
|
|
|
_DBWorkflowGraph :: Iso' IdWorkflowGraph DBWorkflowGraph
|
|
_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)
|
|
|
|
|
|
type IdWorkflowState = WorkflowState FileReference UserId
|
|
type DBWorkflowState = WorkflowState FileReference SqlBackendKey
|
|
|
|
|
|
_DBWorkflowState :: Iso' IdWorkflowState DBWorkflowState
|
|
_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)
|
|
|
|
type IdWorkflowAction = WorkflowAction FileReference UserId
|
|
type DBWorkflowAction = WorkflowAction FileReference SqlBackendKey
|
|
|
|
|
|
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
|
|
|
|
isTopWorkflowScopeSql :: E.SqlExpr (E.Value DBWorkflowScope) -> E.SqlExpr (E.Value Bool)
|
|
isTopWorkflowScopeSql = (`E.in_` E.valList [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScopeSql
|
|
where classifyWorkflowScopeSql = (E.->. "tag")
|
|
|
|
|
|
selectWorkflowInstanceDescription :: ( MonadHandler m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> WorkflowInstanceId
|
|
-> ReaderT backend m (Maybe (Entity WorkflowInstanceDescription))
|
|
selectWorkflowInstanceDescription wiId = withReaderT (projectBackend @SqlReadBackend) $ do
|
|
descLangs <- E.select . E.from $ \workflowInstanceDescription -> do
|
|
E.where_ $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionInstance E.==. E.val wiId
|
|
return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
|
|
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
|
|
fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
|
|
|
|
|
|
data SharedWorkflowGraphException
|
|
= SharedWorkflowGraphNotFound SharedWorkflowGraphId
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
getSharedDBWorkflowGraph :: ( MonadHandler m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> SharedWorkflowGraphId
|
|
-> ReaderT backend m DBWorkflowGraph
|
|
getSharedDBWorkflowGraph swgId = $cachedHereBinary swgId . withReaderT (projectBackend @SqlReadBackend) $ do
|
|
maybe (liftHandler . throwM $ SharedWorkflowGraphNotFound swgId) (return . sharedWorkflowGraphGraph) =<< get swgId
|
|
|
|
getSharedIdWorkflowGraph :: ( MonadHandler m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> SharedWorkflowGraphId
|
|
-> ReaderT backend m IdWorkflowGraph
|
|
getSharedIdWorkflowGraph = fmap (review _DBWorkflowGraph) . getSharedDBWorkflowGraph
|
|
|
|
insertSharedWorkflowGraph :: ( MonadIO m
|
|
, BackendCompatible SqlBackend backend
|
|
)
|
|
=> DBWorkflowGraph
|
|
-> ReaderT backend m SharedWorkflowGraphId
|
|
insertSharedWorkflowGraph graph = withReaderT (projectBackend @SqlBackend) $
|
|
swgId' <$ repsert swgId' (SharedWorkflowGraph swgId graph)
|
|
where
|
|
swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph
|
|
swgId' = SharedWorkflowGraphKey swgId
|