cntd.
This commit is contained in:
parent
d1b56dba55
commit
3ee7a80c6f
@ -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 $ (,,,,)
|
||||
|
@ -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
|
||||
|
@ -90,6 +90,7 @@ library
|
||||
, vector
|
||||
, time
|
||||
, stm
|
||||
, network-uri
|
||||
|
||||
executable gonito
|
||||
if flag(library-only)
|
||||
|
Loading…
Reference in New Issue
Block a user