From edf0624b959ce6ed88aac8eb5fc94be1a74aea27 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Tue, 5 Jun 2018 08:22:51 +0200 Subject: [PATCH] refactor running stuff --- Handler/CreateChallenge.hs | 1 + Handler/MakePublic.hs | 2 ++ Handler/Runner.hs | 73 ++++++++++++++++++++++++++++++++++++++ Handler/Shared.hs | 71 ++---------------------------------- Handler/ShowChallenge.hs | 1 + gonito.cabal | 1 + 6 files changed, 81 insertions(+), 68 deletions(-) create mode 100644 Handler/Runner.hs diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index db73cfe..9608e0e 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -5,6 +5,7 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, withSmallInput) import Handler.Shared +import Handler.Runner import Handler.Extract import GEval.Core diff --git a/Handler/MakePublic.hs b/Handler/MakePublic.hs index d08507e..8e92b96 100644 --- a/Handler/MakePublic.hs +++ b/Handler/MakePublic.hs @@ -8,6 +8,8 @@ import PersistSHA1 import Data.Text as T +import Handler.Runner + getMakePublicR :: SubmissionId -> Handler TypedContent getMakePublicR submissionId = runViewProgress $ doMakePublic submissionId diff --git a/Handler/Runner.hs b/Handler/Runner.hs new file mode 100644 index 0000000..ecb4544 --- /dev/null +++ b/Handler/Runner.hs @@ -0,0 +1,73 @@ + +module Handler.Runner where + +import Import +import System.Process +import System.Exit +import Control.Concurrent.STM +import Control.Concurrent.Lifted (threadDelay) +import qualified Data.ByteString as BS + +type Channel = TChan (Maybe Text) + +runProgram :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text) +runProgram workingDir programPath args chan = do + (_, Just hout, Just herr, pid) <- + liftIO $ createProcess (proc programPath args){ std_out = CreatePipe, + std_err = CreatePipe, + cwd = workingDir} + (code, out) <- gatherOutput pid hout herr chan + _ <- liftIO $ waitForProcess pid + return (code, out) + +gatherOutput :: ProcessHandle -> Handle -> Handle -> Channel -> Handler (ExitCode, Text) +gatherOutput ph hout herr chan = work mempty mempty + where + work accout accerr = do + -- Read any outstanding input. + resterr <- takeABit herr accerr + restout <- takeABit hout accout + liftIO $ threadDelay 1000000 + -- Check on the process. + s <- liftIO $ getProcessExitCode ph + -- Exit or loop. + case s of + Nothing -> work restout resterr + Just ec -> do + -- Get any last bit written between the read and the status + -- check. + _ <- takeFinalBit herr resterr + all <- takeFinalBit hout restout + return (ec, all) + takeABit h acc = do + bs <- liftIO $ BS.hGetNonBlocking hout (64 * 1024) + let acc' = acc <> (decodeUtf8 bs) + let (fullLines, rest) = processOutput acc' + mapM_ (msg chan) fullLines + return rest + takeFinalBit h rest = do + last <- liftIO $ BS.hGetContents h + let all = rest <> (decodeUtf8 last) + mapM_ (msg chan) $ lines all + return all + +msg :: Channel -> Text -> Handler () +msg chan m = liftIO $ atom $ writeTChan chan $ Just (m ++ "\n") + +err :: Channel -> Text -> Handler () +err = msg + +raw :: Channel -> Text -> Handler () +raw = msg + +atom = Control.Concurrent.STM.atomically + +processOutput :: Text -> ([Text], Text) +processOutput = processOutput' . lines + where processOutput' [] = ([], "") + processOutput' out = (init out, last out) + init [] = [] + init [x] = [] + init (x:xs) = (x:(init xs)) + last [x] = x + last (_:xs) = last xs diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 904f01f..9f42c19 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -4,10 +4,12 @@ module Handler.Shared where import Import -import Control.Concurrent.STM import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import Handler.Runner +import System.Exit + import Network.URI import qualified Data.Text as T @@ -20,8 +22,6 @@ import qualified Crypto.Hash.SHA1 as CHS import qualified Data.List as DL -import System.Process -import System.Exit import System.Random import System.Directory (renameDirectory) @@ -38,10 +38,6 @@ import Yesod.Form.Bootstrap3 (bfs) import qualified Crypto.Nonce as Nonce import System.IO.Unsafe (unsafePerformIO) -atom = Control.Concurrent.STM.atomically - -type Channel = TChan (Maybe Text) - arena :: Handler FilePath arena = do app <- getYesod @@ -107,15 +103,6 @@ runViewProgress' route action = do writeTVar jobs $ IntMap.delete jobId m redirect $ route jobId -msg :: Channel -> Text -> Handler () -msg chan m = liftIO $ atom $ writeTChan chan $ Just (m ++ "\n") - -err :: Channel -> Text -> Handler () -err = msg - -raw :: Channel -> Text -> Handler () -raw = msg - validGitProtocols :: [String] validGitProtocols = ["git", "http", "https", "ssh"] @@ -300,58 +287,6 @@ getViewProgressR jobId = do loop loop -runProgram :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text) -runProgram workingDir programPath args chan = do - (_, Just hout, Just herr, pid) <- - liftIO $ createProcess (proc programPath args){ std_out = CreatePipe, - std_err = CreatePipe, - cwd = workingDir} - (code, out) <- gatherOutput pid hout herr chan - _ <- liftIO $ waitForProcess pid - return (code, out) - - -processOutput :: Text -> ([Text], Text) -processOutput = processOutput' . lines - where processOutput' [] = ([], "") - processOutput' out = (init out, last out) - init [] = [] - init [x] = [] - init (x:xs) = (x:(init xs)) - last [x] = x - last (_:xs) = last xs - - -gatherOutput :: ProcessHandle -> Handle -> Handle -> Channel -> Handler (ExitCode, Text) -gatherOutput ph hout herr chan = work mempty mempty - where - work accout accerr = do - -- Read any outstanding input. - resterr <- takeABit herr accerr - restout <- takeABit hout accout - liftIO $ threadDelay 1000000 - -- Check on the process. - s <- liftIO $ getProcessExitCode ph - -- Exit or loop. - case s of - Nothing -> work restout resterr - Just ec -> do - -- Get any last bit written between the read and the status - -- check. - _ <- takeFinalBit herr resterr - all <- takeFinalBit hout restout - return (ec, all) - takeABit h acc = do - bs <- liftIO $ BS.hGetNonBlocking hout (64 * 1024) - let acc' = acc <> (decodeUtf8 bs) - let (fullLines, rest) = processOutput acc' - mapM_ (msg chan) fullLines - return rest - takeFinalBit h rest = do - last <- liftIO $ BS.hGetContents h - let all = rest <> (decodeUtf8 last) - mapM_ (msg chan) $ lines all - return all randomInt :: Handler Int randomInt = liftIO $ randomIO diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 8c428f2..1eefcd3 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -16,6 +16,7 @@ import qualified Yesod.Table as Table import Handler.Extract import Handler.Shared +import Handler.Runner import Handler.Tables import Handler.TagUtils diff --git a/gonito.cabal b/gonito.cabal index 90aa0c6..97ac36b 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -51,6 +51,7 @@ library Handler.Score Handler.AchievementUtils Handler.ExtraPoints + Handler.Runner if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT