chore: support storing chunks in minio

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:

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

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

models/files.model

@@ -1,7 +1,7 @@
 FileContentEntry
     hash              FileContentReference
     ix                Word64 
-    chunkHash         FileContentChunkId
+    chunkHash         FileContentChunkReference
     UniqueFileContentEntry hash ix
     deriving Generic
 

package.yaml

@@ -318,6 +318,7 @@ tests:
       - uniworx
       - hspec >=2.0.0
       - QuickCheck
+      - splitmix
       - HUnit
       - yesod-test
       - conduit-extra

routes

@@ -286,6 +286,10 @@
 /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
 

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

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

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

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
+              for chunk' $ \(chunk, mStorage) -> chunk <$ do
-                let w = length chunk
                 $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)
+sourceFileChunks :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, MonadUnliftIO m)
-                   => ((Int, Int) -> ReaderT SqlReadBackend m (Maybe ByteString) -> ReaderT SqlReadBackend m (Maybe ByteString)) -> FileContentChunkReference -> ConduitT i (ByteString, (Int, Int)) (ReaderT backend 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) ()
-sourceFileDBChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlReadBackend) $ do
+sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlReadBackend) $ do
   dbChunksize <- getsYesod $ view _appFileUploadDBChunksize
-  -- mRunner <- getMinioRunner
+  let dbRetrieveChunk = \case
-  let retrieveChunk = \case
         Nothing -> return Nothing
         Just start -> do
