From 6c6c63114f1b546b7f5a9ff09871b63bc8610efc Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 1 Sep 2018 12:01:35 +0200 Subject: [PATCH] improve creating challenges --- Handler/CreateChallenge.hs | 59 ++++++++++++++++++++++---------------- Handler/Shared.hs | 16 +++++++++++ Handler/YourAccount.hs | 17 +---------- messages/en.msg | 2 ++ 4 files changed, 53 insertions(+), 41 deletions(-) diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index e296377..52aac75 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -2,7 +2,7 @@ module Handler.CreateChallenge where import Import import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, - withSmallInput) + bfs) import Handler.Shared import Handler.Runner @@ -25,19 +25,15 @@ import Data.Conduit.Binary (sinkLbs, sourceFile) getCreateChallengeR :: Handler Html getCreateChallengeR = do - (formWidget, formEnctype) <- generateFormPost sampleForm - let submission = Nothing :: Maybe (Import.FileInfo, Text) - handlerName = "getCreateChallengeR" :: Text + (formWidget, formEnctype) <- generateFormPost createChallengeForm defaultLayout $ do - aDomId <- newIdent setTitle "Welcome To Yesod!" $(widgetFile "create-challenge") postCreateChallengeR :: Handler TypedContent postCreateChallengeR = do - ((result, formWidget), formEnctype) <- runFormPost sampleForm - let handlerName = "postCreateChallengeR" :: Text - challengeData = case result of + ((result, _), _) <- runFormPost createChallengeForm + let challengeData = case result of FormSuccess res -> Just res _ -> Nothing Just (name, publicUrl, publicBranch, publicGitAnnexRemote, @@ -47,7 +43,20 @@ postCreateChallengeR = do user <- runDB $ get404 userId if userIsAdmin user then - runViewProgress $ doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote + do + let name' = T.strip name + + if isLocalIdAcceptable name' + then + runViewProgress $ doCreateChallenge name' + (T.strip publicUrl) + (T.strip publicBranch) + (T.strip <$> publicGitAnnexRemote) + (T.strip privateUrl) + (T.strip privateBranch) + (T.strip <$> privateGitAnnexRemote) + else + runViewProgress $ (flip err) "unexpected challenge ID (use only lower-case letters, digits and hyphens, start with a letter)" else runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE" @@ -56,12 +65,12 @@ doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl pr maybePublicRepoId <- cloneRepo (RepoCloningSpec { cloningSpecRepo = RepoSpec { repoSpecUrl = publicUrl, - repoSpecBranch = publicBranch, - repoSpecGitAnnexRemote = publicGitAnnexRemote}, - cloningSpecReferenceRepo = RepoSpec { + repoSpecBranch = publicBranch, + repoSpecGitAnnexRemote = publicGitAnnexRemote}, + cloningSpecReferenceRepo = RepoSpec { repoSpecUrl = publicUrl, - repoSpecBranch = publicBranch, - repoSpecGitAnnexRemote = publicGitAnnexRemote}}) chan + repoSpecBranch = publicBranch, + repoSpecGitAnnexRemote = publicGitAnnexRemote}}) chan case maybePublicRepoId of Just publicRepoId -> do publicRepo <- runDB $ get404 publicRepoId @@ -76,8 +85,8 @@ doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl pr repoSpecBranch = (repoBranch publicRepo), repoSpecGitAnnexRemote = (repoGitAnnexRemote publicRepo)}}) chan case maybePrivateRepoId of - Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan - Nothing -> return () + Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan + Nothing -> return () Nothing -> return () addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler () @@ -184,12 +193,12 @@ never = depth ==? 0 testDirFilter :: FindClause Bool testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.fileName ~~? "test-*") -sampleForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text) -sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,) - <$> areq textField (fieldSettingsLabel MsgName) Nothing - <*> areq textField (fieldSettingsLabel MsgPublicUrl) Nothing - <*> areq textField (fieldSettingsLabel MsgBranch) Nothing - <*> aopt textField (fieldSettingsLabel MsgGitAnnexRemote) Nothing - <*> areq textField (fieldSettingsLabel MsgPrivateUrl) Nothing - <*> areq textField (fieldSettingsLabel MsgBranch) Nothing - <*> aopt textField (fieldSettingsLabel MsgGitAnnexRemote) Nothing +createChallengeForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text) +createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,) + <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing + <*> areq textField (bfs MsgPublicUrl) Nothing + <*> areq textField (bfs MsgBranch) (Just "master") + <*> aopt textField (bfs MsgGitAnnexRemote) Nothing + <*> areq textField (bfs MsgPrivateUrl) Nothing + <*> areq textField (bfs MsgBranch) (Just "dont-peek") + <*> aopt textField (bfs MsgGitAnnexRemote) Nothing diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 321cf6d..e2c6389 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -35,6 +35,8 @@ import qualified Test.RandomStrings as RS import qualified Crypto.Nonce as Nonce import System.IO.Unsafe (unsafePerformIO) +import Text.Regex.TDFA + arena :: Handler FilePath arena = do app <- getYesod @@ -363,3 +365,17 @@ findFilePossiblyCompressed baseFilePath = do return $ case foundFiles of [] -> Nothing (h:_) -> Just h + +localIdRegexp :: Regex +localIdRegexp = makeRegexOpts defaultCompOpt{newSyntax=True} defaultExecOpt ("\\`[a-z][-a-z0-9]{0,31}\\'" ::String) + +unwantedLocalIds :: [Text] +unwantedLocalIds = ["git", + "gitolite", + "admin", + "root", + "filipg"] + +isLocalIdAcceptable :: Text -> Bool +isLocalIdAcceptable localId = + match localIdRegexp (unpack localId) && not (localId `elem` unwantedLocalIds) diff --git a/Handler/YourAccount.hs b/Handler/YourAccount.hs index 086d6e3..a05c620 100644 --- a/Handler/YourAccount.hs +++ b/Handler/YourAccount.hs @@ -3,8 +3,6 @@ module Handler.YourAccount where import Import import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) -import Text.Regex.TDFA - import Data.Conduit.Binary import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -55,6 +53,7 @@ checkPassword Nothing = True checkPassword (Just "") = True checkPassword (Just passwd) = isPasswordAcceptable passwd +autocompleteOff :: (RenderMessage master msg2, RenderMessage master msg1) => msg1 -> msg2 -> FieldSettings master autocompleteOff name tooltip = setts { fsAttrs = (fsAttrs setts) ++ [("autocomplete", "nope")]} where setts = (bfs name) { fsTooltip = Just $ SomeMessage tooltip } @@ -67,20 +66,6 @@ yourAccountForm maybeName maybeLocalId maybeSshPubKey anonimised = renderBootstr <*> fileAFormOpt (bfs MsgAvatar) <*> areq checkBoxField (bfs MsgWantToBeAnonimised) (Just anonimised) -localIdRegexp :: Regex -localIdRegexp = makeRegexOpts defaultCompOpt{newSyntax=True} defaultExecOpt ("\\`[a-z][-a-z0-9]{0,31}\\'" ::String) - -unwantedLocalIds :: [Text] -unwantedLocalIds = ["git", - "gitolite", - "admin", - "root", - "filipg"] - -isLocalIdAcceptable :: Text -> Bool -isLocalIdAcceptable localId = - match localIdRegexp (unpack localId) && not (localId `elem` unwantedLocalIds) - updateUserAccount :: Key User -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe FileInfo -> Bool -> Handler () updateUserAccount userId name maybeLocalId maybePassword maybeSshPubKey maybeAvatarFile anonimised = do updateJustName userId name diff --git a/messages/en.msg b/messages/en.msg index 904d7e4..751021a 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -64,3 +64,5 @@ RemoveSubmission: remove submission RestoreSubmission: restore submission ParameterName: parameter name ParameterValue: parameter value +ChallengeName: computer-friendly name ("slug") +ChallengeNameTooltip: to be used in the URLs (only lower-case letters, digits or hyphens, must start with a lower-case letter), once set cannot be changed!