diff --git a/.gitignore b/.gitignore index 67bdd95..a1e6b00 100644 --- a/.gitignore +++ b/.gitignore @@ -18,3 +18,5 @@ cabal.sandbox.config *.swp *.keter *~ +arena/t-* +arena/r-* diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index e87c1ae..25f3b1a 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -25,7 +25,16 @@ postCreateChallengeR = do _ -> Nothing 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 = renderBootstrap3 BootstrapBasicForm $ (,,,,) diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 99f67f3..89967a0 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -17,6 +17,9 @@ import Control.Concurrent.Lifted (fork, threadDelay) import System.Process import System.Exit +import System.Random + +import PersistSHA1 import qualified Data.ByteString as BS @@ -24,16 +27,21 @@ atom = Control.Concurrent.STM.atomically type Channel = TChan (Maybe Text) +arena :: FilePath +arena = "arena" + +gitPath :: FilePath +gitPath = "/usr/bin/git" + runViewProgress :: (Channel -> Handler ()) -> Handler TypedContent runViewProgress action = do App {..} <- getYesod - (jobId, chan) <- liftIO $ atom $ do - jobId <- readTVar nextJob - writeTVar nextJob $! jobId + 1 + jobId <- randomInt + chan <- liftIO $ atom $ do chan <- newBroadcastTChan m <- readTVar jobs writeTVar jobs $ IntMap.insert jobId chan m - return (jobId, chan) + return chan fork $ do liftIO $ threadDelay 1000000 action chan @@ -53,14 +61,6 @@ err = msg raw :: Channel -> Text -> Handler () 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 url branch chan = do msg chan "Did something" @@ -73,7 +73,7 @@ validGitProtocols = ["git", "http", "https", "ssh"] validGitProtocolsAsText :: Text 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 maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch case maybeRepo of @@ -85,14 +85,69 @@ cloneRepo url branch chan = do if checkRepoUrl url then do msg chan "Cloning..." - runProgram "/usr/bin/git" ["clone", - "--progress", - T.unpack url] chan - return Nothing + r <- randomInt + let repoDir = arena ("t" ++ show r) + (exitCode, _) <- runProgram Nothing gitPath ["clone", + "--progress", + "--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 else do err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText] 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 url = case parsedURI of Just uri -> (uriScheme uri) `elem` (map (++":") validGitProtocols) @@ -120,13 +175,15 @@ getViewProgressR jobId = do loop loop -runProgram :: FilePath -> [String] -> Channel -> Handler () -runProgram programPath args chan = do +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 } + liftIO $ createProcess (proc programPath args){ std_out = CreatePipe, + std_err = CreatePipe, + cwd = workingDir} (code, out) <- gatherOutput pid hout herr chan _ <- liftIO $ waitForProcess pid - return () + return (code, out) processOutput :: Text -> ([Text], Text) @@ -170,3 +227,6 @@ gatherOutput ph hout herr chan = work mempty mempty let all = rest <> (decodeUtf8 last) mapM_ (msg chan) $ lines all return all + +randomInt :: Handler Int +randomInt = liftIO $ randomIO diff --git a/PersistSHA1.hs b/PersistSHA1.hs index a25e766..4c2c73f 100644 --- a/PersistSHA1.hs +++ b/PersistSHA1.hs @@ -11,12 +11,15 @@ data SHA1 = SHA1 ByteString deriving Show 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 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" instance PersistFieldSql SHA1 where diff --git a/gonito.cabal b/gonito.cabal index f4707bd..61937e3 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -93,6 +93,7 @@ library , network-uri , lifted-base , process + , random executable gonito