Merge branch 'master' into sshpassword

Assistant/WebApp/Bootstrap3.hs

@@ -0,0 +1,284 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+-- | Helper functions for creating forms when using Bootstrap v3.
+-- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly
+-- modified to be compatible with Yesod 1.0.1
+module Assistant.WebApp.Bootstrap3
+  ( -- * Rendering forms
+    renderBootstrap3
+  , BootstrapFormLayout(..)
+  , BootstrapGridOptions(..)
+    -- * Field settings
+  , bfs
+  , withPlaceholder
+  , withAutofocus
+  , withLargeInput
+  , withSmallInput
+    -- * Submit button
+  , bootstrapSubmit
+  , mbootstrapSubmit
+  , BootstrapSubmit(..)
+  ) where
+
+import Control.Arrow (second)
+import Control.Monad (liftM)
+import Data.Text (Text)
+import Data.String (IsString(..))
+import Yesod.Core
+
+import qualified Data.Text as T
+
+import Yesod.Form.Types
+import Yesod.Form.Functions
+
+-- | Create a new 'FieldSettings' with the classes that are
+-- required by Bootstrap v3.
+--
+-- Since: yesod-form 1.3.8
+bfs :: RenderMessage site msg => msg -> FieldSettings site
+bfs msg =
+    FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
+
+
+-- | Add a placeholder attribute to a field.  If you need i18n
+-- for the placeholder, currently you\'ll need to do a hack and
+-- use 'getMessageRender' manually.
+--
+-- Since: yesod-form 1.3.8
+withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
+withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
+    where newAttrs = ("placeholder", placeholder) : fsAttrs fs
+
+
+-- | Add an autofocus attribute to a field.
+--
+-- Since: yesod-form 1.3.8
+withAutofocus :: FieldSettings site -> FieldSettings site
+withAutofocus fs = fs { fsAttrs = newAttrs }
+    where newAttrs = ("autofocus", "autofocus") : fsAttrs fs
+
+
+-- | Add the @input-lg@ CSS class to a field.
+--
+-- Since: yesod-form 1.3.8
+withLargeInput :: FieldSettings site -> FieldSettings site
+withLargeInput fs = fs { fsAttrs = newAttrs }
+    where newAttrs = addClass "input-lg" (fsAttrs fs)
+
+
+-- | Add the @input-sm@ CSS class to a field.
+--
+-- Since: yesod-form 1.3.8
+withSmallInput :: FieldSettings site -> FieldSettings site
+withSmallInput fs = fs { fsAttrs = newAttrs }
+    where newAttrs = addClass "input-sm" (fsAttrs fs)
+
+
+addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
+addClass klass []                    = [("class", klass)]
+addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
+addClass klass (other         :rest) = other : addClass klass rest
+
+
+-- | How many bootstrap grid columns should be taken (see
+-- 'BootstrapFormLayout').
+--
+-- Since: yesod-form 1.3.8
+data BootstrapGridOptions =
+    ColXs !Int
+  | ColSm !Int
+  | ColMd !Int
+  | ColLg !Int
+    deriving (Eq, Ord, Show)
+
+toColumn :: BootstrapGridOptions -> String
+toColumn (ColXs 0) = ""
+toColumn (ColSm 0) = ""
+toColumn (ColMd 0) = ""
+toColumn (ColLg 0) = ""
+toColumn (ColXs columns) = "col-xs-" ++ show columns
+toColumn (ColSm columns) = "col-sm-" ++ show columns
+toColumn (ColMd columns) = "col-md-" ++ show columns
+toColumn (ColLg columns) = "col-lg-" ++ show columns
+
+toOffset :: BootstrapGridOptions -> String
+toOffset (ColXs 0) = ""
+toOffset (ColSm 0) = ""
+toOffset (ColMd 0) = ""
+toOffset (ColLg 0) = ""
+toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
+toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
+toOffset (ColMd columns) = "col-md-offset-" ++ show columns
+toOffset (ColLg columns) = "col-lg-offset-" ++ show columns
+
+addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
+addGO (ColXs a) (ColXs b) = ColXs (a+b)
+addGO (ColSm a) (ColSm b) = ColSm (a+b)
+addGO (ColMd a) (ColMd b) = ColMd (a+b)
+addGO (ColLg a) (ColLg b) = ColLg (a+b)
+addGO a b     | a > b = addGO b a
+addGO (ColXs a) other = addGO (ColSm a) other
+addGO (ColSm a) other = addGO (ColMd a) other
+addGO (ColMd a) other = addGO (ColLg a) other
+addGO (ColLg _) _     = error "Yesod.Form.Bootstrap.addGO: never here"
+
+
+-- | The layout used for the bootstrap form.
+--
+-- Since: yesod-form 1.3.8
+data BootstrapFormLayout =
+    BootstrapBasicForm
+  | BootstrapInlineForm
+  | BootstrapHorizontalForm
+      { bflLabelOffset :: !BootstrapGridOptions
+      , bflLabelSize   :: !BootstrapGridOptions
+      , bflInputOffset :: !BootstrapGridOptions
+      , bflInputSize   :: !BootstrapGridOptions
+      }
+    deriving (Show)
+
+
+-- | Render the given form using Bootstrap v3 conventions.
+--
+-- Sample Hamlet for 'BootstrapHorizontalForm':
+--
+-- >  <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
+-- >    ^{formWidget}
+-- >    ^{bootstrapSubmit MsgSubmit}
+--
+-- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
+renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
+#else
+renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
+#endif
+renderBootstrap3 formLayout aform fragment = do
+    (res, views') <- aFormToForm aform
+    let views = views' []
+        has (Just _) = True
+        has Nothing  = False
+        widget = [whamlet|
+#if MIN_VERSION_yesod(1,2,0)
+            $newline never
+#endif
+            #{fragment}
+            $forall view <- views
+              <div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
+                $case formLayout
+                  $of BootstrapBasicForm
+                    $if nequals (fvId view) bootstrapSubmitId
+                      <label for=#{fvId view}>#{fvLabel view}
+                    ^{fvInput view}
+                    ^{helpWidget view}
+                  $of BootstrapInlineForm
+                    $if nequals (fvId view) bootstrapSubmitId
+                      <label .sr-only for=#{fvId view}>#{fvLabel view}
+                    ^{fvInput view}
+                    ^{helpWidget view}
+                  $of f@(BootstrapHorizontalForm _ _ _ _)
+                    $if nequals (fvId view) bootstrapSubmitId
+                      <label .control-label .#{toOffset (bflLabelOffset f)} .#{toColumn (bflLabelSize f)} for=#{fvId view}>#{fvLabel view}
+                      <div .#{toOffset (bflInputOffset f)} .#{toColumn (bflInputSize f)}>
+                        ^{fvInput view}
+                        ^{helpWidget view}
+                    $else
+                      <div .#{toOffset (addGO (bflInputOffset f) (addGO (bflLabelOffset f) (bflLabelSize f)))} .#{toColumn (bflInputSize f)}>
+                        ^{fvInput view}
+                        ^{helpWidget view}
+                |]
+    return (res, widget)
+  where
+    nequals a b = a /= b -- work around older hamlet versions not liking /=
+
+-- | (Internal) Render a help widget for tooltips and errors.
+#if MIN_VERSION_yesod(1,2,0)
+helpWidget :: FieldView site -> WidgetT site IO ()
+#else
+helpWidget :: FieldView sub master -> GWidget sub master ()
+#endif
+helpWidget view = [whamlet|
+    $maybe tt <- fvTooltip view
+      <span .help-block>#{tt}
+    $maybe err <- fvErrors view
+      <span .help-block>#{err}
+|]
+
+
+-- | How the 'bootstrapSubmit' button should be rendered.
+--
+-- Since: yesod-form 1.3.8
+data BootstrapSubmit msg =
+    BootstrapSubmit
+        { bsValue   :: msg
+          -- ^ The text of the submit button.
+        , bsClasses :: Text
+          -- ^ Classes added to the @<button>@.
+        , bsAttrs   :: [(Text, Text)]
+          -- ^ Attributes added to the @<button>@.
+        } deriving (Show)
+
+instance IsString msg => IsString (BootstrapSubmit msg) where
+    fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
+
+
+-- | A Bootstrap v3 submit button disguised as a field for
+-- convenience.  For example, if your form currently is:
+--
+-- > Person <$> areq textField "Name"    Nothing
+-- >        <*> areq textField "Surname" Nothing
+--
+-- Then just change it to:
+--
+-- > Person <$> areq textField "Name"    Nothing
+-- >        <*> areq textField "Surname" Nothing
+-- >        <*  bootstrapSubmit "Register"
+--
+-- (Note that @<*@ is not a typo.)
+--
+-- Alternatively, you may also just create the submit button
+-- manually as well in order to have more control over its
+-- layout.
+--
+-- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
+bootstrapSubmit
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> AForm m ()
+#else
+bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
+#endif
+bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
+
+
+-- | Same as 'bootstrapSubmit' but for monadic forms.  This isn't
+-- as useful since you're not going to use 'renderBootstrap3'
+-- anyway.
+--
+-- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
+mbootstrapSubmit
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
+#else
+mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
+#endif
+mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
+    let res = FormSuccess ()
+        widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
+        fv  = FieldView { fvLabel    = ""
+                        , fvTooltip  = Nothing
+                        , fvId       = bootstrapSubmitId
+                        , fvInput    = widget
+                        , fvErrors   = Nothing
+                        , fvRequired = False }
+    in return (res, fv)
+
+
+-- | A royal hack.  Magic id used to identify whether a field
+-- should have no label.  A valid HTML4 id which is probably not
+-- going to clash with any other id should someone use
+-- 'bootstrapSubmit' outside 'renderBootstrap3'.
+bootstrapSubmitId :: Text
+bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"

Assistant/WebApp/Common.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.WebApp.Common (module X) where
 
 import Assistant.Common as X
@@ -13,6 +15,9 @@ import Assistant.WebApp.Page as X
 import Assistant.WebApp.Form as X
 import Assistant.WebApp.Types as X
 import Assistant.WebApp.RepoId as X
+#if MIN_VERSION_yesod(1,2,0)
 import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
-
+#else
+import Utility.Yesod as X hiding (textField, passwordField, selectField, selectFieldList, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
+#endif
 import Data.Text as X (Text)

Assistant/WebApp/Configurators/AWS.hs

@@ -68,8 +68,8 @@ s3InputAForm defcreds = AWSInput
 	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 	<*> datacenterField AWS.S3
-	<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
-	<*> areq textField "Repository name" (Just "S3")
+	<*> areq (selectFieldList storageclasses) (bfs "Storage class") (Just StandardRedundancy)
+	<*> areq textField (bfs "Repository name") (Just "S3")
 	<*> enableEncryptionField
   where
 	storageclasses :: [(Text, StorageClass)]
@@ -84,7 +84,7 @@ glacierInputAForm defcreds = AWSInput
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 	<*> datacenterField AWS.Glacier
 	<*> pure StandardRedundancy
-	<*> areq textField "Repository name" (Just "glacier")
+	<*> areq textField (bfs "Repository name") (Just "glacier")
 	<*> enableEncryptionField
 
 awsCredsAForm :: Maybe CredPair -> MkAForm AWSCreds
@@ -93,7 +93,7 @@ awsCredsAForm defcreds = AWSCreds
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 
 accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text
-accessKeyIDField help = areq (textField `withNote` help) "Access Key ID"
+accessKeyIDField help = areq (textField `withNote` help) (bfs "Access Key ID")
 
 accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
 accessKeyIDFieldWithHelp = accessKeyIDField help
@@ -104,10 +104,10 @@ accessKeyIDFieldWithHelp = accessKeyIDField help
 |]
 
 secretAccessKeyField :: Maybe Text -> MkAForm Text
-secretAccessKeyField = areq passwordField "Secret Access Key"
+secretAccessKeyField = areq passwordField (bfs "Secret Access Key")
 
 datacenterField :: AWS.Service -> MkAForm Text
-datacenterField service = areq (selectFieldList list) "Datacenter" defregion
+datacenterField service = areq (selectFieldList list) (bfs "Datacenter") defregion
   where
 	list = M.toList $ AWS.regionMap service
 	defregion = Just $ AWS.defaultRegion service
@@ -120,7 +120,7 @@ postAddS3R :: Handler Html
 postAddS3R = awsConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ s3InputAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ s3InputAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
@@ -143,7 +143,7 @@ postAddGlacierR :: Handler Html
 postAddGlacierR = glacierConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ glacierInputAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ glacierInputAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
@@ -186,7 +186,7 @@ enableAWSRemote :: RemoteType -> UUID -> Widget
 enableAWSRemote remotetype uuid = do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ awsCredsAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ awsCredsAForm defcreds
 	case result of
 		FormSuccess creds -> liftH $ do
 			m <- liftAnnex readRemoteLog

Assistant/WebApp/Configurators/Delete.hs

@@ -89,8 +89,8 @@ deleteCurrentRepository = dangerPage $ do
 	havegitremotes <- haveremotes syncGitRemotes
 	havedataremotes <- haveremotes syncDataRemotes
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ sanityVerifierAForm $
-			SanityVerifier magicphrase
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
+			sanityVerifierAForm $ SanityVerifier magicphrase
 	case result of
 		FormSuccess _ -> liftH $ do
 			dir <- liftAnnex $ fromRepo Git.repoPath
@@ -122,7 +122,7 @@ data SanityVerifier = SanityVerifier T.Text
 
 sanityVerifierAForm :: SanityVerifier -> MkAForm SanityVerifier
 sanityVerifierAForm template = SanityVerifier
-	<$> areq checksanity "Confirm deletion?" Nothing
+	<$> areq checksanity (bfs "Confirm deletion?") Nothing
   where
 	checksanity = checkBool (\input -> SanityVerifier input == template)
 		insane textField

Assistant/WebApp/Configurators/Edit.hs

@@ -142,9 +142,9 @@ setRepoConfig uuid mremote oldc newc = do
 editRepositoryAForm :: Maybe Remote -> RepoConfig -> MkAForm RepoConfig
 editRepositoryAForm mremote def = RepoConfig
 	<$> areq (if ishere then readonlyTextField else textField)
-		"Name" (Just $ repoName def)
-	<*> aopt textField "Description" (Just $ repoDescription def)
-	<*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def)
+		(bfs "Name") (Just $ repoName def)
+	<*> aopt textField (bfs "Description") (Just $ repoDescription def)
+	<*> areq (selectFieldList groups `withNote` help) (bfs "Repository group") (Just $ repoGroup def)
 	<*> associateddirectory
 	<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
   where
