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