fix(workflows): integrate in new master
This commit is contained in:
Gregor Kleen
parent
ed4ee1320b
commit
99f3fca6d0
@ -1,5 +1,5 @@
|
||||
WorkflowDefinition
|
||||
graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId
|
||||
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
|
||||
scope WorkflowInstanceScope'
|
||||
name WorkflowDefinitionName
|
||||
UniqueWorkflowDefinition name scope
|
||||
@ -13,7 +13,7 @@ WorkflowDefinitionDescription
|
||||
|
||||
WorkflowInstance
|
||||
definition WorkflowDefinitionId Maybe
|
||||
graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId
|
||||
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
|
||||
scope (WorkflowInstanceScope SqlBackendKey SqlBackendKey SqlBackendKey) -- TermId, SchoolId, CourseId
|
||||
name WorkflowInstanceName
|
||||
category WorkflowInstanceCategory Maybe
|
||||
@ -21,8 +21,8 @@ WorkflowInstance
|
||||
|
||||
WorkflowWorkflow
|
||||
instance WorkflowInstanceId Maybe
|
||||
graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId
|
||||
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
|
||||
initUser UserId Maybe
|
||||
initTime UTCTime
|
||||
state (WorkflowState SqlBackendKey SqlBackendKey) -- FileId, UserId
|
||||
state (WorkflowState FileReference SqlBackendKey) -- UserId
|
||||
currentNode WorkflowGraphNodeLabel
|
||||
|
||||
@ -21,6 +21,11 @@ import Control.Monad.Fail
|
||||
import Language.Haskell.TH.Syntax (Lift(liftTyped))
|
||||
import Instances.TH.Lift ()
|
||||
|
||||
import Data.Binary
|
||||
import qualified Data.Binary.Put as Binary
|
||||
import qualified Data.Binary.Get as Binary
|
||||
|
||||
|
||||
instance HashAlgorithm hash => PersistField (Digest hash) where
|
||||
toPersistValue = PersistByteString . convert
|
||||
fromPersistValue (PersistByteString bs) = maybe (Left "Could not convert Digest from ByteString") Right $ digestFromByteString bs
|
||||
@ -51,3 +56,7 @@ instance Hashable (Digest hash) where
|
||||
|
||||
instance HashAlgorithm hash => Lift (Digest hash) where
|
||||
liftTyped dgst = [||fromMaybe (error "Lifted digest has wrong length") $ digestFromByteString $$(liftTyped (convert dgst :: ByteString))||]
|
||||
|
||||
instance HashAlgorithm hash => Binary (Digest hash) where
|
||||
put = Binary.putByteString . convert
|
||||
get = Binary.getByteString (hashDigestSize (error "hashDigestSize inspected value of type hash" :: hash)) >>= maybe (fail "Could not parse Digest") return . digestFromByteString
|
||||
|
||||
@ -15,8 +15,6 @@ import Handler.Utils.Invitations
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
@ -14,7 +14,6 @@ import Handler.Utils.Invitations
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
instance IsInvitableJunction SheetCorrector where
|
||||
|
||||
@ -60,8 +60,6 @@ import Handler.Utils.Form.MassInput
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
|
||||
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
|
||||
|
||||
@ -16,9 +16,6 @@ import qualified Data.Bimap as Bimap
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
@ -34,30 +31,24 @@ postAWDEditR wds' wdn = do
|
||||
| Entity _ WorkflowDefinitionDescription{..} <- descs
|
||||
]
|
||||
|
||||
let recordFile :: FileId -> StateT (Bimap FileIdent FileId) DB FileIdent
|
||||
recordFile fId = do
|
||||
prev <- State.gets $ Bimap.lookupR fId
|
||||
let recordFile :: forall m. Monad m => FileReference -> StateT (Bimap FileIdent FileReference) m FileIdent
|
||||
recordFile fRef@FileReference{..} = do
|
||||
prev <- State.gets $ Bimap.lookupR fRef
|
||||
case prev of
|
||||
Just fIdent -> return fIdent
|
||||
Nothing -> do
|
||||
mTitle <- lift . E.selectMaybe . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId E.==. E.val fId
|
||||
return $ file E.^. FileTitle
|
||||
cMap <- State.get
|
||||
let candidateIdents = map (review _Wrapped . CI.mk) $ case mTitle of
|
||||
Just (E.Value fTitle)
|
||||
-> map pack $ fTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fTitle ]
|
||||
Nothing
|
||||
-> [ [st|file_#{n}|] | n <- [1..] :: [Natural]]
|
||||
let candidateIdents = map (review _Wrapped . CI.mk) $
|
||||
map pack $ fileReferenceTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fileReferenceTitle ]
|
||||
fIdent = case filter (`Bimap.notMember` cMap) candidateIdents of
|
||||
fIdent' : _ -> fIdent'
|
||||
[] -> error "candidateIdents should be infinite; cMap should be finite"
|
||||
State.modify $ Bimap.insert fIdent fId
|
||||
State.modify $ Bimap.insert fIdent fRef
|
||||
return fIdent
|
||||
|
||||
(wdfGraph, Bimap.toMap -> wdfFiles) <- (runStateT ?? Bimap.empty) . ($ workflowDefinitionGraph)
|
||||
$ (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey SqlBackendKey) (WorkflowGraph FileIdent SqlBackendKey) SqlBackendKey FileIdent) (recordFile . review _SqlKey)
|
||||
>=> (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent SqlBackendKey) (WorkflowGraph FileIdent CryptoUUIDUser) SqlBackendKey CryptoUUIDUser) (encrypt . review (_SqlKey @User))
|
||||
$ traverseOf (typesCustom @WorkflowChildren) recordFile
|
||||
>=> traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileIdent SqlBackendKey) @_ @_ @CryptoUUIDUser) (encrypt . review (_SqlKey @User))
|
||||
|
||||
return WorkflowDefinitionForm
|
||||
{ wdfScope = workflowDefinitionScope
|
||||
@ -71,8 +62,8 @@ postAWDEditR wds' wdn = do
|
||||
|
||||
act <- formResultMaybe editRes $ \WorkflowDefinitionForm{..} -> do
|
||||
wdfGraph' <- wdfGraph
|
||||
& over (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent CryptoUUIDUser) (WorkflowGraph SqlBackendKey CryptoUUIDUser) FileIdent SqlBackendKey) (view _SqlKey . (wdfFiles !))
|
||||
& (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey CryptoUUIDUser) (WorkflowGraph SqlBackendKey SqlBackendKey) CryptoUUIDUser SqlBackendKey) (fmap (view _SqlKey :: UserId -> SqlBackendKey) . decrypt)
|
||||
& over (typesCustom @WorkflowChildren) (wdfFiles !)
|
||||
& traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
|
||||
|
||||
insConflict <- replaceUnique wdId WorkflowDefinition
|
||||
{ workflowDefinitionGraph = wdfGraph'
|
||||
|
||||
@ -31,7 +31,7 @@ data WorkflowDefinitionForm = WorkflowDefinitionForm
|
||||
, wdfName :: CI Text
|
||||
, wdfDescriptions :: Map Lang (Text, Maybe Html)
|
||||
, wdfGraph :: WorkflowGraph FileIdent CryptoUUIDUser
|
||||
, wdfFiles :: Map FileIdent FileId
|
||||
, wdfFiles :: Map FileIdent FileReference
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
makeLenses_ ''WorkflowDefinitionForm
|
||||
@ -75,24 +75,24 @@ workflowDefinitionForm template = validateForm validateWorkflowDefinitionForm .
|
||||
-> FormSuccess $ pure newFile
|
||||
return (res', $(widgetFile "widgets/massinput/workflowDefinitionFiles/add"))
|
||||
fileEdit nudge = fileForm nudge . Just
|
||||
fileForm :: (Text -> Text) -> Maybe (FileIdent, FileId) -> Form (FileIdent, FileId)
|
||||
fileForm :: (Text -> Text) -> Maybe (FileIdent, FileReference) -> Form (FileIdent, FileReference)
|
||||
fileForm nudge fileTemplate csrf = do
|
||||
(fileIdentRes, fileIdentView) <- mpreq (isoField _Unwrapped ciField) (fslI MsgWorkflowDefinitionFileIdent & addName (nudge "ident")) (view _1 <$> fileTemplate)
|
||||
(fileRes, fileView) <- mpreq fileField (fslI MsgWorkflowDefinitionFile & addName (nudge "file")) (views _2 (yield . Left) <$> fileTemplate)
|
||||
(fileRes, fileView) <- mpreq fileField (fslI MsgWorkflowDefinitionFile & addName (nudge "file")) (views _2 yield <$> fileTemplate)
|
||||
fileRes' <- liftHandler . runDB $ case fileRes of
|
||||
FormSuccess uploads -> maybe FormMissing FormSuccess <$> runConduit (transPipe liftHandler uploads .| C.mapM (either return insert) .| C.head)
|
||||
FormSuccess uploads -> maybe FormMissing FormSuccess <$> runConduit (transPipe liftHandler uploads .| C.head)
|
||||
FormFailure errs -> return $ FormFailure errs
|
||||
FormMissing -> return FormMissing
|
||||
return ((,) <$> fileIdentRes <*> fileRes', $(widgetFile "widgets/massinput/workflowDefinitionFiles/form"))
|
||||
fileLayout :: MassInputLayout ListLength (FileIdent, FileId) (FileIdent, FileId)
|
||||
fileLayout :: MassInputLayout ListLength (FileIdent, FileReference) (FileIdent, FileReference)
|
||||
fileLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDefinitionFiles/layout")
|
||||
|
||||
|
||||
|
||||
validateWorkflowDefinitionForm :: FormValidator WorkflowDefinitionForm DB ()
|
||||
validateWorkflowDefinitionForm = do
|
||||
join . uses _wdfGraph . mapMOf_ (typesUsing @WorkflowChildren @CryptoUUIDUser) . ensureExists $ Proxy @User
|
||||
fIdentsReferenced <- uses _wdfGraph . setOf $ typesUsing @WorkflowChildren @FileIdent
|
||||
join . uses _wdfGraph . mapMOf_ (typesCustom @WorkflowChildren) . ensureExists $ Proxy @User
|
||||
fIdentsReferenced <- uses _wdfGraph . setOf $ typesCustom @WorkflowChildren
|
||||
fIdentsAvailable <- uses _wdfFiles Map.keysSet
|
||||
forM_ (fIdentsReferenced `Set.difference` fIdentsAvailable) $ tellValidationError . MsgWorkflowDefinitionFileIdentDoesNotExist . views _Wrapped CI.original
|
||||
where
|
||||
|
||||
@ -17,8 +17,8 @@ postAdminWorkflowDefinitionNewR = do
|
||||
|
||||
act <- formResultMaybe newRes $ \WorkflowDefinitionForm{..} -> do
|
||||
wdfGraph' <- wdfGraph
|
||||
& over (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent CryptoUUIDUser) (WorkflowGraph SqlBackendKey CryptoUUIDUser) FileIdent SqlBackendKey) (view _SqlKey . (wdfFiles !))
|
||||
& (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey CryptoUUIDUser) (WorkflowGraph SqlBackendKey SqlBackendKey) CryptoUUIDUser SqlBackendKey) (fmap (view _SqlKey :: UserId -> SqlBackendKey) . decrypt)
|
||||
& over (typesCustom @WorkflowChildren) (wdfFiles !)
|
||||
& traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
|
||||
|
||||
insRes <- insertUnique WorkflowDefinition
|
||||
{ workflowDefinitionGraph = wdfGraph'
|
||||
|
||||
@ -156,7 +156,7 @@ determineCrontab = execWriterT $ do
|
||||
epochInterval = within / 2
|
||||
(currEpoch, epochNow) = now `divMod'` epochInterval
|
||||
currInterval = epochNow `div'` interval
|
||||
numIntervals = floor $ epochInterval / interval
|
||||
numIntervals = max 1 . floor $ epochInterval / interval
|
||||
n = ceiling $ 4 * cInterval / interval
|
||||
i <- [ negate (ceiling $ n % 2) .. ceiling $ n % 2 ]
|
||||
let
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# OPTIONS_GHC -Wno-error=deprecations #-}
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Jobs.Handler.Files
|
||||
@ -73,6 +71,13 @@ fileReferences (E.just -> fHash)
|
||||
E.&&. chunkLock E.^. FileChunkLockHash E.==. E.subSelectForeign fileContentEntry FileContentEntryChunkHash (E.^. FileContentChunkHash)
|
||||
]
|
||||
|
||||
workflowFileReferences :: MonadResource m => ConduitT () FileContentReference (SqlPersistT m) ()
|
||||
workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. WorkflowDefinitionGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
|
||||
, E.selectSource (E.from $ pure . (E.^. WorkflowInstanceGraph )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
|
||||
, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowGraph )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
|
||||
, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
|
||||
]
|
||||
|
||||
|
||||
dispatchJobDetectMissingFiles :: JobHandler UniWorX
|
||||
dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin
|
||||
@ -81,13 +86,15 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin
|
||||
act = hoist lift $ do
|
||||
uploadBucket <- getsYesod $ view _appUploadCacheBucket
|
||||
|
||||
missingDb <- forM trackedReferences $ \refQuery ->
|
||||
fmap (Set.fromList . mapMaybe E.unValue) . E.select $ do
|
||||
ref <- refQuery
|
||||
E.where_ . E.not_ $ E.isNothing ref
|
||||
E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry ->
|
||||
E.where_ $ E.just (fileContentEntry E.^. FileContentEntryHash) E.==. ref
|
||||
E.distinctOnOrderBy [E.asc ref] $ return ref
|
||||
missingDb <- execWriterT $ do
|
||||
tellM . forM trackedReferences $ \refQuery ->
|
||||
fmap (Set.fromList . mapMaybe E.unValue) . E.select $ do
|
||||
ref <- refQuery
|
||||
E.where_ . E.not_ $ E.isNothing ref
|
||||
E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry ->
|
||||
E.where_ $ E.just (fileContentEntry E.^. FileContentEntryHash) E.==. ref
|
||||
E.distinctOnOrderBy [E.asc ref] $ return ref
|
||||
tellM . fmap (Map.singleton "workflows") . runConduit $ workflowFileReferences .| C.foldMap Set.singleton
|
||||
|
||||
let allMissingDb :: Set Minio.Object
|
||||
allMissingDb = setOf (folded . folded . re minioFileReference) missingDb
|
||||
@ -207,12 +214,15 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
|
||||
|
||||
$logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst)
|
||||
|
||||
workflowFiles <- runConduit $ workflowFileReferences .| C.foldMap Set.singleton
|
||||
|
||||
E.insertSelectWithConflict
|
||||
(UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint")
|
||||
(E.from $ \fileContentChunk -> do
|
||||
E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do
|
||||
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId
|
||||
return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash
|
||||
return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
|
||||
E.||. fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList (Set.toList workflowFiles)
|
||||
E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash
|
||||
return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now
|
||||
)
|
||||
@ -223,7 +233,8 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
|
||||
E.delete . E.from $ \fileContentChunkUnreferenced -> do
|
||||
E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
|
||||
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
|
||||
return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash
|
||||
return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
|
||||
E.||. fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList (Set.toList workflowFiles)
|
||||
E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
|
||||
|
||||
let
|
||||
|
||||
@ -34,6 +34,7 @@ newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512)
|
||||
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
|
||||
, Hashable, NFData
|
||||
, ByteArrayAccess
|
||||
, Binary
|
||||
)
|
||||
|
||||
makeWrapped ''FileContentChunkReference
|
||||
@ -44,6 +45,7 @@ newtype FileContentReference = FileContentReference (Digest SHA3_512)
|
||||
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
|
||||
, Hashable, NFData
|
||||
, ByteArrayAccess
|
||||
, Binary
|
||||
)
|
||||
|
||||
makeWrapped ''FileContentReference
|
||||
@ -129,8 +131,12 @@ data FileReference = FileReference
|
||||
, fileReferenceContent :: Maybe FileContentReference
|
||||
, fileReferenceModified :: UTCTime
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Hashable, Binary)
|
||||
|
||||
makeLenses_ ''FileReference
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 2
|
||||
} ''FileReference
|
||||
|
||||
|
||||
class HasFileReference record where
|
||||
|
||||
@ -13,6 +13,7 @@ module Model.Types.Workflow
|
||||
import Import.NoModel
|
||||
|
||||
import Model.Types.Security (AuthDNF)
|
||||
import Model.Types.File (FileContentReference)
|
||||
|
||||
import Database.Persist.Sql (PersistFieldSql(..))
|
||||
|
||||
@ -28,7 +29,7 @@ import Data.Aeson.Types (Parser)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Type.Reflection (eqTypeRep, typeOf, (:~~:)(..))
|
||||
import Type.Reflection (eqTypeRep, typeRep, typeOf, (:~~:)(..))
|
||||
|
||||
import Data.Generics.Product.Types
|
||||
|
||||
@ -267,6 +268,7 @@ type instance Children WorkflowChildren a = ChildrenWorkflowChildren a
|
||||
type family ChildrenWorkflowChildren a where
|
||||
ChildrenWorkflowChildren (Map k v) = '[v]
|
||||
ChildrenWorkflowChildren (Set a) = '[a]
|
||||
ChildrenWorkflowChildren (Seq a) = '[a]
|
||||
ChildrenWorkflowChildren (NonNull mono) = '[Element mono]
|
||||
ChildrenWorkflowChildren (CI a) = '[a]
|
||||
ChildrenWorkflowChildren UUID = '[]
|
||||
@ -274,6 +276,8 @@ type family ChildrenWorkflowChildren a where
|
||||
ChildrenWorkflowChildren Scientific = '[]
|
||||
ChildrenWorkflowChildren (BackendKey SqlBackend) = '[]
|
||||
ChildrenWorkflowChildren (Key record) = '[]
|
||||
ChildrenWorkflowChildren FileContentReference = '[]
|
||||
ChildrenWorkflowChildren UTCTime = '[]
|
||||
ChildrenWorkflowChildren (WorkflowPayloadSpec fileid userid)
|
||||
= ChildrenWorkflowChildren I18nText
|
||||
`Concat` ChildrenWorkflowChildren (Maybe I18nText)
|
||||
@ -285,21 +289,35 @@ type family ChildrenWorkflowChildren a where
|
||||
`Concat` ChildrenWorkflowChildren (Maybe userid)
|
||||
`Concat` ChildrenWorkflowChildren Bool
|
||||
`Concat` ChildrenWorkflowChildren WorkflowPayloadLabel
|
||||
ChildrenWorkflowChildren (WorkflowFieldPayloadW fileid userid)
|
||||
= ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Text)
|
||||
`Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Scientific)
|
||||
`Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Bool)
|
||||
`Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid fileid)
|
||||
`Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid userid)
|
||||
ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid payload)
|
||||
= ChildrenWorkflowChildren payload
|
||||
ChildrenWorkflowChildren a = Children ChGeneric a
|
||||
|
||||
instance HasTypesCustom WorkflowChildren a a a a where
|
||||
typesCustom = id
|
||||
|
||||
instance HasTypesCustom WorkflowChildren v v' a a' => HasTypesCustom WorkflowChildren (Map k v) (Map k v') a a' where
|
||||
typesCustom = traverse . typesCustom @WorkflowChildren
|
||||
|
||||
instance (Ord b', HasTypesCustom WorkflowChildren a' b' a b) => HasTypesCustom WorkflowChildren (Set a') (Set b') a b where
|
||||
typesCustom = iso Set.toList Set.fromList . traverse . typesCustom @WorkflowChildren
|
||||
|
||||
instance (HasTypesCustom WorkflowChildren a' b' a b) => HasTypesCustom WorkflowChildren (Seq a') (Seq b') a b where
|
||||
typesCustom = traverse . typesCustom @WorkflowChildren
|
||||
|
||||
instance (HasTypesCustom WorkflowChildren mono mono' a a', MonoFoldable mono') => HasTypesCustom WorkflowChildren (NonNull mono) (NonNull mono') a a' where
|
||||
typesCustom = iso toNullable impureNonNull . typesCustom @WorkflowChildren
|
||||
|
||||
instance (HasTypesCustom WorkflowChildren a' b' a b, FoldCase b') => HasTypesCustom WorkflowChildren (CI a') (CI b') a b where
|
||||
typesCustom = iso CI.original CI.mk . typesCustom @WorkflowChildren
|
||||
|
||||
instance (Typeable userid, Typeable fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid) fileid fileid' where
|
||||
instance (Typeable userid, Typeable fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') fileid fileid' where
|
||||
typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Just fid', .. }
|
||||
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Nothing, .. }) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Nothing, ..}
|
||||
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
|
||||
@ -308,7 +326,7 @@ instance (Typeable userid, Typeable fileid') => HasTypesCustom WorkflowChildren
|
||||
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..}
|
||||
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}
|
||||
|
||||
instance (Typeable userid', Typeable fileid) => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid userid') userid userid' where
|
||||
instance (Typeable userid', Typeable fileid, fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') userid userid' where
|
||||
typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid', .. }
|
||||
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..}
|
||||
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
|
||||
@ -317,6 +335,18 @@ instance (Typeable userid', Typeable fileid) => HasTypesCustom WorkflowChildren
|
||||
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
|
||||
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}
|
||||
|
||||
instance (Typeable payload, Typeable fileid, Typeable userid, fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') payload payload where
|
||||
typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload) of
|
||||
Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid payload) @(WorkflowFieldPayload fileid userid payload) @payload @payload f p
|
||||
Nothing -> pure pw
|
||||
|
||||
instance (fileid ~ fileid', userid ~ userid', payload ~ payload') => HasTypesCustom WorkflowChildren (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload' where
|
||||
typesCustom f (WFPText x) = WFPText <$> f x
|
||||
typesCustom f (WFPNumber x) = WFPNumber <$> f x
|
||||
typesCustom f (WFPBool x) = WFPBool <$> f x
|
||||
typesCustom f (WFPFile x) = WFPFile <$> f x
|
||||
typesCustom f (WFPUser x) = WFPUser <$> f x
|
||||
|
||||
----- ToJSON / FromJSON instances -----
|
||||
|
||||
omitNothing :: [JSON.Pair] -> [JSON.Pair]
|
||||
|
||||
@ -336,7 +336,8 @@ rationalToFixed3 = rationalToFixed
|
||||
rationalToFixed2 :: Rational -> Fixed E2
|
||||
rationalToFixed2 = rationalToFixed
|
||||
|
||||
|
||||
realToFixed :: forall a n. (Real n, HasResolution a) => n -> Fixed a
|
||||
realToFixed = rationalToFixed . toRational
|
||||
|
||||
----------
|
||||
-- Bool --
|
||||
|
||||
@ -247,7 +247,8 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
|
||||
makeLenses_ ''WorkflowDefinition
|
||||
makeLenses_ ''WorkflowDefinitionDescription
|
||||
|
||||
|
||||
makeWrapped ''Textarea
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
@ -56,8 +56,6 @@ extra-deps:
|
||||
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git
|
||||
commit: 843683d024f767de236f74d24a3348f69181a720
|
||||
|
||||
- generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524 # manual downgrade; won't compile with >=2.0.0.0
|
||||
|
||||
- acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
||||
- commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278
|
||||
- commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176
|
||||
|
||||
@ -157,13 +157,6 @@ packages:
|
||||
original:
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git
|
||||
commit: 843683d024f767de236f74d24a3348f69181a720
|
||||
- completed:
|
||||
hackage: generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524
|
||||
pantry-tree:
|
||||
size: 4315
|
||||
sha256: 9ed161eadfda5b1eb36cfcf077146f7b66db1da69f1041fc720aea287ec021b0
|
||||
original:
|
||||
hackage: generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524
|
||||
- completed:
|
||||
hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
||||
pantry-tree:
|
||||
|
||||
Reference in New Issue
Block a user