This commit is contained in:
Filip Gralinski 2015-08-29 22:19:44 +02:00
parent d1b56dba55
commit 3ee7a80c6f
3 changed files with 48 additions and 5 deletions

View File

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

View File

@ -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

View File

@ -90,6 +90,7 @@ library
, vector
, time
, stm
, network-uri
executable gonito
if flag(library-only)