@@ -166,7 +166,7 @@ editRepositoryAForm mremote def = RepoConfig
 
 	associateddirectory = case repoAssociatedDirectory def of
 		Nothing -> aopt hiddenField "" Nothing
-		Just d -> aopt textField "Associated directory" (Just $ Just d)
+		Just d -> aopt textField (bfs "Associated directory") (Just $ Just d)
 
 getEditRepositoryR :: RepoId -> Handler Html
 getEditRepositoryR = postEditRepositoryR
@@ -195,7 +195,7 @@ editForm new (RepoUUID uuid) = page "Edit repository" (Just Configuration) $ do
 	curr <- liftAnnex $ getRepoConfig uuid mremote
 	liftAnnex $ checkAssociatedDirectory curr mremote
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ editRepositoryAForm mremote curr
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ editRepositoryAForm mremote curr
 	case result of
 		FormSuccess input -> liftH $ do
 			setRepoConfig uuid mremote curr input

Assistant/WebApp/Configurators/Fsck.hs

@@ -64,10 +64,10 @@ runFsckForm new activity = case activity of
 		u <- liftAnnex getUUID
 		repolist <- liftAssistant (getrepolist ru)
 		runFormPostNoToken $ \msg -> do
-			(reposRes, reposView) <- mreq (selectFieldList repolist) "" (Just ru)
-			(durationRes, durationView) <- mreq intField "" (Just $ durationSeconds d `quot` 60 )
-			(timeRes, timeView) <- mreq (selectFieldList times) "" (Just t)
-			(recurranceRes, recurranceView) <- mreq (selectFieldList recurrances) "" (Just r)
+			(reposRes, reposView) <- mreq (selectFieldList repolist) (bfs "") (Just ru)
+			(durationRes, durationView) <- mreq intField (bfs "") (Just $ durationSeconds d `quot` 60 )
+			(timeRes, timeView) <- mreq (selectFieldList times) (bfs "") (Just t)
+			(recurranceRes, recurranceView) <- mreq (selectFieldList recurrances) (bfs "") (Just r)
 			let form = do
 				webAppFormAuthToken
 				$(widgetFile "configurators/fsck/formcontent")
