s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects Releases Wiki Activity

Refactor challenge creation

Browse Source
This commit is contained in:
Filip Gralinski 2020-03-26 18:55:01 +01:00
parent 6dd6863174
commit 8c7243f2d5
1 changed files with 43 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
Handler/CreateChallenge.hs
View File

@ -30,6 +30,19 @@ import qualified Data.ByteString.Lazy as L
import Data.Conduit.Binary (sinkLbs, sourceFile) import Data.Conduit.Binary (sinkLbs, sourceFile)
data ChallengeCreationData = ChallengeCreationData {
challengeCreationDataName :: Text,
challengeCreationDataPublicUrl :: Text,
challengeCreationDataPublicBranch :: Text,
challengeCreationDataPublicGitAnnexRemote :: Maybe Text,
challengeCreationDataPrivateUrl :: Text,
challengeCreationDataPrivateBranch :: Text,
challengeCreationDataPrivateGitAnnexRemote :: Maybe Text,
challengeCreationDataDeadline :: Maybe UTCTime }
getCreateChallengeR :: Handler Html getCreateChallengeR :: Handler Html
getCreateChallengeR = do getCreateChallengeR = do
(formWidget, formEnctype) <- generateFormPost createChallengeForm (formWidget, formEnctype) <- generateFormPost createChallengeForm
@ -40,39 +53,40 @@ getCreateChallengeR = do
postCreateChallengeR :: Handler TypedContent postCreateChallengeR :: Handler TypedContent
postCreateChallengeR = do postCreateChallengeR = do
((result, _), _) <- runFormPost createChallengeForm ((result, _), _) <- runFormPost createChallengeForm
let challengeData = case result of let challengeData' = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing
Just (name, publicUrl, publicBranch, publicGitAnnexRemote, Just challengeData = challengeData'
privateUrl, privateBranch, privateGitAnnexRemote,
mDeadlineDay, mDeadlineTime) = challengeData
let mDeadline = combineMaybeDayAndTime mDeadlineDay mDeadlineTime
userId <- requireAuthId userId <- requireAuthId
user <- runDB $ get404 userId user <- runDB $ get404 userId
if userIsAdmin user if userIsAdmin user
then then
do do
let name' = T.strip name let name = challengeCreationDataName challengeData
if isLocalIdAcceptable name' if isLocalIdAcceptable name
then then
runViewProgress $ doCreateChallenge name' runViewProgress $ doCreateChallenge challengeData
(T.strip publicUrl)
(T.strip publicBranch)
(T.strip <$> publicGitAnnexRemote)
(T.strip privateUrl)
(T.strip privateBranch)
(T.strip <$> privateGitAnnexRemote)
mDeadline
else else
runViewProgress $ (flip err) "unexpected challenge ID (use only lower-case letters, digits and hyphens, start with a letter)" runViewProgress $ (flip err) "unexpected challenge ID (use only lower-case letters, digits and hyphens, start with a letter)"
else else
runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE" runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE"
doCreateChallenge :: Text -> Text -> Text -> Maybe Text -> Text -> Text -> Maybe Text -> Maybe UTCTime -> Channel -> Handler () doCreateChallenge :: ChallengeCreationData -> Channel -> Handler ()
doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote mDeadline chan = do doCreateChallenge creationData chan = do
let name = challengeCreationDataName creationData
let publicUrl = challengeCreationDataPublicUrl creationData
let publicBranch = challengeCreationDataPublicBranch creationData
let publicGitAnnexRemote = challengeCreationDataPublicGitAnnexRemote creationData
let privateUrl = challengeCreationDataPrivateUrl creationData
let privateBranch = challengeCreationDataPrivateBranch creationData
let privateGitAnnexRemote = challengeCreationDataPrivateGitAnnexRemote creationData
let mDeadline = challengeCreationDataDeadline creationData
maybePublicRepoId <- cloneRepo (RepoCloningSpec { maybePublicRepoId <- cloneRepo (RepoCloningSpec {
cloningSpecRepo = RepoSpec { cloningSpecRepo = RepoSpec {
repoSpecUrl = publicUrl, repoSpecUrl = publicUrl,
@ -411,17 +425,17 @@ never = depth ==? 0
testDirFilter :: FindClause Bool testDirFilter :: FindClause Bool
testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.fileName ~~? "test-*") testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.fileName ~~? "test-*")
createChallengeForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text, Maybe Day, Maybe TimeOfDay) createChallengeForm :: Form ChallengeCreationData
createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,,,) createChallengeForm = renderBootstrap3 BootstrapBasicForm $ ChallengeCreationData
<$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing <$> (T.strip <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing)
<*> areq textField (bfs MsgPublicUrl) Nothing <*> (T.strip <$> areq textField (bfs MsgPublicUrl) Nothing)
<*> areq textField (bfs MsgBranch) (Just "master") <*> (T.strip <$> areq textField (bfs MsgBranch) (Just "master"))
<*> aopt textField (bfs MsgGitAnnexRemote) Nothing <*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) Nothing)
<*> areq textField (bfs MsgPrivateUrl) Nothing <*> (T.strip <$> areq textField (bfs MsgPrivateUrl) Nothing)
<*> areq textField (bfs MsgBranch) (Just "dont-peek") <*> (T.strip <$> areq textField (bfs MsgBranch) (Just "dont-peek"))
<*> aopt textField (bfs MsgGitAnnexRemote) Nothing <*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) Nothing)
<*> aopt dayField (bfs MsgChallengeDeadlineDay) Nothing <*> (combineMaybeDayAndTime <$> aopt dayField (bfs MsgChallengeDeadlineDay) Nothing
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) Nothing <*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) Nothing)
updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Form (ChallengeUpdateType, updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Form (ChallengeUpdateType,