-          let getChunkDB = cont (start, dbChunksize) . fmap (fmap E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do
+          let getChunkDB = cont (start, dbChunksize) . runMaybeT $
-                E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
+                let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do
-                return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize)
+                      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)
+sourceMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
-                => FileContentReference -> ConduitT () ByteString m ()
+            => Either FileContentChunkReference FileContentReference
-sourceFileMinio fileReference = do
+            -> 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
+              let (byteRange', respRange) = byteRangeSpecificationToMinio iLength byteRange
-                    ByteRangeSpecification f Nothing -> ByteRangeFrom (fromIntegral $ min (pred iLength) f)
+               in ( sourceMinio (Right fileContent) $ Just byteRange'
-                    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
                   , ByteContentRangeSpecification (Just respRange) (Just iLength)
                   )
-          Just (toNullable -> dbManifest')
+          Just (toNullable -> dbManifest') -> do
-            | Just dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value chunkLength) -> (,) <$> chunkHash <*> chunkLength
+            dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value mChunkLength) -> case mChunkLength of
-              -> do
+              Just chunkLength -> return (chunkHash, chunkLength)
-                let iLength = sumOf (folded . _2) dbManifest''
+              Nothing -> throwM SourceFilesContentUnavailable
-                respondSourceDBConditional condInfo cType . Right $ \byteRange ->
+            let iLength = sumOf (folded . _2) dbManifest''
-                  let (byteFrom, byteTo) = case byteRange of
+            respondSourceDBConditional condInfo cType . Right $ \byteRange ->
-                        ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength)
+              let (byteFrom, byteTo) = case byteRange of
-                        ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t)
+                    ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength)
-                        ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength)
+                    ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t)
-                      relevantChunks = view _2 $ foldl' go (0, []) dbManifest''
+                    ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength)
-                        where go :: (Word64, [(FileContentChunkReference, Word64, Word64)])
+                  relevantChunks = view _2 $ foldl' go (0, []) dbManifest''
-                                 -> (FileContentChunkReference, Word64)
+                    where go :: (Word64, [(FileContentChunkReference, Word64, Word64)])
-                                 -> (Word64, [(FileContentChunkReference, Word64, Word64)])
+                             -> (FileContentChunkReference, Word64)
-                              go (lengthBefore, acc) (cChunk, cLength)
+                             -> (Word64, [(FileContentChunkReference, Word64, Word64)])
-                                = ( lengthBefore + cLength
+                          go (lengthBefore, acc) (cChunk, cLength)
-                                  , if
+                            = ( lengthBefore + cLength
-                                      | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore
+                              , if
-                                        -> let cChunk' = ( cChunk
+                                  | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore
-                                                         , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore
+                                    -> let cChunk' = ( cChunk
-                                                         , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength
+                                                     , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore
-                                                         )
+                                                     , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength
-                                            in acc ++ pure cChunk'
+                                                     )
-                                      | otherwise
+                                        in acc ++ pure cChunk'
-                                        -> acc
+                                  | otherwise
-                                  )
+                                    -> acc
-                   in ( do
+                              )
-                          dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral
+               in ( do
-                          forM_ relevantChunks $ \(chunkHash, offset, cLength)
+                      dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral
-                            -> let retrieveChunk = \case
+                      forM_ relevantChunks $ \(chunkHash, offset, cLength)
-                                     Just (start, cLength') | cLength' > 0 -> do
+                        -> let retrieveChunk = \case
-                                       let getChunkDB = fmap (fmap E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do
+                                 Just (start, cLength') | cLength' > 0 -> do
-                                             E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
+                                   let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do
-                                             return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize)
+                                         E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
-                                       chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB
+                                         return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize)
-                                       case chunk of
+                                   chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB
-                                         Nothing -> throwM SourceFilesContentUnavailable
+                                   case chunk of
-                                         Just c -> do
+                                     Nothing -> throwM SourceFilesContentUnavailable
-                                           return . Just . (c, ) $ if
+                                     Just c -> do
-                                             | fromIntegral (olength c) >= min cLength' dbChunksize
+                                       return . Just . (c, ) $ if
-                                               -> Just (start + dbChunksize, cLength' - fromIntegral (olength c))
+                                         | fromIntegral (olength c) >= min cLength' dbChunksize
-                                             | otherwise
+                                           -> Just (start + dbChunksize, cLength' - fromIntegral (olength c))
-                                               -> Nothing
+                                         | otherwise
-                                     _other -> return Nothing
+                                           -> Nothing
-                                in C.unfoldM retrieveChunk . Just $ (succ offset, cLength)
+                                 _other -> return Nothing
-                      , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength)
+                            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')

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
+    void . Binary.getByteString $ Saltine.secretbox_noncebytes + 4 + Saltine.secretbox_macbytes
-  mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode
+  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
+    void . Binary.getByteString $ Saltine.secretbox_noncebytes + 4 + Saltine.secretbox_macbytes
-  mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode
+  mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretbox_noncebytes >>= hoistMaybe . Saltine.decode
   let mExpiry = Nothing
   mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString
   return MemcachedValue{..}

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
+            Just (bs, _) -> return $ Just (bs, Nothing)
-            Nothing -> getChunk
+            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

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.from $ \chunkLock -> E.where_ . E.exists . E.from $ \(fileContentEntry `E.InnerJoin` fileContentChunk) -> do
-        E.where_ $ E.just (fileContentEntry E.^. FileContentEntryHash) E.==. fHash
+        E.on $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkHash
-             E.&&. chunkLock E.^. FileChunkLockHash E.==. E.subSelectForeign fileContentEntry FileContentEntryChunkHash (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))
 

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

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" $

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

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

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)

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

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"

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
 

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
@@ -101,11 +104,20 @@ minioTmpGenerator :: Nonce.Generator
 minioTmpGenerator = unsafePerformIO Nonce.new
 {-# NOINLINE minioTmpGenerator #-}
 
-sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
+class Typeable ret => SinkMinio ret where
-              => ConduitT () ByteString m ()
+  _sinkMinioRet :: Iso' ret (Digest SHA3_512)
-              -> MaybeT m FileContentReference
+  default _sinkMinioRet :: (Rewrapping ret ret, Unwrapped ret ~ Digest SHA3_512) => Iso' ret (Digest SHA3_512)
--- ^ Cannot deal with zero length uploads
+  _sinkMinioRet = _Wrapped
-sinkFileMinio fileContentContent = do
+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
+    contentHash <- waitAsync sinkAsync
-    let dstName = minioFileReference # fileContentHash
+    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) ()

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)
-
+  deriving anyclass (Exception)
-instance Exception BearerTokenException
 
 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
          <input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece bearer}>
        #{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

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

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

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

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

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
+    modifyMaxSuccess (`div` 50) . it "roundtrips" $ \(tSite, _) -> property $ do
-      fileContentContent <- arbitrary
+      file <- fmap getLargeFile arbitrary `suchThat` (not . fileNull) :: Gen PureFile
-        `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`
+      let fileContentContent = fromMaybe (error "no file content") $ file ^. _fileContent
-      file' <- arbitrary :: Gen PureFile
-      let file = file' { fileContent = Just fileContentContent }
       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
+    modifyMaxSuccess (`div` 50) . it "roundtrips" $ \(tSite, _) -> property $ do
-      fileContentContent <- arbitrary
+      file <- fmap getLargeFile arbitrary `suchThat` (not . fileNull) :: Gen PureFile
-        `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`
+      let fileContentContent = fromMaybe (error "no file content") $ file ^. _fileContent
-      file' <- arbitrary :: Gen PureFile
-      let file = file' { fileContent = Just fileContentContent }
       return . propertyIO . unsafeHandler tSite $ do
         let fRef = file ^. _FileReference . _1 . _fileReferenceContent
         fRef' <- runDB . setSerializable . sinkFileDB True $ transPipe generalize fileContentContent

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 ]

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
 

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 $