@@ -175,7 +175,8 @@ fsckPreferencesAForm def = FsckPreferences
 runFsckPreferencesForm :: Handler ((FormResult FsckPreferences, Widget), Enctype)
 runFsckPreferencesForm = do
 	prefs <- liftAnnex getFsckPreferences
-	runFormPostNoToken $ renderBootstrap $ fsckPreferencesAForm prefs
+	runFormPostNoToken $ renderBootstrap3 formLayout $ fsckPreferencesAForm prefs
+  where formLayout = BootstrapHorizontalForm (ColSm 0) (ColSm 2) (ColSm 0) (ColSm 10)
 
 showFsckPreferencesForm :: Widget
 showFsckPreferencesForm = do

Assistant/WebApp/Configurators/IA.hs

@@ -83,8 +83,8 @@ iaInputAForm :: Maybe CredPair -> MkAForm IAInput
 iaInputAForm defcreds = IAInput
 	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
 	<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
-	<*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted)
-	<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) "Item Name" Nothing
+	<*> areq (selectFieldList mediatypes) (bfs "Media Type") (Just MediaOmitted)
+	<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) (bfs "Item Name") Nothing
   where
 	mediatypes :: [(Text, MediaType)]
 	mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..]
@@ -126,7 +126,7 @@ postAddIAR :: Handler Html
 postAddIAR = iaConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedIACreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ iaInputAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaInputAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = escapeBucket $ T.unpack $ itemName input
