fix(workflows): integrate in new master

models/workflows.model

@@ -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

src/Crypto/Hash/Instances.hs

@@ -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

src/Handler/Exam/RegistrationInvite.hs

@@ -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

src/Handler/Sheet/CorrectorInvite.hs

@@ -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

src/Handler/Utils/Form.hs

@@ -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
   

src/Handler/Workflow/Definition/Edit.hs

@@ -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
+      let recordFile :: forall m. Monad m => FileReference -> StateT (Bimap FileIdent FileReference) m FileIdent
-          recordFile fId = do
+          recordFile fRef@FileReference{..} = do
-            prev <- State.gets $ Bimap.lookupR fId
+            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
+                let candidateIdents = map (review _Wrapped . CI.mk) $
-                      Just (E.Value fTitle)
+                      map pack $ fileReferenceTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fileReferenceTitle ]
-                        -> map pack $ fTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fTitle ]
-                      Nothing
-                        -> [ [st|file_#{n}|] | n <- [1..] :: [Natural]]
                     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)
+          $ traverseOf (typesCustom @WorkflowChildren) recordFile
-        >=> (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent SqlBackendKey) (WorkflowGraph FileIdent CryptoUUIDUser) SqlBackendKey CryptoUUIDUser) (encrypt . review (_SqlKey @User))
+        >=> 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 !))
+        & over (typesCustom @WorkflowChildren) (wdfFiles !)
-        & (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey CryptoUUIDUser) (WorkflowGraph SqlBackendKey SqlBackendKey) CryptoUUIDUser SqlBackendKey) (fmap (view _SqlKey :: UserId -> SqlBackendKey) . decrypt)
+        & traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
       
       insConflict <- replaceUnique wdId WorkflowDefinition
         { workflowDefinitionGraph = wdfGraph'

src/Handler/Workflow/Definition/Form.hs

@@ -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
+  join . uses _wdfGraph . mapMOf_ (typesCustom @WorkflowChildren) . ensureExists $ Proxy @User
-  fIdentsReferenced <- uses _wdfGraph . setOf $ typesUsing @WorkflowChildren @FileIdent
+  fIdentsReferenced <- uses _wdfGraph . setOf $ typesCustom @WorkflowChildren
   fIdentsAvailable <- uses _wdfFiles Map.keysSet
   forM_ (fIdentsReferenced `Set.difference` fIdentsAvailable) $ tellValidationError . MsgWorkflowDefinitionFileIdentDoesNotExist . views _Wrapped CI.original
   where

src/Handler/Workflow/Definition/New.hs

@@ -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 !))
+        & over (typesCustom @WorkflowChildren) (wdfFiles !)
-        & (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey CryptoUUIDUser) (WorkflowGraph SqlBackendKey SqlBackendKey) CryptoUUIDUser SqlBackendKey) (fmap (view _SqlKey :: UserId -> SqlBackendKey) . decrypt)
+        & traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
       
       insRes <- insertUnique WorkflowDefinition
         { workflowDefinitionGraph = wdfGraph'

src/Jobs/Crontab.hs

@@ -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

src/Jobs/Handler/Files.hs

@@ -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 ->
+      missingDb <- execWriterT $ do
-        fmap (Set.fromList . mapMaybe E.unValue) . E.select $ do
+        tellM . forM trackedReferences $ \refQuery ->
-          ref <- refQuery
+          fmap (Set.fromList . mapMaybe E.unValue) . E.select $ do
-          E.where_ . E.not_ $ E.isNothing ref
+            ref <- refQuery
-          E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry ->
+            E.where_ . E.not_ $ E.isNothing ref
-            E.where_ $ E.just (fileContentEntry E.^. FileContentEntryHash) E.==. ref
+            E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry ->
-          E.distinctOnOrderBy [E.asc ref] $ return ref
+              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

src/Model/Types/File.hs

@@ -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

src/Model/Types/Workflow.hs

@@ -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]

src/Utils.hs

@@ -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 --

src/Utils/Lens.hs

@@ -247,7 +247,8 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey
 
 makeLenses_ ''WorkflowDefinition
 makeLenses_ ''WorkflowDefinitionDescription
-  
+
+makeWrapped ''Textarea
 
 -- makeClassy_ ''Load
 

stack.yaml

@@ -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

stack.yaml.lock

@@ -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: