katt 0.2.0.1 → 0.2.0.3

raw patch · 8 files changed

+217/−316 lines, 8 filesdep +aesondep +lensdep +textdep −HsOpenSSLdep −blaze-builderdep −http-streamsdep ~parsecdep ~zip-archivePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, lens, text, wreq

Dependencies removed: HsOpenSSL, blaze-builder, http-streams, io-streams, unix

Dependency ranges changed: parsec, zip-archive

API changes (from Hackage documentation)

Files

• katt-cli/src/Main.hs +15/−24
• katt-lib/src/Utils/Katt/Configuration.hs +14/−14
• katt-lib/src/Utils/Katt/Init.hs +34/−38
• katt-lib/src/Utils/Katt/SourceHandler.hs +16/−11
• katt-lib/src/Utils/Katt/Upload.hs +61/−105
• katt-lib/src/Utils/Katt/Utils.hs +56/−97
• katt-tests/src/TestSourceHandler.hs +9/−9
• katt.cabal +12/−18

@@ -13,16 +13,14 @@ module Main(main) where  import qualified Utils.Katt.Configuration as C-import Control.Monad.State+import qualified Control.Monad.State as S import qualified Data.ByteString.Char8 as B-import Data.Monoid ((<>))-import Utils.Katt.Init-import Network.Http.Client-import OpenSSL (withOpenSSL)-import System.Environment-import System.Exit (exitFailure)-import Utils.Katt.Upload-import Utils.Katt.Utils+import           Data.Monoid ((<>))+import           System.Environment (getArgs)+import           System.Exit (exitFailure)+import           Utils.Katt.Init+import           Utils.Katt.Upload+import           Utils.Katt.Utils  -- | Main loads the global config and runs argument parsing. main :: IO ()@@ -35,7 +33,7 @@       exitFailure     Right c -> return c -  withOpenSSL $ parseArgs conf'+  parseArgs conf'  -- | Given some configuration state, parse arguments and --   run the appropiate submodule.@@ -44,9 +42,9 @@ parseArgs conf = getArgs >>= parse   where   parse :: [String] -> IO ()-  parse ("init" : problem : []) = withConn conf . initializeProblem True True . ProblemName $ B.pack problem-  parse ("init-session" : session : []) = withConn conf . initializeSession True $ read session-  parse ("submit" : filterList) = withConn conf $ makeSubmission filterList+  parse ("init" : problem : []) = withConf conf . initializeProblem True True . ProblemName $ B.pack problem+  parse ("init-session" : session : []) = withConf conf . initializeSession True $ read session+  parse ("submit" : filterList) = withConf conf $ makeSubmission filterList   parse _ = printHelp  -- | Print help text.@@ -64,15 +62,8 @@   "Note that you will need a valid configuration file (placed in ~/.kattisrc), such as:\n" <>   "https://www.kattis.com/download/kattisrc\n" --- | Given some action, initiate a connection and run it.---   Connections are layered using StateT since they may be reestablished.-withConn :: ConfigState -> ConnEnv IO a -> IO a-withConn conf action = do-  B.putStrLn $ "Connecting to host: " <> host conf-  conn <- establishConnection (host conf)-  ((res, conn'), _) <- runStateT (withConf conn) conf-  closeConnection conn'+-- | Run an action with the supplied configuration.+withConf :: ConfigState -> ConfigEnv IO a -> IO a+withConf conf action = do+  (res, _) <- S.runStateT (terminateOnFailure "Failed to run command" action) conf   return res--  where-  withConf = runStateT (terminateOnFailure "Failed to run command" action)

@@ -1,4 +1,4 @@-{-# Language OverloadedStrings, NoMonomorphismRestriction #-}+{-# Language OverloadedStrings #-}  -------------------------------------------------------------------- -- |@@ -19,18 +19,18 @@ (loadGlobalConfig, projectConfigExists, loadProjectConfig, saveProjectConfig) where -import Control.Error hiding (tryIO)-import Control.Monad+import           Control.Error hiding (tryIO)+import           Control.Monad import qualified Control.Monad.State as S-import Control.Monad.Trans (liftIO, lift)+import           Control.Monad.Trans (liftIO) import qualified Data.ByteString.Char8 as B-import Data.ConfigFile-import Data.Monoid ((<>))+import           Data.ConfigFile+import           Data.Monoid ((<>)) import qualified Network.URL as U-import System.Directory (getHomeDirectory)-import System.IO-import System.IO.Error (catchIOError)-import Utils.Katt.Utils+import           System.Directory (getHomeDirectory)+import           System.IO+import           System.IO.Error (catchIOError)+import           Utils.Katt.Utils  -- | Path to global configuration file, relative home directory. globalConfigFile :: FilePath@@ -99,14 +99,14 @@ loadProjectConfig = do   conf <- fmapLT convertErrorDesc $ join . liftIO $ readfile emptyCP projectConfigFile   problem <- get' conf "problem" "problemname"-  lift . S.modify $ \s -> s { project = Just . ProblemName $ B.pack problem}+  S.modify $ \s -> s { project = Just . ProblemName $ B.pack problem}  -- | Save a project-specific configuration file to disk.-saveProjectConfig :: ConnEnv IO ()+saveProjectConfig :: ConfigEnv IO () saveProjectConfig = do-  project' <- lift . lift $ S.gets project+  project' <- S.gets project   state <- noteT "Tried to save an empty project configuration." . hoistMaybe $ project'-  problemName <- retrieveProblemName state+  problemName <- tryIO $ retrieveProblemName state   serialized <- serialize problemName   tryIOMsg (B.pack $             "Failed to save project configuration file (path: "

@@ -1,5 +1,4 @@-{-# Language OverloadedStrings, ScopedTypeVariables,-    NoMonomorphismRestriction #-}+{-# Language OverloadedStrings, ScopedTypeVariables #-}  -------------------------------------------------------------------- -- |@@ -19,24 +18,24 @@ (initializeProblem, initializeSession) where -import Control.Applicative ((<$>), (<*))-import Codec.Archive.Zip-import Control.Arrow ((***))+import           Control.Applicative ((<$>), (<*))+import qualified Codec.Archive.Zip as Z+import           Control.Arrow ((***))+import           Control.Monad (liftM, liftM2, void, when) import qualified Control.Monad.State as S-import qualified Utils.Katt.Configuration as C-import Control.Error hiding (tryIO)+import           Control.Error hiding (tryIO) import qualified Control.Exception as E-import Control.Monad.Reader import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL-import Data.Foldable (fold)-import Data.List (isSuffixOf, nub)-import Data.Monoid ((<>))-import System.Directory-import System.IO (stderr)-import Text.Parsec hiding (token)-import Text.Parsec.ByteString-import Utils.Katt.Utils+import           Data.Foldable (fold)+import           Data.List (isSuffixOf, nub)+import           Data.Monoid ((<>))+import qualified System.Directory as D+import           System.IO (stderr)+import           Text.Parsec hiding (token)+import           Text.Parsec.ByteString+import qualified Utils.Katt.Configuration as C+import           Utils.Katt.Utils  -- | Parsed test cases associated with a problem. type TestContent = [(B.ByteString, B.ByteString)]@@ -111,14 +110,13 @@  -- | Retrieve the zip archive located at the specified URL and unzip the contents. --   Matches input and output file pairs, producing a list of tuples.-downloadTestArchive :: B.ByteString -> ConnEnv IO TestContent+downloadTestArchive :: B.ByteString -> ConfigEnv IO TestContent downloadTestArchive url = do-  reestablishConnection   zipFile <- BL.fromChunks . return <$> retrievePublicPage url   zipEntries <- tryIOMsg "Failed to unpack zip file: corrupt archive" $-    E.evaluate (zEntries $ toArchive zipFile)+    E.evaluate (Z.zEntries $ Z.toArchive zipFile) -  let filterFiles suffix = filter (isSuffixOf suffix . eRelativePath) zipEntries+  let filterFiles suffix = filter (isSuffixOf suffix . Z.eRelativePath) zipEntries       inFiles = filterFiles inputTestExtension       outFiles = filterFiles outputTestExtension @@ -130,12 +128,12 @@   return $ zipWith (curry convertEntry) inFiles outFiles   where   convertEntry = getData *** getData-  getData = fold . BL.toChunks . fromEntry+  getData = fold . BL.toChunks . Z.fromEntry  -- | Retrieve test cases, which fall into either one of the three categories.-retrieveTestFiles :: KattisProblem -> ConnEnv IO TestContent+retrieveTestFiles :: KattisProblem -> ConfigEnv IO TestContent retrieveTestFiles problem = do-  problemName <- retrieveProblemName problem+  problemName <- tryIO $ retrieveProblemName problem   problemPage <- retrievePublicPage $ problemAddress <> problemName    case parseProblemPage problemPage of@@ -160,43 +158,41 @@     return . ProblemName $ B.pack problem  -- | Given a problem session id, initialize all the corresponding problems.-initializeSession :: Bool -> ProblemSession -> ConnEnv IO ()+initializeSession :: Bool -> ProblemSession -> ConfigEnv IO () initializeSession retrieveTests session = do-  contents <- retrievePublicPage $ sessionPage <> (B.pack $ show session)+  contents <- retrievePublicPage $ sessionPage <> B.pack (show session)   problems <- nub <$> (EitherT . return  . fmapL (B.pack . show) $ parse' contents)   mapM_ (\problem -> do-      reestablishConnection       initializeProblem True retrieveTests problem       restoreDir     )     problems   where-  parse' contents = parse (parseProblemList) "Problem list parser" contents-  restoreDir = liftIO $ setCurrentDirectory ".."-  -- TODO: restore to previously used directory+  parse' = parse parseProblemList "Problem list parser"+  restoreDir = S.liftIO $ D.setCurrentDirectory ".."  -- | Given a problem identifier, setup directory structures and --   optionally download test cases.-initializeProblem :: Bool -> Bool -> KattisProblem -> ConnEnv IO ()+initializeProblem :: Bool -> Bool -> KattisProblem -> ConfigEnv IO () initializeProblem mkDir retrieveTests problem = do-  liftIO . putStrLn $ "Initializing problem: " <> show problem-  problemName <- retrieveProblemName problem+  S.liftIO . putStrLn $ "Initializing problem: " <> show problem+  problemName <- tryIO $ retrieveProblemName problem   tryIO . when mkDir $ do-    createDirectoryIfMissing False (B.unpack problemName)-    setCurrentDirectory (B.unpack problemName)+    D.createDirectoryIfMissing False (B.unpack problemName)+    D.setCurrentDirectory (B.unpack problemName) -  tryIO $ createDirectoryIfMissing False (B.unpack configDir)+  tryIO $ D.createDirectoryIfMissing False (B.unpack configDir) -  fileExists <- liftIO C.projectConfigExists+  fileExists <- S.liftIO C.projectConfigExists   tryAssert     "Project configuration file already exists, please remove it in order to continue."     (not fileExists) -  lift . lift . S.modify $ \s -> s { project = Just $ ProblemName problemName }+  S.modify $ \s -> s { project = Just $ ProblemName problemName }   C.saveProjectConfig    when retrieveTests $ do-    tryIO $ createDirectory testFolder+    tryIO $ D.createDirectory testFolder     files <- zip [1..] <$> retrieveTestFiles problem     mapM_ (\(n :: Integer, (input, output)) -> do       let fileName = testFolder <> "/" <> B.unpack problemName <> "-" <> show n

@@ -15,23 +15,24 @@ (parseFilter, findFiles, determineLanguage, findMainClass, languageKattisName, languageContentType) where -import Control.Applicative ((<$>))-import Control.Arrow ((***))-import Control.Monad+import           Control.Applicative ((<$>))+import           Control.Arrow ((***))+import           Control.Monad (filterM, mapAndUnzipM, void) import qualified Data.ByteString.Char8 as B-import Data.List+import           Data.List ((\\), isSuffixOf) import qualified Data.Set as Set-import System.Directory-import System.FilePath (takeBaseName, takeExtension)-import Text.Parsec-import Text.Parsec.ByteString-import Utils.Katt.Utils+import           System.Directory (doesDirectoryExist, getDirectoryContents)+import           System.FilePath (takeBaseName, takeExtension)+import           Text.Parsec+import           Text.Parsec.ByteString+import           Utils.Katt.Utils  -- | All supported source file extensions, per language. supported :: KattisLanguage -> Set.Set FilePath supported LangCplusplus = Set.fromList [".cc", ".cpp", ".hpp", ".h"] supported LangC         = Set.fromList [".c", ".h"] supported LangJava      = Set.fromList [".java"]+supported LangHaskell   = Set.fromList [".hs"]  -- | Parse an argument list from the +file1 -file2 style into --   two lists of file paths (included and ignored files).@@ -57,7 +58,7 @@     return $ sourceFiles ++ concat nextDepth    isValidSourceFile file = any (`isSuffixOf` file)-    (Set.toList . Set.unions $ map supported [LangCplusplus, LangC, LangJava])+    (Set.toList . Set.unions $ map supported [LangCplusplus, LangC, LangJava, LangHaskell])   exploreDir dir = explore (dir ++ "/") dir  -- | Determine source code language by studying file extensions.@@ -67,10 +68,11 @@   | is LangC = Just LangC   | is LangCplusplus = Just LangCplusplus   | is LangJava = Just LangJava+  | is LangHaskell = Just LangHaskell   | otherwise = Nothing   where   fileSet = Set.fromList $ map takeExtension files-  is lang = fileSet `Set.isSubsetOf` (supported lang)+  is lang = fileSet `Set.isSubsetOf` supported lang  -- | Locate main class based on source file contents. --   C++ and C solutions do not need to be specified, returns an empty string.@@ -83,6 +85,7 @@ findMainClass ([], _)            = return Nothing findMainClass (_, LangCplusplus) = return $ Just "" findMainClass (_, LangC)         = return $ Just ""+findMainClass (_, LangHaskell)   = return $ Just "" findMainClass (files, LangJava)  = survey <$> filterM containsMain files   where   containsMain file = do@@ -108,9 +111,11 @@ languageContentType LangCplusplus = "text/x-c++src" languageContentType LangJava = "text/x-c++src" languageContentType LangC = "text/x-c++src"+languageContentType LangHaskell = "text/x-c++src"  -- | Determine Kattis language string identifier. languageKattisName :: KattisLanguage -> B.ByteString languageKattisName LangCplusplus = "C++" languageKattisName LangJava = "Java" languageKattisName LangC = "C"+languageKattisName LangHaskell = "Haskell"

@@ -1,4 +1,4 @@-{-# Language OverloadedStrings, ScopedTypeVariables #-}+{-# Language OverloadedStrings #-}  -------------------------------------------------------------------- -- |@@ -18,49 +18,24 @@ (makeSubmission) where -import Control.Applicative ((<$>))-import Blaze.ByteString.Builder (fromByteString)-import qualified Utils.Katt.Configuration as C-import Control.Concurrent (threadDelay)-import Control.Error hiding (tryIO)-import Control.Monad.Reader+import           Control.Applicative ((<$>))+import           Control.Concurrent (threadDelay)+import           Control.Error hiding (tryIO)+import           Control.Lens+import           Control.Monad (join, liftM2, void) import qualified Control.Monad.State as S import qualified Data.ByteString.Char8 as B-import Data.List ((\\), union, findIndex)-import Data.Maybe (fromJust)-import Data.Monoid ((<>))-import Network.Http.Client-import Utils.Katt.SourceHandler-import System.IO.Streams (write)-import Text.Parsec hiding (token)-import Text.Parsec.ByteString-import Utils.Katt.Utils---- | Line separator used in HTTP headers. -crlf :: B.ByteString-crlf = "\r\n"---- | Multipart field consisting of an option or file.-data MultiPartField-  -- | Option built using a list of assignments and a payload.-  = Option [B.ByteString] B.ByteString-  -- | File to submitted, path given.-  | File FilePath---- | Serialize a chunk based on a file to be submitted.-buildChunk :: B.ByteString -> MultiPartField -> IO B.ByteString-buildChunk langStr (File path) = do-  file <- B.readFile path-  return $ B.intercalate crlf [headerLine, "Content-Type: " <> langStr, "", file, ""]-  where-    headerLine = B.intercalate "; " ["Content-Disposition: form-data", "name=\"sub_file[]\"",-                                     B.concat ["filename=\"", B.pack path, "\""]]---- | Serialize a chunk based on an option.-buildChunk _ (Option fields payload) = return $ B.intercalate crlf [headerLine, "", payload, ""]-  where-    headerLine = B.intercalate "; " fieldList-    fieldList = "Content-Disposition: form-data" : fields+import           Data.List ((\\), union, findIndex)+import           Data.Maybe (fromJust)+import           Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Network.Wreq as W+import qualified Network.Wreq.Session as WS+import           Text.Parsec hiding (token)+import           Text.Parsec.ByteString+import qualified Utils.Katt.Configuration as C+import           Utils.Katt.SourceHandler+import           Utils.Katt.Utils  -- | Submission page URL, relative 'Utils.host', from which specific submission can be requested. submissionPage :: B.ByteString@@ -112,39 +87,35 @@ -- --   In addition to the filters, all recursively found source code files --   will be included in the submission.-makeSubmission :: [String] -> ConnEnv IO ()+makeSubmission :: [String] -> ConfigEnv IO () makeSubmission filterArguments = do-  exists <- liftIO C.projectConfigExists+  exists <- tryIO C.projectConfigExists   tryAssert "No project configuration could be found."     exists -  unWrapTrans C.loadProjectConfig-  problem <- lift . lift $ (fromJust <$> S.gets project)+  C.loadProjectConfig+  problem <- fromJust <$> S.gets project+  conf <- S.get    -- Locate all source files, filter based on filter list.   files <- tryIOMsg "Failed to locate source files" findFiles   let adjusted = adjust (parseFilter filterArguments) files -  liftIO $ mapM_ (putStrLn . ("Adding file: "++)) adjusted+  tryIO $ mapM_ (putStrLn . ("Adding file: "++)) adjusted    -- Authenticate, submit files, and retrieve submission id.-  token <- authenticate --  submission <- EitherT $ runReaderT-    (runEitherT $ submitSolution (problem, adjusted)) token--  tryIO . putStrLn $ "Made submission: " <> show submission-  tryIO $ threadDelay initialTimeout+  let url = buildURL (host conf) (submitPage conf)+      toState sess = (sess, host conf) -  -- Reauthenticate to allow future requests.-  reestablishConnection-  token' <- authenticate +  submission <- withAuth $ \sess ->+    submitSolution (toState sess) url (problem, adjusted) -  -- Poll submission page until completion.-  reestablishConnection-  EitherT $ runReaderT-    (runEitherT $ checkSubmission submission) token'+  tryIO $ do+    putStrLn $ "Made submission: " <> show submission+    threadDelay initialTimeout +  withAuth $ \sess ->+    checkSubmission (toState sess) submission   where   adjust Nothing files = files   adjust (Just (add, sub)) files = union (files \\ sub) add@@ -155,10 +126,10 @@ -- | Poll kattis for updates on a submission. --  This function returns when the submission has reached one of the final states. --  TODO: Consider exponential back-off and timeout-checkSubmission :: SubmissionId -> AuthEnv IO ()-checkSubmission submission = do-  page <- retrievePrivatePage $-    "/" <> submissionPage <> "?id=" <> B.pack (show submission)+checkSubmission :: Session -> SubmissionId -> EitherT ErrorDesc IO ()+checkSubmission sess submission = do+  page <- retrievePrivatePage sess $+    submissionPage <> "?id=" <> B.pack (show submission)   let (state, tests) = parseSubmission page    if finalSubmissionState state@@ -166,8 +137,7 @@       tryIO $ printResult tests state     else do       tryIO $ putStrLn "Waiting for completion.." >> threadDelay interval-      unWrapTrans reestablishConnection-      checkSubmission submission+      checkSubmission sess submission       where   -- Default poll interval is 1 s.@@ -268,57 +238,43 @@   resultStr = "Result: " <> show state   testCaseStr = ", failed on test case " <> firstFailed <> " of " <> numTests - -- | Submit a solution, given problem name and source code files.-submitSolution :: Submission -> AuthEnv IO SubmissionId-submitSolution (problem, files) = do+submitSolution :: Session -> String -> Submission -> EitherT ErrorDesc IO SubmissionId+submitSolution (sess, _) url (problem, files) = do   -- Determine language in submission.   language <- noteT ("\nFailed to decide submission language\n" <>                     "Please use either Java or some union of C++ and C")     . hoistMaybe $ determineLanguage files   let languageStr = languageKattisName language -  mainClassStr <- join . liftIO $+  -- Locate main class, if any+  mainClassStr <- join . tryIO $     (noteT "Failed to locate the \"public static void main\" method - is there any?" . hoistMaybe)       <$> findMainClass (files, language) -  -- Build HTTP headers and form.-  let multiPartSeparator = "separator"--  conf <- lift . lift $ lift S.get-  header <- makeSignedRequest $ do-    http POST ("/" <> submitPage conf)-    defaultRequest-    setContentType $ B.append "multipart/form-data; boundary=" multiPartSeparator--  problemName <- unWrapTrans $ retrieveProblemName problem--  let postFields = [Option ["name=\"submit\""] "true"]-                <> [Option ["name=\"submit_ctr\""] "2"]-                <> [Option ["name=\"language\""] languageStr]-                <> [Option ["name=\"mainclass\""] (B.pack mainClassStr)]-                <> [Option ["name=\"problem\""] problemName]-                <> [Option ["name=\"tag\""] ""]-                <> [Option ["name=\"script\""] "true"]-                <> map File files--  -- Send request. Connection is reestablished.-  unWrapTrans reestablishConnection-  conn <- lift . lift $ S.get--  tryIO $ sendRequest conn header (\o -> do-    mapM_ (\part -> do-        serialized <- buildChunk (languageContentType language) part-        write (Just . fromByteString $ B.concat ["--", multiPartSeparator, crlf, serialized]) o)-      postFields+  -- Construct POST data+  problemName <- tryIO $ retrieveProblemName problem+  let files'     = map (W.partFile "sub_file[]") files+      conv       = T.pack . B.unpack+      postFields = [W.partText "submit" "true"]+                <> [W.partText "submit_ctr" "2"]+                <> [W.partText "language" (conv languageStr)]+                <> [W.partText "mainclass" (T.pack mainClassStr)]+                <> [W.partText "problem" (conv problemName)]+                <> [W.partText "tag" ""]+                <> [W.partText "script" "true"] -    write (Just . fromByteString $ B.concat ["--", multiPartSeparator, "--", crlf]) o-    )+  -- Submit the request+  reply <- tryIO $ WS.postWith+    defaultOpts+    sess+    url+    (files' <> postFields) -  -- Receive server response and parse submission ID.-  reply <- tryIO $ receiveResponse conn concatHandler+  -- Extract the submission ID+  let body = reply ^. W.responseBody   (EitherT . return  . fmapL (B.pack . show)) $-    parse parseSubmissionId "Submission ID parser" reply+    parse parseSubmissionId "Submission ID parser" body    where   parseSubmissionId = manyTill anyChar (lookAhead identifier) >> identifier

@@ -1,5 +1,4 @@-{-# Language OverloadedStrings, ScopedTypeVariables,-    NoMonomorphismRestriction #-}+{-# Language OverloadedStrings #-}  -------------------------------------------------------------------- -- |@@ -12,32 +11,25 @@ Utils.Katt.Utils where -import Control.Applicative ((<$>))-import Control.Error hiding (tryIO)+import           Control.Error hiding (tryIO) import qualified Control.Exception as E-import Control.Monad.Reader+import           Control.Lens+import           Control.Monad (liftM)+import           Control.Monad.Trans (lift) import qualified Control.Monad.State as S import qualified Data.ByteString.Char8 as B-import Data.Monoid ((<>))-import Network.Http.Client-import System.Exit (exitFailure)-import System.IO (stderr)-import System.IO.Streams (readExactly)+import qualified Data.ByteString.Lazy.Char8 as BL+import           Data.Monoid ((<>))+import qualified Network.Wreq as W+import qualified Network.Wreq.Session as WS+import           System.Exit (exitFailure)+import           System.IO (stderr)  -- | Configuration layer consisting of configuration state. type ConfigEnvInternal m = S.StateT ConfigState m -- | Configuration layer wrapped with error handling. type ConfigEnv m = EitherT ErrorDesc (ConfigEnvInternal m) --- | Connection layer with connection state layered on the configuration layer.-type ConnEnvInternal m = S.StateT Connection (ConfigEnvInternal m)--- | Connection layer wrapped with error handling.-type ConnEnv m = EitherT ErrorDesc (ConnEnvInternal m)---- | Authentication layer with token state and error handling,---   wrapping the connection layer.-type AuthEnv m = EitherT ErrorDesc (ReaderT B.ByteString (ConnEnvInternal m))- -- | Submissions consist of a problem identifier and a set of file paths. type Submission = (KattisProblem, [FilePath]) @@ -71,6 +63,9 @@   }   deriving Show +-- | HTTP client session and the host path.+type Session = (WS.Session, B.ByteString)+ -- | A Kattis problem. data KattisProblem   -- | Problem ID, unique.@@ -87,6 +82,8 @@   | LangJava   -- | C.   | LangC+  -- | Haskell.+  | LangHaskell   deriving (Eq, Show)  -- | Server response indicating successful login.@@ -118,114 +115,76 @@ problemAddress = "/problems/"  -- | Lift some error monad one layer.-unWrapTrans :: (Monad m, MonadTrans t) => EitherT e m a -> EitherT e (t m) a+unWrapTrans :: (Monad m, S.MonadTrans t) => EitherT e m a -> EitherT e (t m) a unWrapTrans = EitherT . lift . runEitherT  -- | Execute an IO action and catch any exceptions.-tryIO :: MonadIO m => IO a -> EitherT ErrorDesc m a-tryIO = EitherT . liftIO . liftM (fmapL (B.pack . show)) . +tryIO :: S.MonadIO m => IO a -> EitherT ErrorDesc m a+tryIO = EitherT . S.liftIO . liftM (fmapL (B.pack . show)) .   (E.try :: (IO a -> IO (Either E.SomeException a)))  -- | Execute an IO action and catch any exceptions, tagged with description.-tryIOMsg :: MonadIO m => B.ByteString -> IO a -> EitherT ErrorDesc m a-tryIOMsg msg = EitherT . liftIO . liftM (fmapL $ const msg) . +tryIOMsg :: S.MonadIO m => B.ByteString -> IO a -> EitherT ErrorDesc m a+tryIOMsg msg = EitherT . S.liftIO . liftM (fmapL $ const msg) .   (E.try :: (IO a -> IO (Either E.SomeException a)))  -- | Evaluate an error action and terminate process upon failure.-terminateOnFailure :: MonadIO m => ErrorDesc -> EitherT ErrorDesc m a -> m a+terminateOnFailure :: S.MonadIO m => ErrorDesc -> EitherT ErrorDesc m a -> m a terminateOnFailure msg state = do   res <- runEitherT state-  liftIO $ case res of+  S.liftIO $ case res of     Left errorMessage -> do       B.hPutStrLn stderr $ msg <> ", error: " <> errorMessage       exitFailure     Right success -> return success --- | Sign an existing HTTP request with a temporary token.-makeSignedRequest :: RequestBuilder () -> AuthEnv IO Request-makeSignedRequest req = do-  key <- lift $ liftM (setHeader "Cookie") ask-  liftIO . buildRequest $ req >> key---- | Default HTTP request.-defaultRequest :: RequestBuilder ()-defaultRequest = do-  setHeader "User-Agent" programName-  setHeader "Connection" "keep-alive"---- | Reestablish an existing connection.---   Useful in order to avoid timeouts related to keep-alive.-reestablishConnection :: ConnEnv IO ()-reestablishConnection = do-  conn <- lift S.get-  tryIOMsg "Failed to close connection" $ closeConnection conn-  host' <- host <$> lift (lift S.get)-  conn' <- tryIOMsg "Failed to reestablish connection" $ establishConnection host'-  lift $ S.put conn'+-- | Default HTTP options.+defaultOpts :: W.Options+defaultOpts = W.defaults+            & W.header "User-Agent" .~ [programName] --- | Retrieve a publically available page, using HTTP GET.-retrievePublicPage :: B.ByteString -> ConnEnv IO B.ByteString-retrievePublicPage page = do-  header <- tryIO . buildRequest $ http GET page >> defaultRequest-  makeRequest header+-- | Retrieve a publicly available page, using HTTP GET.+retrievePublicPage :: B.ByteString -> ConfigEnv IO B.ByteString+retrievePublicPage path = do+  host' <- S.gets host+  reply <- tryIO $ W.getWith defaultOpts $ buildURL host' path+  return . B.concat . BL.toChunks $ reply ^. W.responseBody  -- | Retrieve a page requiring authentication, using HTTP GET.-retrievePrivatePage :: B.ByteString -> AuthEnv IO B.ByteString-retrievePrivatePage page = do-  header <- makeSignedRequest $ do-    http GET page-    defaultRequest-  unWrapTrans $ makeRequest header---- | Make a HTTP request and retrieve the server response body.-makeRequest :: Request -> ConnEnv IO B.ByteString-makeRequest header = do-  conn <- lift S.get-  tryIO $ sendRequest conn header emptyBody-  tryIO $ receiveResponse conn concatHandler+retrievePrivatePage :: Session -> B.ByteString -> EitherT ErrorDesc IO B.ByteString+retrievePrivatePage (sess, host') page = do+  reply <- tryIO $ WS.getWith defaultOpts sess (buildURL host' page)+  return . B.concat . BL.toChunks $ reply ^. W.responseBody --- | Extract correct temporary token from cookie header string.-extractSessionHeader :: B.ByteString -> Maybe B.ByteString-extractSessionHeader headerStr -  | B.null match = Nothing-  | otherwise =-    case extractSessionHeader (B.tail match) of-      Just match' -> Just match'-      Nothing -> Just $ B.takeWhile (/= ';') match-  where-  (_, match) = B.breakSubstring "PHPSESSID" headerStr+-- | Construct URL from host path (e.g. /http:\/\/x.com\/) and path (e.g. //).+buildURL :: B.ByteString -> B.ByteString -> String+buildURL host' path = B.unpack $ host' <> "/" <> path --- | Authenticate an existing connection, returns a temporary token.---   Basically the API token is used to acquire a session-specific token.-authenticate :: ConnEnv IO B.ByteString-authenticate = do-  conf <- lift $ lift S.get+-- | Authenticate and run the provided action.+withAuth :: (WS.Session -> EitherT ErrorDesc IO a) -> ConfigEnv IO a+withAuth action = do+  conf <- S.get -  header <- tryIO . buildRequest $ do-    http POST ("/" <> loginPage conf)-    defaultRequest-    setContentType "application/x-www-form-urlencoded"+  EitherT . S.liftIO . WS.withSession $ \sess -> runEitherT $ do+    let formData = [("token" :: B.ByteString, apiKey conf),+                    ("user", user conf),+                    ("script", "true")]+        url      = buildURL (host conf) (loginPage conf) -  let formData = [("token", apiKey conf), ("user", user conf), ("script", "true")] -  conn <- S.get-  tryIO . sendRequest conn header $ encodedFormBody formData+    reply <- tryIO $ WS.postWith defaultOpts sess url formData+    let response = B.concat . BL.toChunks $ reply ^. W.responseBody -  (headers, response) <- tryIO $ receiveResponse conn (\headers stream -> do-    response <- readExactly (B.length loginSuccess) stream-    return (headers, response))+    tryAssert ("Login failure. Server returned: '" <> response <> "'")+      (response == loginSuccess) -  tryAssert ("Login failure. Server returned: '" <> response <> "'")-    (response == loginSuccess)-    -  noteT "Failed to parse login cookie" . hoistMaybe $ -    getHeader headers "Set-Cookie" >>= extractSessionHeader+    action sess  -- | Retrieve problem ID of a Kattis problem.-retrieveProblemId :: KattisProblem -> ConnEnv IO Integer+retrieveProblemId :: KattisProblem -> IO Integer retrieveProblemId (ProblemId id') = return id' retrieveProblemId (ProblemName _) = undefined  -- | Retrieve problem name of a Kattis problem.-retrieveProblemName :: KattisProblem -> ConnEnv IO B.ByteString+retrieveProblemName :: KattisProblem -> IO B.ByteString retrieveProblemName (ProblemId _) = undefined retrieveProblemName (ProblemName name) = return name

@@ -1,14 +1,14 @@ module Main where -import Control.Applicative ((<$>))-import Control.Monad-import Data.List (subsequences)-import Data.Monoid ((<>))-import System.Exit (exitFailure, exitSuccess)-import System.Directory (getDirectoryContents)-import System.IO-import Utils.Katt.SourceHandler-import Utils.Katt.Utils+import           Control.Applicative ((<$>))+import           Control.Monad (liftM2)+import           Data.List (subsequences)+import           Data.Monoid ((<>))+import           System.Exit (exitFailure, exitSuccess)+import           System.Directory (getDirectoryContents)+import           System.IO (hPutStrLn, stderr)+import           Utils.Katt.SourceHandler+import           Utils.Katt.Utils  main :: IO () main = do

@@ -1,5 +1,5 @@ name:                katt-version:             0.2.0.1+version:             0.2.0.3 stability:           experimental  synopsis:            Client for the Kattis judge system.@@ -29,17 +29,16 @@                      the official site, make sure you have the haskell platform                      installed, then run /cabal install katt/.                      .-                     Please note that the beta release is limited to C, C++ and Java.+                     Please note that the beta release is limited to C, C++, Java, and Haskell.                      It also only supports running on unix.                      .                      Changes since last release:                      .-                       * Fix issues related to to new keep-alive handling-                     .-                       * New test suite+                       * Support for Haskell submissions                      .-                       * Confirmed working with open kattis (www.kattis.com)+                       * HTTP client replaced with wreq                      .+                       * Improved code readability   homepage:            https://github.com/davnils/katt@@ -72,23 +71,23 @@    ghc-options:       -Wall +  -- lens 4.2 needs to handle https://github.com/ekmett/lens/issues/450   build-depends:     +                     aeson >= 0.7.0.6 && < 0.8,                      base >= 4.5 && < 4.7,                      bytestring >= 0.9.2.1 && < 0.11,-                     blaze-builder == 0.3.*,                      containers >= 0.4.2.1 && < 0.6,                      ConfigFile == 1.1.*,                      directory >= 1.1.0.2 && < 1.3,                      errors == 1.4.*,                      filepath == 1.3.*,-                     http-streams == 0.6.*,-                     HsOpenSSL == 0.10.*,-                     io-streams,+                     lens >= 4.1 && < 4.3,                      mtl >= 2.0 && < 2.2,-                     parsec == 3.1.*,-                     unix >= 2.5.1.0 && < 2.7,+                     parsec >= 3.1.5 && < 3.2,+                     text >= 0.11 && < 1.2,                      url == 2.1.*,-                     zip-archive == 0.1.*+                     wreq == 0.1.*,+                     zip-archive >= 0.1 && < 0.3  executable katt   hs-source-dirs:    katt-cli/src@@ -98,9 +97,6 @@   build-depends:                           base >= 4.5 && < 4.7,                      bytestring >= 0.9.2.1 && < 0.11,-                     containers >= 0.4.2.1 && < 0.6,-                     http-streams == 0.6.*,-                     HsOpenSSL == 0.10.*,                      katt,                      mtl >= 2.0 && < 2.2 @@ -114,8 +110,6 @@                      base >= 4.5 && < 4.7,                      bytestring >= 0.9.2.1 && < 0.11,                      directory >= 1.1.0.2 && < 1.3,-                     http-streams == 0.6.*,-                     HsOpenSSL == 0.10.*,                      katt,                      mtl >= 2.0 && < 2.2