add challenge

This commit is contained in:
Filip Gralinski 2015-09-04 06:47:49 +02:00
parent f68371e7e8
commit d8a775a9ee
5 changed files with 99 additions and 24 deletions

2
.gitignore vendored
View File

@ -18,3 +18,5 @@ cabal.sandbox.config
*.swp *.swp
*.keter *.keter
*~ *~
arena/t-*
arena/r-*

View File

@ -25,7 +25,16 @@ postCreateChallengeR = do
_ -> Nothing _ -> Nothing
Just (name, publicUrl, publicBranch, privateUrl, privateBranch) = challengeData Just (name, publicUrl, publicBranch, privateUrl, privateBranch) = challengeData
runViewProgress $ doRepoCloning publicUrl publicBranch runViewProgress $ doCreateChallenge name publicUrl publicBranch privateUrl privateBranch
doCreateChallenge :: Text -> Text -> Text -> Text -> Text -> Channel -> Handler ()
doCreateChallenge name publicUrl publicBranch privateUrl privateBranch chan = do
maybePublicRepoId <- cloneRepo publicUrl publicBranch chan
case maybePublicRepoId of
Just publicRepoId -> do
maybePrivateRepoId <- cloneRepo privateUrl privateBranch chan
return ()
Nothing -> return ()
sampleForm :: Form (Text, Text, Text, Text, Text) sampleForm :: Form (Text, Text, Text, Text, Text)
sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,) sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,)

View File