@@ -165,7 +165,7 @@ enableIARemote :: UUID -> Widget
 enableIARemote uuid = do
 	defcreds <- liftAnnex previouslyUsedIACreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ iaCredsAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaCredsAForm defcreds
 	case result of
 		FormSuccess creds -> liftH $ do
 			m <- liftAnnex readRemoteLog

Assistant/WebApp/Configurators/Local.hs

@@ -143,7 +143,7 @@ defaultRepositoryPath firstrun = do
 
 newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
 newRepositoryForm defpath msg = do
-	(pathRes, pathView) <- mreq (repositoryPathField True) ""
+	(pathRes, pathView) <- mreq (repositoryPathField True) (bfs "")
 		(Just $ T.pack $ addTrailingPathSeparator defpath)
 	let (err, errmsg) = case pathRes of
 		FormMissing -> (False, "")
@@ -217,10 +217,10 @@ getCombineRepositoryR newrepopath newrepouuid = do
 	remotename = takeFileName newrepopath
 
 selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
-selectDriveForm drives = renderBootstrap $ RemovableDrive
+selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive
 	<$> pure Nothing
-	<*> areq (selectFieldList pairs `withNote` onlywritable) "Select drive:" Nothing
-	<*> areq textField "Use this directory on the drive:"
+	<*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing
+	<*> areq textField (bfs "Use this directory on the drive:")
 		(Just $ T.pack gitAnnexAssistantDefaultDir)
   where
 	pairs = zip (map describe drives) (map mountPoint drives)

