225 lines
12 KiB
Haskell
225 lines
12 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
|
|
, getWorkflowWorkflowState', getWorkflowWorkflowState
|
|
, WorkflowWorkflowStateParseException(..)
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Foundation.Type
|
|
|
|
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 Handler.Utils.Memcached
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Internal.Internal 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 :: ( MonadHandler m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> RouteWorkflowScope
|
|
-> MaybeT (ReaderT backend m) IdWorkflowScope
|
|
fromRouteWorkflowScope rScope = $cachedHereBinary 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 :: ( MonadHandler m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> IdWorkflowScope
|
|
-> MaybeT (ReaderT backend m) RouteWorkflowScope
|
|
toRouteWorkflowScope scope = $cachedHereBinary 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
|
|
|
|
|
|
newtype WorkflowWorkflowStateParse = WorkflowWorkflowStateParse PersistValue
|
|
deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Binary)
|
|
|
|
newtype WorkflowWorkflowStateParseException = WorkflowWorkflowStateParseException Text
|
|
deriving stock (Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
getWorkflowWorkflowState' :: forall backend m.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BackendCompatible SqlReadBackend backend
|
|
, MonadThrow m
|
|
)
|
|
=> WorkflowWorkflowId
|
|
-> Maybe WorkflowWorkflow
|
|
-> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
|
|
getWorkflowWorkflowState' wwId Nothing = withReaderT (projectBackend @SqlBackend . projectBackend @SqlReadBackend) . runMaybeT $ do
|
|
res <- MaybeT . E.selectMaybe . E.from $ \workflowWorkflow -> do
|
|
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowId E.==. E.val wwId
|
|
return
|
|
( workflowWorkflow E.^. WorkflowWorkflowInstance
|
|
, workflowWorkflow E.^. WorkflowWorkflowScope
|
|
, workflowWorkflow E.^. WorkflowWorkflowGraph
|
|
, E.veryUnsafeCoerceSqlExprValue $ workflowWorkflow E.^. WorkflowWorkflowState
|
|
)
|
|
let
|
|
( E.Value workflowWorkflowInstance
|
|
, E.Value workflowWorkflowScope
|
|
, E.Value workflowWorkflowGraph
|
|
, E.Value (wwState :: PersistValue) -- Don't parse
|
|
) = res
|
|
wwState' <- memcachedBy Nothing (WorkflowWorkflowStateParse wwState) . return $ fromPersistValue wwState
|
|
case wwState' of
|
|
Left err -> lift . throwM $ WorkflowWorkflowStateParseException err
|
|
Right workflowWorkflowState -> return $ Entity wwId WorkflowWorkflow{..}
|
|
getWorkflowWorkflowState' wwId (Just ww@WorkflowWorkflow{..}) = Just (Entity wwId ww) <$ do
|
|
memcachedBySet Nothing (WorkflowWorkflowStateParse $ toPersistValue workflowWorkflowState) workflowWorkflowState
|
|
|
|
getWorkflowWorkflowState :: forall backend m.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BackendCompatible SqlReadBackend backend
|
|
, MonadThrow m
|
|
)
|
|
=> WorkflowWorkflowId
|
|
-> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
|
|
getWorkflowWorkflowState = flip getWorkflowWorkflowState' Nothing
|