diff --git a/models/workflows.model b/models/workflows.model index 09aa58f2c..201bfa72c 100644 --- a/models/workflows.model +++ b/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 diff --git a/src/Crypto/Hash/Instances.hs b/src/Crypto/Hash/Instances.hs index 0be90af18..349464132 100644 --- a/src/Crypto/Hash/Instances.hs +++ b/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 diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 3b721ec26..1e87c3516 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/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 diff --git a/src/Handler/Sheet/CorrectorInvite.hs b/src/Handler/Sheet/CorrectorInvite.hs index 810dfa09b..da23c0b78 100644 --- a/src/Handler/Sheet/CorrectorInvite.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index a91210f10..d8a4a5295 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 diff --git a/src/Handler/Workflow/Definition/Edit.hs b/src/Handler/Workflow/Definition/Edit.hs index 78990b1c0..91018416a 100644 --- a/src/Handler/Workflow/Definition/Edit.hs +++ b/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 - 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' diff --git a/src/Handler/Workflow/Definition/Form.hs b/src/Handler/Workflow/Definition/Form.hs index 8a3b7ce8e..b07089051 100644 --- a/src/Handler/Workflow/Definition/Form.hs +++ b/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 - 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 diff --git a/src/Handler/Workflow/Definition/New.hs b/src/Handler/Workflow/Definition/New.hs index a035c88c6..41ee9a858 100644 --- a/src/Handler/Workflow/Definition/New.hs +++ b/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 !)) - & (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' diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 1663cb2fc..e16db8f24 100644 --- a/src/Jobs/Crontab.hs +++ b/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 diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 6fa139a45..f54e3c9b6 100644 --- a/src/Jobs/Handler/Files.hs +++ b/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 -> - 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 diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index 5da04921b..53f9df9c5 100644 --- a/src/Model/Types/File.hs +++ b/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 diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 51444b3d6..4c61947f7 100644 --- a/src/Model/Types/Workflow.hs +++ b/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] diff --git a/src/Utils.hs b/src/Utils.hs index 89c7a99ec..15235a141 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 1641da3fc..35cc640dc 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -247,7 +247,8 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey makeLenses_ ''WorkflowDefinition makeLenses_ ''WorkflowDefinitionDescription - + +makeWrapped ''Textarea -- makeClassy_ ''Load diff --git a/stack.yaml b/stack.yaml index fbbcd4aaa..987832657 100644 --- a/stack.yaml +++ b/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 diff --git a/stack.yaml.lock b/stack.yaml.lock index 04c6067bc..1e1783785 100644 --- a/stack.yaml.lock +++ b/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: