From adbbb8db6b31ddde65bc94d085c52241b2f4ac39 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 27 Jun 2021 10:51:58 +0200 Subject: [PATCH 1/4] chore: support storing chunks in minio --- config/settings.yml | 1 + .../navigation/breadcrumbs/de-de-formal.msg | 1 + .../utils/navigation/breadcrumbs/en-eu.msg | 1 + models/files.model | 2 +- package.yaml | 1 + routes | 6 +- src/Application.hs | 1 + src/Foundation/Navigation.hs | 1 + src/Handler/Upload.hs | 29 +++ src/Handler/Utils/Files.hs | 197 +++++++++--------- src/Handler/Utils/Memcached.hs | 10 +- src/Jobs.hs | 10 +- src/Jobs/Handler/Files.hs | 35 ++-- src/Model/Tokens.hs | 1 + src/Model/Tokens/Session.hs | 2 +- src/Model/Tokens/Upload.hs | 133 ++++++++++++ src/Model/Types.hs | 1 + src/Model/Types/File.hs | 4 +- src/Model/Types/Upload.hs | 24 +++ src/Settings.hs | 5 +- src/Utils.hs | 15 +- src/Utils/Files.hs | 45 +++- src/Utils/Tokens.hs | 52 ++++- .../Backend/Persistent/Memcached.hs | 6 +- src/Web/ServerSession/Frontend/Yesod/Jwt.hs | 4 +- stack.yaml | 2 + stack.yaml.lock | 7 + test/Handler/Utils/FilesSpec.hs | 62 +++++- test/Model/Tokens/UploadSpec.hs | 47 +++++ test/Model/Types/FileSpec.hs | 48 +++++ test/Model/TypesSpec.hs | 5 + 31 files changed, 596 insertions(+), 162 deletions(-) create mode 100644 src/Handler/Upload.hs create mode 100644 src/Model/Tokens/Upload.hs create mode 100644 src/Model/Types/Upload.hs create mode 100644 test/Model/Tokens/UploadSpec.hs diff --git a/config/settings.yml b/config/settings.yml index 441096909..7cefd42f4 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -194,6 +194,7 @@ session-token-encoding: HS256 session-token-clock-leniency-start: 5 bearer-token-clock-leniency-start: 5 +upload-token-clock-leniency-start: 5 cookies: SESSION: diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 158a13a18..a38672835 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -105,6 +105,7 @@ BreadcrumbGlobalWorkflowInstanceList: Systemweite Workflows BreadcrumbTopWorkflowInstanceList !ident-ok: Workflows BreadcrumbTopWorkflowWorkflowList: Laufende Workflows BreadcrumbError: Fehler +BreadcrumbUpload !ident-ok: Upload BreadcrumbUserAdd: Benutzer:in anlegen BreadcrumbUserNotifications: Benachrichtigungs-Einstellungen BreadcrumbUserPassword: Passwort diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index ecc66292b..f7fd04c97 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -105,6 +105,7 @@ BreadcrumbGlobalWorkflowInstanceList: System-wide workflows BreadcrumbTopWorkflowInstanceList: Workflows BreadcrumbTopWorkflowWorkflowList: Running workflows BreadcrumbError: Error +BreadcrumbUpload: Upload BreadcrumbUserAdd: Add user BreadcrumbUserNotifications: Notification settings BreadcrumbUserPassword: Password diff --git a/models/files.model b/models/files.model index eb0c3ebf3..4d2b7506a 100644 --- a/models/files.model +++ b/models/files.model @@ -1,7 +1,7 @@ FileContentEntry hash FileContentReference ix Word64 - chunkHash FileContentChunkId + chunkHash FileContentChunkReference UniqueFileContentEntry hash ix deriving Generic diff --git a/package.yaml b/package.yaml index 48f3f23d2..66088ba69 100644 --- a/package.yaml +++ b/package.yaml @@ -318,6 +318,7 @@ tests: - uniworx - hspec >=2.0.0 - QuickCheck + - splitmix - HUnit - yesod-test - conduit-extra diff --git a/routes b/routes index 584f6a225..c9b45f88c 100644 --- a/routes +++ b/routes @@ -286,7 +286,11 @@ /msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDreadANDauthentication /msg/#{CryptoUUIDSystemMessage}/hide MessageHideR POST !timeANDauthentication + +/upload UploadR PUT !free + + !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -!/*WellKnownFileName WellKnownR GET !free +!/*WellKnownFileName WellKnownR GET !free \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index bcaf1edda..98260f6b4 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -142,6 +142,7 @@ import Handler.Participants import Handler.StorageKey import Handler.Workflow import Handler.Error +import Handler.Upload -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index e97320722..dd1649358 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -79,6 +79,7 @@ breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing +breadcrumb UploadR = i18nCrumb MsgBreadcrumbUpload Nothing breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs new file mode 100644 index 000000000..7ca52b802 --- /dev/null +++ b/src/Handler/Upload.hs @@ -0,0 +1,29 @@ +module Handler.Upload + ( putUploadR + ) where + +import Import + + +data UploadResponse + = UploadResponseNoToken + deriving (Eq, Ord, Show, Generic, Typeable) + +deriveJSON defaultOptions + { tagSingleConstructors = True + , allNullaryToStringTag = False + , constructorTagModifier = camelToPathPiece' 2 + } ''UploadResponse + + +putUploadR :: Handler TypedContent +putUploadR = do + resp <- exceptT return return $ do + _uploadToken <- decodeUploadToken <=< maybeExceptT UploadResponseNoToken $ lookupCustomHeader HeaderUploadToken + + error "not implemented" + + selectRep $ do + provideRep . return $ toPrettyJSON resp + provideRep . return $ toJSON resp + provideRep . return $ toYAML resp diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index d37e3bac0..2d64af34f 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -2,7 +2,7 @@ module Handler.Utils.Files ( sourceFile, sourceFile' , sourceFiles, sourceFiles' , SourceFilesException(..), _SourceFilesMismatchedHashes, _SourceFilesContentUnavailable - , sourceFileDB, sourceFileDBChunks, sourceFileMinio + , sourceFileDB, sourceFileChunks, sourceFileMinio , acceptFile , respondFileConditional ) where @@ -42,12 +42,18 @@ fileChunkARC :: ( MonadHandler m ) => Maybe Int -> (FileContentChunkReference, (Int, Int)) - -> m (Maybe ByteString) + -> m (Maybe (ByteString, Maybe FileChunkStorage)) -> m (Maybe ByteString) fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do prewarm <- getsYesod appFileSourcePrewarm let getChunkDB = case prewarm of - Nothing -> getChunkDB' + Nothing -> do + chunk' <- getChunkDB' + for chunk' $ \(chunk, mStorage) -> chunk <$ do + $logDebugS "fileChunkARC" "No prewarm" + for_ mStorage $ \storage -> + let w = length chunk + in liftIO $ observeSourcedChunk storage w Just lh -> do chunkRes <- lookupLRUHandle lh k case chunkRes of @@ -56,10 +62,11 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do liftIO $ observeSourcedChunk StoragePrewarm w Nothing -> do chunk' <- getChunkDB' - for chunk' $ \chunk -> chunk <$ do - let w = length chunk + for chunk' $ \(chunk, mStorage) -> chunk <$ do $logDebugS "fileChunkARC" "Prewarm miss" - liftIO $ observeSourcedChunk StorageDB w + for_ mStorage $ \storage -> + let w = length chunk + in liftIO $ observeSourcedChunk storage w arc <- getsYesod appFileSourceARC case arc of @@ -85,50 +92,54 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do sourceFileDB :: forall m. - (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) + (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) => FileContentReference -> ConduitT () ByteString (SqlPersistT m) () sourceFileDB fileReference = chunkHashes - .| awaitForever (sourceFileDBChunks (const id) . unFileContentChunkKey . E.unValue) + .| awaitForever (sourceFileChunks (const $ over (mapped . mapped . _2) Just) . E.unValue) .| C.map (view _1) where - chunkHashes :: ConduitT () (E.Value FileContentChunkId) (SqlPersistT m) () + chunkHashes :: ConduitT () (E.Value FileContentChunkReference) (SqlPersistT m) () chunkHashes = E.selectSource . E.from $ \fileContentEntry -> do E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryIx ] return $ fileContentEntry E.^. FileContentEntryChunkHash -sourceFileDBChunks :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend) - => ((Int, Int) -> ReaderT SqlReadBackend m (Maybe ByteString) -> ReaderT SqlReadBackend m (Maybe ByteString)) -> FileContentChunkReference -> ConduitT i (ByteString, (Int, Int)) (ReaderT backend m) () -sourceFileDBChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlReadBackend) $ do +sourceFileChunks :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, MonadUnliftIO m) + => ((Int, Int) -> ReaderT SqlReadBackend m (Maybe (ByteString, FileChunkStorage)) -> ReaderT SqlReadBackend m (Maybe (ByteString, Maybe FileChunkStorage))) -> FileContentChunkReference -> ConduitT i (ByteString, (Int, Int)) (ReaderT backend m) () +sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlReadBackend) $ do dbChunksize <- getsYesod $ view _appFileUploadDBChunksize - -- mRunner <- getMinioRunner - let retrieveChunk = \case + let dbRetrieveChunk = \case Nothing -> return Nothing Just start -> do - let getChunkDB = cont (start, dbChunksize) . fmap (fmap E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do - E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash - return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) + let getChunkDB = cont (start, dbChunksize) . runMaybeT $ + let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do + E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash + return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) + getChunkMinio = fmap (, StorageMinio) . catchIfMaybeT (is _SourceFilesContentUnavailable) . runConduit $ sourceMinio (Left chunkHash) (Just $ ByteRangeFromTo (fromIntegral $ pred start) (fromIntegral . pred $ pred start + dbChunksize)) .| C.fold + in getChunkDB' <|> getChunkMinio chunk <- fileChunkARC Nothing (chunkHash, (start, dbChunksize)) getChunkDB case chunk of + Just c | olength c <= 0 -> return Nothing Just c -> do return . Just . ((c, (start, dbChunksize)), ) $ if | olength c >= dbChunksize -> Just $ start + dbChunksize | otherwise -> Nothing - -- Nothing | Just MinioRunner{..} <- mRunner -> do Nothing -> throwM SourceFilesContentUnavailable - C.unfoldM retrieveChunk $ Just (1 :: Int) + C.unfoldM dbRetrieveChunk $ Just (1 :: Int) -sourceFileMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) - => FileContentReference -> ConduitT () ByteString m () -sourceFileMinio fileReference = do +sourceMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) + => Either FileContentChunkReference FileContentReference + -> Maybe ByteRange + -> ConduitT i ByteString m () +sourceMinio fileReference mRange = do chunkVar <- newEmptyTMVarIO minioAsync <- lift . allocateLinkedAsync $ maybeT (throwM SourceFilesContentUnavailable) $ do - let uploadName = minioFileReference # fileReference + let uploadName = either (review minioFileChunkReference) (review minioFileReference) fileReference uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket hoistMaybe <=< runAppMinio . runMaybeT $ do - objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions + objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions{ Minio.gooRange = mRange } lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar) let go = do mChunk <- atomically $ Right <$> takeTMVar chunkVar @@ -142,6 +153,9 @@ sourceFileMinio fileReference = do Left (Left exc) -> throwM exc in go +sourceFileMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) + => FileContentReference -> ConduitT () ByteString m () +sourceFileMinio fileContent = sourceMinio (Right fileContent) Nothing sourceFiles :: (Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT FileReference DBFile m () sourceFiles = C.map sourceFile @@ -178,10 +192,10 @@ respondFileConditional representationLastModified cType FileReference{..} = do -> return . respondSourceConditional @ByteRangesSpecifier condInfo cType . Left $ (return () :: ConduitT () ByteString _ ()) | Just fileContent <- fileReferenceContent -> do dbManifest <- fmap fromNullable . E.select . E.from $ \(fileContentEntry `E.LeftOuterJoin` fileContentChunk) -> do - E.on $ E.just (fileContentEntry E.^. FileContentEntryChunkHash) E.==. fileContentChunk E.?. FileContentChunkId + E.on $ E.just (fileContentEntry E.^. FileContentEntryChunkHash) E.==. fileContentChunk E.?. FileContentChunkHash E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileContent E.orderBy [E.asc $ fileContentEntry E.^. FileContentEntryIx ] - return ( fileContentChunk E.?. FileContentChunkHash + return ( fileContentEntry E.^. FileContentEntryChunkHash , E.maybe E.nothing (E.just . E.length_) $ fileContentChunk E.?. FileContentChunkContent ) case dbManifest of @@ -192,79 +206,57 @@ respondFileConditional representationLastModified cType FileReference{..} = do catchIfMaybeT minioIsDoesNotExist $ Minio.statObject uploadBucket uploadName Minio.defaultGetObjectOptions let iLength = fromIntegral $ Minio.oiSize statRes respondSourceConditional condInfo cType . Right $ \byteRange -> - let byteRange' = case byteRange of - ByteRangeSpecification f Nothing -> ByteRangeFrom (fromIntegral $ min (pred iLength) f) - ByteRangeSpecification f (Just t) -> ByteRangeFromTo (fromIntegral $ min iLength f) (fromIntegral $ min (pred iLength) t) - ByteRangeSuffixSpecification s -> ByteRangeSuffix (fromIntegral $ min iLength s) - respRange = case byteRange of - ByteRangeSpecification f Nothing -> ByteRangeResponseSpecification (min (pred iLength) f) (pred iLength) - ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t) - ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength) - in ( do - chunkVar <- newEmptyTMVarIO - minioAsync <- lift . allocateLinkedAsync $ - maybeT (throwM SourceFilesContentUnavailable) . (hoistMaybe <=< runAppMinio) . runMaybeT $ do - objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions{ Minio.gooRange = Just byteRange' } - lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar) - let go = do - mChunk <- atomically $ Right <$> takeTMVar chunkVar - <|> Left <$> waitCatchSTM minioAsync - case mChunk of - Right chunk -> do - observeSourcedChunk StorageMinio $ olength chunk - yield chunk - go - Left (Right ()) -> return () - Left (Left exc) -> throwM exc - in go + let (byteRange', respRange) = byteRangeSpecificationToMinio iLength byteRange + in ( sourceMinio (Right fileContent) $ Just byteRange' , ByteContentRangeSpecification (Just respRange) (Just iLength) ) - Just (toNullable -> dbManifest') - | Just dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value chunkLength) -> (,) <$> chunkHash <*> chunkLength - -> do - let iLength = sumOf (folded . _2) dbManifest'' - respondSourceDBConditional condInfo cType . Right $ \byteRange -> - let (byteFrom, byteTo) = case byteRange of - ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength) - ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t) - ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength) - relevantChunks = view _2 $ foldl' go (0, []) dbManifest'' - where go :: (Word64, [(FileContentChunkReference, Word64, Word64)]) - -> (FileContentChunkReference, Word64) - -> (Word64, [(FileContentChunkReference, Word64, Word64)]) - go (lengthBefore, acc) (cChunk, cLength) - = ( lengthBefore + cLength - , if - | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore - -> let cChunk' = ( cChunk - , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore - , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength - ) - in acc ++ pure cChunk' - | otherwise - -> acc - ) - in ( do - dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral - forM_ relevantChunks $ \(chunkHash, offset, cLength) - -> let retrieveChunk = \case - Just (start, cLength') | cLength' > 0 -> do - let getChunkDB = fmap (fmap E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do - E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash - return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) - chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB - case chunk of - Nothing -> throwM SourceFilesContentUnavailable - Just c -> do - return . Just . (c, ) $ if - | fromIntegral (olength c) >= min cLength' dbChunksize - -> Just (start + dbChunksize, cLength' - fromIntegral (olength c)) - | otherwise - -> Nothing - _other -> return Nothing - in C.unfoldM retrieveChunk . Just $ (succ offset, cLength) - , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength) - ) + Just (toNullable -> dbManifest') -> do + dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value mChunkLength) -> case mChunkLength of + Just chunkLength -> return (chunkHash, chunkLength) + Nothing -> throwM SourceFilesContentUnavailable + let iLength = sumOf (folded . _2) dbManifest'' + respondSourceDBConditional condInfo cType . Right $ \byteRange -> + let (byteFrom, byteTo) = case byteRange of + ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength) + ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t) + ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength) + relevantChunks = view _2 $ foldl' go (0, []) dbManifest'' + where go :: (Word64, [(FileContentChunkReference, Word64, Word64)]) + -> (FileContentChunkReference, Word64) + -> (Word64, [(FileContentChunkReference, Word64, Word64)]) + go (lengthBefore, acc) (cChunk, cLength) + = ( lengthBefore + cLength + , if + | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore + -> let cChunk' = ( cChunk + , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore + , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength + ) + in acc ++ pure cChunk' + | otherwise + -> acc + ) + in ( do + dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral + forM_ relevantChunks $ \(chunkHash, offset, cLength) + -> let retrieveChunk = \case + Just (start, cLength') | cLength' > 0 -> do + let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do + E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash + return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) + chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB + case chunk of + Nothing -> throwM SourceFilesContentUnavailable + Just c -> do + return . Just . (c, ) $ if + | fromIntegral (olength c) >= min cLength' dbChunksize + -> Just (start + dbChunksize, cLength' - fromIntegral (olength c)) + | otherwise + -> Nothing + _other -> return Nothing + in C.unfoldM retrieveChunk . Just $ (succ offset, cLength) + , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength) + ) | otherwise -> throwM SourceFilesContentUnavailable | otherwise @@ -277,6 +269,17 @@ respondFileConditional representationLastModified cType FileReference{..} = do , requestedActionAlreadySucceeded = Nothing } +byteRangeSpecificationToMinio :: Word64 -> ByteRangeSpecification -> (ByteRange, ByteRangeResponseSpecification) +byteRangeSpecificationToMinio iLength byteRange = (byteRange', respRange) + where + byteRange' = case byteRange of + ByteRangeSpecification f Nothing -> ByteRangeFrom (fromIntegral $ min (pred iLength) f) + ByteRangeSpecification f (Just t) -> ByteRangeFromTo (fromIntegral $ min iLength f) (fromIntegral $ min (pred iLength) t) + ByteRangeSuffixSpecification s -> ByteRangeSuffix (fromIntegral $ min iLength s) + respRange = case byteRange of + ByteRangeSpecification f Nothing -> ByteRangeResponseSpecification (min (pred iLength) f) (pred iLength) + ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t) + ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength) acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m') diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 593ddf14e..41dd2aecc 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -56,7 +56,7 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent.STM.Delay import qualified Crypto.Saltine.Class as Saltine -import qualified Crypto.Saltine.Internal.ByteSizes as Saltine +import qualified Crypto.Saltine.Internal.SecretBox as Saltine import qualified Crypto.Saltine.Core.AEAD as AEAD import qualified Control.Monad.State.Class as State @@ -126,15 +126,15 @@ putMemcachedValue MemcachedValue{..} = do getMemcachedValue, getMemcachedValueNoExpiry :: Binary.Get MemcachedValue getMemcachedValue = do Binary.lookAhead . Binary.label "length check" $ do - void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac - mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode + void . Binary.getByteString $ Saltine.secretbox_noncebytes + 4 + Saltine.secretbox_macbytes + mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretbox_noncebytes >>= hoistMaybe . Saltine.decode mExpiry <- getExpiry mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString return MemcachedValue{..} getMemcachedValueNoExpiry = do Binary.lookAhead . Binary.label "length check" $ do - void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac - mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode + void . Binary.getByteString $ Saltine.secretbox_noncebytes + 4 + Saltine.secretbox_macbytes + mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretbox_noncebytes >>= hoistMaybe . Saltine.decode let mExpiry = Nothing mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString return MemcachedValue{..} diff --git a/src/Jobs.hs b/src/Jobs.hs index ee817c880..520694b50 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -53,7 +53,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Data.ByteString as ByteString -import Handler.Utils.Files (sourceFileDBChunks, _SourceFilesContentUnavailable) +import Handler.Utils.Files (sourceFileChunks, _SourceFilesContentUnavailable) import qualified Data.IntervalMap.Strict as IntervalMap @@ -598,7 +598,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker prewarm <- getsYesod appFileSourcePrewarm for_ prewarm $ \lh -> lift . runDBRead $ runConduit $ sourceFileChunkIds .| C.map E.unValue - .| awaitForever (\cRef -> handleC handleUnavailable $ sourceFileDBChunks (withLRU lh cRef) cRef .| C.map (cRef, )) + .| awaitForever (\cRef -> handleC handleUnavailable $ sourceFileChunks (withLRU lh cRef) cRef .| C.map (cRef, )) .| C.mapM_ (sinkChunkCache lh) where handleUnavailable e @@ -607,11 +607,11 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker withLRU lh cRef range getChunk = do touched <- touchLRUHandle lh (cRef, range) jcTargetTime case touched of - Just (bs, _) -> return $ Just bs - Nothing -> getChunk + Just (bs, _) -> return $ Just (bs, Nothing) + Nothing -> over (mapped . _2) Just <$> getChunk (minBoundDgst, maxBoundDgst) = jcChunkInterval sourceFileChunkIds = E.selectSource . E.from $ \fileContentEntry -> do - let cRef = E.unKey $ fileContentEntry E.^. FileContentEntryChunkHash + let cRef = fileContentEntry E.^. FileContentEntryChunkHash eRef = fileContentEntry E.^. FileContentEntryHash E.where_ . E.and $ catMaybes [ minBoundDgst <&> \b -> cRef E.>=. E.val b diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index ecf6a2924..b70e45835 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -60,7 +60,7 @@ dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin fileReferences :: E.SqlExpr (E.Value FileContentReference) -> [E.SqlQuery ()] -fileReferences (E.just -> fHash) +fileReferences fHash'@(E.just -> fHash) = [ E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileContent E.==. fHash , E.from $ \matFile -> E.where_ $ matFile E.^. MaterialFileContent E.==. fHash , E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileContent E.==. fHash @@ -71,9 +71,10 @@ fileReferences (E.just -> fHash) , E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileContent E.==. fHash , E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileContent E.==. fHash , E.from $ \lock -> E.where_ $ E.just (lock E.^. FileLockContent) E.==. fHash - , E.from $ \chunkLock -> E.where_ . E.exists . E.from $ \fileContentEntry -> - E.where_ $ E.just (fileContentEntry E.^. FileContentEntryHash) E.==. fHash - E.&&. chunkLock E.^. FileChunkLockHash E.==. E.subSelectForeign fileContentEntry FileContentEntryChunkHash (E.^. FileContentChunkHash) + , E.from $ \chunkLock -> E.where_ . E.exists . E.from $ \(fileContentEntry `E.InnerJoin` fileContentChunk) -> do + E.on $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkHash + E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. fHash' + E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. chunkLock E.^. FileChunkLockHash ] workflowFileReferences :: MonadResource m => Map Text (ConduitT () FileContentReference (SqlPersistT m) ()) @@ -187,7 +188,7 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom (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 + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkHash return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash) E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now @@ -197,25 +198,28 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom ) E.delete . E.from $ \fileContentChunkUnreferenced -> do + let unreferencedChunkHash = E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash) - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + E.where_ $ chunkIdFilter unreferencedChunkHash let unmarkWorkflowFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do + let unreferencedChunkHash = E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + E.where_ $ chunkIdFilter unreferencedChunkHash chunkSize = 100 in runConduit $ sequence_ workflowFileReferences .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkWorkflowFiles let getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do - E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash + let unreferencedChunkHash = E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + E.where_ $ chunkIdFilter unreferencedChunkHash return . E.max_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.where_ $ E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) unreferencedSince @@ -236,11 +240,12 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom let getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do + let unreferencedChunkHash = E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) E.where_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.<. E.val (addUTCTime (-keep) now) E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry -> - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + E.where_ $ chunkIdFilter unreferencedChunkHash return ( fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash , E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash $ E.length_ . (E.^. FileContentChunkContent) @@ -371,12 +376,12 @@ dispatchJobRechunkFiles = JobHandlerAtomicWithFinalizer act fin let getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> E.distinctOnOrderBy [E.asc $ fileContentEntry E.^. FileContentEntryHash] $ do E.where_ . E.exists . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do - E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash + E.on $ fileContentChunk E.^. FileContentChunkHash E.==. fileContentEntry' E.^. FileContentEntryChunkHash E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash E.where_ . E.not_ $ fileContentChunk E.^. FileContentChunkContentBased let size = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do - E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash + E.on $ fileContentChunk E.^. FileContentChunkHash E.==. fileContentEntry' E.^. FileContentEntryChunkHash E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash return $ E.sum_ (E.length_ $ fileContentChunk E.^. FileContentChunkContent:: E.SqlExpr (E.Value Word64)) diff --git a/src/Model/Tokens.hs b/src/Model/Tokens.hs index 3486f9eab..533eed442 100644 --- a/src/Model/Tokens.hs +++ b/src/Model/Tokens.hs @@ -5,3 +5,4 @@ module Model.Tokens import Model.Tokens.Lens as Model.Tokens import Model.Tokens.Bearer as Model.Tokens import Model.Tokens.Session as Model.Tokens +import Model.Tokens.Upload as Model.Tokens diff --git a/src/Model/Tokens/Session.hs b/src/Model/Tokens/Session.hs index 2a5990eaf..547a510c1 100644 --- a/src/Model/Tokens/Session.hs +++ b/src/Model/Tokens/Session.hs @@ -58,7 +58,7 @@ instance FromJSON (SessionToken sess) where Jose.JwtClaims{..} <- parseJSON val sessionIdentifier <- parseMaybe "sessionIdentfier" $ - fromPathPiece =<< jwtIss + fromPathPiece =<< jwtJti sessionId <- parseMaybe "sessionId" $ fromPathPiece =<< jwtSub sessionIssuedAt <- parseMaybe "sessionIssuedAt" $ diff --git a/src/Model/Tokens/Upload.hs b/src/Model/Tokens/Upload.hs new file mode 100644 index 000000000..da51252db --- /dev/null +++ b/src/Model/Tokens/Upload.hs @@ -0,0 +1,133 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +module Model.Tokens.Upload + ( UploadNonce, newUploadNonce + , UploadToken(..) + , _uploadTokenIdentifier, _uploadTokenNonce, _uploadTokenIssuedBy, _uploadTokenIssuedAt, _uploadTokenExpiresAt, _uploadTokenStartsAt, _uploadTokenConfig + , UploadTokenState(..) + , _uploadTokenStateHashState, _uploadTokenStateManifest + , UploadTokenStateHashState(..) + , _utsHashStateNonce, _utsHashStateState + ) where + +import ClassyPrelude.Yesod + +import Model.Tokens.Lens +import Model +import Utils.Lens + +import Jose.Jwt (IntDate(..)) +import qualified Jose.Jwt as Jose + +import Data.Time.Clock.POSIX + +import Control.Monad.Fail + +import qualified Data.Aeson as JSON +import Data.Aeson.TH +import Utils.PathPiece + +import qualified Data.HashMap.Strict as HashMap + +import qualified Crypto.Saltine.Core.SecretBox as SecretBox +import qualified Data.ByteString.Base64.URL as Base64 +import qualified Crypto.Saltine.Class as Saltine +import qualified Crypto.Saltine.Internal.SecretBox as Saltine + +import qualified Data.ByteString as BS + + +data UploadToken = UploadToken + { uploadTokenIdentifier :: TokenId + , uploadTokenNonce :: UploadNonce + , uploadTokenIssuedAt :: UTCTime + , uploadTokenIssuedBy :: InstanceId + , uploadTokenIssuedFor :: ClusterId + , uploadTokenExpiresAt + , uploadTokenStartsAt :: Maybe UTCTime + , uploadTokenConfig :: FileField FileReference + , uploadTokenState :: Maybe UploadTokenState + } deriving (Eq, Ord, Show, Generic, Typeable) + +data UploadTokenState = UploadTokenState + { uploadTokenStateHashState :: UploadTokenStateHashState + , uploadTokenStateManifest :: Seq FileContentChunkReference + } deriving (Eq, Ord, Show, Generic, Typeable) + +data UploadTokenStateHashState = UploadTokenStateHashState + { utsHashStateNonce :: SecretBox.Nonce + , utsHashStateState :: ByteString + } deriving (Eq, Ord, Show, Generic, Typeable) + + +makeLenses_ ''UploadToken +instance HasTokenIdentifier UploadToken TokenId where + _tokenIdentifier = _uploadTokenIdentifier +instance HasTokenIssuedBy UploadToken InstanceId where + _tokenIssuedBy = _uploadTokenIssuedBy +instance HasTokenIssuedFor UploadToken ClusterId where + _tokenIssuedFor = _uploadTokenIssuedFor +instance HasTokenIssuedAt UploadToken UTCTime where + _tokenIssuedAt = _uploadTokenIssuedAt +instance HasTokenExpiresAt UploadToken (Maybe UTCTime) where + _tokenExpiresAt = _uploadTokenExpiresAt +instance HasTokenStartsAt UploadToken (Maybe UTCTime) where + _tokenStartsAt = _uploadTokenStartsAt +makeLenses_ ''UploadTokenState +makeLenses_ ''UploadTokenStateHashState + + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 3 + } ''UploadTokenState + +instance ToJSON UploadTokenStateHashState where + toJSON UploadTokenStateHashState{..} = JSON.String . decodeUtf8 . Base64.encode $ Saltine.encode utsHashStateNonce <> utsHashStateState + +instance FromJSON UploadTokenStateHashState where + parseJSON = JSON.withText "UploadTokenStateHashState" $ \t -> do + decoded <- either (const $ fail "Invalid base64") return . Base64.decode $ encodeUtf8 t + unless (BS.length decoded >= Saltine.secretbox_noncebytes + Saltine.secretbox_macbytes) $ + fail "Too short" + let (nonceBS, utsHashStateState) = BS.splitAt Saltine.secretbox_noncebytes decoded + utsHashStateNonce <- maybe (fail "Invalid nonce") return $ Saltine.decode nonceBS + return UploadTokenStateHashState{..} + +instance ToJSON UploadToken where + toJSON UploadToken{..} = JSON.object . catMaybes $ + [ pure $ "config" JSON..= uploadTokenConfig + , fmap ("state" JSON..=) uploadTokenState + ] ++ let JSON.Object hm = toJSON Jose.JwtClaims{..} in (pure <$> HashMap.toList hm) + where jwtIss = Just $ toPathPiece uploadTokenIssuedBy + jwtSub = Just $ toPathPiece uploadTokenNonce + jwtAud = Just . pure $ toPathPiece uploadTokenIssuedFor + jwtExp = IntDate . utcTimeToPOSIXSeconds <$> uploadTokenExpiresAt + jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> uploadTokenStartsAt + jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds uploadTokenIssuedAt + jwtJti = Just $ toPathPiece uploadTokenIdentifier + +instance FromJSON UploadToken where + parseJSON val = flip (JSON.withObject "UploadToken") val $ \o -> do + Jose.JwtClaims{..} <- parseJSON val + + uploadTokenIdentifier <- parseMaybe "uploadTokenIdentfier" $ + fromPathPiece =<< jwtJti + uploadTokenNonce <- parseMaybe "uploadTokenNonce" $ + fromPathPiece =<< jwtSub + uploadTokenIssuedAt <- parseMaybe "uploadTokenIssuedAt" $ + unIntDate <$> jwtIat + uploadTokenIssuedBy <- parseMaybe "uploadTokenIssuedBy" $ + fromPathPiece =<< jwtIss + uploadTokenIssuedFor <- parseMaybe "uploadTokenIssuedFor" $ do + [aud] <- jwtAud + fromPathPiece aud + let uploadTokenExpiresAt = unIntDate <$> jwtExp + uploadTokenStartsAt = unIntDate <$> jwtNbf + + uploadTokenConfig <- o JSON..: "config" + uploadTokenState <- o JSON..:? "state" + + return UploadToken{..} + where + parseMaybe errId = maybe (fail $ "Could not parse " <> errId) return + unIntDate (IntDate posix) = posixSecondsToUTCTime posix diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 9ee14e263..5b5562675 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -22,3 +22,4 @@ import Model.Types.Changelog as Types import Model.Types.Markup as Types import Model.Types.Room as Types import Model.Types.Csv as Types +import Model.Types.Upload as Types diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index b06396f86..0a3819c28 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -57,12 +57,12 @@ instance PersistFieldSql FileContentChunkReference where makeWrapped ''FileContentChunkReference -minioFileChunkReference :: Prism' Minio.Object FileContentReference +minioFileChunkReference :: Prism' Minio.Object FileContentChunkReference minioFileChunkReference = prism' toObjectName fromObjectName where toObjectName = (chunkPrefix <>) . decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert fromObjectName = fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded . encodeUtf8 <=< Text.stripPrefix chunkPrefix - chunkPrefix = "partial." + chunkPrefix = "chunk." newtype FileContentReference = FileContentReference (Digest SHA3_512) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) diff --git a/src/Model/Types/Upload.hs b/src/Model/Types/Upload.hs new file mode 100644 index 000000000..4363c841a --- /dev/null +++ b/src/Model/Types/Upload.hs @@ -0,0 +1,24 @@ +module Model.Types.Upload + ( UploadNonce, newUploadNonce + ) where + +import Import.NoModel +import Model.Types.TH.PathPiece + +import qualified Crypto.Nonce as Nonce +import System.IO.Unsafe + + +newtype UploadNonce = UploadNonce Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (ToJSON, FromJSON, ToJSONKey, FromJSONKey, PathPiece) +makeWrapped ''UploadNonce + +derivePersistFieldPathPiece ''UploadNonce + +uploadNonceGen :: Nonce.Generator +uploadNonceGen = unsafePerformIO Nonce.new +{-# NOINLINE uploadNonceGen #-} + +newUploadNonce :: MonadIO m => m UploadNonce +newUploadNonce = review _Wrapped <$> Nonce.nonce128urlT uploadNonceGen diff --git a/src/Settings.hs b/src/Settings.hs index deac6d484..dbb414987 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -116,7 +116,8 @@ data AppSettings = AppSettings , appSessionTokenExpiration :: Maybe NominalDiffTime , appSessionTokenEncoding :: JwtEncoding , appSessionTokenClockLeniencyStart, appSessionTokenClockLeniencyEnd - , appBearerTokenClockLeniencyStart, appBearerTokenClockLeniencyEnd :: Maybe NominalDiffTime + , appBearerTokenClockLeniencyStart, appBearerTokenClockLeniencyEnd + , appUploadTokenClockLeniencyStart, appUploadTokenClockLeniencyEnd :: Maybe NominalDiffTime , appMailObjectDomain :: Text , appMailVerp :: VerpMode @@ -641,6 +642,8 @@ instance FromJSON AppSettings where appSessionTokenClockLeniencyEnd <- o .:? "session-token-clock-leniency-end" appBearerTokenClockLeniencyStart <- o .:? "bearer-token-clock-leniency-start" appBearerTokenClockLeniencyEnd <- o .:? "bearer-token-clock-leniency-end" + appUploadTokenClockLeniencyStart <- o .:? "upload-token-clock-leniency-start" + appUploadTokenClockLeniencyEnd <- o .:? "upload-token-clock-leniency-end" appFavouritesQuickActionsBurstsize <- o .: "favourites-quick-actions-burstsize" appFavouritesQuickActionsAvgInverseRate <- o .: "favourites-quick-actions-avg-inverse-rate" diff --git a/src/Utils.hs b/src/Utils.hs index 16a716cc6..caa059f5e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -92,7 +92,7 @@ import qualified Data.Yaml as Yaml import Data.Universe -import qualified Crypto.Saltine.Internal.ByteSizes as Saltine +import qualified Crypto.Saltine.Internal.SecretBox as Saltine import qualified Data.ByteString.Base64.URL as Base64 import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Crypto.Saltine.Core.Auth as Auth @@ -1110,7 +1110,14 @@ choice = foldr (<|>) empty -- Custom HTTP Headers -- --------------------------------- -data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit | HeaderMassInputShortcircuit | HeaderAlerts | HeaderDBTableCanonicalURL | HeaderDryRun +data CustomHeader + = HeaderIsModal + | HeaderDBTableShortcircuit + | HeaderMassInputShortcircuit + | HeaderAlerts + | HeaderDBTableCanonicalURL + | HeaderDryRun + | HeaderUploadToken deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe CustomHeader @@ -1211,9 +1218,9 @@ encodedSecretBoxOpen' sKey chunked = do let unchunked = stripAll chunked decoded <- either (throwError . EncodedSecretBoxInvalidBase64) return . Base64.decode $ encodeUtf8 unchunked - unless (BS.length decoded >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $ + unless (BS.length decoded >= Saltine.secretbox_noncebytes + Saltine.secretbox_macbytes) $ throwError EncodedSecretBoxCiphertextTooShort - let (nonceBS, encrypted) = BS.splitAt Saltine.secretBoxNonce decoded + let (nonceBS, encrypted) = BS.splitAt Saltine.secretbox_noncebytes decoded nonce <- maybe (throwError EncodedSecretBoxCouldNotDecodeNonce) return $ Saltine.decode nonceBS padded <- maybe (throwError EncodedSecretBoxCouldNotOpenSecretBox) return $ SecretBox.secretboxOpen sKey nonce encrypted diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 1e3ebb620..be59f4701 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -7,6 +7,7 @@ module Utils.Files , replaceFileReferences, replaceFileReferences' , sinkFileDB, sinkFileMinio , isEmptyFileReference + , sinkMinio ) where import Import.NoFoundation @@ -41,6 +42,8 @@ import Control.Monad.Trans.Cont import qualified Crypto.Nonce as Nonce import System.IO.Unsafe +import Data.Typeable (eqT) + sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => Bool -- ^ Replace? Use only in serializable transaction @@ -84,7 +87,7 @@ sinkFileDB doReplace fileContentContent = do let entryExists = E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileContentHash insertEntries = handleIfSql isUniqueConstraintViolation (const $ return ()) . void $ insertMany_ [ FileContentEntry{ fileContentEntryHash = fileContentHash, .. } - | fileContentEntryChunkHash <- otoList fileContentChunks + | fileContentEntryChunkHash <- fileContentChunks ^.. traverse . to unFileContentChunkKey | fileContentEntryIx <- [0..] ] if | not doReplace -> unlessM entryExists insertEntries @@ -100,12 +103,21 @@ sinkFileDB doReplace fileContentContent = do minioTmpGenerator :: Nonce.Generator minioTmpGenerator = unsafePerformIO Nonce.new {-# NOINLINE minioTmpGenerator #-} - -sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) - => ConduitT () ByteString m () - -> MaybeT m FileContentReference --- ^ Cannot deal with zero length uploads -sinkFileMinio fileContentContent = do + +class Typeable ret => SinkMinio ret where + _sinkMinioRet :: Iso' ret (Digest SHA3_512) + default _sinkMinioRet :: (Rewrapping ret ret, Unwrapped ret ~ Digest SHA3_512) => Iso' ret (Digest SHA3_512) + _sinkMinioRet = _Wrapped +instance SinkMinio FileContentReference +instance SinkMinio FileContentChunkReference + +sinkMinio :: forall ret m. + ( MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m + , SinkMinio ret + ) + => ConduitT () ByteString m () + -> MaybeT m ret +sinkMinio content = do uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket tmpBucket <- getsYesod $ views appSettings appUploadTmpBucket chunk <- liftIO newEmptyMVar @@ -120,7 +132,7 @@ sinkFileMinio fileContentContent = do yield nextChunk' putChunks sinkAsync <- lift . allocateLinkedAsync . runConduit - $ fileContentContent + $ content .| putChunks .| Crypto.sinkHash @@ -131,8 +143,13 @@ sinkFileMinio fileContentContent = do } removeObject <- withRunInIO $ \runInIO -> runInIO . register . runInIO $ Minio.removeObject tmpBucket uploadName Minio.putObject tmpBucket uploadName (C.unfoldM (\x -> fmap (, x) <$> takeMVar chunk) ()) Nothing pooOptions - fileContentHash <- review _Wrapped <$> waitAsync sinkAsync - let dstName = minioFileReference # fileContentHash + contentHash <- waitAsync sinkAsync + let dstName | Just Refl <- eqT @ret @FileContentReference + = minioFileReference . _sinkMinioRet # contentHash + | Just Refl <- eqT @ret @FileContentChunkReference + = minioFileChunkReference . _sinkMinioRet # contentHash + | otherwise + = error "sinkMinio called for return type other than FileContentReference or FileContentChunkReference" copySrc = Minio.defaultSourceInfo { Minio.srcBucket = tmpBucket , Minio.srcObject = uploadName @@ -145,7 +162,13 @@ sinkFileMinio fileContentContent = do unless uploadExists $ Minio.copyObject copyDst copySrc release removeObject - return fileContentHash + return $ _sinkMinioRet # contentHash + +sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) + => ConduitT () ByteString m () + -> MaybeT m FileContentReference +-- ^ Cannot deal with zero length uploads +sinkFileMinio = sinkMinio @FileContentReference sinkFiles :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT (File (SqlPersistT m)) FileReference (SqlPersistT m) () diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index d26f22ec0..e072148d2 100644 --- a/src/Utils/Tokens.hs +++ b/src/Utils/Tokens.hs @@ -4,6 +4,7 @@ module Utils.Tokens , bearerParseJSON' , askBearer , formEmbedBearerPost, formEmbedBearerGet + , decodeUploadToken ) where import Import.NoModel @@ -101,10 +102,9 @@ data BearerTokenException = BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation | BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted) | BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken` - | BearerTokenExpired | BearerTokenNotStarted + | BearerTokenExpired | BearerTokenNotStarted | BearerTokenWrongAudience deriving (Eq, Show, Generic, Typeable) - -instance Exception BearerTokenException + deriving anyclass (Exception) decodeBearer :: forall m. ( MonadHandler m @@ -115,12 +115,12 @@ decodeBearer :: forall m. , MonadCrypto m , ParseRoute (HandlerSite m) , Hashable (Route (HandlerSite m)) - , HasAppSettings (HandlerSite m) + , HasAppSettings (HandlerSite m), HasClusterID (HandlerSite m) ClusterId ) => Jwt -> m (BearerToken (HandlerSite m)) -- ^ Decode a `Jwt` and call `bearerParseJSON` -- --- Throws `bearerTokenException`s +-- Throws `BearerTokenException`s decodeBearer (Jwt bs) = do JwkSet jwks <- getsYesod $ view jsonWebKeySet content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs) @@ -130,6 +130,9 @@ decodeBearer (Jwt bs) = do Jose.Jwe (_header, payload) -> return payload parser <- bearerParseJSON' bearer@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content' + bearerIssuedFor' <- getsYesod $ view clusterID + unless (bearerIssuedFor' == bearerIssuedFor) $ + throwM BearerTokenWrongAudience now <- liftIO getCurrentTime (clockLeniencyStart, clockLeniencyEnd) <- getsYesod $ (,) <$> view _appBearerTokenClockLeniencyStart <*> view _appBearerTokenClockLeniencyEnd unless (NTop bearerExpiresAt > NTop (Just $ maybe id addUTCTime (negate <$> clockLeniencyEnd) now)) $ @@ -166,3 +169,42 @@ formEmbedBearerGet f fragment = do #{fragment} |] + + +data UploadTokenException + = UploadTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation + | UploadTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted) + | UploadTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `UploadToken` + | UploadTokenExpired | UploadTokenNotStarted | UploadTokenWrongAudience + deriving (Eq, Show, Generic, Typeable) + deriving anyclass (Exception) + +decodeUploadToken :: forall m. + ( MonadHandler m, MonadThrow m + , HasJSONWebKeySet (HandlerSite m) JwkSet + , HasAppSettings (HandlerSite m), HasClusterID (HandlerSite m) ClusterId + ) + => Jwt -> m UploadToken +-- ^ Decode a `Jwt` +-- +-- Throws `UploadTokenException`s +decodeUploadToken (Jwt bs) = do + JwkSet jwks <- getsYesod $ view jsonWebKeySet + content <- either (throwM . UploadTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs) + content' <- case content of + Jose.Unsecured _ -> throwM UploadTokenUnsecured + Jose.Jws (_header, payload) -> return payload + Jose.Jwe (_header, payload) -> return payload + + uploadToken@UploadToken{..} <- either (throwM . UploadTokenInvalidFormat) return $ JSON.eitherDecodeStrict content' + + uploadTokenIssuedFor' <- getsYesod $ view clusterID + unless (uploadTokenIssuedFor' == uploadTokenIssuedFor) $ + throwM UploadTokenWrongAudience + now <- liftIO getCurrentTime + (clockLeniencyStart, clockLeniencyEnd) <- getsYesod $ (,) <$> view _appUploadTokenClockLeniencyStart <*> view _appUploadTokenClockLeniencyEnd + unless (NTop uploadTokenExpiresAt > NTop (Just $ maybe id addUTCTime (negate <$> clockLeniencyEnd) now)) $ + throwM UploadTokenExpired + unless (uploadTokenStartsAt <= Just (maybe id addUTCTime clockLeniencyStart now)) $ + throwM UploadTokenNotStarted + return uploadToken diff --git a/src/Web/ServerSession/Backend/Persistent/Memcached.hs b/src/Web/ServerSession/Backend/Persistent/Memcached.hs index 7457fac16..2f588ca5a 100644 --- a/src/Web/ServerSession/Backend/Persistent/Memcached.hs +++ b/src/Web/ServerSession/Backend/Persistent/Memcached.hs @@ -21,7 +21,7 @@ import qualified Data.Binary as Binary import qualified Database.Memcached.Binary.IO as Memcached import qualified Crypto.Saltine.Class as Saltine -import qualified Crypto.Saltine.Internal.ByteSizes as Saltine +import qualified Crypto.Saltine.Internal.SecretBox as Saltine import qualified Crypto.Saltine.Core.AEAD as AEAD import qualified Data.ByteString as BS @@ -115,9 +115,9 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do encSession <- catchIfExceptT (const Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached - guardExceptT (BS.length encSession >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $ + guardExceptT (BS.length encSession >= Saltine.secretbox_noncebytes + Saltine.secretbox_macbytes) $ Just MemcachedSqlStorageAEADCiphertextTooShort - let (nonceBS, encrypted) = BS.splitAt Saltine.secretBoxNonce encSession + let (nonceBS, encrypted) = BS.splitAt Saltine.secretbox_noncebytes encSession encSessId = LBS.toStrict $ Binary.encode sessId nonce <- maybeTExceptT (Just MemcachedSqlStorageAEADCouldNotDecodeNonce) . hoistMaybe $ Saltine.decode nonceBS decrypted <- maybeTExceptT (Just MemcachedSqlStorageAEADCouldNotOpenAEAD) . hoistMaybe $ AEAD.aeadOpen mcdSqlMemcachedKey nonce encrypted encSessId diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs index 0dc2f1109..6349c53e5 100644 --- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs +++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs @@ -54,7 +54,7 @@ data ServerSessionJwtException = SessionTokenJwtError Jose.JwtError | SessionTokenUnsecured | SessionTokenInvalidFormat String - | SessionTokenExpired | SessionTokenNotStarted + | SessionTokenExpired | SessionTokenNotStarted | SessionTokenWrongAudience deriving (Eq, Show, Generic, Typeable) instance Exception ServerSessionJwtException @@ -147,6 +147,8 @@ decodeSession ServerSessionJwtConfig{..} (Jwt bs) = do Jose.Jwe (_header, payload) -> return payload session@SessionToken{..} <- either (throwM . SessionTokenInvalidFormat) return $ JSON.eitherDecodeStrict content' + unless (sJwtIssueFor == sessionIssuedFor) $ + throwM SessionTokenWrongAudience now <- liftIO getCurrentTime unless (NTop sessionExpiresAt > NTop (Just $ maybe id addUTCTime (negate <$> sJwtClockLeniencyEnd) now)) $ throwM SessionTokenExpired diff --git a/stack.yaml b/stack.yaml index b6804636c..e2a7e4e83 100644 --- a/stack.yaml +++ b/stack.yaml @@ -104,6 +104,8 @@ extra-deps: - process-extras-0.7.4@sha256:4e79289131415796c181889c4a226ebab7fc3b0d27b164f65e1aad123ae9b9e3,1759 - ListLike-4.7.4@sha256:613b2967df738010e8f6f6b7c47d615f6fe42081f68eba7f946d5de7552aa8a4,3778 + - saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198 + resolver: nightly-2021-01-11 compiler: ghc-8.10.4 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 4b6dbfab3..ad279dd82 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -559,6 +559,13 @@ packages: sha256: 50e22178b0713d0c8367ee6bc9f3b5026422b4b285837bdf9f4173a14db1e8bf original: hackage: ListLike-4.7.4@sha256:613b2967df738010e8f6f6b7c47d615f6fe42081f68eba7f946d5de7552aa8a4,3778 +- completed: + hackage: saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198 + pantry-tree: + size: 5016 + sha256: fdf4397f4b1ed7975f38d0b463eb6c9d206d0c85d157c41c19983e80b2005763 + original: + hackage: saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198 snapshots: - completed: size: 562265 diff --git a/test/Handler/Utils/FilesSpec.hs b/test/Handler/Utils/FilesSpec.hs index cdd3f181c..32fb49914 100644 --- a/test/Handler/Utils/FilesSpec.hs +++ b/test/Handler/Utils/FilesSpec.hs @@ -5,6 +5,7 @@ import Yesod.Core.Handler (getsYesod) import Yesod.Persist.Core (YesodPersist(runDB)) import ModelSpec () +import Model.Types.FileSpec (LargeFile(..)) import Handler.Utils.Files import Utils.Files @@ -19,15 +20,25 @@ import Control.Monad.Trans.Maybe (runMaybeT) import Utils.Sql (setSerializable) +import qualified Crypto.Hash.Conduit as Crypto (sinkHash) +import Utils (maybeT) +import Data.Conduit.Algorithms.FastCDC (fastCDC) +import Settings (_appFileChunkingParams) + +import qualified Data.ByteString as BS + + +fileNull :: PureFile -> Bool +fileNull file = maybe True BS.null $ file ^. _pureFileContent + + spec :: Spec spec = withApp . describe "File handling" $ do describe "Minio" $ do - modifyMaxSuccess (`div` 10) . it "roundtrips" $ \(tSite, _) -> property $ do - fileContentContent <- arbitrary - `suchThat` (\fc -> not . null . runIdentity . runConduit $ fc .| C.sinkLazy) -- Minio (and by extension `sinkFileMinio`) cannot deal with zero length uploads; this is handled seperately by `sinkFile` - file' <- arbitrary :: Gen PureFile - let file = file' { fileContent = Just fileContentContent } + modifyMaxSuccess (`div` 50) . it "roundtrips" $ \(tSite, _) -> property $ do + file <- fmap getLargeFile arbitrary `suchThat` (not . fileNull) :: Gen PureFile + let fileContentContent = fromMaybe (error "no file content") $ file ^. _fileContent return . propertyIO . unsafeHandler tSite $ do haveUploadCache <- getsYesod $ is _Just . appUploadCache unless haveUploadCache . liftIO $ @@ -47,13 +58,44 @@ spec = withApp . describe "File handling" $ do .| C.takeE (succ $ olength suppliedContent) .| C.sinkLazy + liftIO $ readContent `shouldBe` suppliedContent + describe "Minio, chunkwise" $ do + modifyMaxSuccess (`div` 50) . it "roundtrips" $ \(tSite, _) -> property $ do + file <- fmap getLargeFile arbitrary `suchThat` (not . fileNull) :: Gen PureFile + let fileContentContent = fromMaybe (error "no file content") $ file ^. _fileContent + return . propertyIO . unsafeHandler tSite $ do + haveUploadCache <- getsYesod $ is _Just . appUploadCache + unless haveUploadCache . liftIO $ + pendingWith "No upload cache (minio) configured" + + chunkingParams <- getsYesod $ view _appFileChunkingParams + let mkChunks = transPipe generalize fileContentContent .| fastCDC chunkingParams + sinkChunks = C.mapM (maybeT (liftIO $ fail "sinkMinio produced no chunk reference") . sinkMinio @FileContentChunkReference . yield) .| C.foldMap (pure :: FileContentChunkReference -> [FileContentChunkReference]) + (review _Wrapped -> fRef', chunks) <- runConduit $ mkChunks .| getZipConduit ((,) <$> ZipConduit Crypto.sinkHash <*> ZipConduit sinkChunks) + + liftIO $ Just fRef' `shouldBe` view (_FileReference . _1 . _fileReferenceContent) file + + runDB . void $ insertMany_ + [ FileContentEntry{ fileContentEntryHash = fRef', .. } + | fileContentEntryChunkHash <- chunks + | fileContentEntryIx <- [0..] + ] + + suppliedContent <- runConduit $ transPipe generalize fileContentContent + .| C.sinkLazy + for_ [1..10] $ \_i -> do + let dbFile = sourceFile $ file ^. _FileReference . _1 + fileContent' <- liftIO . maybe (fail "sourceFile produced no file reference") return $ fileContent dbFile + readContent <- runDB . runConduit + $ fileContent' + .| C.takeE (succ $ olength suppliedContent) + .| C.sinkLazy + liftIO $ readContent `shouldBe` suppliedContent describe "DB" $ do - modifyMaxSuccess (`div` 10) . it "roundtrips" $ \(tSite, _) -> property $ do - fileContentContent <- arbitrary - `suchThat` (\fc -> not . null . runIdentity . runConduit $ fc .| C.sinkLazy) -- Minio (and by extension `sinkFileMinio`) cannot deal with zero length uploads; this is handled seperately by `sinkFile` - file' <- arbitrary :: Gen PureFile - let file = file' { fileContent = Just fileContentContent } + modifyMaxSuccess (`div` 50) . it "roundtrips" $ \(tSite, _) -> property $ do + file <- fmap getLargeFile arbitrary `suchThat` (not . fileNull) :: Gen PureFile + let fileContentContent = fromMaybe (error "no file content") $ file ^. _fileContent return . propertyIO . unsafeHandler tSite $ do let fRef = file ^. _FileReference . _1 . _fileReferenceContent fRef' <- runDB . setSerializable . sinkFileDB True $ transPipe generalize fileContentContent diff --git a/test/Model/Tokens/UploadSpec.hs b/test/Model/Tokens/UploadSpec.hs new file mode 100644 index 000000000..4113dc0d0 --- /dev/null +++ b/test/Model/Tokens/UploadSpec.hs @@ -0,0 +1,47 @@ +module Model.Tokens.UploadSpec where + +import TestImport +import Model.Tokens.Upload + +import Model.TypesSpec () + +import Utils.Lens + +import qualified Crypto.Saltine.Core.SecretBox as SecretBox + +import System.IO.Unsafe + + +instance Arbitrary UploadToken where + arbitrary = UploadToken + <$> arbitrary + <*> arbitrary + <*> fmap (over _utctDayTime $ fromInteger . round) arbitrary + <*> arbitrary + <*> arbitrary + <*> fmap (over (mapped . _utctDayTime) $ fromInteger . round) arbitrary + <*> fmap (over (mapped . _utctDayTime) $ fromInteger . round) arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary UploadTokenState where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary UploadTokenStateHashState where + arbitrary = do + let key = unsafePerformIO SecretBox.newKey + utsHashStateNonce = unsafePerformIO SecretBox.newNonce + plaintext <- arbitrary + let utsHashStateState = SecretBox.secretbox key utsHashStateNonce plaintext + return UploadTokenStateHashState{..} + +spec :: Spec +spec = do + parallel $ do + lawsCheckHspec (Proxy @UploadToken) + [ eqLaws, ordLaws, showLaws, jsonLaws ] + lawsCheckHspec (Proxy @UploadTokenState) + [ eqLaws, ordLaws, showLaws, jsonLaws ] + lawsCheckHspec (Proxy @UploadTokenStateHashState) + [ eqLaws, ordLaws, showLaws, jsonLaws ] diff --git a/test/Model/Types/FileSpec.hs b/test/Model/Types/FileSpec.hs index 292bc047b..03a141da9 100644 --- a/test/Model/Types/FileSpec.hs +++ b/test/Model/Types/FileSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} module Model.Types.FileSpec where @@ -15,10 +16,57 @@ import Data.Time import qualified Data.Map as Map +import Test.QuickCheck.Random (QCGen (..)) +import qualified System.Random.SplitMix as SM + +import qualified Data.ByteString as BS + scaleRatio :: Rational -> Int -> Int scaleRatio r = ceiling . (* r) . fromIntegral +arbitraryBS :: Int -> Gen ByteString +arbitraryBS l = MkGen $ \(QCGen g0) _ -> if + | l <= 0 -> BS.empty + | otherwise -> fst $ BS.unfoldrN l gen g0 + where + gen :: SM.SMGen -> Maybe (Word8, SM.SMGen) + gen !g = Just (fromIntegral w64, g') + where + ~(w64, g') = SM.nextWord64 g + + +newtype LargeFile m = LargeFile { getLargeFile :: File m } + +instance Monad m => Arbitrary (LargeFile m) where + arbitrary = do + fileTitle <- scale (scaleRatio $ 1 % 8) $ (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator) + date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2) + fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange + fileContent <- oneof + [ pure Nothing + , pure . Just $ return () + , oneof + [ Just . yield <$> (arbitraryBS =<< choose (1,1e3)) + , Just . yield <$> (arbitraryBS =<< choose (succ 1e3,1e6)) + , Just . yield <$> (arbitraryBS =<< choose (succ 1e6,20e6)) + ] + , oneof + [ Just . C.yieldMany <$> (flip vectorOf (arbitraryBS =<< choose (1,1e3)) =<< choose (2,100)) + , Just . C.yieldMany <$> (flip vectorOf (arbitraryBS =<< choose (succ 1e3,1e6)) =<< choose (2,10)) + , Just . C.yieldMany <$> (flip vectorOf (arbitraryBS =<< choose (succ 1e6,20e6)) =<< choose (2,10)) + ] + ] + return $ LargeFile File{..} + where + inZipRange :: UTCTime -> Bool + inZipRange time + | time > UTCTime (fromGregorian 1980 1 1) 0 + , time < UTCTime (fromGregorian 2107 1 1) 0 + = True + | otherwise + = False + instance (LazySequence lazy strict, Arbitrary lazy, Monad m) => Arbitrary (ConduitT () strict m ()) where arbitrary = C.sourceLazy <$> arbitrary diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index e1736ce03..e7b88713f 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -336,6 +336,9 @@ instance Arbitrary RoomReference where instance Arbitrary RoomReference' where arbitrary = genericArbitrary +instance Arbitrary UploadNonce where + arbitrary = pure $ unsafePerformIO newUploadNonce + spec :: Spec @@ -443,6 +446,8 @@ spec = do [ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ] lawsCheckHspec (Proxy @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey)) [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ] + lawsCheckHspec (Proxy @UploadNonce) + [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ From 5ade6c65d663f184e50e7574478e7a3cbb1dfcce Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 28 Jun 2021 09:21:34 +0200 Subject: [PATCH 2/4] chore: bump versions --- .gitlab-ci.yml | 2 +- .hlint.yaml | 1 + flake.lock | 12 +- models/allocations.model | 2 +- models/courses.model | 10 +- models/courses/applications.model | 2 +- models/courses/favourite.model | 4 +- models/courses/materials.model | 4 +- models/courses/news.model | 4 +- models/sheets.model | 14 +- models/submissions.model | 8 +- models/system-messages.model | 4 +- models/tutorials.model | 6 +- models/workflows.model | 6 +- src/Application.hs | 3 +- src/Crypto/Random/Instances.hs | 3 +- src/Data/CaseInsensitive/Instances.hs | 2 +- src/Database/Esqueleto/Instances.hs | 2 +- src/Database/Esqueleto/Utils.hs | 43 ++-- src/Database/Esqueleto/Utils/TH.hs | 2 +- src/Database/Persist/Class/Instances.hs | 4 +- src/Database/Persist/Types/Instances.hs | 8 + src/Foundation/Authorization.hs | 2 +- src/Foundation/Instances.hs | 2 +- src/Foundation/Navigation.hs | 2 +- src/Foundation/SiteLayout.hs | 2 +- src/Foundation/Yesod/Auth.hs | 2 +- src/Foundation/Yesod/Persist.hs | 1 + src/Handler/Admin/StudyFeatures.hs | 2 +- src/Handler/Admin/Test/Download.hs | 2 +- src/Handler/Admin/Tokens.hs | 2 +- src/Handler/Allocation/Accept.hs | 2 +- src/Handler/Allocation/Application.hs | 4 +- src/Handler/Allocation/Compute.hs | 2 +- src/Handler/Allocation/EditUser.hs | 2 +- src/Handler/Allocation/Form.hs | 2 +- src/Handler/Allocation/List.hs | 2 +- src/Handler/Allocation/Prios.hs | 2 +- src/Handler/Allocation/Show.hs | 2 +- src/Handler/Allocation/UserForm.hs | 2 +- src/Handler/Allocation/Users.hs | 2 +- src/Handler/Course.hs | 2 +- src/Handler/Course/Application/Files.hs | 2 +- src/Handler/Course/Application/List.hs | 2 +- src/Handler/Course/Communication.hs | 2 +- src/Handler/Course/Edit.hs | 2 +- src/Handler/Course/Events/Form.hs | 2 +- src/Handler/Course/List.hs | 2 +- src/Handler/Course/News/Download.hs | 2 +- src/Handler/Course/Register.hs | 2 +- src/Handler/Course/Show.hs | 2 +- src/Handler/Course/User.hs | 2 +- src/Handler/Course/Users.hs | 2 +- src/Handler/Exam/AutoOccurrence.hs | 2 +- src/Handler/Exam/Correct.hs | 2 +- src/Handler/Exam/Edit.hs | 2 +- src/Handler/Exam/Form.hs | 2 +- src/Handler/Exam/List.hs | 2 +- src/Handler/Exam/Show.hs | 2 +- src/Handler/Exam/Users.hs | 2 +- src/Handler/ExamOffice/Course.hs | 2 +- src/Handler/ExamOffice/Exam.hs | 2 +- src/Handler/ExamOffice/Exams.hs | 2 +- src/Handler/ExamOffice/Fields.hs | 2 +- src/Handler/ExamOffice/Users.hs | 2 +- src/Handler/ExternalExam/Correct.hs | 2 +- src/Handler/ExternalExam/Form.hs | 2 +- src/Handler/ExternalExam/List.hs | 2 +- src/Handler/ExternalExam/Show.hs | 2 +- src/Handler/Info.hs | 2 +- src/Handler/Material.hs | 2 +- src/Handler/News.hs | 2 +- src/Handler/Participants.hs | 2 +- src/Handler/Profile.hs | 2 +- src/Handler/School.hs | 2 +- src/Handler/Sheet/Delete.hs | 2 +- src/Handler/Sheet/Download.hs | 2 +- src/Handler/Sheet/Form.hs | 2 +- src/Handler/Sheet/List.hs | 2 +- src/Handler/Sheet/New.hs | 2 +- src/Handler/Sheet/PersonalisedFiles.hs | 2 +- src/Handler/Sheet/PersonalisedFiles/Meta.hs | 2 +- src/Handler/Sheet/Show.hs | 2 +- src/Handler/Submission.hs | 2 +- src/Handler/Submission/Assign.hs | 2 +- src/Handler/Submission/Correction.hs | 2 +- src/Handler/Submission/Create.hs | 2 +- src/Handler/Submission/Download.hs | 2 +- src/Handler/Submission/Helper.hs | 2 +- src/Handler/Submission/List.hs | 2 +- src/Handler/SystemMessage.hs | 4 +- src/Handler/Term.hs | 2 +- src/Handler/Tutorial/Communication.hs | 2 +- src/Handler/Tutorial/Delete.hs | 2 +- src/Handler/Tutorial/Edit.hs | 2 +- src/Handler/Tutorial/Form.hs | 2 +- src/Handler/Tutorial/List.hs | 2 +- src/Handler/Tutorial/Users.hs | 2 +- src/Handler/Users.hs | 6 +- src/Handler/Utils/Allocation.hs | 2 +- src/Handler/Utils/Communication.hs | 2 +- src/Handler/Utils/Course.hs | 2 +- src/Handler/Utils/Database.hs | 2 +- src/Handler/Utils/Delete.hs | 15 +- src/Handler/Utils/Exam.hs | 5 +- src/Handler/Utils/ExamOffice/Course.hs | 2 +- src/Handler/Utils/ExamOffice/Exam.hs | 2 +- src/Handler/Utils/ExamOffice/ExternalExam.hs | 2 +- src/Handler/Utils/ExternalExam/Users.hs | 2 +- src/Handler/Utils/Files.hs | 2 +- src/Handler/Utils/Form.hs | 24 +-- src/Handler/Utils/Rating.hs | 2 +- src/Handler/Utils/Sheet.hs | 2 +- src/Handler/Utils/StudyFeatures.hs | 2 +- src/Handler/Utils/Submission.hs | 2 +- src/Handler/Utils/Table/Columns.hs | 2 +- src/Handler/Utils/Table/Pagination.hs | 2 +- src/Handler/Utils/Term.hs | 2 +- src/Handler/Utils/TermCandidates.hs | 2 +- src/Handler/Utils/Tutorial.hs | 2 +- src/Handler/Utils/Users.hs | 2 +- src/Handler/Utils/Workflow/EdgeForm.hs | 5 +- src/Handler/Workflow/Definition/Delete.hs | 2 +- src/Handler/Workflow/Definition/List.hs | 2 +- src/Handler/Workflow/Instance/List.hs | 2 +- src/Handler/Workflow/Workflow/List.hs | 2 +- src/Jobs.hs | 2 +- src/Jobs/Crontab.hs | 2 +- src/Jobs/Handler/Files.hs | 2 +- src/Jobs/Handler/PruneOldSentMails.hs | 2 +- src/Jobs/Handler/QueueNotification.hs | 2 +- .../Handler/SendNotification/Allocation.hs | 2 +- .../Handler/SendNotification/SheetInactive.hs | 2 +- .../SendNotification/SubmissionEdited.hs | 2 +- src/Jobs/Handler/StudyFeatures.hs | 2 +- src/Jobs/HealthReport.hs | 2 +- src/Model.hs | 4 +- src/Model/Migration.hs | 2 +- src/Model/Types/Allocation.hs | 2 +- src/Model/Types/Markup.hs | 2 +- src/Network/Mail/Mime/Instances.hs | 7 - src/Utils/Course.hs | 2 +- src/Utils/DB.hs | 2 +- src/Utils/Files.hs | 2 +- src/Utils/Form.hs | 83 +++++--- src/Utils/Lens.hs | 2 +- src/Utils/Sheet.hs | 2 +- src/Utils/Term.hs | 2 +- src/Utils/Workflow.hs | 2 +- src/Yesod/Form/Fields/Instances.hs | 16 +- stack.yaml | 28 +-- stack.yaml.lock | 196 +++++++----------- .../widgets/permutation/permutation.hamlet | 2 +- test/Database.hs | 3 +- test/Handler/Utils/SubmissionSpec.hs | 2 +- 155 files changed, 377 insertions(+), 406 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f138a2a4e..d09d49945 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -6,7 +6,7 @@ workflow: default: image: - name: fpco/stack-build:lts-16.31 + name: fpco/stack-build:lts-17.15 variables: STACK_ROOT: "${CI_PROJECT_DIR}/.stack" diff --git a/.hlint.yaml b/.hlint.yaml index 24e2d327e..9352cd5f6 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -13,6 +13,7 @@ - ignore: { name: "Redundant void" } - ignore: { name: "Too strict maybe" } - ignore: { name: "Use Just" } + - ignore: { name: "Use const" } - arguments: - -XQuasiQuotes diff --git a/flake.lock b/flake.lock index b486ac53f..f5c74561b 100644 --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,11 @@ "nodes": { "flake-utils": { "locked": { - "lastModified": 1619345332, - "narHash": "sha256-qHnQkEp1uklKTpx3MvKtY6xzgcqXDsz5nLilbbuL+3A=", + "lastModified": 1623875721, + "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=", "owner": "numtide", "repo": "flake-utils", - "rev": "2ebf2558e5bf978c7fb8ea927dfaed8fefab2e28", + "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772", "type": "github" }, "original": { @@ -18,11 +18,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1620323686, - "narHash": "sha256-+gfcE3YTGl+Osc8HzOUXSFO8/0PAK4J8ZxCXZ4hjXHI=", + "lastModified": 1624788075, + "narHash": "sha256-xzO2aL5gGejNvey2jKGnbnFXbo99pdytlY5FF/IhvAE=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "dfacb8329b2236688b9a1e705116203a213b283a", + "rev": "4ba70da807359ed01d662763a96c7b442762e5ef", "type": "github" }, "original": { diff --git a/models/allocations.model b/models/allocations.model index cb275f2a2..de16d91da 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -53,7 +53,7 @@ AllocationUser AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId - course CourseId Maybe + course CourseId Maybe OnDeleteSetNull OnUpdateCascade time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) deriving Eq Ord Show Generic diff --git a/models/courses.model b/models/courses.model index 581704aa5..6ea7c5a40 100644 --- a/models/courses.model +++ b/models/courses.model @@ -1,5 +1,5 @@ DegreeCourse json -- for which degree programmes this course is appropriate for - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade degree StudyDegreeId terms StudyTermsId UniqueDegreeCourse course degree terms @@ -31,7 +31,7 @@ Course -- Information about a single course; contained info is always visible deriving Generic CourseEvent type (CI Text) - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade room RoomReference Maybe roomHidden Bool default=false time Occurrences @@ -40,7 +40,7 @@ CourseEvent deriving Generic CourseAppInstructionFile - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime @@ -50,11 +50,11 @@ CourseAppInstructionFile CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables) user UserId time UTCTime - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade deriving Generic Lecturer -- course ownership user UserId - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade type LecturerType default='"lecturer"'::jsonb UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table deriving Generic diff --git a/models/courses/applications.model b/models/courses/applications.model index b5c342198..9cebe6855 100644 --- a/models/courses/applications.model +++ b/models/courses/applications.model @@ -13,7 +13,7 @@ CourseApplication deriving Generic CourseApplicationFile - application CourseApplicationId + application CourseApplicationId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime diff --git a/models/courses/favourite.model b/models/courses/favourite.model index f42f5f6c4..8570b6051 100644 --- a/models/courses/favourite.model +++ b/models/courses/favourite.model @@ -1,12 +1,12 @@ CourseFavourite -- which user accessed which course when, only displayed to user for convenience; user UserId - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade reason FavouriteReason lastVisit UTCTime UniqueCourseFavourite user course deriving Generic CourseNoFavourite user UserId - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade UniqueCourseNoFavourite user course deriving Generic \ No newline at end of file diff --git a/models/courses/materials.model b/models/courses/materials.model index d020271bc..86355db83 100644 --- a/models/courses/materials.model +++ b/models/courses/materials.model @@ -1,5 +1,5 @@ Material -- course material for disemination to course participants - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade name (CI Text) type (CI Text) Maybe description StoredMarkup Maybe @@ -8,7 +8,7 @@ Material -- course material for disemination to course participants UniqueMaterial course name deriving Generic MaterialFile -- a file that is part of a material distribution - material MaterialId + material MaterialId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime diff --git a/models/courses/news.model b/models/courses/news.model index c12bbe5d7..9f5390ceb 100644 --- a/models/courses/news.model +++ b/models/courses/news.model @@ -1,5 +1,5 @@ CourseNews - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade visibleFrom UTCTime Maybe participantsOnly Bool title Text Maybe @@ -8,7 +8,7 @@ CourseNews lastEdit UTCTime deriving Generic CourseNewsFile - news CourseNewsId + news CourseNewsId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime diff --git a/models/sheets.model b/models/sheets.model index 92845f112..57213ec7b 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -1,5 +1,5 @@ Sheet -- exercise sheet for a given course - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade name (CI Text) description StoredMarkup Maybe type (SheetType SqlBackendKey) -- ExamPartId; Does it count towards overall course grade? @@ -20,14 +20,14 @@ Sheet -- exercise sheet for a given course SheetEdit -- who edited when a row in table "Course", kept indefinitely user UserId time UTCTime - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade deriving Generic -- For anonoymous external submissions (i.e. paper submission tracked in uni2work) -- Map pseudonyms to users injectively in the context of a single sheet; for the next sheet all-new pseudonyms need to be created -- Chosen uniformly at random when the submitting user presses a button on the view of a sheet SheetPseudonym - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade pseudonym Pseudonym -- 24-bit number that should be attached to external submission (i.e. written on the submitted paper); encoded as two english words akin to PGP-Wordlist user UserId UniqueSheetPseudonym sheet pseudonym @@ -35,13 +35,13 @@ SheetPseudonym deriving Generic SheetCorrector -- grant corrector role to user for a sheet user UserId - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade load Load -- portion of work that will be assigned to this corrector state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness) UniqueSheetCorrector user sheet deriving Show Eq Ord Generic SheetFile -- a file that is part of an exercise sheet - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade type SheetFileType -- excercise, marking, hint or solution title FilePath content FileContentReference Maybe @@ -49,7 +49,7 @@ SheetFile -- a file that is part of an exercise sheet UniqueSheetFile sheet type title deriving Generic PersonalisedSheetFile - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade user UserId type SheetFileType title FilePath @@ -59,7 +59,7 @@ PersonalisedSheetFile deriving Eq Ord Read Show Typeable Generic FallbackPersonalisedSheetFilesKey - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade index Word24 secret ByteString generated UTCTime diff --git a/models/submissions.model b/models/submissions.model index 9b9b500fb..6a86bd854 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -9,10 +9,10 @@ Submission -- submission for marking by a CourseParticipa SubmissionEdit -- user uploads new version of their submission user UserId Maybe -- track id, important for group submissions time UTCTime - submission SubmissionId + submission SubmissionId OnDeleteCascade OnUpdateCascade deriving Generic SubmissionFile json -- files that are part of a submission - submission SubmissionId + submission SubmissionId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime @@ -22,11 +22,11 @@ SubmissionFile json -- files that are part of a submission deriving Eq Ord Read Show Generic SubmissionUser -- which submission belongs to whom user UserId - submission SubmissionId + submission SubmissionId OnDeleteCascade OnUpdateCascade UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups deriving Generic SubmissionGroup -- pre-defined submission groups; some courses only allow pre-defined submission groups - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade name SubmissionGroupName UniqueSubmissionGroup course name deriving Generic diff --git a/models/system-messages.model b/models/system-messages.model index 5ba6b3c53..d7e3fd852 100644 --- a/models/system-messages.model +++ b/models/system-messages.model @@ -16,7 +16,7 @@ SystemMessage deriving Generic SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers - message SystemMessageId + message SystemMessageId OnDeleteCascade OnUpdateCascade language Lang content StoredMarkup summary StoredMarkup Maybe @@ -24,7 +24,7 @@ SystemMessageTranslation -- Translation of a @SystemMessage@ into another langua deriving Generic SystemMessageHidden - message SystemMessageId + message SystemMessageId OnDeleteCascade OnUpdateCascade user UserId time UTCTime UniqueSystemMessageHidden user message diff --git a/models/tutorials.model b/models/tutorials.model index a364c203c..707d37ea8 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -1,6 +1,6 @@ Tutorial json name TutorialName - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade type (CI Text) -- "Tutorium", "Zentralübung", ... capacity Int Maybe -- limit for enrolment in this tutorial room RoomReference Maybe @@ -15,12 +15,12 @@ Tutorial json UniqueTutorial course name deriving Generic Tutor - tutorial TutorialId + tutorial TutorialId OnDeleteCascade OnUpdateCascade user UserId UniqueTutor tutorial user deriving Generic TutorialParticipant - tutorial TutorialId + tutorial TutorialId OnDeleteCascade OnUpdateCascade user UserId UniqueTutorialParticipant tutorial user deriving Eq Ord Show diff --git a/models/workflows.model b/models/workflows.model index d68a91cee..d20d4e040 100644 --- a/models/workflows.model +++ b/models/workflows.model @@ -13,7 +13,7 @@ WorkflowDefinition deriving Generic WorkflowDefinitionDescription - definition WorkflowDefinitionId + definition WorkflowDefinitionId OnDeleteCascade OnUpdateCascade language Lang title Text description StoredMarkup Maybe @@ -21,7 +21,7 @@ WorkflowDefinitionDescription deriving Generic WorkflowDefinitionInstanceDescription - definition WorkflowDefinitionId + definition WorkflowDefinitionId OnDeleteCascade OnUpdateCascade language Lang title Text description StoredMarkup Maybe @@ -29,7 +29,7 @@ WorkflowDefinitionInstanceDescription deriving Generic WorkflowInstance - definition WorkflowDefinitionId Maybe + definition WorkflowDefinitionId Maybe OnDeleteSetNull OnUpdateCascade graph SharedWorkflowGraphId scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId name WorkflowInstanceName diff --git a/src/Application.hs b/src/Application.hs index 98260f6b4..0c0fcbbd5 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -17,9 +17,10 @@ module Application ) where import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) -import Database.Persist.Postgresql ( openSimpleConn, pgConnStr, connClose, pgPoolIdleTimeout +import Database.Persist.Postgresql ( openSimpleConn, pgConnStr, pgPoolIdleTimeout , pgPoolSize ) +import Database.Persist.SqlBackend.Internal ( connClose ) import qualified Database.PostgreSQL.Simple as PG import Import hiding (cancel, respond) import Language.Haskell.TH.Syntax (qLocation) diff --git a/src/Crypto/Random/Instances.hs b/src/Crypto/Random/Instances.hs index 3c840da89..687972e55 100644 --- a/src/Crypto/Random/Instances.hs +++ b/src/Crypto/Random/Instances.hs @@ -23,7 +23,8 @@ import qualified Data.ByteString as BS instance RandomGen ChaChaDRG where - next g = withRandomBytes g (finiteBitSize (maxBound :: Int) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes) + genWord64 g = withRandomBytes g (finiteBitSize (maxBound :: Word64) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes) + genWord32 g = withRandomBytes g (finiteBitSize (maxBound :: Word32) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes) split g = withDRG g drgNew instance Binary Seed where diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index cdde140f5..bc5a483bd 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -22,7 +22,7 @@ import Language.Haskell.TH.Syntax (Lift(..)) import Data.Aeson (ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..)) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Web.HttpApiData diff --git a/src/Database/Esqueleto/Instances.hs b/src/Database/Esqueleto/Instances.hs index c4dabfe41..5ead79af7 100644 --- a/src/Database/Esqueleto/Instances.hs +++ b/src/Database/Esqueleto/Instances.hs @@ -6,7 +6,7 @@ module Database.Esqueleto.Instances import ClassyPrelude.Yesod -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Data.Binary (Binary) import qualified Data.Binary as B diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 3daa8b813..757f491d9 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -43,7 +43,7 @@ import Data.Universe import qualified Data.Set as Set import qualified Data.List as List import qualified Data.Foldable as F -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH @@ -126,40 +126,24 @@ substring :: ( E.SqlString str -> E.SqlExpr (E.Value from) -> E.SqlExpr (E.Value for) -> E.SqlExpr (E.Value str) -substring (E.ERaw p1 f1) (E.ERaw p2 f2) (E.ERaw p3 f3) - = E.ERaw E.Never $ \info -> - let (strTLB, strVals) = f1 info - (fromiTLB, fromiVals) = f2 info - (foriTLB, foriVals) = f3 info - in ( "SUBSTRING" <> E.parens (E.parensM p1 strTLB <> " FROM " <> E.parensM p2 fromiTLB <> " FOR " <> E.parensM p3 foriTLB) +substring (E.ERaw _m1 f1) (E.ERaw _m2 f2) (E.ERaw _m3 f3) + = E.ERaw E.noMeta $ \_nParens info -> + let (strTLB, strVals) = f1 E.Parens info + (fromiTLB, fromiVals) = f2 E.Parens info + (foriTLB, foriVals) = f3 E.Parens info + in ( "SUBSTRING" <> E.parens (E.parens strTLB <> " FROM " <> E.parens fromiTLB <> " FOR " <> E.parens foriTLB) , strVals <> fromiVals <> foriVals ) -substring a b c = substring (construct a) (construct b) (construct c) explicitUnsafeCoerceSqlExprValue :: forall b a. Text -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) -explicitUnsafeCoerceSqlExprValue typ (E.ERaw p1 f1) = E.ERaw E.Parens $ \info -> - let (valTLB, valVals) = f1 info - in ( E.parensM p1 valTLB <> " :: " <> Text.Builder.fromText typ +explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nParens info -> + let (valTLB, valVals) = f1 E.Parens info + in ( E.parens valTLB <> " :: " <> Text.Builder.fromText typ , valVals ) -explicitUnsafeCoerceSqlExprValue typ val = explicitUnsafeCoerceSqlExprValue typ $ construct val - -construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -construct (E.ERaw p f) = E.ERaw E.Parens $ \info -> - let (b1, vals) = f info - build ("?", [E.PersistList vals']) = - (E.uncommas $ replicate (length vals') "?", vals') - build expr = expr - in build (E.parensM p b1, vals) -construct (E.ECompositeKey f) = - E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty) -construct (E.EAliasedValue i _) = - E.ERaw E.Never $ E.aliasedValueIdentToRawSql i -construct (E.EValueReference i i') = - E.ERaw E.Never $ E.valueReferenceToRawSql i i' and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) and = F.foldr (E.&&.) true @@ -485,12 +469,11 @@ diffTimes :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value UTCTime) -> E.Sql diffTimes a b = unsafeExtract "EPOCH" $ a E.-. b unsafeExtract :: String -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) -unsafeExtract extr (E.ERaw vP vF) = E.ERaw E.Never $ \info -> - let (vTLB, vVals) = vF info - in ( "EXTRACT" <> E.parens (fromString extr <> " FROM " <> E.parensM vP vTLB) +unsafeExtract extr (E.ERaw _mF vF) = E.ERaw E.noMeta $ \_nParens info -> + let (vTLB, vVals) = vF E.Parens info + in ( "EXTRACT" <> E.parens (fromString extr <> " FROM " <> E.parens vTLB) , vVals ) -unsafeExtract extr v = unsafeExtract extr $ construct v class ExprLift e a | e -> a where diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 3c21ce597..ff2fefef5 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -9,7 +9,7 @@ module Database.Esqueleto.Utils.TH import ClassyPrelude -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) import Database.Persist (PersistField) diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 24eb0902c..02401e3af 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -31,8 +31,8 @@ instance PersistEntity record => Binary (Key record) where get = either (fail . unpack) return . fromPersistValue =<< Binary.get -uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue -uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues +uniqueToMap :: PersistEntity record => Unique record -> Map (FieldNameHS, FieldNameDB) PersistValue +uniqueToMap = fmap Map.fromList $ zip <$> fmap toList persistUniqueToFieldNames <*> persistUniqueToValues instance PersistEntity record => Eq (Unique record) where (==) = (==) `on` uniqueToMap diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs index 3c79521d1..852538b93 100644 --- a/src/Database/Persist/Types/Instances.hs +++ b/src/Database/Persist/Types/Instances.hs @@ -17,6 +17,14 @@ import Data.Binary.Instances.Time as Import () import Data.Binary (Binary) +deriving instance Generic LiteralType +deriving instance Typeable LiteralType + +instance Hashable LiteralType +instance Binary LiteralType +instance NFData LiteralType + + deriving instance Generic PersistValue deriving instance Typeable PersistValue diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 912007db1..5d3f9a697 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -48,7 +48,7 @@ import qualified Data.Text as Text import Data.List (findIndex, inits) import Data.Semigroup (Last(..)) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 730d0ad29..16cc1143d 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -48,7 +48,7 @@ import qualified Data.Binary as Binary import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E -- Please see the documentation for the Yesod typeclass. There are a number diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index dd1649358..5be9cbd42 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -30,7 +30,7 @@ import Handler.Utils.ExamOffice.Course import Utils.Sheet import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Trans.State (execStateT) diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index c8e2955db..b8e1751c5 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -30,7 +30,7 @@ import qualified Data.Text as Text import qualified Data.Set as Set import qualified Data.HashMap.Strict as HashMap -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.Combinators as C diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index b4e72497e..8460462e9 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -39,7 +39,7 @@ import Data.ByteArray (convert) import Crypto.Hash (SHAKE128) import qualified Data.Binary as Binary -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Crypto.Hash.Conduit (sinkHash) diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index 6c7bccae4..67007f420 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -14,6 +14,7 @@ import Foundation.Authorization import Database.Persist.Sql (transactionUndo) import qualified Database.Persist.Sql as SQL +import qualified Database.Persist.SqlBackend.Internal as SQL import qualified Utils.Pool as Custom diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index d75e14e58..ef6b7f051 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/src/Handler/Admin/StudyFeatures.hs @@ -12,7 +12,7 @@ import qualified Data.Text as Text import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) import qualified Handler.Utils.TermCandidates as Candidates diff --git a/src/Handler/Admin/Test/Download.hs b/src/Handler/Admin/Test/Download.hs index 9bf85419d..c27e512d2 100644 --- a/src/Handler/Admin/Test/Download.hs +++ b/src/Handler/Admin/Test/Download.hs @@ -18,7 +18,7 @@ import Data.Binary.Builder (Builder) import Control.Monad.Random.Lazy (evalRandT, liftRandT) -import qualified Database.Esqueleto as E hiding (random_) +import qualified Database.Esqueleto.Legacy as E hiding (random_) import qualified Database.Esqueleto.PostgreSQL as E diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs index 0d29853a6..a684392c2 100644 --- a/src/Handler/Admin/Tokens.hs +++ b/src/Handler/Admin/Tokens.hs @@ -16,7 +16,7 @@ import Data.Map ((!), (!?)) import qualified Data.Text as Text -import qualified Database.Esqueleto as E hiding (random_) +import qualified Database.Esqueleto.Legacy as E hiding (random_) import qualified Database.Esqueleto.PostgreSQL as E import qualified Data.Conduit.Combinators as C diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs index b148122ea..39d909ee6 100644 --- a/src/Handler/Allocation/Accept.hs +++ b/src/Handler/Allocation/Accept.hs @@ -13,7 +13,7 @@ import Data.Map ((!?)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Control.Monad.State.Class as State import Data.Sequence (Seq((:|>))) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 8084da1be..5170fcc7b 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -14,7 +14,7 @@ import Handler.Utils import qualified Data.Text as Text import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Conduit.List as C @@ -348,7 +348,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do , allowAction afAction , Just appId <- mAppId -> runDB $ do - deleteCascade appId + delete appId audit $ TransactionCourseApplicationDeleted cid uid appId addMessageI Success $ MsgCourseApplicationDeleted courseShorthand | otherwise diff --git a/src/Handler/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs index 3f92a055d..161289e2e 100644 --- a/src/Handler/Allocation/Compute.hs +++ b/src/Handler/Allocation/Compute.hs @@ -12,7 +12,7 @@ import Handler.Allocation.Accept (SessionDataAllocationResults(..)) import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Control.Monad.State.Class as State diff --git a/src/Handler/Allocation/EditUser.hs b/src/Handler/Allocation/EditUser.hs index a11230c14..c6086b0cb 100644 --- a/src/Handler/Allocation/EditUser.hs +++ b/src/Handler/Allocation/EditUser.hs @@ -16,7 +16,7 @@ import qualified Data.Conduit.Combinators as C import Handler.Utils.Delete -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Course.Register (deregisterParticipant) diff --git a/src/Handler/Allocation/Form.hs b/src/Handler/Allocation/Form.hs index afe192155..8b3ba800e 100644 --- a/src/Handler/Allocation/Form.hs +++ b/src/Handler/Allocation/Form.hs @@ -7,7 +7,7 @@ import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Map.Strict as Map import qualified Data.Set as Set diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index a70a39d56..20b28e0fc 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -8,7 +8,7 @@ import Import import Utils.Course (mayViewCourse) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Utils.Table.Columns import Handler.Utils.Table.Pagination diff --git a/src/Handler/Allocation/Prios.hs b/src/Handler/Allocation/Prios.hs index 092aed617..6bc84ac33 100644 --- a/src/Handler/Allocation/Prios.hs +++ b/src/Handler/Allocation/Prios.hs @@ -8,7 +8,7 @@ import Handler.Utils import Handler.Utils.Csv import Handler.Utils.Allocation -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 881bb2b4b..eb348e266 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -12,7 +12,7 @@ import Handler.Utils.Allocation (allocationNotifyNewCourses) import Handler.Allocation.Register import Handler.Allocation.Application -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Allocation/UserForm.hs b/src/Handler/Allocation/UserForm.hs index 48ca7ca7d..931643a36 100644 --- a/src/Handler/Allocation/UserForm.hs +++ b/src/Handler/Allocation/UserForm.hs @@ -12,7 +12,7 @@ import Handler.Allocation.Application import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Data.Map.Strict as Map diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index ca3026047..5fca740ec 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -12,7 +12,7 @@ import Handler.Utils import Handler.Utils.Allocation import Handler.Utils.StudyFeatures -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Csv as Csv diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 0247f13b8..aaff28b89 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -4,7 +4,7 @@ module Handler.Course import Import -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Persist as P import Handler.Course.Communication as Handler.Course diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index 9daf7e0df..323ef9d69 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/src/Handler/Course/Application/Files.hs @@ -10,7 +10,7 @@ import Handler.Utils import qualified Data.Conduit.List as C -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 390c912f3..7b86b1a61 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -9,7 +9,7 @@ import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index 005aca3ae..eac35ee83 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -9,7 +9,7 @@ import Handler.Utils.Communication import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 3ebbd2c73..5973c7043 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -18,7 +18,7 @@ import qualified Data.Map as Map import qualified Control.Monad.State.Class as State -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Jobs.Queue diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index 1f3eb88bc..d9ef4ffeb 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/src/Handler/Course/Events/Form.hs @@ -8,7 +8,7 @@ import Import import Handler.Utils import Handler.Utils.Form.Occurrences -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E data CourseEventForm = CourseEventForm diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index edc5f6ad7..02c5f7b43 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -17,7 +17,7 @@ import Utils.Form -- import Utils.DB import Handler.Utils hiding (colSchoolShort) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Course/News/Download.hs b/src/Handler/Course/News/Download.hs index 3d1ea1b0f..9032acd97 100644 --- a/src/Handler/Course/News/Download.hs +++ b/src/Handler/Course/News/Download.hs @@ -6,7 +6,7 @@ module Handler.Course.News.Download import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Conduit.List as C diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index cc210739f..aaba24cf7 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -18,7 +18,7 @@ import qualified Data.Text as Text import qualified Data.Conduit.List as C import Database.Persist.Sql (transactionUndo) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 647be20d3..fab484c0b 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 0d63369f3..30ef678c2 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -9,7 +9,7 @@ import Handler.Utils import Handler.Utils.SheetType import Database.Esqueleto.Utils.TH -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Persist.Sql (deleteWhereCount) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index e6a771428..e9d2eb811 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -23,7 +23,7 @@ import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Vector as Vector -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Csv as Csv diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index df036163b..e4422ba6e 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -12,7 +12,7 @@ import Handler.Utils.Exam import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Database.Persist.Sql (updateWhereCount) newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs index cc373b0bd..f22e9d3c6 100644 --- a/src/Handler/Exam/Correct.hs +++ b/src/Handler/Exam/Correct.hs @@ -7,7 +7,7 @@ import Import import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Persist.Sql (transactionUndo) diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 909e571f7..5ecffe1f0 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -14,7 +14,7 @@ import Handler.Utils.Invitations import Jobs.Queue -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 98bc2be9a..9801ab658 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -18,7 +18,7 @@ import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Control.Monad.State.Class as State diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs index d9d37fdc7..20535552f 100644 --- a/src/Handler/Exam/List.hs +++ b/src/Handler/Exam/List.hs @@ -9,7 +9,7 @@ import Handler.Utils import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 63d235e81..392c56337 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -12,7 +12,7 @@ import Handler.ExamOffice.Exam (examCloseWidget, examFinishWidget) import Data.Map ((!?)) import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 8a13664c6..5d20a3587 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -16,7 +16,7 @@ import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) import Handler.ExamOffice.Exam (examCloseWidget, examFinishWidget) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/ExamOffice/Course.hs b/src/Handler/ExamOffice/Course.hs index 651ede248..9ad0cf949 100644 --- a/src/Handler/ExamOffice/Course.hs +++ b/src/Handler/ExamOffice/Course.hs @@ -6,7 +6,7 @@ import Import import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Utils.ExamOffice.Course diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 264fbd5bc..cc631665f 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -11,7 +11,7 @@ import Handler.Utils.Exam import Handler.Utils.Csv import qualified Handler.Utils.ExamOffice.Exam as Exam -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Csv as Csv diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 1e3bafe42..f98eac37f 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -10,7 +10,7 @@ import Handler.Utils import qualified Handler.Utils.ExamOffice.Exam as Exam import qualified Handler.Utils.ExamOffice.ExternalExam as ExternalExam -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Colonnade diff --git a/src/Handler/ExamOffice/Fields.hs b/src/Handler/ExamOffice/Fields.hs index bd69d7b5d..48f2c02fd 100644 --- a/src/Handler/ExamOffice/Fields.hs +++ b/src/Handler/ExamOffice/Fields.hs @@ -6,7 +6,7 @@ module Handler.ExamOffice.Fields import Import import Utils.Form -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index c12090101..79e6da3a4 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -13,7 +13,7 @@ import Handler.Utils.Invitations import Data.Aeson hiding (Result(..)) import Jobs.Queue -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs index c4d359ec6..cb13183b4 100644 --- a/src/Handler/ExternalExam/Correct.hs +++ b/src/Handler/ExternalExam/Correct.hs @@ -7,7 +7,7 @@ import Import import qualified Data.Set as Set import qualified Data.List.NonEmpty as NonEmpty (toList) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E --import qualified Database.Esqueleto.Utils as E import Database.Persist.Sql (transactionUndo) diff --git a/src/Handler/ExternalExam/Form.hs b/src/Handler/ExternalExam/Form.hs index e62ac2f68..5c278e3ad 100644 --- a/src/Handler/ExternalExam/Form.hs +++ b/src/Handler/ExternalExam/Form.hs @@ -13,7 +13,7 @@ import Data.Map ((!)) import qualified Control.Monad.State.Class as State -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E data ExternalExamForm = ExternalExamForm diff --git a/src/Handler/ExternalExam/List.hs b/src/Handler/ExternalExam/List.hs index 0dafaafc4..2a65080ec 100644 --- a/src/Handler/ExternalExam/List.hs +++ b/src/Handler/ExternalExam/List.hs @@ -6,7 +6,7 @@ import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/ExternalExam/Show.hs b/src/Handler/ExternalExam/Show.hs index 5f9d3fdb4..49f3a85ac 100644 --- a/src/Handler/ExternalExam/Show.hs +++ b/src/Handler/ExternalExam/Show.hs @@ -11,7 +11,7 @@ import Handler.ExternalExam.StaffInvite () import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E getEEShowR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 095eadb52..eac3e22dc 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -9,7 +9,7 @@ import Data.Map ((!)) import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Development.GitRev diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 6b4781c3e..2e0e961b5 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -17,7 +17,7 @@ import qualified Data.Conduit.List as C import qualified Data.CaseInsensitive as CI -- import qualified Data.Text.Encoding as Text -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Utils.Form import Handler.Utils diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 7ec2aeb1a..c696006f9 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -11,7 +11,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Database.Esqueleto.Utils.TH -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C (consume, mapMaybeM) diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index cbeb69ab2..0d1b9eb1b 100644 --- a/src/Handler/Participants.hs +++ b/src/Handler/Participants.hs @@ -8,7 +8,7 @@ module Handler.Participants import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d057e02fb..9b7dc1ee0 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -18,7 +18,7 @@ import Handler.Utils.Profile import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto ((^.)) import qualified Data.Text as Text diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 14e028d10..c6373ae23 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -3,7 +3,7 @@ module Handler.School where import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Sheet/Delete.hs b/src/Handler/Sheet/Delete.hs index 1658e6c81..5a4ede7cb 100644 --- a/src/Handler/Sheet/Delete.hs +++ b/src/Handler/Sheet/Delete.hs @@ -7,7 +7,7 @@ import Import import Handler.Utils.Delete import Handler.Utils.Sheet -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set diff --git a/src/Handler/Sheet/Download.hs b/src/Handler/Sheet/Download.hs index 75a0cbf44..3c2ff51ad 100644 --- a/src/Handler/Sheet/Download.hs +++ b/src/Handler/Sheet/Download.hs @@ -9,7 +9,7 @@ import Handler.Utils import qualified Data.Conduit.Combinators as C -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 353b3d11a..4cd5ba324 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -9,7 +9,7 @@ import Import import Handler.Utils import Handler.Utils.Invitations -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index 4593fb9f0..de27c8d3b 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -8,7 +8,7 @@ import Utils.Sheet import Handler.Utils import Handler.Utils.SheetType -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/Sheet/New.hs b/src/Handler/Sheet/New.hs index 922659140..8d8bd1c2b 100644 --- a/src/Handler/Sheet/New.hs +++ b/src/Handler/Sheet/New.hs @@ -6,7 +6,7 @@ import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Map as Map diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index 5d19b0e51..f1276f124 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -32,7 +32,7 @@ import Language.Haskell.TH (nameBase) import qualified Data.CryptoID.ByteString as CryptoID import qualified Data.CryptoID.Class.ImplicitNamespace as I -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Map as Map import qualified Data.Set as Set diff --git a/src/Handler/Sheet/PersonalisedFiles/Meta.hs b/src/Handler/Sheet/PersonalisedFiles/Meta.hs index dbbf5f7b2..e95993ae8 100644 --- a/src/Handler/Sheet/PersonalisedFiles/Meta.hs +++ b/src/Handler/Sheet/PersonalisedFiles/Meta.hs @@ -18,7 +18,7 @@ import qualified Data.YAML.Token as YAML (Encoding(..)) import Control.Monad.Trans.State.Lazy (evalState) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index 05c1b78cb..045d8d631 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -6,7 +6,7 @@ import Import hiding (link) import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 0c409bdc1..db3beb8a6 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -30,7 +30,7 @@ import Handler.Utils import Import -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html diff --git a/src/Handler/Submission/Assign.hs b/src/Handler/Submission/Assign.hs index e39c3445f..30470c0ed 100644 --- a/src/Handler/Submission/Assign.hs +++ b/src/Handler/Submission/Assign.hs @@ -18,7 +18,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Data.List.NonEmpty (unzip) diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index fa69877d1..5cc2154cd 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -14,7 +14,7 @@ import qualified Data.Text as Text import qualified Control.Monad.State.Class as State -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Submission/Create.hs b/src/Handler/Submission/Create.hs index 0aefb0f03..9eb2bdfd1 100644 --- a/src/Handler/Submission/Create.hs +++ b/src/Handler/Submission/Create.hs @@ -16,7 +16,7 @@ import qualified Data.Text as Text import qualified Control.Monad.State.Class as State -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Data.List (genericLength) diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs index 897fcf7d1..454e361dc 100644 --- a/src/Handler/Submission/Download.hs +++ b/src/Handler/Submission/Download.hs @@ -11,7 +11,7 @@ import Handler.Utils.Submission import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Conduit.Combinators as Conduit diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 048e1713f..c0c003dc3 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -14,7 +14,7 @@ import Handler.Utils.Invitations import Data.Maybe (fromJust) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E (unsafeSqlFunction) diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index c5296a64a..72ef9192a 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -26,7 +26,7 @@ import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import Database.Esqueleto.Utils.TH -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as IE (From) diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 87c19fd96..f472d932c 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -17,7 +17,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Handler.Utils import Handler.Utils.News -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E -- htmlField' moved to Handler.Utils.Form/Fields @@ -257,7 +257,7 @@ postMessageListR = do FormSuccess (SMDDelete, selection) | not $ null selection -> do selection' <- traverse decrypt $ Set.toList selection - runDB $ deleteCascadeWhere [ SystemMessageId <-. selection' ] + runDB $ deleteWhere [ SystemMessageId <-. selection' ] $(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet") redirect MessageListR FormSuccess (SMDActivate ts, selection) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 6115c4db6..325c582fa 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -13,7 +13,7 @@ import Handler.Utils import qualified Data.Map.Strict as Map import Data.Map.Strict ((!)) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs index 70ca14d52..c01464eec 100644 --- a/src/Handler/Tutorial/Communication.hs +++ b/src/Handler/Tutorial/Communication.hs @@ -7,7 +7,7 @@ import Handler.Utils import Handler.Utils.Tutorial import Handler.Utils.Communication -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/Tutorial/Delete.hs b/src/Handler/Tutorial/Delete.hs index 524daebe1..ed82c7fc5 100644 --- a/src/Handler/Tutorial/Delete.hs +++ b/src/Handler/Tutorial/Delete.hs @@ -7,7 +7,7 @@ import Handler.Utils import Handler.Utils.Tutorial import Handler.Utils.Delete -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index c8a9ce789..fd783a5a9 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -8,7 +8,7 @@ import Handler.Utils.Tutorial import Handler.Utils.Invitations import Jobs.Queue -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Map as Map import qualified Data.Set as Set diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 04a0d1a69..178b43cba 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -7,7 +7,7 @@ import Import import Handler.Utils import Handler.Utils.Form.Occurrences -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Data.Map ((!)) import qualified Data.Set as Set diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index e4f929d76..39f67c0e8 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -6,7 +6,7 @@ import Import import Handler.Utils import Handler.Utils.Tutorial -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 5e91ce386..f8215a0d9 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Handler.Course.Users diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 7d9e97e19..29963c64e 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -19,7 +19,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Profile (makeProfileData) @@ -503,9 +503,9 @@ deleteUser duid = do groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64)) singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) - deleteCascade duid + delete duid -- cascade is now defined in models files; therefor does not cascade at all currently (2021-06-27); not even SubmissionUser... forM_ singleSubmissions $ \(E.Value submissionId) -> do - deleteCascade submissionId + delete submissionId -- ditto deletedSubmissionGroups <- deleteSingleSubmissionGroups return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups) diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index 6902abdfb..785d69392 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -13,7 +13,7 @@ import Import import qualified Data.Map.Strict as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Trans.State (execStateT) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 27a8e31a0..1377ab621 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -13,7 +13,7 @@ import Handler.Utils import Jobs.Queue -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.CaseInsensitive as CI import Data.Map ((!), (!?)) import qualified Data.Map as Map diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index 34b671b7d..0951152bd 100644 --- a/src/Handler/Utils/Course.hs +++ b/src/Handler/Utils/Course.hs @@ -4,7 +4,7 @@ import Import import Handler.Utils.Delete import Handler.Utils.Memcached -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set diff --git a/src/Handler/Utils/Database.hs b/src/Handler/Utils/Database.hs index bd6e81250..c869b4bbb 100644 --- a/src/Handler/Utils/Database.hs +++ b/src/Handler/Utils/Database.hs @@ -11,7 +11,7 @@ import Data.Map as Map -- import Data.CaseInsensitive (CI) -- import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E makeSchoolDictionaryDB :: DB (Map.Map SchoolId SchoolName) makeSchoolDictionaryDB = makeSchoolDictionary <$> selectList [] [Asc SchoolShorthand] diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 658007730..6df29c670 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -25,7 +25,7 @@ import qualified Data.CaseInsensitive as CI import Data.Char (isAlphaNum) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) import Jobs.Queue @@ -76,7 +76,7 @@ confirmForm' drRecords confirmString mmsg = identifyForm FIDDelete . addDeleteTa over _2 (mappend $ fvInput fvTargets) <$> form csrf -postDeleteR :: ( DeleteCascade record SqlBackend ) +postDeleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => (Set (Key record) -> DeleteRoute record) -- ^ Construct `DeleteRoute` based on incoming record keys -> Handler () -- | Perform deletion @@ -85,10 +85,12 @@ postDeleteR mkRoute = do traverse_ deleteR' drResult -getDeleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a +getDeleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + => DeleteRoute record -> Handler a getDeleteR = deleteR' -deleteR' :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a +deleteR' :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + => DeleteRoute record -> Handler a deleteR' DeleteRoute{..} = do (targets, confirmString, message) <- runDB $ do infos <- E.select . E.from $ \t -> do @@ -106,7 +108,7 @@ deleteR' DeleteRoute{..} = do formResult confirmRes $ \case True -> do runDBJobs $ do - forM_ drRecords $ \k -> drDelete k $ deleteCascade k + forM_ drRecords $ \k -> drDelete k $ delete k addMessageI Success drSuccessMessage redirect drSuccess False -> @@ -124,7 +126,8 @@ deleteR' DeleteRoute{..} = do -deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html +deleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + => DeleteRoute record -> Handler Html deleteR dr = do postDeleteR $ \drRecords -> dr {drRecords} getDeleteR dr diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 4416b7fa6..2453e7dd6 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -21,7 +21,7 @@ module Handler.Utils.Exam import Import import Database.Persist.Sql (SqlBackendCanRead) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH @@ -851,10 +851,11 @@ examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredE evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..} = dnfTerms - & map (Set.toList . toNullable) . Set.toList + & Set.toList & map ( maybe True (ofoldr1 (&&)) . fromNullable . map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl) + . Set.toList . toNullable ) & maybe False (ofoldr1 (||)) . fromNullable where diff --git a/src/Handler/Utils/ExamOffice/Course.hs b/src/Handler/Utils/ExamOffice/Course.hs index bd3a3a5c2..ca7482a34 100644 --- a/src/Handler/Utils/ExamOffice/Course.hs +++ b/src/Handler/Utils/ExamOffice/Course.hs @@ -4,7 +4,7 @@ module Handler.Utils.ExamOffice.Course import Import.NoFoundation -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs index be3ab8fda..424c8b948 100644 --- a/src/Handler/Utils/ExamOffice/Exam.hs +++ b/src/Handler/Utils/ExamOffice/Exam.hs @@ -7,7 +7,7 @@ import Import.NoFoundation import Handler.Utils.StudyFeatures -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index 1c9d74310..b557e6cf6 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -6,7 +6,7 @@ module Handler.Utils.ExamOffice.ExternalExam import Import.NoFoundation import Handler.Utils.StudyFeatures -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index c5712cb96..70a20fec6 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -14,7 +14,7 @@ import qualified Data.List.NonEmpty as NonEmpty (head) import qualified Colonnade -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Data.Csv ((.:)) diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index 2d64af34f..83b5f7552 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -19,7 +19,7 @@ import qualified Data.Conduit.List as C (unfoldM) import Handler.Utils.Minio import qualified Network.Minio as Minio -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import System.FilePath (normalise, makeValid) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index a111d58de..a43dd4403 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -38,7 +38,7 @@ import Handler.Utils.Zip import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) @@ -416,9 +416,9 @@ explainOptionList :: forall a. -> (a -> MaybeT Handler Widget) -> Handler ([(Option a, Maybe Widget)], Text -> Maybe a) explainOptionList ol mkExplanation = do - OptionList{..} <- ol - olOptions' <- forM olOptions $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue) - return (olOptions', olReadExternal) + (options, readExternal) <- ((,) <$> toListOf _olOptions <*> view _olReadExternal) <$> ol -- TODO: support grouped? + olOptions' <- forM options $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue) + return (olOptions', readExternal) explainedMultiAction' :: forall action a. Ord action @@ -1850,21 +1850,21 @@ examResultField :: forall m res. examResultField optMsg mkOl = Field { fieldEnctype = UrlEncoded -- breaks if mkOl contains options with other enctype , fieldParse = \ts fs -> do - ol@OptionList{..} <- liftHandler mkOl + (options, readExternal) <- ((,) <$> toListOf _olOptions <*> view _olReadExternal) <$> liftHandler mkOl -- TODO: support grouped? if | res : _ <- mapMaybe (assertM ((||) <$> is _ExamNoShow <*> is _ExamVoided) . fromPathPiece) ts -> return . Right $ Just res | any null ts -> return $ Right Nothing - | (optPred, innerField) : _ <- mapMaybe olReadExternal ts - -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (`notElem` outerOptions ol) $ filter (optPred . Left) ts) fs + | (optPred, innerField) : _ <- mapMaybe readExternal ts + -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (`notElem` outerOptions options) $ filter (optPred . Left) ts) fs | [] <- ts -> return $ Right Nothing | t : _ <- ts -> return . Left . SomeMessage $ MsgInvalidEntry t , fieldView = \theId name attrs val isReq -> do innerId <- newIdent - OptionList{..} <- liftHandler mkOl + options <- toListOf _olOptions <$> liftHandler mkOl let innerVal :: Either Text res innerVal = val >>= maybe (Left "") return . preview _ExamAttended @@ -1877,14 +1877,14 @@ examResultField optMsg mkOl = Field $maybe optMsg' <- guardOnM (not isReq) optMsg