Assistant/WebApp/Configurators/Pairing.hs

@@ -265,8 +265,8 @@ data InputSecret = InputSecret { secretText :: Maybe Text }
 promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html
 promptSecret msg cont = pairPage $ do
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $
-			InputSecret <$> aopt textField "Secret phrase" Nothing
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
+			InputSecret <$> aopt textField (bfs "Secret phrase") Nothing
 	case result of
 		FormSuccess v -> do
 			let rawsecret = fromMaybe "" $ secretText v

Assistant/WebApp/Configurators/Preferences.hs

@@ -36,13 +36,13 @@ data PrefsForm = PrefsForm
 prefsAForm :: PrefsForm -> MkAForm PrefsForm
 prefsAForm def = PrefsForm
 	<$> areq (storageField `withNote` diskreservenote)
-		"Disk reserve" (Just $ diskReserve def)
+		(bfs "Disk reserve") (Just $ diskReserve def)
 	<*> areq (positiveIntField `withNote` numcopiesnote)
-		"Number of copies" (Just $ numCopies def)
+		(bfs "Number of copies") (Just $ numCopies def)
 	<*> areq (checkBoxField `withNote` autostartnote)
 		"Auto start" (Just $ autoStart def)
 	<*> areq (selectFieldList autoUpgradeChoices)
-		autoUpgradeLabel (Just $ autoUpgrade def)
+		(bfs autoUpgradeLabel) (Just $ autoUpgrade def)
 	<*> areq (checkBoxField `withNote` debugnote)
 		"Enable debug logging" (Just $ debugEnabled def)
   where
@@ -109,7 +109,7 @@ postPreferencesR :: Handler Html
 postPreferencesR = page "Preferences" (Just Configuration) $ do
 	((result, form), enctype) <- liftH $ do
 		current <- liftAnnex getPrefs
-		runFormPostNoToken $ renderBootstrap $ prefsAForm current
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ prefsAForm current
 	case result of
 		FormSuccess new -> liftH $ do
 			liftAnnex $ storePrefs new

Assistant/WebApp/Configurators/Ssh.hs

@@ -76,10 +76,10 @@ sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
 sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
 #endif
 sshInputAForm hostnamefield def = SshInput
-	<$> aopt check_hostname "Host name" (Just $ inputHostname def)
-	<*> aopt check_username "User name" (Just $ inputUsername def)
-	<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
-	<*> areq intField "Port" (Just $ inputPort def)
+	<$> aopt check_hostname (bfs "Host name") (Just $ inputHostname def)
+	<*> aopt check_username (bfs "User name") (Just $ inputUsername def)
+	<*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
+	<*> areq intField (bfs "Port") (Just $ inputPort def)
   where
 	check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
 		bad_username textField
