diff --git a/load/Load.hs b/load/Load.hs index 9b569491a..c10104533 100644 --- a/load/Load.hs +++ b/load/Load.hs @@ -6,7 +6,9 @@ module Load ( main ) where -import "uniworx" Import hiding (Option(..), Normal, responseBody) +import "uniworx" Import hiding (Option(..), Normal, responseBody, responseStatus) +import Utils.Form (FormIdentifier(..)) +import Handler.Admin.Test.Download (generateDownload', seedNew) import System.Console.GetOpt @@ -28,15 +30,23 @@ import qualified System.Clock as Clock import Network.URI +import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS import qualified Data.Char as Char (isSpace) import Network.Wreq +import Network.Wreq.Types (FormValue(..)) import Network.Wreq.Session (Session) import qualified Network.Wreq.Session as Session +import Network.HTTP.Client.MultipartFormData (partFileRequestBody) import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Text.HTML.Scalpel as Scalpel + +import qualified Data.Conduit.Combinators as C +import Data.List (genericLength) + instance (a ~ b, Monad m) => Monoid (Kleisli m a b) where mempty = Kleisli return @@ -76,6 +86,13 @@ sampleNDiffTime :: (Random.MonadSplit g m, RandomGen g) => Normal DiffTime -> m sampleNDiffTime = sampleN scaleDiffTime +scaleIntegral :: Integral n => n -> Centi -> n +scaleIntegral n s = round $ toRational n * toRational s + +sampleIntegral :: (Random.MonadSplit g m, RandomGen g, Integral n) => Normal n -> m n +sampleIntegral = sampleN scaleIntegral + + instance PathPiece DiffTime where toPathPiece = toPathPiece . MkFixed @E12 . diffTimeToPicoseconds fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps @@ -94,6 +111,7 @@ data LoadOptions = LoadOptions , loadBaseURI :: URI , loadToken :: Maybe Jwt , loadTerm :: TermId, loadSchool :: SchoolId, loadCourse :: CourseShorthand, loadSheet :: SheetName + , loadUploadChunks :: Normal Natural, loadUploadChunkSize :: Normal Natural } deriving (Eq, Ord, Show, Generic, Typeable) instance Default LoadOptions where @@ -102,6 +120,8 @@ instance Default LoadOptions where , loadBaseURI = error "No BaseURI given" , loadToken = Nothing , loadTerm = error "No term given", loadSchool = error "No school given", loadCourse = error "No course given", loadSheet = error "No sheet given" + , loadUploadChunks = Normal 48 0.11 + , loadUploadChunkSize = Normal (2^16) 0 } data SimulationOptions = SimulationOptions @@ -146,6 +166,8 @@ argsDescr , Option [] ["ssh", "school"] (ReqArg (\(ppArg -> ssh) -> Kleisli $ return . set _loadSchool ssh) "SCHOOL") "SchoolId" , Option [] ["csh", "course"] (ReqArg (\(ppArg -> csh) -> Kleisli $ return . set _loadCourse csh) "COURSE") "CourseName" , Option [] ["shn", "sheet"] (ReqArg (\(ppArg -> shn) -> Kleisli $ return . set _loadSheet shn) "SHEET") "SheetName" + , Option [] ["chunks"] (ReqArg (\(ppArg -> cs) -> Kleisli $ return . set _loadUploadChunks cs) "NATURAL") "Number of chunks to upload" + , Option [] ["chunk-size"] (ReqArg (\(ppArg -> cs) -> Kleisli $ return . set _loadUploadChunkSize cs) "NATURAL") "Size of chunks to upload" ] where splitArg :: PathPiece p => String -> (AnIndexedTraversal' LoadSimulation LoadOptions SimulationOptions, p) @@ -189,15 +211,20 @@ main = do runSimulation :: LoadSimulation -> ReaderT (LoadOptions, SimulationOptions) IO () runSimulation sim = do p <- view $ _2 . _simParallel - replicateConcurrently_ (fromIntegral p) $ do + delays <- replicateM (fromIntegral p) $ do d <- view $ _2 . _simDelay - d' <- sampleNDiffTime d + sampleNDiffTime d + + forConcurrently_ ([1..p] `zip` sort delays) $ \(n, d') -> do + begin <- liftIO getCurrentTime dur <- view $ _2 . _simDuration tDuration <- sampleNDiffTime dur let MkFixed us = realToFrac d' :: Micro threadDelay $ fromInteger us + start <- liftIO getCurrentTime + print ("start", n, diffUTCTime start begin, utctDayTime start) cTime <- liftIO $ getTime Monotonic let running :: forall m. MonadIO m => m DiffTime @@ -208,6 +235,9 @@ runSimulation sim = do return $ picosecondsToDiffTime ps withReaderT (\(lO, sO) -> SimulationContext lO sO tDuration running) $ runSimulation' sim + end <- liftIO getCurrentTime + + print ("end", n, diffUTCTime start begin, diffUTCTime end start) delayRemaining :: (MonadReader SimulationContext m, MonadIO m, RealFrac r) => r -> m () @@ -224,9 +254,70 @@ runSimulation' LoadSheetDownload = do session <- newLoadSession uri <- sheetZipURI resp <- liftIO . Session.get session $ uriToString id uri mempty - print . length $ resp ^. responseBody -runSimulation' other = terror $ "Not implemented: " <> tshow other + void . evaluate $! resp + -- print . length $ resp ^. responseBody +runSimulation' LoadSheetSubmission = do + LoadOptions{..} <- asks loadOptions + session <- newLoadSession + let formURI = formURI' `relativeTo` loadBaseURI + where formURI' = nullURI { uriPath = unpack . Text.intercalate "/" $ "." : formPath } + (formPath, _) = renderRoute $ CSheetR loadTerm loadSchool loadCourse loadSheet SubmissionNewR + resp <- liftIO . Session.get session $ uriToString id formURI mempty + Just formData <- return . getFormData FIDsubmission $ resp ^. responseBody + Just addButtonData <- return . flip (runFormScraper FIDsubmission) (resp ^. responseBody) $ do + let btnSel = "button" Scalpel.@: [Scalpel.hasClass "btn-mass-input-add"] + + name <- Scalpel.attr "name" btnSel + value <- Scalpel.attr "value" btnSel + guard $ value == "add__0__0" + return $ toStrict name := value + let miData = addButtonData : map addEmail formData + where addEmail dat@(name := _) + | "__add__0__fields__emails" `isSuffixOf` name = name := ("loadtest@example.invalid" :: Text) + | otherwise = dat + resp2 <- liftIO $ Session.post session (uriToString id formURI mempty) miData + Just formData2 <- return . getFormData FIDsubmission $ resp2 ^. responseBody + uploadSeed <- liftIO seedNew + chunkCount <- sampleIntegral loadUploadChunks + chunks <- replicateM (fromIntegral chunkCount) $ sampleIntegral loadUploadChunkSize + simCtx <- ask + let fileUploadPart = requestBodySourceChunked $ + yieldMany (zip [0..] chunks) + .| runReaderC simCtx + ( C.mapM $ \(ci, cs) -> + fromIntegral cs <$ delayRemaining (1 % (genericLength chunks - ci) :: Rational) + ) + .| generateDownload' uploadSeed + -- print $ ala Sum foldMap chunks + Just fileData <- return . flip (runFormScraper FIDsubmission) (resp ^. responseBody) $ do + let fileSel = "input" Scalpel.@: ["type" Scalpel.@= "file"] + name <- Scalpel.attr "name" fileSel + return $ partFileRequestBody (decodeUtf8 $ toStrict name) "loadtest.bin" fileUploadPart + let subData = (:) fileData $ formData2 >>= \(name := (renderFormValue -> value)) -> do + guard $ name /= encodeUtf8 (fileData ^. partName) + return $ partBS (decodeUtf8 name) value + resp3 <- liftIO $ Session.post session (uriToString id formURI mempty) subData + void . evaluate $! resp3 + -- print $ resp3 ^. responseStatus + +-- runSimulation' other = terror $ "Not implemented: " <> tshow other + +runFormScraper :: FormIdentifier -> Scalpel.Scraper Lazy.ByteString a -> Lazy.ByteString -> Maybe a +runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $ + fmap listToMaybe . Scalpel.chroots "form" $ do + fid' <- Scalpel.attr "value" $ "input" Scalpel.@: ["name" Scalpel.@= "form-identifier"] + guard $ fid' == encodeUtf8 (fromStrict $ toPathPiece fid) + + innerS + +getFormData :: FormIdentifier -> Lazy.ByteString -> Maybe [FormParam] +getFormData = flip runFormScraper $ + Scalpel.chroots ("input") $ do + name <- Scalpel.attr "name" Scalpel.anySelector + value <- Scalpel.attr "value" Scalpel.anySelector <|> pure "" + return $ toStrict name := value + newLoadSession :: ReaderT SimulationContext IO Session newLoadSession = do @@ -234,11 +325,12 @@ newLoadSession = do let withToken = case loadToken of Nothing -> id - Just (Jwt bs) -> (:) $ traceShowId (hAuthorization, "Bearer " <> bs) + Just (Jwt bs) -> (:) (hAuthorization, "Bearer " <> bs) liftIO . Session.newSessionControl (Just mempty) $ tlsManagerSettings { managerModifyRequest = \req -> return $ req { requestHeaders = withToken $ requestHeaders req } + , managerResponseTimeout = responseTimeoutNone } sheetZipURI :: ReaderT SimulationContext IO URI diff --git a/package.yaml b/package.yaml index abe0a6ad3..c8ee7a8e0 100644 --- a/package.yaml +++ b/package.yaml @@ -276,7 +276,9 @@ executables: - normaldistribution - network-uri - wreq + - http-client - http-client-tls + - scalpel other-modules: [] when: - condition: flag(library-only) diff --git a/shell.nix b/shell.nix index b06e92c64..b7edf8725 100644 --- a/shell.nix +++ b/shell.nix @@ -43,7 +43,7 @@ let pgSockDir=$(mktemp -d) pgLogFile=$(mktemp) initdb --no-locale -D ''${pgDir} - pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=1000" + pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990" export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} psql -f ${postgresSchema} postgres printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} diff --git a/src/Handler/Admin/Test/Download.hs b/src/Handler/Admin/Test/Download.hs index fdc391313..a7c73c857 100644 --- a/src/Handler/Admin/Test/Download.hs +++ b/src/Handler/Admin/Test/Download.hs @@ -1,5 +1,6 @@ module Handler.Admin.Test.Download ( testDownload + , generateDownload', Random.seedNew ) where import Import hiding (Builder) @@ -53,7 +54,7 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do <*> modeRes -generateDownload :: MonadLogger m => TestDownloadOptions -> ConduitT i ByteString m () +generateDownload :: Monad m => TestDownloadOptions -> ConduitT i ByteString m () generateDownload TestDownloadOptions{..} = C.unfold genChunk dlMaxSize .| generateDownload' dlSeed where genChunk remaining @@ -61,10 +62,9 @@ generateDownload TestDownloadOptions{..} | remaining <= 0 = Nothing | otherwise = Just (remaining, 0) -generateDownload' :: MonadLogger m => Random.Seed -> ConduitT Int ByteString m () +generateDownload' :: Monad 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