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 $