gonito/Handler/Shared.hs

381 lines
13 KiB
Haskell
Raw Normal View History

2015-08-29 18:24:01 +02:00
{-# LANGUAGE RecordWildCards #-}
module Handler.Shared where
import Import
import Control.Concurrent.STM
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
2015-08-29 22:19:44 +02:00
import Network.URI
import qualified Data.Text as T
2015-09-04 10:51:53 +02:00
import Database.Persist.Sql (ConnectionPool, runSqlPool, fromSqlKey)
2015-08-29 22:19:44 +02:00
2015-08-30 12:33:47 +02:00
import Control.Concurrent.Lifted (fork, threadDelay)
2015-09-29 14:15:49 +02:00
import qualified Crypto.Hash.SHA1 as CHS
2018-01-25 16:34:05 +01:00
import qualified Data.List as DL
2015-08-30 12:33:47 +02:00
import System.Process
import System.Exit
2015-09-04 06:47:49 +02:00
import System.Random
2015-09-04 10:51:53 +02:00
import System.Directory (renameDirectory)
2015-09-04 06:47:49 +02:00
import PersistSHA1
2015-08-30 12:33:47 +02:00
import qualified Data.ByteString as BS
import Text.Printf
import Database.Persist.Sql
import Yesod.Form.Bootstrap3 (bfs)
2017-09-28 11:29:48 +02:00
import qualified Crypto.Nonce as Nonce
import System.IO.Unsafe (unsafePerformIO)
2015-08-29 18:24:01 +02:00
atom = Control.Concurrent.STM.atomically
type Channel = TChan (Maybe Text)
2016-01-08 21:57:29 +01:00
arena :: Handler FilePath
arena = do
app <- getYesod
return $ (appVarDir $ appSettings app) </> "arena"
2015-09-04 06:47:49 +02:00
gitPath :: FilePath
gitPath = "/usr/bin/git"
browsableGitSite :: Text
2017-09-23 10:33:39 +02:00
browsableGitSite = "https://gonito.net/gitlist/"
serverAddress :: Text
serverAddress = "gonito.net"
2016-02-15 11:43:47 +01:00
gitServer :: Text
gitServer = "ssh://gitolite@" ++ serverAddress ++ "/"
gitReadOnlyServer :: Text
gitReadOnlyServer = "git://" ++ serverAddress ++ "/"
getPublicSubmissionBranch :: SubmissionId -> Text
getPublicSubmissionBranch = T.pack . (printf "submission-%05d") . fromSqlKey
getPublicSubmissionUrl :: Text -> Text
getPublicSubmissionUrl bareRepoName = gitServer ++ bareRepoName
getReadOnlySubmissionUrl :: Text -> Text
getReadOnlySubmissionUrl bareRepoName = gitReadOnlyServer ++ bareRepoName
browsableGitRepoBranch :: Text -> Text -> Text
browsableGitRepoBranch bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/"
2016-02-15 11:43:47 +01:00
browsableGitRepo :: Text -> Text
browsableGitRepo bareRepoName
| ".git" `isSuffixOf` bareRepoName = browsableGitSite ++ bareRepoName
| otherwise = browsableGitSite ++ bareRepoName ++ ".git"
2017-09-28 11:29:48 +02:00
2015-08-30 12:33:47 +02:00
runViewProgress :: (Channel -> Handler ()) -> Handler TypedContent
2017-09-28 11:29:48 +02:00
runViewProgress = runViewProgress' ViewProgressR
runOpenViewProgress :: (Channel -> Handler ()) -> Handler TypedContent
runOpenViewProgress = runViewProgress' OpenViewProgressR
runViewProgress' :: (Int -> Route App) -> (Channel -> Handler ()) -> Handler TypedContent
runViewProgress' route action = do
2015-08-29 18:24:01 +02:00
App {..} <- getYesod
2015-09-04 06:47:49 +02:00
jobId <- randomInt
chan <- liftIO $ atom $ do
2015-08-29 18:24:01 +02:00
chan <- newBroadcastTChan
m <- readTVar jobs
writeTVar jobs $ IntMap.insert jobId chan m
2015-09-04 06:47:49 +02:00
return chan
2015-08-30 12:33:47 +02:00
fork $ do
liftIO $ threadDelay 1000000
2015-08-29 18:24:01 +02:00
action chan
2015-08-30 12:33:47 +02:00
liftIO $ atom $ do
2015-08-29 18:24:01 +02:00
writeTChan chan $ Just "All done\n"
writeTChan chan Nothing
m <- readTVar jobs
writeTVar jobs $ IntMap.delete jobId m
2017-09-28 11:29:48 +02:00
redirect $ route jobId
2015-08-29 18:24:01 +02:00
2015-08-30 12:33:47 +02:00
msg :: Channel -> Text -> Handler ()
msg chan m = liftIO $ atom $ writeTChan chan $ Just (m ++ "\n")
2015-08-29 22:19:44 +02:00
2015-08-30 12:33:47 +02:00
err :: Channel -> Text -> Handler ()
2015-08-29 22:19:44 +02:00
err = msg
2015-08-29 18:24:01 +02:00
2015-08-30 12:33:47 +02:00
raw :: Channel -> Text -> Handler ()
raw = msg
2015-08-29 22:19:44 +02:00
validGitProtocols :: [String]
validGitProtocols = ["git", "http", "https", "ssh"]
validGitProtocolsAsText :: Text
validGitProtocolsAsText = T.pack $ intercalate ", " $ map (++"://") validGitProtocols
cloneRepo :: Text -> Text -> Text -> Text -> Channel -> Handler (Maybe (Key Repo))
cloneRepo url branch referenceUrl referenceBranch chan = do
2015-08-30 12:33:47 +02:00
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
2015-08-29 22:19:44 +02:00
case maybeRepo of
Just _ -> do
err chan "Repo already there"
return Nothing
Nothing -> cloneRepo' url branch referenceUrl referenceBranch chan
2015-09-28 23:43:55 +02:00
updateRepo :: Key Repo -> Channel -> Handler Bool
updateRepo repoId chan = do
repo <- runDB $ get404 repoId
2016-01-08 21:57:29 +01:00
repoDir <- getRepoDir repoId
2016-02-11 22:25:07 +01:00
let branch = repoBranch repo
(exitCode, _) <- runProgram (Just repoDir) gitPath ["fetch",
"origin",
T.unpack branch,
"--progress"] chan
2015-09-28 23:43:55 +02:00
case exitCode of
ExitSuccess -> do
(exitCode, _) <- runProgram (Just repoDir) gitPath ["reset",
"--hard",
"FETCH_HEAD"] chan
case exitCode of
ExitSuccess -> do
maybeHeadCommit <- getHeadCommit repoDir chan
case maybeHeadCommit of
Just headCommit -> do
runDB $ update repoId [RepoCurrentCommit =. headCommit]
return True
Nothing -> return False
_ -> return False
_ -> return False
2015-09-28 23:43:55 +02:00
getHeadCommit :: FilePath -> Channel -> Handler (Maybe SHA1)
getHeadCommit repoDir chan = do
(exitCode, out) <- runProgram (Just repoDir) gitPath ["rev-parse", "HEAD"] chan
case exitCode of
ExitSuccess -> do
msg chan $ concat ["HEAD commit is ", commitId]
return $ Just commitRaw
where commitId = T.replace "\n" "" out
commitRaw = fromTextToSHA1 commitId
ExitFailure _ -> do
err chan "cannot determine HEAD commit"
return Nothing
getLastCommitMessage :: FilePath -> Channel -> Handler (Maybe Text)
getLastCommitMessage repoDir chan = do
(exitCode, out) <- runProgram (Just repoDir) gitPath ["log", "-1", "--pretty=%B"] chan
return $ case exitCode of
ExitSuccess -> Just out
ExitFailure _ -> Nothing
2015-11-11 09:50:32 +01:00
cloneRepo' :: Text -> Text -> Text -> Text -> Channel -> Handler (Maybe (Key Repo))
cloneRepo' url branch referenceUrl referenceBranch chan = do
2015-08-29 22:19:44 +02:00
msg chan $ concat ["Preparing to clone repo ", url]
if checkRepoUrl url
2015-08-30 12:33:47 +02:00
then do
msg chan "Cloning..."
2015-09-04 06:47:49 +02:00
r <- randomInt
2016-01-08 21:57:29 +01:00
arenaDir <- arena
let tmpRepoDir = arenaDir </> ("t" ++ show r)
2015-11-11 09:50:32 +01:00
exitCode <- rawClone tmpRepoDir url branch referenceUrl referenceBranch chan
2015-09-04 06:47:49 +02:00
case exitCode of
ExitSuccess -> do
2015-09-28 23:43:55 +02:00
maybeHeadCommit <- getHeadCommit tmpRepoDir chan
case maybeHeadCommit of
Just commitRaw -> do
2015-09-04 06:47:49 +02:00
userId <- requireAuthId
time <- liftIO getCurrentTime
repoId <- runDB $ insert $ Repo {
repoUrl=url,
repoBranch=branch,
2015-09-04 10:02:33 +02:00
repoCurrentCommit=commitRaw,
2015-09-04 06:47:49 +02:00
repoOwner=userId,
repoReady=True,
repoStamp=time }
2016-01-08 21:57:29 +01:00
repoDir <- getRepoDir repoId
2015-09-04 10:51:53 +02:00
liftIO $ renameDirectory tmpRepoDir repoDir
msg chan $ concat ["Repo is in ", (T.pack repoDir)]
2015-09-04 06:47:49 +02:00
return $ Just repoId
2015-09-28 23:43:55 +02:00
Nothing -> do
2015-09-04 06:47:49 +02:00
return Nothing
ExitFailure _ -> do
err chan "git failed"
return Nothing
2015-08-29 22:19:44 +02:00
else do
err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText]
return Nothing
2015-11-11 09:50:32 +01:00
rawClone :: FilePath -> Text -> Text -> Text -> Text -> Channel -> Handler (ExitCode)
rawClone tmpRepoDir url branch referenceUrl referenceBranch chan = do
(exitCode, _) <- runProgram Nothing gitPath ["clone",
"--progress",
"--branch",
T.unpack referenceBranch,
T.unpack referenceUrl,
tmpRepoDir] chan
if url /= referenceUrl || branch /= referenceBranch
then
do
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["remote",
"set-url",
"origin",
T.unpack url] chan
case exitCode of
ExitSuccess -> do
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["fetch",
"origin",
T.unpack branch] chan
case exitCode of
ExitSuccess -> do
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["reset",
"--hard",
"FETCH_HEAD"] chan
return exitCode
_ -> return exitCode
_ -> return exitCode
else
return exitCode
2015-09-28 23:43:55 +02:00
2016-01-08 21:57:29 +01:00
getRepoDir :: Key Repo -> Handler FilePath
getRepoDir repoId = do
arenaDir <- arena
return $ arenaDir </> ("r" ++ repoIdAsString)
where repoIdAsString = show $ fromSqlKey repoId
2015-09-04 10:51:53 +02:00
2015-08-29 22:19:44 +02:00
checkRepoUrl :: Text -> Bool
checkRepoUrl url = case parsedURI of
Just uri -> (uriScheme uri) `elem` (map (++":") validGitProtocols)
Nothing -> False
where parsedURI = parseURI $ T.unpack url
2015-08-29 18:24:01 +02:00
2017-09-28 11:29:48 +02:00
getOpenViewProgressR :: Int -> Handler TypedContent
getOpenViewProgressR = getViewProgressR
2015-08-29 18:24:01 +02:00
getViewProgressR :: Int -> Handler TypedContent
getViewProgressR jobId = do
App {..} <- getYesod
mchan <- liftIO $ atom $ do
m <- readTVar jobs
case IntMap.lookup jobId m of
Nothing -> return Nothing
Just chan -> fmap Just $ dupTChan chan
case mchan of
Nothing -> notFound
Just chan -> respondSource typePlain $ do
let loop = do
mtext <- liftIO $ atom $ readTChan chan
case mtext of
Nothing -> return ()
Just text -> do
sendChunkText text
sendFlush
loop
loop
2015-08-30 12:33:47 +02:00
2015-09-04 06:47:49 +02:00
runProgram :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text)
runProgram workingDir programPath args chan = do
2015-08-30 13:11:34 +02:00
(_, Just hout, Just herr, pid) <-
2015-09-04 06:47:49 +02:00
liftIO $ createProcess (proc programPath args){ std_out = CreatePipe,
std_err = CreatePipe,
cwd = workingDir}
2015-08-30 13:11:34 +02:00
(code, out) <- gatherOutput pid hout herr chan
_ <- liftIO $ waitForProcess pid
2015-09-04 06:47:49 +02:00
return (code, out)
2015-08-30 12:33:47 +02:00
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
2015-08-30 13:11:34 +02:00
gatherOutput :: ProcessHandle -> Handle -> Handle -> Channel -> Handler (ExitCode, Text)
gatherOutput ph hout herr chan = work mempty mempty
2015-08-30 12:33:47 +02:00
where
2015-08-30 13:11:34 +02:00
work accout accerr = do
2015-08-30 12:33:47 +02:00
-- Read any outstanding input.
2015-08-30 13:11:34 +02:00
resterr <- takeABit herr accerr
restout <- takeABit hout accout
threadDelay 1000000
2015-08-30 12:33:47 +02:00
-- Check on the process.
2015-08-30 13:11:34 +02:00
s <- liftIO $ getProcessExitCode ph
2015-08-30 12:33:47 +02:00
-- Exit or loop.
case s of
2015-08-30 13:11:34 +02:00
Nothing -> work restout resterr
2015-08-30 12:33:47 +02:00
Just ec -> do
-- Get any last bit written between the read and the status
-- check.
2015-08-30 13:11:34 +02:00
_ <- 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
2015-09-04 06:47:49 +02:00
randomInt :: Handler Int
randomInt = liftIO $ randomIO
2015-09-29 14:15:49 +02:00
gatherSHA1ForCollectionOfFiles :: [FilePath] -> IO ByteString
gatherSHA1ForCollectionOfFiles files = do
contentss <- mapM readFile $ sort files
return $ CHS.finalize $ foldl' CHS.update CHS.init contentss
2016-05-03 08:46:10 +02:00
formatSubmitter :: User -> Text
formatSubmitter user = if userIsAnonymous user
then
"[anonymised]"
else
case userName user of
Just name -> name
Nothing -> "[name not given]"
fieldWithTooltip :: forall master msg msg1. (RenderMessage master msg, RenderMessage master msg1) => msg -> msg1 -> FieldSettings master
fieldWithTooltip name tooltip = (bfs name) { fsTooltip = Just $ SomeMessage tooltip }
2017-09-28 11:29:48 +02:00
nonceGen :: Nonce.Generator
nonceGen = unsafePerformIO Nonce.new
{-# NOINLINE nonceGen #-}
-- | Randomly create a new verification key.
newToken :: MonadIO m => m Text
newToken = Nonce.nonce128urlT nonceGen
2017-09-28 16:51:10 +02:00
enableTriggerToken _ (Just _) = return ()
enableTriggerToken userId Nothing = do
token <- newToken
runDB $ update userId [UserTriggerToken =. Just token]
2018-01-25 16:34:05 +01:00
getMainTest :: [Entity Test] -> Entity Test
getMainTest tests = DL.maximumBy (\(Entity _ a) (Entity _ b) -> ((testName a) `compare` (testName b))) tests
formatFullScore :: Maybe Evaluation -> Text
formatFullScore (Just evaluation) = fromMaybe "???" (T.pack <$> show <$> evaluationScore evaluation)
formatFullScore Nothing = "N/A"
formatTruncatedScore :: Maybe Int -> Maybe Evaluation -> Text
formatTruncatedScore Nothing e = formatFullScore e
formatTruncatedScore _ Nothing = formatFullScore Nothing
formatTruncatedScore (Just precision) (Just evaluation) = case evaluationScore evaluation of
Just score -> T.pack $ printf "%0.*f" precision score
Nothing -> formatFullScore Nothing