feat(admin-test): download test

messages/uniworx/de-de-formal.msg

@@ -2541,3 +2541,10 @@ CourseParticipantActive: Teilnehmer
 CourseParticipantInactive: Abgemeldet
 CourseParticipantNoShow: Nicht erschienen
 CourseUserState: Zustand
+
+TestDownload: Download-Test
+TestDownloadMaxSize: Maximale Dateigröße
+TestDownloadMode: Modus
+TestDownloadDirect: Direkte Generierung
+TestDownloadInTransaction: Generierung während Datenbank-Transaktion
+TestDownloadFromDatabase: Generierung während Download aus Datenbank

messages/uniworx/en-eu.msg

@@ -2541,3 +2541,10 @@ CourseParticipantActive: Participant
 CourseParticipantInactive: Deregistered
 CourseParticipantNoShow: No show
 CourseUserState: State
+
+TestDownload: Download test
+TestDownloadMaxSize: Maximum filesize
+TestDownloadMode: Mode
+TestDownloadDirect: Direct generation
+TestDownloadInTransaction: Generate during database transaction
+TestDownloadFromDatabase: Generate while streaming from database

src/Crypto/Random/Instances.hs

@@ -8,12 +8,26 @@ import ClassyPrelude
 
 import Crypto.Random
 import System.Random (RandomGen(..))
+import qualified Crypto.Error as Crypto
 
 import qualified Data.ByteArray as BA
 
 import Data.Bits
 
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+import Control.Monad.Fail (MonadFail(..))
+
+import qualified Data.ByteString as BS
+
 
 instance RandomGen ChaChaDRG where
   next g = withRandomBytes g (finiteBitSize (maxBound :: Int) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes)
   split g = withDRG g drgNew
+
+instance Binary Seed where
+  put = mapM_ Binary.putWord8 . (BA.convert :: Seed -> ByteString)
+  get = do
+    seedBytes <- BS.pack <$> replicateM 40 Binary.getWord8
+    Crypto.onCryptoFailure (fail . show) return $ seedFromBinary seedBytes

src/Handler/Admin/Test.hs

@@ -13,6 +13,8 @@ import qualified Data.Text as Text
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
+import Handler.Admin.Test.Download (testDownload)
+
 
 -- BEGIN - Buttons needed only here
 data ButtonCreate = CreateMath | CreateInf  -- Dummy for Example
@@ -186,6 +188,8 @@ postAdminTestR = do
   ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
 
 
+  testDownloadWidget <- testDownload
+
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
   siteLayout locallyDefinedPageHeading $ do
   -- defaultLayout $ do
@@ -225,3 +229,9 @@ postAdminTestR = do
           <p style="white-space:pre-wrap; font-family:monospace;">
             #{tshow res}
     |]
+
+    [whamlet|
+       <section>
+         <h2>_{MsgTestDownload}
+         ^{testDownloadWidget}
+    |]

src/Handler/Admin/Test/Download.hs

