filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

add handling VAR_DIR env variable

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Foundation.hs
View File

@ -76,9 +76,9 @@ instance Yesod App where
-- Store session data on the client in encrypted cookies, -- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes -- default session idle timeout is 120 minutes
makeSessionBackend _ = Just <$> defaultClientSessionBackend makeSessionBackend app = Just <$> defaultClientSessionBackend
120 -- timeout in minutes 120 -- timeout in minutes
"config/client_session_key.aes" ((appVarDir $ appSettings app) </> "config/client_session_key.aes")
defaultLayout widget = do defaultLayout widget = do
master <- getYesod master <- getYesod

10
Handler/CreateChallenge.hs
View File

@ -50,7 +50,8 @@ doCreateChallenge name publicUrl publicBranch privateUrl privateBranch chan = do
case maybePublicRepoId of case maybePublicRepoId of
Just publicRepoId -> do Just publicRepoId -> do
publicRepo <- runDB $ get404 publicRepoId 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 case maybePrivateRepoId of
Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan
Nothing -> return () Nothing -> return ()
@ -59,7 +60,7 @@ doCreateChallenge name publicUrl publicBranch privateUrl privateBranch chan = do
addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler () addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler ()
addChallenge name publicRepoId privateRepoId chan = do addChallenge name publicRepoId privateRepoId chan = do
msg chan "adding challenge..." msg chan "adding challenge..."
let publicRepoDir = getRepoDir publicRepoId publicRepoDir <- getRepoDir publicRepoId
let readmeFilePath = publicRepoDir </> readmeFile let readmeFilePath = publicRepoDir </> readmeFile
doesReadmeExist <- liftIO $ doesFileExist readmeFilePath doesReadmeExist <- liftIO $ doesFileExist readmeFilePath
(title, description) <- if doesReadmeExist (title, description) <- if doesReadmeExist
@ -83,7 +84,7 @@ updateTests :: (Key Challenge) -> Channel -> Handler ()
updateTests challengeId chan = do updateTests challengeId chan = do
challenge <- runDB $ get404 challengeId challenge <- runDB $ get404 challengeId
let repoId = challengePrivateRepo challenge let repoId = challengePrivateRepo challenge
let repoDir = getRepoDir repoId repoDir <- getRepoDir repoId
repo <- runDB $ get404 repoId repo <- runDB $ get404 repoId
let commit = repoCurrentCommit repo let commit = repoCurrentCommit repo
testDirs <- liftIO $ findTestDirs repoDir testDirs <- liftIO $ findTestDirs repoDir
@ -103,8 +104,9 @@ checkTestDir chan challengeId challenge commit testDir = do
then do then do
msg chan $ concat ["Test dir ", (T.pack testDir), " found."] msg chan $ concat ["Test dir ", (T.pack testDir), " found."]
checksum <- liftIO $ gatherSHA1 testDir checksum <- liftIO $ gatherSHA1 testDir
challengeRepoDir <- getRepoDir $ challengePrivateRepo challenge
optionsParsingResult <- liftIO $ getOptions [ optionsParsingResult <- liftIO $ getOptions [
"--expected-directory", (getRepoDir $ challengePrivateRepo challenge), "--expected-directory", challengeRepoDir,
"--test-name", takeFileName testDir] "--test-name", takeFileName testDir]
case optionsParsingResult of case optionsParsingResult of
Left evalException -> do Left evalException -> do

19
Handler/Shared.hs
View File

@ -31,8 +31,10 @@ atom = Control.Concurrent.STM.atomically
type Channel = TChan (Maybe Text) type Channel = TChan (Maybe Text)
arena :: FilePath arena :: Handler FilePath
arena = "arena" arena = do
app <- getYesod
return $ (appVarDir $ appSettings app) </> "arena"
gitPath :: FilePath gitPath :: FilePath
gitPath = "/usr/bin/git" gitPath = "/usr/bin/git"
@ -83,7 +85,7 @@ cloneRepo url branch referenceUrl referenceBranch chan = do
updateRepo :: Key Repo -> Channel -> Handler Bool updateRepo :: Key Repo -> Channel -> Handler Bool
updateRepo repoId chan = do updateRepo repoId chan = do
repo <- runDB $ get404 repoId repo <- runDB $ get404 repoId
let repoDir = getRepoDir repoId repoDir <- getRepoDir repoId
(exitCode, _) <- runProgram (Just repoDir) gitPath ["fetch", "--progress"] chan (exitCode, _) <- runProgram (Just repoDir) gitPath ["fetch", "--progress"] chan
case exitCode of case exitCode of
ExitSuccess -> do ExitSuccess -> do
@ -121,7 +123,8 @@ cloneRepo' url branch referenceUrl referenceBranch chan = do
then do then do
msg chan "Cloning..." msg chan "Cloning..."
r <- randomInt r <- randomInt
let tmpRepoDir = arena </> ("t" ++ show r) arenaDir <- arena
let tmpRepoDir = arenaDir </> ("t" ++ show r)
exitCode <- rawClone tmpRepoDir url branch referenceUrl referenceBranch chan exitCode <- rawClone tmpRepoDir url branch referenceUrl referenceBranch chan
case exitCode of case exitCode of
ExitSuccess -> do ExitSuccess -> do
@ -137,7 +140,7 @@ cloneRepo' url branch referenceUrl referenceBranch chan = do
repoOwner=userId, repoOwner=userId,
repoReady=True, repoReady=True,
repoStamp=time } repoStamp=time }
let repoDir = getRepoDir repoId repoDir <- getRepoDir repoId
liftIO $ renameDirectory tmpRepoDir repoDir liftIO $ renameDirectory tmpRepoDir repoDir
msg chan $ concat ["Repo is in ", (T.pack repoDir)] msg chan $ concat ["Repo is in ", (T.pack repoDir)]
return $ Just repoId return $ Just repoId
@ -182,8 +185,10 @@ rawClone tmpRepoDir url branch referenceUrl referenceBranch chan = do
else else
return exitCode return exitCode
getRepoDir :: Key Repo -> FilePath getRepoDir :: Key Repo -> Handler FilePath
getRepoDir repoId = arena </> ("r" ++ repoIdAsString) getRepoDir repoId = do
arenaDir <- arena
return $ arenaDir </> ("r" ++ repoIdAsString)
where repoIdAsString = show $ fromSqlKey repoId where repoIdAsString = show $ fromSqlKey repoId
checkRepoUrl :: Text -> Bool checkRepoUrl :: Text -> Bool

