filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

Refactor challenge creation & update - cntd.

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

119
Handler/CreateChallenge.hs
View File

@ -32,16 +32,18 @@ import Data.Conduit.Binary (sinkLbs, sourceFile)
data ChallengeCreationData = ChallengeCreationData { data ChallengeCreationData = ChallengeCreationData {
challengeCreationDataName :: Text, challengeCreationDataName :: Text,
challengeCreationMetadata :: ChallengeMetadata }
challengeCreationDataPublicUrl :: Text, data ChallengeMetadata = ChallengeMetadata {
challengeCreationDataPublicBranch :: Text, challengeMetadataPublicUrl :: Text,
challengeCreationDataPublicGitAnnexRemote :: Maybe Text, challengeMetadataPublicBranch :: Text,
challengeMetadataPublicGitAnnexRemote :: Maybe Text,
challengeCreationDataPrivateUrl :: Text, challengeMetadataPrivateUrl :: Text,
challengeCreationDataPrivateBranch :: Text, challengeMetadataPrivateBranch :: Text,
challengeCreationDataPrivateGitAnnexRemote :: Maybe Text, challengeMetadataPrivateGitAnnexRemote :: Maybe Text,
challengeCreationDataDeadline :: Maybe UTCTime } challengeMetadataDeadline :: Maybe UTCTime }
getCreateChallengeR :: Handler Html getCreateChallengeR :: Handler Html
getCreateChallengeR = do getCreateChallengeR = do
@ -77,15 +79,16 @@ doCreateChallenge :: ChallengeCreationData -> Channel -> Handler ()
doCreateChallenge creationData chan = do doCreateChallenge creationData chan = do
let name = challengeCreationDataName creationData let name = challengeCreationDataName creationData
let publicUrl = challengeCreationDataPublicUrl creationData let challengeMetadata = challengeCreationMetadata creationData
let publicBranch = challengeCreationDataPublicBranch creationData let publicUrl = challengeMetadataPublicUrl challengeMetadata
let publicGitAnnexRemote = challengeCreationDataPublicGitAnnexRemote creationData let publicBranch = challengeMetadataPublicBranch challengeMetadata
let publicGitAnnexRemote = challengeMetadataPublicGitAnnexRemote challengeMetadata
let privateUrl = challengeCreationDataPrivateUrl creationData let privateUrl = challengeMetadataPrivateUrl challengeMetadata
let privateBranch = challengeCreationDataPrivateBranch creationData let privateBranch = challengeMetadataPrivateBranch challengeMetadata
let privateGitAnnexRemote = challengeCreationDataPrivateGitAnnexRemote creationData let privateGitAnnexRemote = challengeMetadataPrivateGitAnnexRemote challengeMetadata
let mDeadline = challengeCreationDataDeadline creationData let mDeadline = challengeMetadataDeadline challengeMetadata
maybePublicRepoId <- cloneRepo (RepoCloningSpec { maybePublicRepoId <- cloneRepo (RepoCloningSpec {
cloningSpecRepo = RepoSpec { cloningSpecRepo = RepoSpec {
@ -119,6 +122,10 @@ doCreateChallenge creationData chan = do
data ChallengeUpdateType = MajorChange | MinorChange | ChallengePatch data ChallengeUpdateType = MajorChange | MinorChange | ChallengePatch
deriving (Eq, Enum, Bounded) deriving (Eq, Enum, Bounded)
data ChallengeUpdateData = ChallengeUpdateData {
challengeUpdateDataType :: ChallengeUpdateType,
challengeUpdateDataMetadata :: ChallengeMetadata }
instance Show ChallengeUpdateType where instance Show ChallengeUpdateType where
show MajorChange = "major change" show MajorChange = "major change"
show MinorChange = "minor change" show MinorChange = "minor change"
@ -145,29 +152,17 @@ postChallengeUpdateR :: ChallengeId -> Handler TypedContent
postChallengeUpdateR challengeId = do postChallengeUpdateR challengeId = do
(publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId (publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId
((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline ((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline
let challengeData = case result of let challengeData' = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing
Just (updateType, publicUrl, publicBranch, publicGitAnnexRemote, Just challengeData = challengeData'
privateUrl, privateBranch, privateGitAnnexRemote,
mDeadlineDay, mDeadlineTime) = challengeData
let mNewDeadline = 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
runViewProgress $ doChallengeUpdate challengeId runViewProgress $ doChallengeUpdate challengeId challengeData
updateType
mNewDeadline
publicUrl
publicBranch
publicGitAnnexRemote
privateUrl
privateBranch
privateGitAnnexRemote
else else
runViewProgress $ (flip err) "MUST BE AN ADMIN TO UPDATE A CHALLENGE" runViewProgress $ (flip err) "MUST BE AN ADMIN TO UPDATE A CHALLENGE"
@ -179,20 +174,21 @@ combineMaybeDayAndTime mDeadlineDay mDeadlineTime =
utctDayTime = fromMaybe (secondsToDiffTime 24 * 60 * 60 - 1) $ timeOfDayToTime <$> mDeadlineTime } utctDayTime = fromMaybe (secondsToDiffTime 24 * 60 * 60 - 1) $ timeOfDayToTime <$> mDeadlineTime }
Nothing -> Nothing Nothing -> Nothing
doChallengeUpdate :: ChallengeId -> ChallengeUpdateType -> Maybe UTCTime doChallengeUpdate :: ChallengeId -> ChallengeUpdateData -> Channel -> Handler ()
-> Text -> Text -> Maybe Text doChallengeUpdate challengeId challengeData chan = do
-> Text -> Text -> Maybe Text let updateType = challengeUpdateDataType challengeData
-> Channel -> Handler ()
doChallengeUpdate challengeId let metadata = challengeUpdateDataMetadata challengeData
updateType
newDeadline let publicUrl = challengeMetadataPublicUrl metadata
publicUrl let publicBranch = challengeMetadataPublicBranch metadata
publicBranch let publicGitAnnexRemote = challengeMetadataPublicGitAnnexRemote metadata
publicGitAnnexRemote
privateUrl let privateUrl = challengeMetadataPrivateUrl metadata
privateBranch let privateBranch = challengeMetadataPrivateBranch metadata
privateGitAnnexRemote let privateGitAnnexRemote = challengeMetadataPrivateGitAnnexRemote metadata
chan = do
let newDeadline = challengeMetadataDeadline metadata
challenge <- runDB $ get404 challengeId challenge <- runDB $ get404 challengeId
(Entity _ version) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge (Entity _ version) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
@ -428,31 +424,24 @@ testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.f
createChallengeForm :: Form ChallengeCreationData createChallengeForm :: Form ChallengeCreationData
createChallengeForm = renderBootstrap3 BootstrapBasicForm $ ChallengeCreationData createChallengeForm = renderBootstrap3 BootstrapBasicForm $ ChallengeCreationData
<$> (T.strip <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing) <$> (T.strip <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing)
<*> (T.strip <$> areq textField (bfs MsgPublicUrl) Nothing) <*> challengeMetadataInputs Nothing Nothing Nothing
<*> (T.strip <$> areq textField (bfs MsgBranch) (Just "master"))
<*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) Nothing)
<*> (T.strip <$> areq textField (bfs MsgPrivateUrl) Nothing)
<*> (T.strip <$> areq textField (bfs MsgBranch) (Just "dont-peek"))
<*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) Nothing)
<*> (combineMaybeDayAndTime <$> aopt dayField (bfs MsgChallengeDeadlineDay) Nothing
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) Nothing)
challengeMetadataInputs :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) AppMessage)
=> Maybe Repo -> Maybe Repo -> Maybe UTCTime -> AForm m ChallengeMetadata
challengeMetadataInputs mPublicRepo mPrivateRepo mDeadline =
ChallengeMetadata <$> (T.strip <$> areq textField (bfs MsgPublicUrl) (repoUrl <$> mPublicRepo))
<*> (T.strip <$> areq textField (bfs MsgBranch) (Just $ maybe "master" repoBranch mPublicRepo))
<*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) (repoGitAnnexRemote <$> mPublicRepo))
<*> (T.strip <$> areq textField (bfs MsgPrivateUrl) (repoUrl <$> mPrivateRepo))
<*> (T.strip <$> areq textField (bfs MsgBranch) (Just $ maybe "dont-peek" repoBranch mPrivateRepo))
<*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) (repoGitAnnexRemote <$> mPrivateRepo))
<*> (combineMaybeDayAndTime <$> aopt dayField (bfs MsgChallengeDeadlineDay) (Just $ utctDay <$> mDeadline)
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) (Just $ timeToTimeOfDay <$> utctDayTime <$> mDeadline))
updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Form (ChallengeUpdateType, updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Form ChallengeUpdateData
Text, Text, Maybe Text, updateChallengeForm publicRepo privateRepo mDeadline = renderBootstrap3 BootstrapBasicForm $ ChallengeUpdateData
Text, Text, Maybe Text,
Maybe Day, Maybe TimeOfDay)
updateChallengeForm publicRepo privateRepo mDeadline = renderBootstrap3 BootstrapBasicForm $ (,,,,,,,,)
<$> areq (radioField optionsEnum) "change type" (Just ChallengePatch) <$> areq (radioField optionsEnum) "change type" (Just ChallengePatch)
<*> areq textField (bfs MsgPublicUrl) (Just $ repoUrl publicRepo) <*> challengeMetadataInputs (Just publicRepo) (Just privateRepo) mDeadline
<*> areq textField (bfs MsgBranch) (Just $ repoBranch publicRepo)
<*> aopt textField (bfs MsgGitAnnexRemote) (Just $ repoGitAnnexRemote publicRepo)
<*> areq textField (bfs MsgPrivateUrl) (Just $ repoUrl privateRepo)
<*> areq textField (bfs MsgBranch) (Just $ repoBranch privateRepo)
<*> aopt textField (bfs MsgGitAnnexRemote) (Just $ repoGitAnnexRemote privateRepo)
<*> aopt dayField (bfs MsgChallengeDeadlineDay) (Just $ utctDay <$> mDeadline)
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip)
(Just $ timeToTimeOfDay <$> utctDayTime <$> mDeadline)
-- Validate whether a challenge is correct. -- Validate whether a challenge is correct.
-- Contrary to `GEval.Validate.validationChallenge` do not -- Contrary to `GEval.Validate.validationChallenge` do not