From 0230b29db17f41e04bc92b0ed67b02e4287904c5 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Fri, 8 Jan 2016 21:57:29 +0100 Subject: [PATCH] add handling VAR_DIR env variable --- Foundation.hs | 4 ++-- Handler/CreateChallenge.hs | 10 ++++++---- Handler/Shared.hs | 21 +++++++++++++-------- Handler/ShowChallenge.hs | 16 +++++++++------- Settings.hs | 2 ++ config/settings.yml | 1 + 6 files changed, 33 insertions(+), 21 deletions(-) diff --git a/Foundation.hs b/Foundation.hs index 2a38265..fbf4738 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -76,9 +76,9 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes - makeSessionBackend _ = Just <$> defaultClientSessionBackend + makeSessionBackend app = Just <$> defaultClientSessionBackend 120 -- timeout in minutes - "config/client_session_key.aes" + ((appVarDir $ appSettings app) "config/client_session_key.aes") defaultLayout widget = do master <- getYesod diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index 414907a..979ce6d 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -50,7 +50,8 @@ doCreateChallenge name publicUrl publicBranch privateUrl privateBranch chan = do case maybePublicRepoId of Just publicRepoId -> do publicRepo <- runDB $ get404 publicRepoId - maybePrivateRepoId <- cloneRepo privateUrl privateBranch (T.pack $ getRepoDir publicRepoId) (repoBranch publicRepo) chan + publicRepoDir <- getRepoDir publicRepoId + maybePrivateRepoId <- cloneRepo privateUrl privateBranch (T.pack $ publicRepoDir) (repoBranch publicRepo) chan case maybePrivateRepoId of Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan Nothing -> return () @@ -59,7 +60,7 @@ doCreateChallenge name publicUrl publicBranch privateUrl privateBranch chan = do addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler () addChallenge name publicRepoId privateRepoId chan = do msg chan "adding challenge..." - let publicRepoDir = getRepoDir publicRepoId + publicRepoDir <- getRepoDir publicRepoId let readmeFilePath = publicRepoDir readmeFile doesReadmeExist <- liftIO $ doesFileExist readmeFilePath (title, description) <- if doesReadmeExist @@ -83,7 +84,7 @@ updateTests :: (Key Challenge) -> Channel -> Handler () updateTests challengeId chan = do challenge <- runDB $ get404 challengeId let repoId = challengePrivateRepo challenge - let repoDir = getRepoDir repoId + repoDir <- getRepoDir repoId repo <- runDB $ get404 repoId let commit = repoCurrentCommit repo testDirs <- liftIO $ findTestDirs repoDir @@ -103,8 +104,9 @@ checkTestDir chan challengeId challenge commit testDir = do then do msg chan $ concat ["Test dir ", (T.pack testDir), " found."] checksum <- liftIO $ gatherSHA1 testDir + challengeRepoDir <- getRepoDir $ challengePrivateRepo challenge optionsParsingResult <- liftIO $ getOptions [ - "--expected-directory", (getRepoDir $ challengePrivateRepo challenge), + "--expected-directory", challengeRepoDir, "--test-name", takeFileName testDir] case optionsParsingResult of Left evalException -> do diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 6210717..4e9af57 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -31,8 +31,10 @@ atom = Control.Concurrent.STM.atomically type Channel = TChan (Maybe Text) -arena :: FilePath -arena = "arena" +arena :: Handler FilePath +arena = do + app <- getYesod + return $ (appVarDir $ appSettings app) "arena" gitPath :: FilePath gitPath = "/usr/bin/git" @@ -83,7 +85,7 @@ cloneRepo url branch referenceUrl referenceBranch chan = do updateRepo :: Key Repo -> Channel -> Handler Bool updateRepo repoId chan = do repo <- runDB $ get404 repoId - let repoDir = getRepoDir repoId + repoDir <- getRepoDir repoId (exitCode, _) <- runProgram (Just repoDir) gitPath ["fetch", "--progress"] chan case exitCode of ExitSuccess -> do @@ -121,7 +123,8 @@ cloneRepo' url branch referenceUrl referenceBranch chan = do then do msg chan "Cloning..." r <- randomInt - let tmpRepoDir = arena ("t" ++ show r) + arenaDir <- arena + let tmpRepoDir = arenaDir ("t" ++ show r) exitCode <- rawClone tmpRepoDir url branch referenceUrl referenceBranch chan case exitCode of ExitSuccess -> do @@ -137,7 +140,7 @@ cloneRepo' url branch referenceUrl referenceBranch chan = do repoOwner=userId, repoReady=True, repoStamp=time } - let repoDir = getRepoDir repoId + repoDir <- getRepoDir repoId liftIO $ renameDirectory tmpRepoDir repoDir msg chan $ concat ["Repo is in ", (T.pack repoDir)] return $ Just repoId @@ -182,9 +185,11 @@ rawClone tmpRepoDir url branch referenceUrl referenceBranch chan = do else return exitCode -getRepoDir :: Key Repo -> FilePath -getRepoDir repoId = arena ("r" ++ repoIdAsString) - where repoIdAsString = show $ fromSqlKey repoId +getRepoDir :: Key Repo -> Handler FilePath +getRepoDir repoId = do + arenaDir <- arena + return $ arenaDir ("r" ++ repoIdAsString) + where repoIdAsString = show $ fromSqlKey repoId checkRepoUrl :: Text -> Bool checkRepoUrl url = case parsedURI of diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index fd8f061..f41ec8d 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -40,7 +40,7 @@ getChallengeReadmeR :: Text -> Handler Html getChallengeReadmeR name = do (Entity _ challenge) <- runDB $ getBy404 $ UniqueName name let repoId = challengePublicRepo challenge - let repoDir = getRepoDir repoId + repoDir <- getRepoDir repoId let readmeFilePath = repoDir readmeFile contents <- readFile readmeFilePath challengeLayout False challenge $ toWidget $ markdown def $ TL.fromStrict contents @@ -118,7 +118,7 @@ getOuts :: Channel -> Key Submission -> Handler ([Out]) getOuts chan submissionId = do submission <- runDB $ get404 submissionId let challengeId = submissionChallenge submission - let repoDir = getRepoDir $ submissionRepo submission + repoDir <- getRepoDir $ submissionRepo submission activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] [] testsDone <- filterM (doesOutExist repoDir) activeTests outs <- mapM (outForTest repoDir submissionId) testsDone @@ -156,7 +156,8 @@ checkOrInsertEvaluation repoDir chan out = do msg chan $ concat ["Already evaluated with score ", (T.pack $ fromMaybe "???" $ show <$> evaluationScore evaluation)] Nothing -> do msg chan $ "Start evaluation..." - resultOrException <- liftIO $ rawEval challenge repoDir (testName test) + challengeDir <- getRepoDir $ challengePrivateRepo challenge + resultOrException <- liftIO $ rawEval challengeDir repoDir (testName test) case resultOrException of Right (Left parseResult) -> do err chan "Cannot parse options, check the challenge repo" @@ -175,9 +176,9 @@ checkOrInsertEvaluation repoDir chan out = do Left exception -> do err chan $ "Evaluation failed: " ++ (T.pack $ show exception) -rawEval :: Challenge -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue))) -rawEval challenge repoDir name = try (runGEvalGetOptions [ - "--expected-directory", (getRepoDir $ challengePrivateRepo challenge), +rawEval :: FilePath -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue))) +rawEval challengeDir repoDir name = try (runGEvalGetOptions [ + "--expected-directory", challengeDir, "--out-directory", repoDir, "--test-name", (T.unpack name)]) @@ -203,7 +204,8 @@ getSubmissionRepo challengeId url branch chan = do challenge <- runDB $ get404 challengeId let repoId = challengePublicRepo challenge repo <- runDB $ get404 repoId - cloneRepo' url branch (T.pack $ getRepoDir repoId) (repoBranch repo) chan + repoDir <- getRepoDir repoId + cloneRepo' url branch (T.pack repoDir) (repoBranch repo) chan checkRepoAvailibility :: Key Challenge -> Key Repo -> Channel -> Handler Bool checkRepoAvailibility challengeId repoId chan = do diff --git a/Settings.hs b/Settings.hs index e3d309e..853ea14 100644 --- a/Settings.hs +++ b/Settings.hs @@ -53,6 +53,7 @@ data AppSettings = AppSettings -- ^ Copyright text to appear in the footer of the page , appAnalytics :: Maybe Text -- ^ Google Analytics code + , appVarDir :: String } instance FromJSON AppSettings where @@ -78,6 +79,7 @@ instance FromJSON AppSettings where appCopyright <- o .: "copyright" appAnalytics <- o .:? "analytics" + appVarDir <- o .: "var-dir" return AppSettings {..} diff --git a/config/settings.yml b/config/settings.yml index 480fad5..9708c22 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -6,6 +6,7 @@ host: "_env:HOST:*4" # any IPv4 host port: "_env:PORT:3000" approot: "_env:APPROOT:http://localhost:3000" ip-from-header: "_env:IP_FROM_HEADER:false" +var-dir: "_env:VAR_DIR:." # Optional values with the following production defaults. # In development, they default to the inverse.