diff --git a/config/settings.yml b/config/settings.yml index 47c517a15..89e115e79 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -87,7 +87,7 @@ database: port: "_env:PGPORT:5432" # See config/test-settings.yml for an override during tests database: "_env:PGDATABASE:uniworx" - poolsize: "_env:PGPOOLSIZE:10" + poolsize: "_env:PGPOOLSIZE:990" auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' diff --git a/package.yaml b/package.yaml index 458f1bd78..1216b1e10 100644 --- a/package.yaml +++ b/package.yaml @@ -274,6 +274,9 @@ executables: dependencies: - uniworx - normaldistribution + - network-uri + - wreq + - http-client-tls other-modules: [] when: - condition: flag(library-only) diff --git a/shell.nix b/shell.nix index c76f4e99d..b06e92c64 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" + 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" 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/test/Load.hs b/test/Load.hs index 7533b6f13..9b569491a 100644 --- a/test/Load.hs +++ b/test/Load.hs @@ -1,11 +1,12 @@ {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} module Load ( main ) where -import "uniworx" Import hiding (Option(..), Normal) +import "uniworx" Import hiding (Option(..), Normal, responseBody) import System.Console.GetOpt @@ -25,6 +26,24 @@ import UnliftIO.Concurrent (threadDelay) import System.Clock (getTime, Clock(Monotonic)) import qualified System.Clock as Clock +import Network.URI + +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.Session (Session) +import qualified Network.Wreq.Session as Session +import Network.HTTP.Client.TLS (tlsManagerSettings) + + +instance (a ~ b, Monad m) => Monoid (Kleisli m a b) where + mempty = Kleisli return + +instance (a ~ b, Monad m) => Semigroup (Kleisli m a b) where + Kleisli f <> Kleisli g = Kleisli $ f <=< g + data Normal k = Normal { dAvg :: k @@ -63,7 +82,8 @@ instance PathPiece DiffTime where data LoadSimulation - = LoadSheetSubmission + = LoadSheetDownload + | LoadSheetSubmission deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) @@ -71,11 +91,17 @@ nullaryPathPiece ''LoadSimulation $ camelToPathPiece' 1 data LoadOptions = LoadOptions { loadSimulations :: Map LoadSimulation SimulationOptions + , loadBaseURI :: URI + , loadToken :: Maybe Jwt + , loadTerm :: TermId, loadSchool :: SchoolId, loadCourse :: CourseShorthand, loadSheet :: SheetName } deriving (Eq, Ord, Show, Generic, Typeable) instance Default LoadOptions where def = LoadOptions { loadSimulations = Map.empty + , 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" } data SimulationOptions = SimulationOptions @@ -108,12 +134,18 @@ _MapF :: (Finite k, Ord k) => Iso' (Map k v) (k -> Maybe v) _MapF = iso (flip Map.lookup) (\f -> Map.fromList $ mapMaybe (\k -> (k, ) <$> f k) universeF) -argsDescr :: [OptDescr (Endo LoadOptions)] +argsDescr :: [OptDescr (Kleisli IO LoadOptions LoadOptions)] argsDescr - = [ Option ['n', 'p'] ["number", "parallel"] (ReqArg (\(splitArg -> (cloneIndexedTraversal -> f, arg)) -> Endo . over f $ set _simParallel arg) "NATURAL") "Number of simulations to run in parallel" - , Option ['r'] ["run"] (ReqArg (\(ppArg -> sim) -> Endo $ over (_loadSimulations . at sim) (<|> Just def)) "SIMULATION") "Run the given Simulation" - , Option ['d'] ["duration"] (ReqArg (\(splitArg -> (cloneIndexedTraversal -> f, arg)) -> Endo . over f $ set _simDuration arg) "DURATION") "Try to run each simulation to take up the given duration" - , Option ['w', 's'] ["wait", "delay", "stagger"] (ReqArg (\(splitArg -> (cloneIndexedTraversal -> f, arg)) -> Endo . over f $ set _simDelay arg) "DURATION") "Wait the given time before starting each simulation" + = [ Option ['n', 'p'] ["number", "parallel"] (ReqArg (\(splitArg -> (cloneIndexedTraversal -> f, arg)) -> Kleisli $ return . over f (set _simParallel arg)) "NATURAL") "Number of simulations to run in parallel" + , Option ['r'] ["run"] (ReqArg (\(ppArg -> sim) -> Kleisli $ return . over (_loadSimulations . at sim) (<|> Just def)) "SIMULATION") "Run the given Simulation" + , Option ['d'] ["duration"] (ReqArg (\(splitArg -> (cloneIndexedTraversal -> f, arg)) -> Kleisli $ return . over f (set _simDuration arg)) "DURATION") "Try to run each simulation to take up the given duration" + , Option ['w', 's'] ["wait", "delay", "stagger"] (ReqArg (\(splitArg -> (cloneIndexedTraversal -> f, arg)) -> Kleisli $ return . over f (set _simDelay arg)) "DURATION") "Wait the given time before starting each simulation" + , Option ['b', 'u'] ["base", "uri"] (ReqArg (\uriStr -> let uri = fromMaybe (error $ "Could not parse URI: " <> uriStr) $ parseURI uriStr in Kleisli $ return . set _loadBaseURI uri ) "URI") "Base URI" + , Option ['t'] ["token"] (ReqArg (Kleisli . loadTokenFile) "FILE") "File containing bearer token" + , Option [] ["tid", "term"] (ReqArg (\(ppArg -> tid) -> Kleisli $ return . set _loadTerm tid) "TERM") "TermId" + , 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" ] where splitArg :: PathPiece p => String -> (AnIndexedTraversal' LoadSimulation LoadOptions SimulationOptions, p) @@ -133,12 +165,22 @@ argsDescr ppArg :: PathPiece p => String -> p ppArg (Text.pack -> a) = fromMaybe (terror $ "Invalid option argument: " <> a) $ fromPathPiece a + loadTokenFile :: FilePath -> LoadOptions -> IO LoadOptions + loadTokenFile fp pOpts = do + token <- Jwt . CBS.filter (not . Char.isSpace) <$> BS.readFile fp + return $ pOpts & _loadToken ?~ token + main :: IO () main = do args <- map unpack <$> getArgs - case over _1 (over _loadSimulations (Map.filter $ (> 0) . simParallel) . (`appEndo` def) . getDual . foldMap Dual) $ getOpt Permute argsDescr args of - (cfg, [], []) | not . Map.null $ loadSimulations cfg - -> imapM_ (\sim simOpts -> runReaderT (runSimulation sim) (cfg & _loadSimulations . at sim .~ Nothing, simOpts)) $ loadSimulations cfg + case getOpt Permute argsDescr args of + (kl, [], []) -> do + cfg <- over (mapped . _loadSimulations) (Map.filter $ (> 0) . simParallel) . (`runKleisli` def) . getDual $ foldMap Dual kl + if | not . Map.null $ loadSimulations cfg + -> imapM_ (\sim simOpts -> runReaderT (runSimulation sim) (cfg & _loadSimulations . at sim .~ Nothing, simOpts)) $ loadSimulations cfg + | otherwise -> do + hPutStrLn stderr $ usageInfo "uniworxload" argsDescr + exitWith $ ExitFailure 2 (_, _, errs) -> do forM_ errs $ hPutStrLn stderr hPutStrLn stderr $ usageInfo "uniworxload" argsDescr @@ -178,4 +220,30 @@ delayRemaining p = do runSimulation' :: LoadSimulation -> ReaderT SimulationContext IO () -runSimulation' = liftIO . print +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 + + +newLoadSession :: ReaderT SimulationContext IO Session +newLoadSession = do + LoadOptions{..} <- asks loadOptions + + let withToken = case loadToken of + Nothing -> id + Just (Jwt bs) -> (:) $ traceShowId (hAuthorization, "Bearer " <> bs) + + + liftIO . Session.newSessionControl (Just mempty) $ tlsManagerSettings + { managerModifyRequest = \req -> return $ req { requestHeaders = withToken $ requestHeaders req } + } + +sheetZipURI :: ReaderT SimulationContext IO URI +sheetZipURI = do + LoadOptions{..} <- asks loadOptions + let zipURI = nullURI { uriPath = unpack . Text.intercalate "/" $ "." : zipPath } + where (zipPath, _) = renderRoute . CSheetR loadTerm loadSchool loadCourse loadSheet $ SZipR SheetExercise + return $ zipURI `relativeTo` loadBaseURI