chore: support storing chunks in minio

2021-06-27 10:51:58 +02:00 · 2021-06-27 10:51:58 +02:00 · adbbb8db6b
commit adbbb8db6b
parent 79ec5184e6
31 changed files with 596 additions and 162 deletions
--- 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:
--- 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
--- 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
--- 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

--- a/package.yaml
+++ b/package.yaml
@ -318,6 +318,7 @@ tests:
      - uniworx
      - hspec >=2.0.0
      - QuickCheck
+      - splitmix
      - HUnit
      - yesod-test
      - conduit-extra
--- a/6
+++ b/6
@ -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
--- 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
--- 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
--- a/src/Handler/Upload.hs
+++ 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
--- 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')
--- 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{..}
--- 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
--- 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))

--- 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
--- 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" $
--- a/src/Model/Tokens/Upload.hs
+++ 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
--- 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
--- 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)
--- a/src/Model/Types/Upload.hs
+++ 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
--- 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"
--- 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

--- 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) ()
--- 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
         <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
--- 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
--- 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
--- 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
--- 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
--- 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
--- a/test/Model/Tokens/UploadSpec.hs
+++ 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 ]
--- 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

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