@@ -121,7 +121,7 @@ postAddSshR :: Handler Html
 postAddSshR = sshConfigurator $ do
 	username <- liftIO $ T.pack <$> myUserName
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ sshInputAForm textField $
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField $
 			SshInput Nothing (Just username) Nothing 22
 	case result of
 		FormSuccess sshinput -> do
@@ -174,7 +174,7 @@ enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
 	case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of
 		(Just sshinput, Just reponame) -> sshConfigurator $ do
 			((result, form), enctype) <- liftH $
-				runFormPostNoToken $ renderBootstrap $ sshInputAForm textField sshinput
+				runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField sshinput
 			case result of
 				FormSuccess sshinput'
 					| isRsyncNet (inputHostname sshinput') ->
@@ -456,7 +456,7 @@ getAddRsyncNetR = postAddRsyncNetR
 postAddRsyncNetR :: Handler Html
 postAddRsyncNetR = do
 	((result, form), enctype) <- runFormPostNoToken $
-		renderBootstrap $ sshInputAForm hostnamefield $
+		renderBootstrap3 bootstrapFormLayout $ sshInputAForm hostnamefield $
 			SshInput Nothing Nothing Nothing 22
 	let showform status = inpage $
 		$(widgetFile "configurators/rsync.net/add")

Assistant/WebApp/Configurators/Unused.hs

@@ -27,9 +27,9 @@ data UnusedForm = UnusedForm
 
 unusedForm :: UnusedForm -> Hamlet.Html -> MkMForm UnusedForm
 unusedForm def msg = do
-	(enableRes, enableView) <- mreq (selectFieldList enabledisable) ""
+	(enableRes, enableView) <- mreq (selectFieldList enabledisable) (bfs "")
 		(Just $ enableExpire def)
-	(whenRes, whenView) <- mreq intField ""
+	(whenRes, whenView) <- mreq intField (bfs "")
 		(Just $ expireWhen def)
 	let form = do
 		webAppFormAuthToken

Assistant/WebApp/Configurators/WebDAV.hs

@@ -45,16 +45,16 @@ toCredPair input = (T.unpack $ user input, T.unpack $ password input)
 
 boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput
 boxComAForm defcreds = WebDAVInput
-	<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
-	<*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds)
+	<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)
+	<*> areq passwordField (bfs "Box.com Password") (T.pack . snd <$> defcreds)
 	<*> areq checkBoxField "Share this account with other devices and friends?" (Just True)
-	<*> areq textField "Directory" (Just "annex")
+	<*> areq textField (bfs "Directory") (Just "annex")
 	<*> enableEncryptionField
 
 webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput
 webDAVCredsAForm defcreds = WebDAVInput
-	<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
-	<*> areq passwordField "Password" (T.pack . snd <$> defcreds)
+	<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)
+	<*> areq passwordField (bfs "Password") (T.pack . snd <$> defcreds)
 	<*> pure False
 	<*> pure T.empty
 	<*> pure NoEncryption -- not used!
@@ -66,7 +66,8 @@ postAddBoxComR :: Handler Html
 postAddBoxComR = boxConfigurator $ do
 	defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ boxComAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout
+			$ boxComAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ 
 			makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList
@@ -109,7 +110,8 @@ postEnableWebDAVR uuid = do
 			maybe (pure Nothing) previouslyUsedWebDAVCreds $
 				urlHost url
 		((result, form), enctype) <- liftH $
-			runFormPostNoToken $ renderBootstrap $ webDAVCredsAForm defcreds
+			runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
+				webDAVCredsAForm defcreds
 		case result of
 			FormSuccess input -> liftH $
 				makeWebDavRemote enableSpecialRemote name (toCredPair input) M.empty

Assistant/WebApp/Configurators/XMPP.hs

@@ -99,7 +99,7 @@ xmppform :: Route WebApp -> Handler Html
 xmppform next = xmppPage $ do
 	((result, form), enctype) <- liftH $ do
 		oldcreds <- liftAnnex getXMPPCreds
-		runFormPostNoToken $ renderBootstrap $ xmppAForm $
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $
 			creds2Form <$> oldcreds
 	let showform problem = $(widgetFile "configurators/xmpp")
 	case result of
@@ -162,8 +162,8 @@ creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
 
 xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
 xmppAForm def = XMPPForm
-	<$> areq jidField "Jabber address" (formJID <$> def)
-	<*> areq passwordField "Password" Nothing
+	<$> areq jidField (bfs "Jabber address") (formJID <$> def)
+	<*> areq passwordField (bfs "Password") Nothing
 
 jidField :: MkField Text
 jidField = checkBool (isJust . parseJID) bad textField

Assistant/WebApp/Form.hs

@@ -15,10 +15,20 @@ module Assistant.WebApp.Form where
 import Assistant.WebApp.Types
 import Assistant.Gpg
 
+#if MIN_VERSION_yesod(1,2,0)
 import Yesod hiding (textField, passwordField)
 import Yesod.Form.Fields as F
+#else
+import Yesod hiding (textField, passwordField, selectField, selectFieldList)
+import Yesod.Form.Fields as F hiding (selectField, selectFieldList)
+#endif
+import Assistant.WebApp.Bootstrap3 hiding (bfs)
+import Data.String (IsString (..))
 import Data.Text (Text)
 
+import Control.Monad (unless)
+import Data.Maybe (listToMaybe)
+
 {- Yesod's textField sets the required attribute for required fields.
  - We don't want this, because many of the forms used in this webapp 
  - display a modal dialog when submitted, which interacts badly with
@@ -48,6 +58,54 @@ passwordField = F.passwordField
 |]
 	}
 