@ -17,6 +17,9 @@ import Control.Concurrent.Lifted (fork, threadDelay)
import System.Process import System.Process
import System.Exit import System.Exit
import System.Random
import PersistSHA1
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
@ -24,16 +27,21 @@ atom = Control.Concurrent.STM.atomically
type Channel = TChan (Maybe Text) type Channel = TChan (Maybe Text)
arena :: FilePath
arena = "arena"
gitPath :: FilePath
gitPath = "/usr/bin/git"
runViewProgress :: (Channel -> Handler ()) -> Handler TypedContent runViewProgress :: (Channel -> Handler ()) -> Handler TypedContent
runViewProgress action = do runViewProgress action = do
App {..} <- getYesod App {..} <- getYesod
(jobId, chan) <- liftIO $ atom $ do jobId <- randomInt
jobId <- readTVar nextJob chan <- liftIO $ atom $ do
writeTVar nextJob $! jobId + 1
chan <- newBroadcastTChan chan <- newBroadcastTChan
m <- readTVar jobs m <- readTVar jobs
writeTVar jobs $ IntMap.insert jobId chan m writeTVar jobs $ IntMap.insert jobId chan m
return (jobId, chan) return chan
fork $ do fork $ do
liftIO $ threadDelay 1000000 liftIO $ threadDelay 1000000
action chan action chan
@ -53,14 +61,6 @@ err = msg
raw :: Channel -> Text -> Handler () raw :: Channel -> Text -> Handler ()
raw = msg raw = msg
doSomething :: Channel -> Handler ()
doSomething chan = do
msg chan "Did something"
threadDelay 1000000
msg chan "Did something else"
threadDelay 1000000
doRepoCloning :: Text -> Text -> Channel -> Handler () doRepoCloning :: Text -> Text -> Channel -> Handler ()
doRepoCloning url branch chan = do doRepoCloning url branch chan = do
msg chan "Did something" msg chan "Did something"
@ -73,7 +73,7 @@ validGitProtocols = ["git", "http", "https", "ssh"]
validGitProtocolsAsText :: Text validGitProtocolsAsText :: Text
validGitProtocolsAsText = T.pack $ intercalate ", " $ map (++"://") validGitProtocols validGitProtocolsAsText = T.pack $ intercalate ", " $ map (++"://") validGitProtocols
cloneRepo :: Text -> Text -> Channel -> Handler (Maybe Repo) cloneRepo :: Text -> Text -> Channel -> Handler (Maybe (Key Repo))
cloneRepo url branch chan = do cloneRepo url branch chan = do
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
case maybeRepo of case maybeRepo of
@ -85,14 +85,69 @@ cloneRepo url branch chan = do
if checkRepoUrl url if checkRepoUrl url
then do then do
msg chan "Cloning..." msg chan "Cloning..."
runProgram "/usr/bin/git" ["clone", r <- randomInt
let repoDir = arena </> ("t" ++ show r)
(exitCode, _) <- runProgram Nothing gitPath ["clone",
"--progress", "--progress",
T.unpack url] chan "--branch",
T.unpack branch,
T.unpack url,
repoDir] chan
case exitCode of
ExitSuccess -> do
(exitCode, out) <- runProgram (Just repoDir) gitPath ["rev-parse", "HEAD"] chan
case exitCode of
ExitSuccess -> do
msg chan $ concat ["HEAD commit is ", commitId]
userId <- requireAuthId
time <- liftIO getCurrentTime
repoId <- runDB $ insert $ Repo {
repoUrl=url,
repoBranch=branch,
repoCurrentCommit=(toSHA1 (encodeUtf8 commitId)),
repoOwner=userId,
repoReady=True,
repoStamp=time }
return $ Just repoId
where commitId = T.replace "\n" "" out
ExitFailure _ -> do
err chan "cannot determine HEAD commit"
return Nothing
ExitFailure _ -> do
err chan "git failed"
return Nothing return Nothing
else do else do
err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText] err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText]
return Nothing return Nothing
hexByteToWord8 :: Text -> Word8
hexByteToWord8 t = (hexNibbleToWord8 $ T.head t) * 16 + (hexNibbleToWord8 $ T.index t 1)
hexNibbleToWord8 :: Char -> Word8
hexNibbleToWord8 '0' = 0
hexNibbleToWord8 '1' = 1
hexNibbleToWord8 '2' = 2
hexNibbleToWord8 '3' = 3
hexNibbleToWord8 '4' = 4
hexNibbleToWord8 '5' = 5
hexNibbleToWord8 '6' = 6
hexNibbleToWord8 '7' = 7
hexNibbleToWord8 '8' = 8
hexNibbleToWord8 '9' = 9
hexNibbleToWord8 'A' = 10
hexNibbleToWord8 'a' = 10
hexNibbleToWord8 'B' = 11
hexNibbleToWord8 'b' = 11
hexNibbleToWord8 'C' = 12
hexNibbleToWord8 'c' = 12
hexNibbleToWord8 'D' = 13
hexNibbleToWord8 'd' = 13
hexNibbleToWord8 'E' = 14
hexNibbleToWord8 'e' = 14
hexNibbleToWord8 'F' = 15
hexNibbleToWord8 'f' = 15
checkRepoUrl :: Text -> Bool checkRepoUrl :: Text -> Bool
checkRepoUrl url = case parsedURI of checkRepoUrl url = case parsedURI of
Just uri -> (uriScheme uri) `elem` (map (++":") validGitProtocols) Just uri -> (uriScheme uri) `elem` (map (++":") validGitProtocols)
@ -120,13 +175,15 @@ getViewProgressR jobId = do
loop loop
loop loop
runProgram :: FilePath -> [String] -> Channel -> Handler () runProgram :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text)
runProgram programPath args chan = do runProgram workingDir programPath args chan = do
(_, Just hout, Just herr, pid) <- (_, Just hout, Just herr, pid) <-
liftIO $ createProcess (proc programPath args){ std_out = CreatePipe, std_err = CreatePipe } liftIO $ createProcess (proc programPath args){ std_out = CreatePipe,
std_err = CreatePipe,
cwd = workingDir}
(code, out) <- gatherOutput pid hout herr chan (code, out) <- gatherOutput pid hout herr chan
_ <- liftIO $ waitForProcess pid _ <- liftIO $ waitForProcess pid
return () return (code, out)
processOutput :: Text -> ([Text], Text) processOutput :: Text -> ([Text], Text)
@ -170,3 +227,6 @@ gatherOutput ph hout herr chan = work mempty mempty
let all = rest <> (decodeUtf8 last) let all = rest <> (decodeUtf8 last)
mapM_ (msg chan) $ lines all mapM_ (msg chan) $ lines all
return all return all
randomInt :: Handler Int
randomInt = liftIO $ randomIO

View File

@ -11,12 +11,15 @@ data SHA1 = SHA1 ByteString
deriving Show deriving Show
toHex :: ByteString -> ByteString toHex :: ByteString -> ByteString
toHex = BC.pack . concat . (map (flip showHex "")) . B.unpack toHex = BC.pack . concat . (map ("\\x"++)) . (map (flip showHex "")) . B.unpack
toSHA1 :: ByteString -> SHA1
toSHA1 x = SHA1 $ B.concat ["E'\\\\x", x, "'"]
instance PersistField SHA1 where instance PersistField SHA1 where
toPersistValue (SHA1 t) = PersistDbSpecific t toPersistValue (SHA1 t) = PersistDbSpecific t
fromPersistValue (PersistDbSpecific t) = Right $ SHA1 $ B.concat ["E'\\x", toHex(t), "'"] fromPersistValue (PersistDbSpecific t) = Right $ SHA1 t
fromPersistValue _ = Left "SHA1 values must be converted from PersistDbSpecific" fromPersistValue _ = Left "SHA1 values must be converted from PersistDbSpecific"
instance PersistFieldSql SHA1 where instance PersistFieldSql SHA1 where

View File

@ -93,6 +93,7 @@ library
, network-uri , network-uri
, lifted-base , lifted-base
, process , process
, random
executable gonito executable gonito