diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index 5cd1914..e87c1ae 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -23,8 +23,9 @@ postCreateChallengeR = do challengeData = case result of FormSuccess res -> Just res _ -> Nothing + Just (name, publicUrl, publicBranch, privateUrl, privateBranch) = challengeData - runViewProgress doSomething + runViewProgress $ doRepoCloning publicUrl publicBranch sampleForm :: Form (Text, Text, Text, Text, Text) sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,) diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 8b5989d..da4823f 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -9,6 +9,11 @@ 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) + atom = Control.Concurrent.STM.atomically type Channel = TChan (Maybe Text) @@ -24,6 +29,7 @@ runViewProgress action = do writeTVar jobs $ IntMap.insert jobId chan m return (jobId, chan) liftIO $ forkIO $ do + threadDelay 1000000 action chan atom $ do writeTChan chan $ Just "All done\n" @@ -33,16 +39,51 @@ runViewProgress action = do redirect $ ViewProgressR jobId msg :: Channel -> Text -> IO () -msg chan m = atom $ writeTChan chan $ Just m +msg chan m = atom $ writeTChan chan $ Just (m ++ "\n") + +err :: Channel -> Text -> IO () +err = msg doSomething :: Channel -> IO () doSomething chan = do + msg chan "Did something" threadDelay 1000000 - msg chan "Did something\n" - threadDelay 1000000 - msg chan "Did something else\n" + msg chan "Did something else" threadDelay 1000000 +doRepoCloning :: Text -> Text -> Channel -> IO () +doRepoCloning url branch chan = do + msg chan "Did something" + _ <- cloneRepo url branch chan + return () + +validGitProtocols :: [String] +validGitProtocols = ["git", "http", "https", "ssh"] + +validGitProtocolsAsText :: Text +validGitProtocolsAsText = T.pack $ intercalate ", " $ map (++"://") validGitProtocols + +cloneRepo :: Text -> Text -> Channel -> IO (Maybe Repo) +cloneRepo url branch chan = do + let maybeRepo = Nothing + case maybeRepo of + Just _ -> do + err chan "Repo already there" + return Nothing + Nothing -> do + msg chan $ concat ["Preparing to clone repo ", url] + if checkRepoUrl url + then + 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 + +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 diff --git a/gonito.cabal b/gonito.cabal index e055d14..7494357 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -90,6 +90,7 @@ library , vector , time , stm + , network-uri executable gonito if flag(library-only)