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
parent
a15e1158c6
commit
eb8ef44133
13 changed files with 19 additions and 466 deletions
|
|
@ -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"
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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} <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)]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -94,11 +94,7 @@ fixSockAddr addr = addr
|
|||
-- disable buggy sloworis attack prevention code
|
||||
webAppSettings :: Settings
|
||||
|
||||
#if MIN_VERSION_warp(2,1,0)
|
||||
webAppSettings = setTimeout halfhour defaultSettings
|
||||
#else
|
||||
webAppSettings = defaultSettings { settingsTimeout = halfhour }
|
||||
#endif
|
||||
where
|
||||
halfhour = 30 * 60
|
||||
|
||||
|
|
@ -155,11 +151,7 @@ lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
|
|||
|
||||
{- Rather than storing a session key on disk, use a random key
|
||||
- that will only be valid for this run of the webapp. -}
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe Yesod.SessionBackend)
|
||||
#else
|
||||
webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe (Yesod.SessionBackend y))
|
||||
#endif
|
||||
webAppSessionBackend _ = do
|
||||
g <- newGenIO :: IO SystemRandom
|
||||
case genBytes 96 g of
|
||||
|
|
@ -170,18 +162,8 @@ webAppSessionBackend _ = do
|
|||
where
|
||||
timeout = 120 * 60 -- 120 minutes
|
||||
use key =
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
Just . Yesod.clientSessionBackend key . fst
|
||||
<$> Yesod.clientSessionDateCacher timeout
|
||||
#else
|
||||
#if MIN_VERSION_yesod(1,1,7)
|
||||
Just . Yesod.clientSessionBackend2 key . fst
|
||||
<$> Yesod.clientSessionDateCacher timeout
|
||||
#else
|
||||
return $ Just $
|
||||
Yesod.clientSessionBackend key timeout
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifdef WITH_WEBAPP_SECURE
|
||||
type AuthToken = SecureMem
|
||||
|
|
@ -219,11 +201,7 @@ genAuthToken = do
|
|||
- Note that the usual Yesod error page is bypassed on error, to avoid
|
||||
- possibly leaking the auth token in urls on that page!
|
||||
-}
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
checkAuthToken :: (Monad m, Yesod.MonadHandler m) => (Yesod.HandlerSite m -> AuthToken) -> m Yesod.AuthResult
|
||||
#else
|
||||
checkAuthToken :: forall t sub. (t -> AuthToken) -> Yesod.GHandler sub t Yesod.AuthResult
|
||||
#endif
|
||||
checkAuthToken extractAuthToken = do
|
||||
webapp <- Yesod.getYesod
|
||||
req <- Yesod.getRequest
|
||||
|
|
|
|||
|
|
@ -19,70 +19,38 @@ module Utility.Yesod
|
|||
#endif
|
||||
#if ! MIN_VERSION_yesod(1,4,0)
|
||||
, withUrlRenderer
|
||||
#endif
|
||||
#if ! MIN_VERSION_yesod(1,2,0)
|
||||
, Html
|
||||
#endif
|
||||
) where
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
import Yesod as Y
|
||||
#else
|
||||
import Yesod as Y hiding (Html)
|
||||
#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
|
||||
#ifndef __NO_TH__
|
||||
import Yesod.Default.Util
|
||||
import Language.Haskell.TH.Syntax (Q, Exp)
|
||||
#if MIN_VERSION_yesod_default(1,1,0)
|
||||
import Data.Default (def)
|
||||
import Text.Hamlet hiding (Html)
|
||||
#endif
|
||||
#endif
|
||||
#if ! MIN_VERSION_yesod(1,4,0)
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
import Data.Text (Text)
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifndef __NO_TH__
|
||||
widgetFile :: String -> Q Exp
|
||||
#if ! MIN_VERSION_yesod_default(1,1,0)
|
||||
widgetFile = widgetFileNoReload
|
||||
#else
|
||||
widgetFile = widgetFileNoReload $ def
|
||||
{ wfsHamletSettings = defaultHamletSettings
|
||||
{ hamletNewlines = AlwaysNewlines
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
hamletTemplate :: FilePath -> FilePath
|
||||
hamletTemplate f = globFile "hamlet" f
|
||||
#endif
|
||||
|
||||
{- Lift Handler to Widget -}
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
liftH :: Monad m => HandlerT site m a -> WidgetT site m a
|
||||
liftH = handlerToWidget
|
||||
#else
|
||||
liftH :: MonadLift base m => base a -> m a
|
||||
liftH = lift
|
||||
#endif
|
||||
|
||||
{- Misc new names for stuff. -}
|
||||
#if ! MIN_VERSION_yesod(1,2,0)
|
||||
withUrlRenderer :: forall master sub. HtmlUrl (Route master) -> GHandler sub master RepHtml
|
||||
withUrlRenderer = hamletToRepHtml
|
||||
|
||||
type Html = RepHtml
|
||||
#else
|
||||
#if ! MIN_VERSION_yesod_core(1,2,20)
|
||||
withUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output
|
||||
withUrlRenderer = giveUrlRenderer
|
||||
#endif
|
||||
#endif
|
||||
|
|
|
|||
2
debian/changelog
vendored
2
debian/changelog
vendored
|
|
@ -1,6 +1,8 @@
|
|||
git-annex (5.20150421) UNRELEASED; urgency=medium
|
||||
|
||||
* S3: Enable debug logging when annex.debug or --debug is set.
|
||||
* Dropped support for older versions of yesod and warp than the ones
|
||||
in Debian Jessie.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Tue, 21 Apr 2015 15:54:10 -0400
|
||||
|
||||
|
|
|
|||
10
debian/control
vendored
10
debian/control
vendored
|
|
@ -33,13 +33,15 @@ Build-Depends:
|
|||
libghc-stm-dev (>= 2.3),
|
||||
libghc-dbus-dev (>= 0.10.3) [linux-any],
|
||||
libghc-fdo-notify-dev (>= 0.3) [linux-any],
|
||||
libghc-yesod-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-yesod-static-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-yesod-default-dev [i386 amd64 kfreebsd-amd64 powerpc],
|
||||
libghc-yesod-dev (>= 1.2.6.1) [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-yesod-core-dev (>= 1.2.19) [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-yesod-form-dev (>= 1.3.15) [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-yesod-static-dev (>= 1.2.4) [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-yesod-default-dev (>= 1.2.0) [i386 amd64 kfreebsd-amd64 powerpc],
|
||||
libghc-hamlet-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-shakespeare-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-clientsession-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-warp-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-warp-dev (>= 3.0.0.5) [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-warp-tls-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-wai-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
libghc-wai-extra-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc],
|
||||
|
|
|
|||
4
debian/copyright
vendored
4
debian/copyright
vendored
|
|
@ -28,10 +28,6 @@ Files: Utility/Gpg.hs Utility/DirWatcher*
|
|||
Copyright: © 2010-2014 Joey Hess <id@joeyh.name>
|
||||
License: GPL-3+
|
||||
|
||||
Files: Assistant/WebApp/Bootstrap3.hs
|
||||
Copyright: 2010 Michael Snoyman
|
||||
License: BSD-2-clause
|
||||
|
||||
Files: doc/logo* */favicon.ico standalone/osx/git-annex.app/Contents/Resources/git-annex.icns standalone/android/icons/*
|
||||
Copyright: 2007 Henrik Nyh <http://henrik.nyh.se/>
|
||||
2010 Joey Hess <id@joeyh.name>
|
||||
|
|
|
|||
|
|
@ -199,10 +199,17 @@ Executable git-annex
|
|||
|
||||
if flag(Webapp)
|
||||
Build-Depends:
|
||||
yesod, yesod-default, yesod-static, yesod-form, yesod-core,
|
||||
wai, wai-extra, warp, warp-tls,
|
||||
yesod (>= 1.2.6),
|
||||
yesod-default (>= 1.2.0),
|
||||
yesod-static (>= 1.2.4),
|
||||
yesod-form (>= 1.3.15),
|
||||
yesod-core (>= 1.2.19),
|
||||
path-pieces (>= 0.1.4),
|
||||
warp (>= 3.0.0.5),
|
||||
warp-tls,
|
||||
wai, wai-extra,
|
||||
blaze-builder, crypto-api, hamlet, clientsession,
|
||||
template-haskell, aeson, path-pieces,
|
||||
template-haskell, aeson,
|
||||
shakespeare
|
||||
CPP-Options: -DWITH_WEBAPP
|
||||
if flag(Webapp) && flag (Webapp-secure)
|
||||
|
|
|
|||
Loading…
Reference in a new issue