327 lines
11 KiB
Haskell
327 lines
11 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Handler.Shared where
|
|
|
|
import Import
|
|
|
|
import Control.Concurrent.STM
|
|
import Data.IntMap (IntMap)
|
|
import qualified Data.IntMap as IntMap
|
|
|
|
import Network.URI
|
|
import qualified Data.Text as T
|
|
|
|
import Database.Persist.Sql (ConnectionPool, runSqlPool, fromSqlKey)
|
|
|
|
import Control.Concurrent.Lifted (fork, threadDelay)
|
|
|
|
import qualified Crypto.Hash.SHA1 as CHS
|
|
|
|
import System.Process
|
|
import System.Exit
|
|
import System.Random
|
|
|
|
import System.Directory (renameDirectory)
|
|
|
|
import PersistSHA1
|
|
|
|
import qualified Data.ByteString as BS
|
|
|
|
import Text.Printf
|
|
import Database.Persist.Sql
|
|
|
|
atom = Control.Concurrent.STM.atomically
|
|
|
|
type Channel = TChan (Maybe Text)
|
|
|
|
arena :: Handler FilePath
|
|
arena = do
|
|
app <- getYesod
|
|
return $ (appVarDir $ appSettings app) </> "arena"
|
|
|
|
gitPath :: FilePath
|
|
gitPath = "/usr/bin/git"
|
|
|
|
browsableGitSite :: Text
|
|
browsableGitSite = "http://gonito.net/gitlist/"
|
|
|
|
serverAddress :: Text
|
|
serverAddress = "gonito.net"
|
|
|
|
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 ++ "/"
|
|
|
|
browsableGitRepo :: Text -> Text
|
|
browsableGitRepo bareRepoName
|
|
| ".git" `isSuffixOf` bareRepoName = browsableGitSite ++ bareRepoName
|
|
| otherwise = browsableGitSite ++ bareRepoName ++ ".git"
|
|
|
|
runViewProgress :: (Channel -> Handler ()) -> Handler TypedContent
|
|
runViewProgress action = do
|
|
App {..} <- getYesod
|
|
jobId <- randomInt
|
|
chan <- liftIO $ atom $ do
|
|
chan <- newBroadcastTChan
|
|
m <- readTVar jobs
|
|
writeTVar jobs $ IntMap.insert jobId chan m
|
|
return chan
|
|
fork $ do
|
|
liftIO $ threadDelay 1000000
|
|
action chan
|
|
liftIO $ atom $ do
|
|
writeTChan chan $ Just "All done\n"
|
|
writeTChan chan Nothing
|
|
m <- readTVar jobs
|
|
writeTVar jobs $ IntMap.delete jobId m
|
|
redirect $ ViewProgressR 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"]
|
|
|
|
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
|
|
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
|
|
case maybeRepo of
|
|
Just _ -> do
|
|
err chan "Repo already there"
|
|
return Nothing
|
|
Nothing -> cloneRepo' url branch referenceUrl referenceBranch chan
|
|
|
|
updateRepo :: Key Repo -> Channel -> Handler Bool
|
|
updateRepo repoId chan = do
|
|
repo <- runDB $ get404 repoId
|
|
repoDir <- getRepoDir repoId
|
|
let branch = repoBranch repo
|
|
(exitCode, _) <- runProgram (Just repoDir) gitPath ["fetch",
|
|
"origin",
|
|
T.unpack branch,
|
|
"--progress"] chan
|
|
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
|
|
|
|
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
|
|
|
|
cloneRepo' :: Text -> Text -> Text -> Text -> Channel -> Handler (Maybe (Key Repo))
|
|
cloneRepo' url branch referenceUrl referenceBranch chan = do
|
|
msg chan $ concat ["Preparing to clone repo ", url]
|
|
if checkRepoUrl url
|
|
then do
|
|
msg chan "Cloning..."
|
|
r <- randomInt
|
|
arenaDir <- arena
|
|
let tmpRepoDir = arenaDir </> ("t" ++ show r)
|
|
exitCode <- rawClone tmpRepoDir url branch referenceUrl referenceBranch chan
|
|
case exitCode of
|
|
ExitSuccess -> do
|
|
maybeHeadCommit <- getHeadCommit tmpRepoDir chan
|
|
case maybeHeadCommit of
|
|
Just commitRaw -> do
|
|
userId <- requireAuthId
|
|
time <- liftIO getCurrentTime
|
|
repoId <- runDB $ insert $ Repo {
|
|
repoUrl=url,
|
|
repoBranch=branch,
|
|
repoCurrentCommit=commitRaw,
|
|
repoOwner=userId,
|
|
repoReady=True,
|
|
repoStamp=time }
|
|
repoDir <- getRepoDir repoId
|
|
liftIO $ renameDirectory tmpRepoDir repoDir
|
|
msg chan $ concat ["Repo is in ", (T.pack repoDir)]
|
|
return $ Just repoId
|
|
Nothing -> do
|
|
return Nothing
|
|
ExitFailure _ -> do
|
|
err chan "git failed"
|
|
return Nothing
|
|
else do
|
|
err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText]
|
|
return Nothing
|
|
|
|
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
|
|
|
|
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
|
|
Just uri -> (uriScheme uri) `elem` (map (++":") validGitProtocols)
|
|
Nothing -> False
|
|
where parsedURI = parseURI $ T.unpack url
|
|
|
|
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
|
|
|
|
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
|
|
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
|
|
|
|
gatherSHA1ForCollectionOfFiles :: [FilePath] -> IO ByteString
|
|
gatherSHA1ForCollectionOfFiles files = do
|
|
contentss <- mapM readFile $ sort files
|
|
return $ CHS.finalize $ foldl' CHS.update CHS.init contentss
|
|
|
|
formatSubmitter :: User -> Text
|
|
formatSubmitter user = if userIsAnonymous user
|
|
then
|
|
"[anonymised]"
|
|
else
|
|
case userName user of
|
|
Just name -> name
|
|
Nothing -> "[name not given]"
|