16
Handler/ShowChallenge.hs
View File

@ -40,7 +40,7 @@ getChallengeReadmeR :: Text -> Handler Html
getChallengeReadmeR name = do getChallengeReadmeR name = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name (Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
let repoId = challengePublicRepo challenge let repoId = challengePublicRepo challenge
let repoDir = getRepoDir repoId repoDir <- getRepoDir repoId
let readmeFilePath = repoDir </> readmeFile let readmeFilePath = repoDir </> readmeFile
contents <- readFile readmeFilePath contents <- readFile readmeFilePath
challengeLayout False challenge $ toWidget $ markdown def $ TL.fromStrict contents challengeLayout False challenge $ toWidget $ markdown def $ TL.fromStrict contents
@ -118,7 +118,7 @@ getOuts :: Channel -> Key Submission -> Handler ([Out])
getOuts chan submissionId = do getOuts chan submissionId = do
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
let challengeId = submissionChallenge submission let challengeId = submissionChallenge submission
let repoDir = getRepoDir $ submissionRepo submission repoDir <- getRepoDir $ submissionRepo submission
activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] [] activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
testsDone <- filterM (doesOutExist repoDir) activeTests testsDone <- filterM (doesOutExist repoDir) activeTests
outs <- mapM (outForTest repoDir submissionId) testsDone 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)] msg chan $ concat ["Already evaluated with score ", (T.pack $ fromMaybe "???" $ show <$> evaluationScore evaluation)]
Nothing -> do Nothing -> do
msg chan $ "Start evaluation..." 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 case resultOrException of
Right (Left parseResult) -> do Right (Left parseResult) -> do
err chan "Cannot parse options, check the challenge repo" err chan "Cannot parse options, check the challenge repo"
@ -175,9 +176,9 @@ checkOrInsertEvaluation repoDir chan out = do
Left exception -> do Left exception -> do
err chan $ "Evaluation failed: " ++ (T.pack $ show exception) err chan $ "Evaluation failed: " ++ (T.pack $ show exception)
rawEval :: Challenge -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue))) rawEval :: FilePath -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue)))
rawEval challenge repoDir name = try (runGEvalGetOptions [ rawEval challengeDir repoDir name = try (runGEvalGetOptions [
"--expected-directory", (getRepoDir $ challengePrivateRepo challenge), "--expected-directory", challengeDir,
"--out-directory", repoDir, "--out-directory", repoDir,
"--test-name", (T.unpack name)]) "--test-name", (T.unpack name)])
@ -203,7 +204,8 @@ getSubmissionRepo challengeId url branch chan = do
challenge <- runDB $ get404 challengeId challenge <- runDB $ get404 challengeId
let repoId = challengePublicRepo challenge let repoId = challengePublicRepo challenge
repo <- runDB $ get404 repoId 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 :: Key Challenge -> Key Repo -> Channel -> Handler Bool
checkRepoAvailibility challengeId repoId chan = do checkRepoAvailibility challengeId repoId chan = do

2
Settings.hs
View File

@ -53,6 +53,7 @@ data AppSettings = AppSettings
-- ^ Copyright text to appear in the footer of the page -- ^ Copyright text to appear in the footer of the page
, appAnalytics :: Maybe Text , appAnalytics :: Maybe Text
-- ^ Google Analytics code -- ^ Google Analytics code
, appVarDir :: String
} }
instance FromJSON AppSettings where instance FromJSON AppSettings where
@ -78,6 +79,7 @@ instance FromJSON AppSettings where
appCopyright <- o .: "copyright" appCopyright <- o .: "copyright"
appAnalytics <- o .:? "analytics" appAnalytics <- o .:? "analytics"
appVarDir <- o .: "var-dir"
return AppSettings {..} return AppSettings {..}

1
config/settings.yml
View File

@ -6,6 +6,7 @@ host: "_env:HOST:*4" # any IPv4 host
port: "_env:PORT:3000" port: "_env:PORT:3000"
approot: "_env:APPROOT:http://localhost:3000" approot: "_env:APPROOT:http://localhost:3000"
ip-from-header: "_env:IP_FROM_HEADER:false" ip-from-header: "_env:IP_FROM_HEADER:false"
var-dir: "_env:VAR_DIR:."
# Optional values with the following production defaults. # Optional values with the following production defaults.
# In development, they default to the inverse. # In development, they default to the inverse.