improve creating challenges

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
+    (formWidget, formEnctype) <- generateFormPost createChallengeForm
-    let submission = Nothing :: Maybe (Import.FileInfo, Text)
-        handlerName = "getCreateChallengeR" :: Text
     defaultLayout $ do
-        aDomId <- newIdent
         setTitle "Welcome To Yesod!"
         $(widgetFile "create-challenge")
 
 postCreateChallengeR :: Handler TypedContent
 postCreateChallengeR = do
-    ((result, formWidget), formEnctype) <- runFormPost sampleForm
+    ((result, _), _) <- runFormPost createChallengeForm
-    let handlerName = "postCreateChallengeR" :: Text
+    let challengeData = case result of
-        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,
+                                          repoSpecBranch = publicBranch,
-                                        repoSpecGitAnnexRemote = publicGitAnnexRemote},
+                                          repoSpecGitAnnexRemote = publicGitAnnexRemote},
-                                    cloningSpecReferenceRepo = RepoSpec {
+                                      cloningSpecReferenceRepo = RepoSpec {
                                         repoSpecUrl = publicUrl,
-                                        repoSpecBranch = publicBranch,
+                                          repoSpecBranch = publicBranch,
-                                        repoSpecGitAnnexRemote = publicGitAnnexRemote}}) chan
+                                          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
+        Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan
-          Nothing -> return ()
+        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)
+createChallengeForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text)
-sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
+createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
-    <$> areq textField (fieldSettingsLabel MsgName) Nothing
+    <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing
-    <*> areq textField (fieldSettingsLabel MsgPublicUrl) Nothing
+    <*> areq textField (bfs MsgPublicUrl) Nothing
-    <*> areq textField (fieldSettingsLabel MsgBranch) Nothing
+    <*> areq textField (bfs MsgBranch) (Just "master")
-    <*> aopt textField (fieldSettingsLabel MsgGitAnnexRemote) Nothing
+    <*> aopt textField (bfs MsgGitAnnexRemote) Nothing
-    <*> areq textField (fieldSettingsLabel MsgPrivateUrl) Nothing
+    <*> areq textField (bfs MsgPrivateUrl) Nothing
-    <*> areq textField (fieldSettingsLabel MsgBranch) Nothing
+    <*> areq textField (bfs MsgBranch) (Just "dont-peek")
-    <*> aopt textField (fieldSettingsLabel MsgGitAnnexRemote) Nothing
+    <*> aopt textField (bfs MsgGitAnnexRemote) Nothing

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)

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

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!