diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index a6bd3cfb1..065d0eeba 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index d25315ede..156bacecf 100644 --- a/messages/uniworx/en-eu.msg +++ b/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 diff --git a/src/Crypto/Random/Instances.hs b/src/Crypto/Random/Instances.hs index 068760c2b..3c840da89 100644 --- a/src/Crypto/Random/Instances.hs +++ b/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 diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index d2eedd9b6..77f468602 100644 --- a/src/Handler/Admin/Test.hs +++ b/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

#{tshow res} |] + + [whamlet| +

+

_{MsgTestDownload} + ^{testDownloadWidget} + |] diff --git a/src/Handler/Admin/Test/Download.hs b/src/Handler/Admin/Test/Download.hs new file mode 100644 index 000000000..fdc391313 --- /dev/null +++ b/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 + } diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 6df3f8492..a213a6e7d 100644 --- a/src/Utils/Form.hs +++ b/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