chore(load): implement sheet-submission
This commit is contained in:
Gregor Kleen
parent
7fbd94eb84
commit
b8362398da
104
load/Load.hs
104
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
|
||||
|
||||
@ -276,7 +276,9 @@ executables:
|
||||
- normaldistribution
|
||||
- network-uri
|
||||
- wreq
|
||||
- http-client
|
||||
- http-client-tls
|
||||
- scalpel
|
||||
other-modules: []
|
||||
when:
|
||||
- condition: flag(library-only)
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user