webapp: Added help buttons and links next to fields that require explanations.

This commit is contained in:
Joey Hess 2012-12-02 22:33:30 -04:00
parent 98231b3248
commit 4f4209b833
14 changed files with 254 additions and 63 deletions

View file

@ -61,9 +61,9 @@ extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
s3InputAForm :: AForm WebApp WebApp AWSInput
s3InputAForm = AWSInput
<$> areq textField "Access Key ID" Nothing
<*> areq passwordField "Secret Access Key" Nothing
<*> areq (selectFieldList $ M.toList $ AWS.regionMap AWS.S3) "Datacenter" (Just $ AWS.defaultRegion AWS.S3)
<$> accessKeyIDField
<*> secretAccessKeyField
<*> datacenterField AWS.S3
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
<*> areq textField "Repository name" (Just "S3")
where
@ -73,27 +73,35 @@ s3InputAForm = AWSInput
, ("Reduced redundancy (costs less)", ReducedRedundancy)
]
textField' :: RenderMessage master FormMessage => Field sub master Text
textField' = Field
{ fieldParse = fieldParse textField
, fieldView = \theId name attrs val _isReq ->
[whamlet|
<input id="#{theId}" name="#{name}" *{attrs} type="text" value="#{either id id val}">
|]
}
glacierInputAForm :: AForm WebApp WebApp AWSInput
glacierInputAForm = AWSInput
<$> areq textField "Access Key ID" Nothing
<*> areq passwordField "Secret Access Key" Nothing
<*> areq (selectFieldList $ M.toList $ AWS.regionMap AWS.Glacier) "Datacenter" (Just $ AWS.defaultRegion AWS.Glacier)
<$> accessKeyIDField
<*> secretAccessKeyField
<*> datacenterField AWS.Glacier
<*> pure StandardRedundancy
<*> areq textField "Repository name" (Just "glacier")
awsCredsAForm :: AForm WebApp WebApp AWSCreds
awsCredsAForm = AWSCreds
<$> areq textField "Access Key ID" Nothing
<*> areq passwordField "Secret Access Key" Nothing
<$> accessKeyIDField
<*> secretAccessKeyField
accessKeyIDField :: AForm WebApp WebApp Text
accessKeyIDField = areq (textField `withNote` help) "Access Key ID" Nothing
where
help = [whamlet|
<a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">
Get Amazon access keys
|]
secretAccessKeyField :: AForm WebApp WebApp Text
secretAccessKeyField = areq passwordField "Secret Access Key" Nothing
datacenterField :: AWS.Service -> AForm WebApp WebApp Text
datacenterField service = areq (selectFieldList list) "Datacenter" defregion
where
list = M.toList $ AWS.regionMap service
defregion = Just $ AWS.defaultRegion service
getAddS3R :: Handler RepHtml
#ifdef WITH_S3

View file

@ -89,9 +89,10 @@ editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
editRepositoryAForm def = RepoConfig
<$> areq textField "Name" (Just $ repoName def)
<*> aopt textField "Description" (Just $ repoDescription def)
<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
<*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def)
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
where
groups = customgroups ++ standardgroups
standardgroups :: [(Text, RepoGroup)]
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
[minBound :: StandardGroup .. maxBound :: StandardGroup]
@ -99,6 +100,7 @@ editRepositoryAForm def = RepoConfig
customgroups = case repoGroup def of
RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)]
_ -> []
help = [whamlet|<a href="@{RepoGroupR}">What's this?</a>|]
getEditRepositoryR :: UUID -> Handler RepHtml
getEditRepositoryR = editForm False

View file

@ -47,13 +47,13 @@ mkSshData s = SshData
, rsyncOnly = False
}
sshInputAForm :: SshInput -> AForm WebApp WebApp SshInput
sshInputAForm def = SshInput
sshInputAForm :: (Field WebApp WebApp Text) -> SshInput -> AForm WebApp WebApp SshInput
sshInputAForm hostnamefield def = SshInput
<$> aopt check_hostname "Host name" (Just $ hostname def)
<*> aopt check_username "User name" (Just $ username def)
<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def)
where
check_hostname = checkM (liftIO . checkdns) textField
check_hostname = checkM (liftIO . checkdns) hostnamefield
checkdns t = do
let h = T.unpack t
r <- catchMaybeIO $ getAddrInfo canonname (Just h) Nothing
@ -89,7 +89,7 @@ getAddSshR :: Handler RepHtml
getAddSshR = sshConfigurator $ do
u <- liftIO $ T.pack <$> myUserName
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ sshInputAForm $
runFormGet $ renderBootstrap $ sshInputAForm textField $
SshInput Nothing (Just u) Nothing
case result of
FormSuccess sshinput -> do
@ -115,7 +115,7 @@ getEnableRsyncR u = do
case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
(Just sshinput, Just reponame) -> sshConfigurator $ do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ sshInputAForm sshinput
runFormGet $ renderBootstrap $ sshInputAForm textField sshinput
case result of
FormSuccess sshinput'
| isRsyncNet (hostname sshinput') ->
@ -276,7 +276,7 @@ makeSshRepo forcersync setup sshdata = do
getAddRsyncNetR :: Handler RepHtml
getAddRsyncNetR = do
((result, form), enctype) <- runFormGet $
renderBootstrap $ sshInputAForm $
renderBootstrap $ sshInputAForm hostnamefield $
SshInput Nothing Nothing Nothing
let showform status = page "Add a Rsync.net repository" (Just Config) $
$(widgetFile "configurators/addrsync.net")
@ -290,6 +290,19 @@ getAddRsyncNetR = do
showform $ UnusableServer
"That is not a rsync.net host name."
_ -> showform UntestedServer
where
hostnamefield = textField `withNote` help
help = [whamlet|
<a .btn data-toggle="collapse" data-target="#help">
Help
<div #help .collapse>
<div>
When you sign up for a Rsync.net account, you should receive an #
email from them with the host name and user name to put here.
<div>
The host name will be something like "usw-s001.rsync.net", and the #
user name something like "7491"
|]
makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler RepHtml
makeRsyncNet sshinput reponame setup = do