add challenge

.gitignore

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

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 $ (,,,,)

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 <- randomInt
-    jobId <- readTVar nextJob
+  chan <- liftIO $ atom $ do
-    writeTVar nextJob $! jobId + 1
     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",
+        r <- randomInt
-                                   "--progress",
+        let repoDir = arena </> ("t" ++ show r)
-                                   T.unpack url] chan
+        (exitCode, _) <- runProgram Nothing gitPath ["clone",
-        return Nothing
+                                                     "--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 :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text)
-runProgram programPath args chan = do
+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

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

gonito.cabal

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