+{- In older Yesod versions attrs is written into the <option> tag instead of the
+ - surrounding <select>. This breaks the Bootstrap 3 layout of select fields as
+ - it requires the "form-control" class on the <select> tag.
+ - We need to change that to behave the same way as in newer versions.
+ -}
+#if ! MIN_VERSION_yesod(1,2,0)
+selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
+selectFieldList = selectField . optionsPairs
+
+selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
+selectField = selectFieldHelper
+	(\theId name attrs inside -> [whamlet|<select ##{theId} name=#{name} *{attrs}>^{inside}|]) -- outside
+	(\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
+	(\_theId _name _attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected>#{text}|]) -- inside
+
+selectFieldHelper :: (Eq a, RenderMessage master FormMessage)
+	=> (Text -> Text -> [(Text, Text)] -> GWidget sub master () -> GWidget sub master ())
+	-> (Text -> Text -> Bool -> GWidget sub master ())
+	-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ())
+	-> GHandler sub master (OptionList a) -> Field sub master a
+selectFieldHelper outside onOpt inside opts' = Field
+	{ fieldParse = \x -> do
+		opts <- opts'
+		return $ selectParser opts x
+	, fieldView = \theId name attrs val isReq -> do
+		opts <- fmap olOptions $ lift opts'
+		outside theId name attrs $ do
+			unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
+			flip mapM_ opts $ \opt -> inside
+				theId
+				name
+				((if isReq then (("required", "required"):) else id) attrs)
+				(optionExternalValue opt)
+				((render opts val) == optionExternalValue opt)
+				(optionDisplay opt)
+	}
+  where
+	render _ (Left _) = ""
+	render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
+	selectParser _ [] = Right Nothing
+	selectParser opts (s:_) = case s of
+		"" -> Right Nothing
+		"none" -> Right Nothing
+		x -> case olReadExternal opts x of
+			Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
+			Just y -> Right $ Just y
+#endif
+
 {- Makes a note widget be displayed after a field. -}
 #if MIN_VERSION_yesod(1,2,0)
 withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v
@@ -67,7 +125,7 @@ withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (Str
 withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v
 #endif
 withExpandableNote field (toggle, note) = withNote field $ [whamlet|
-<a .btn data-toggle="collapse" data-target="##{ident}">#{toggle}</a>
+<a .btn .btn-default data-toggle="collapse" data-target="##{ident}">#{toggle}</a>
 <div ##{ident} .collapse>
   ^{note}
 |]
@@ -80,10 +138,27 @@ enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT sit
 #else
 enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption
 #endif
-enableEncryptionField = areq (selectFieldList choices) "Encryption" (Just SharedEncryption)
+enableEncryptionField = areq (selectFieldList choices) (bfs "Encryption") (Just SharedEncryption)
   where
 	choices :: [(Text, EnableEncryption)]
 	choices =
 		[ ("Encrypt all data", SharedEncryption)
 		, ("Disable encryption", NoEncryption)
 		]
+
+{- Defines the layout used by the Bootstrap3 form helper -}
+bootstrapFormLayout :: BootstrapFormLayout
+bootstrapFormLayout = BootstrapHorizontalForm (ColSm 0) (ColSm 2) (ColSm 0) (ColSm 10)
+
+{- Adds the form-control class used by Bootstrap3 for layout to a field
+ - This is the same as Yesod.Form.Bootstrap3.bfs except it takes just a Text
+ - parameter as I couldn't get the original bfs to compile due to type ambiguities.
+ -}
+bfs :: Text -> FieldSettings master
+bfs msg = FieldSettings
+	{ fsLabel = SomeMessage msg
+	, fsName  = Nothing
+	, fsId    = Nothing
+	, fsAttrs = [("class", "form-control")]
+	, fsTooltip = Nothing
+	}

Assistant/WebApp/Gpg.hs

@@ -27,11 +27,12 @@ import qualified Data.Map as M
 gpgKeyDisplay :: KeyId -> Maybe UserId -> Widget
 gpgKeyDisplay keyid userid = [whamlet|
   <span title="key id #{keyid}">
-    <i .icon-user></i> #
-      $maybe name <- userid
-        #{name}
-      $nothing
-        key id #{keyid}
+    <span .glyphicon .glyphicon-user>
+    \ 
+    $maybe name <- userid
+      #{name}
+    $nothing
+      key id #{keyid}
 |]
 
 genKeyModal :: Widget

Assistant/WebApp/Page.hs

@@ -59,14 +59,12 @@ customPage' with_longpolling navbaritem content = do
 		Nothing -> do
 			navbar <- map navdetails <$> selectNavBar
 			pageinfo <- widgetToPageContent $ do
-				addStylesheet $ StaticR bootstrap_css
-				addStylesheet $ StaticR bootstrap_responsive_css
-				addScript $ StaticR jquery_full_js
-				addScript $ StaticR bootstrap_dropdown_js
-				addScript $ StaticR bootstrap_modal_js
-				addScript $ StaticR bootstrap_collapse_js
+				addStylesheet $ StaticR css_bootstrap_css
+				addStylesheet $ StaticR css_bootstrap_theme_css
+				addScript $ StaticR js_jquery_full_js
+				addScript $ StaticR js_bootstrap_js
 				when with_longpolling $
-					addScript $ StaticR longpolling_js
+					addScript $ StaticR js_longpolling_js
 				$(widgetFile "page")
 			giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
 		Just msg -> error msg

Assistant/WebApp/RepoList.hs

@@ -113,10 +113,10 @@ cloudRepoList = repoListDisplay RepoSelector
 repoListDisplay :: RepoSelector -> Widget
 repoListDisplay reposelector = do
 	autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int)
-	addScript $ StaticR jquery_ui_core_js
-	addScript $ StaticR jquery_ui_widget_js
-	addScript $ StaticR jquery_ui_mouse_js
-	addScript $ StaticR jquery_ui_sortable_js
+	addScript $ StaticR js_jquery_ui_core_js
+	addScript $ StaticR js_jquery_ui_widget_js
+	addScript $ StaticR js_jquery_ui_mouse_js
+	addScript $ StaticR js_jquery_ui_sortable_js
 
 	repolist <- liftH $ repoList reposelector
 	let addmore = nudgeAddMore reposelector

Assistant/WebApp/SideBar.hs

@@ -38,7 +38,7 @@ sideBarDisplay = do
 	bootstrapclass :: AlertClass -> Text
 	bootstrapclass Activity = "alert-info"
 	bootstrapclass Warning = "alert"
-	bootstrapclass Error = "alert-error"
+	bootstrapclass Error = "alert-danger"
 	bootstrapclass Success = "alert-success"
 	bootstrapclass Message = "alert-info"
 
@@ -106,4 +106,4 @@ htmlIcon UpgradeIcon = bootstrapIcon "arrow-up"
 htmlIcon ConnectionIcon = bootstrapIcon "signal"
 
 bootstrapIcon :: Text -> Widget
-bootstrapIcon name = [whamlet|<i .icon-#{name}></i>|]
+bootstrapIcon name = [whamlet|<span .glyphicon .glyphicon-#{name}>|]

Assistant/WebApp/Types.hs

@@ -73,8 +73,10 @@ instance Yesod WebApp where
 	defaultLayout content = do
 		webapp <- getYesod
 		pageinfo <- widgetToPageContent $ do
-			addStylesheet $ StaticR bootstrap_css
-			addStylesheet $ StaticR bootstrap_responsive_css
+			addStylesheet $ StaticR css_bootstrap_css
+			addStylesheet $ StaticR css_bootstrap_theme_css
+			addScript $ StaticR js_jquery_full_js
+			addScript $ StaticR js_bootstrap_js
 			$(widgetFile "error")
 		giveUrlRenderer $(hamletFile $ hamletTemplate "bootstrap")