Dropped support for older versions of yesod and warp than the ones in Debian Jessie.

466 lines of compat cruft deleted!
This commit is contained in:
Joey Hess 2015-04-22 16:19:05 -04:00
parent a15e1158c6
commit eb8ef44133
13 changed files with 19 additions and 466 deletions

View file

@ -1,260 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
-- | 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
renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
renderBootstrap3 formLayout aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
has (Just _) = True
has Nothing = False
widget = [whamlet|
#{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 BootstrapHorizontalForm _a _b _c _d
$if nequals (fvId view) bootstrapSubmitId
<label .control-label .#{toOffset (bflLabelOffset formLayout)} .#{toColumn (bflLabelSize formLayout)} for=#{fvId view}>#{fvLabel view}
<div .#{toOffset (bflInputOffset formLayout)} .#{toColumn (bflInputSize formLayout)}>
^{fvInput view}
^{helpWidget view}
$else
<div .#{toOffset (addGO (bflInputOffset formLayout) (addGO (bflLabelOffset formLayout) (bflLabelSize formLayout)))} .#{toColumn (bflInputSize formLayout)}>
^{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.
helpWidget :: FieldView sub master -> GWidget sub master ()
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
bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
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
mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
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"

View file

@ -5,8 +5,6 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.WebApp.Common (module X) where
import Assistant.Common as X
@ -15,9 +13,5 @@ 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)

View file

@ -50,18 +50,10 @@ data RepositoryPath = RepositoryPath Text
-
- Validates that the path entered is not empty, and is a safe value
- to use as a repository. -}
#if MIN_VERSION_yesod(1,2,0)
repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text
#else
repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
#endif
repositoryPathField autofocus = Field
#if ! MIN_VERSION_yesod_form(1,2,0)
{ fieldParse = parse
#else
{ fieldParse = \l _ -> parse l
, fieldEnctype = UrlEncoded
#endif
, fieldView = view
}
where

View file

@ -86,11 +86,7 @@ mkSshInput s = SshInput
, inputPort = sshPort s
}
#if MIN_VERSION_yesod(1,2,0)
sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
#else
sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
#endif
sshInputAForm hostnamefield d = normalize <$> gen
where
gen = SshInput

View file

@ -8,28 +8,15 @@
{-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses, TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings, RankNTypes #-}
{-# LANGUAGE CPP #-}
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)
import Data.String (IsString (..))
import Control.Monad (unless)
import Data.Maybe (listToMaybe)
#endif
#if MIN_VERSION_yesod_form(1,3,8)
import Yesod.Form.Bootstrap3 as Y hiding (bfs)
#else
import Assistant.WebApp.Bootstrap3 as Y hiding (bfs)
#endif
import Data.Text (Text)
{- Yesod's textField sets the required attribute for required fields.
@ -61,60 +48,8 @@ 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
#else
withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
#endif
withNote field note = field { fieldView = newview }
where
newview theId name attrs val isReq =
@ -122,11 +57,7 @@ withNote field note = field { fieldView = newview }
in [whamlet|^{fieldwidget}&nbsp;&nbsp;<span>^{note}</span>|]
{- Note that the toggle string must be unique on the form. -}
#if MIN_VERSION_yesod(1,2,0)
withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (String, w) -> Field m v
#else
withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v
#endif
withExpandableNote field (toggle, note) = withNote field $ [whamlet|
<a .btn .btn-default data-toggle="collapse" data-target="##{ident}">#{toggle}</a>
<div ##{ident} .collapse>
@ -136,11 +67,7 @@ withExpandableNote field (toggle, note) = withNote field $ [whamlet|
ident = "toggle_" ++ toggle
{- Adds a check box to an AForm to control encryption. -}
#if MIN_VERSION_yesod(1,2,0)
enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption
#else
enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption
#endif
enableEncryptionField = areq (selectFieldList choices) (bfs "Encryption") (Just SharedEncryption)
where
choices :: [(Text, EnableEncryption)]

View file

@ -5,13 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
#if defined VERSION_yesod_default
#if ! MIN_VERSION_yesod_default(1,1,0)
#define WITH_OLD_YESOD
#endif
#endif
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Notifications where
@ -26,9 +20,7 @@ import Utility.WebApp
import Data.Text (Text)
import qualified Data.Text as T
#ifndef WITH_OLD_YESOD
import qualified Data.Aeson.Types as Aeson
#endif
{- Add to any widget to make it auto-update using long polling.
-
@ -42,15 +34,9 @@ import qualified Data.Aeson.Types as Aeson
-}
autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget
autoUpdate tident geturl ms_delay ms_startdelay = do
#ifdef WITH_OLD_YESOD
let delay = show ms_delay
let startdelay = show ms_startdelay
let ident = "'" ++ T.unpack tident ++ "'"
#else
let delay = Aeson.String (T.pack (show ms_delay))
let startdelay = Aeson.String (T.pack (show ms_startdelay))
let ident = Aeson.String tident
#endif
$(widgetFile "notifications/longpolling")
{- Notifier urls are requested by the javascript, to avoid allocation

View file

@ -8,7 +8,6 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Assistant.WebApp.Types where
@ -83,58 +82,30 @@ instance Yesod WebApp where
instance RenderMessage WebApp FormMessage where
renderMessage _ _ = defaultFormMessage
#if MIN_VERSION_yesod(1,2,0)
instance LiftAnnex Handler where
#else
instance LiftAnnex (GHandler sub WebApp) where
#endif
liftAnnex a = ifM (noAnnex <$> getYesod)
( error "internal liftAnnex"
, liftAssistant $ liftAnnex a
)
#if MIN_VERSION_yesod(1,2,0)
instance LiftAnnex (WidgetT WebApp IO) where
#else
instance LiftAnnex (GWidget WebApp WebApp) where
#endif
liftAnnex = liftH . liftAnnex
class LiftAssistant m where
liftAssistant :: Assistant a -> m a
#if MIN_VERSION_yesod(1,2,0)
instance LiftAssistant Handler where
#else
instance LiftAssistant (GHandler sub WebApp) where
#endif
liftAssistant a = liftIO . flip runAssistant a
=<< assistantData <$> getYesod
#if MIN_VERSION_yesod(1,2,0)
instance LiftAssistant (WidgetT WebApp IO) where
#else
instance LiftAssistant (GWidget WebApp WebApp) where
#endif
liftAssistant = liftH . liftAssistant
#if MIN_VERSION_yesod(1,2,0)
type MkMForm x = MForm Handler (FormResult x, Widget)
#else
type MkMForm x = MForm WebApp WebApp (FormResult x, Widget)
#endif
#if MIN_VERSION_yesod(1,2,0)
type MkAForm x = AForm Handler x
#else
type MkAForm x = AForm WebApp WebApp x
#endif
#if MIN_VERSION_yesod(1,2,0)
type MkField x = Monad m => RenderMessage (HandlerSite m) FormMessage => Field m x
#else
type MkField x = RenderMessage master FormMessage => Field sub master x
#endif
data RepoSelector = RepoSelector
{ onlyCloud :: Bool
@ -154,12 +125,6 @@ data RemovableDrive = RemovableDrive
data RepoKey = RepoKey KeyId | NoRepoKey
deriving (Read, Show, Eq, Ord)
#if ! MIN_VERSION_path_pieces(0,1,4)
instance PathPiece Bool where
toPathPiece = pack . show
fromPathPiece = readish . unpack
#endif
instance PathPiece RemovableDrive where
toPathPiece = pack . show
fromPathPiece = readish . unpack