chore(load): sheet download

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'
 

package.yaml

@@ -274,6 +274,9 @@ executables:
     dependencies:
       - uniworx
       - normaldistribution
+      - network-uri
+      - wreq
+      - http-client-tls
     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"
+        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}

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