@@ -0,0 +1,107 @@
+module Handler.Admin.Test.Download
+  ( testDownload
+  ) where
+
+import Import hiding (Builder)
+import Handler.Utils
+
+import qualified Crypto.Random as Random
+
+import qualified Data.ByteString.Base64.URL as Base64
+
+import qualified Data.Conduit.List as C (mapMaybe)
+import qualified Data.Conduit.Combinators as C
+
+import qualified Data.Binary as Binary
+
+import Data.Binary.Builder (Builder)
+
+import Control.Monad.Random.Lazy (evalRandT, liftRandT)
+
+import qualified Database.Esqueleto as E hiding (random_)
+import qualified Database.Esqueleto.PostgreSQL as E
+
+
+data TestDownloadMode
+  = TestDownloadDirect
+  | TestDownloadInTransaction
+  | TestDownloadFromDatabase
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite, Binary)
+
+nullaryPathPiece ''TestDownloadMode $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''TestDownloadMode id
+
+data TestDownloadOptions = TestDownloadOptions
+  { dlSeed :: Random.Seed
+  , dlMaxSize, dlChunkSize :: Int
+  , dlMode :: TestDownloadMode
+  } deriving (Generic, Typeable)
+    deriving anyclass (Binary)
+
+testDownloadForm :: Form TestDownloadOptions
+testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do
+  randomSeed <- liftIO Random.seedNew
+
+  maxSizeRes <- wreq intField (fslI MsgTestDownloadMaxSize) . Just $ 2 * 2^30
+  modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
+  
+  return $ TestDownloadOptions
+    <$> pure randomSeed
+    <*> maxSizeRes
+    <*> pure (2^20)
+    <*> modeRes
+
+
+generateDownload :: MonadLogger m => TestDownloadOptions -> ConduitT i ByteString m ()
+generateDownload TestDownloadOptions{..}
+  = C.unfold genChunk dlMaxSize .| generateDownload' dlSeed
+  where genChunk remaining
+          | remaining >= dlChunkSize = Just (dlChunkSize, remaining - dlChunkSize)
+          | remaining <= 0 = Nothing
+          | otherwise = Just (remaining, 0)
+
+generateDownload' :: MonadLogger m => Random.Seed -> ConduitT Int ByteString m ()
+generateDownload' seed = transPipe (evalRandT ?? Random.drgNewSeed seed) $
+     C.mapM (liftRandT . (return .) . Random.randomBytesGenerate)
+  .| C.mapM (\bs -> lift $ bs <$ $logDebugS "generateDownload'" (tshow $ length bs))
+
+
+testDownload :: Handler Widget
+testDownload = do
+  ((dlRes, dlForm), dlEnctype) <- runFormPost testDownloadForm
+
+  formResult dlRes $ \opts@TestDownloadOptions{..} -> do
+    addHeader "Test-Download-Options" . decodeUtf8 . Base64.encode . toStrict $ Binary.encode opts
+    setContentDisposition ContentAttachment $ Just "u2w-test-download.bin"
+    let
+      sendDownload :: forall m. Monad m => ConduitT ByteString (Flush Builder) m ()
+      sendDownload = awaitForever $ \bs -> sendChunkBS bs >> sendFlush
+
+      sourceDBChunks :: ConduitT () Int DB ()
+      sourceDBChunks = forever sourceDBFiles
+                    .| C.mapM (\x -> x <$ $logDebugS "testDownload.sourceDBChunks" (tshow $ entityKey x))
+                    .| C.mapMaybe ((fmap length $!!) . fileContent . entityVal)
+                    .| takeLimit dlMaxSize
+        where
+          sourceDBFiles = E.selectSource . E.from $ \file -> do
+            E.orderBy [E.asc $ E.random_ @Int64]
+            E.where_ . E.not_ . E.isNothing $ file E.^. FileContent
+            return file
+          
+          takeLimit n | n <= 0 = return ()
+          takeLimit n = do
+            c <- await
+            $logDebugS "testDownload.takeLimit" $ tshow c
+            case c of
+              Nothing -> return ()
+              Just c' -> yield c' >> takeLimit (n - c')
+    (sendResponse =<<) $ case dlMode of
+      TestDownloadDirect        -> respondSource   typeOctet $ generateDownload opts .| sendDownload
+      TestDownloadInTransaction -> respondSourceDB typeOctet $ generateDownload opts .| sendDownload
+      TestDownloadFromDatabase  -> respondSourceDB typeOctet $ sourceDBChunks .| generateDownload' dlSeed .| sendDownload
+
+  return $
+    wrapForm dlForm def
+      { formEncoding = dlEnctype
+      }

src/Utils/Form.hs

@@ -226,6 +226,7 @@ data FormIdentifier
   | FIDLanguage
   | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
   | FIDAllocationAccept
+  | FIDTestDownload
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where