add handling VAR_DIR env variable

This commit is contained in:
Filip Gralinski 2016-01-08 21:57:29 +01:00
parent 15adf46d73
commit 0230b29db1
6 changed files with 33 additions and 21 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 {..}

View File

@ -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.