chore(load): implement sheet-submission

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,8 +254,69 @@ runSimulation' LoadSheetDownload = do
   session <- newLoadSession
   uri <- sheetZipURI
   resp <- liftIO . Session.get session $ uriToString id uri mempty
-  print . length $ resp ^. responseBody
+  void . evaluate $! resp
-runSimulation' other = terror $ "Not implemented: " <> tshow other
+  -- 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
@@ -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

package.yaml

@@ -276,7 +276,9 @@ executables:
       - normaldistribution
       - network-uri
       - wreq
+      - http-client
       - http-client-tls
+      - scalpel
     other-modules: []
     when:
       - condition: flag(library-only)

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}

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