348 lines
12 KiB
Haskell
348 lines
12 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
module Handler.Utils.Form where
|
|
|
|
import Import
|
|
import qualified Data.Char as Char
|
|
import Handler.Utils.DateTime
|
|
import Data.String (IsString(..))
|
|
|
|
import qualified Data.Foldable as Foldable
|
|
|
|
-- import Yesod.Core
|
|
import qualified Data.Text as T
|
|
-- import Yesod.Form.Types
|
|
import Yesod.Form.Functions (parseHelper)
|
|
import Yesod.Form.Bootstrap3
|
|
|
|
import qualified Text.Blaze.Internal as Blaze (null)
|
|
|
|
import Web.PathPieces (showToPathPiece, readFromPathPiece)
|
|
|
|
------------------------------------------------
|
|
-- Unique Form Identifiers to avoid accidents --
|
|
------------------------------------------------
|
|
|
|
data FormIdentifier = FIDcourse | FIDsheet
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
|
|
|
|
identForm :: FormIdentifier -> Form a -> Form a
|
|
identForm fid = identifyForm (T.pack $ show fid)
|
|
|
|
-------------------
|
|
-- Form Renderer --
|
|
-------------------
|
|
|
|
-- | Use this type to pass information to the form template
|
|
data FormLayout = FormStandard
|
|
|
|
renderAForm :: Monad m => FormLayout -> FormRender m a
|
|
renderAForm formLayout aform fragment = do
|
|
(res, (($ []) -> views)) <- aFormToForm aform
|
|
let widget = $(widgetFile "form")
|
|
return (res, widget)
|
|
|
|
----------------------------
|
|
-- Buttons (new version ) --
|
|
----------------------------
|
|
|
|
data ButtonCssClass = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
|
|
bcc2txt :: ButtonCssClass -> Text -- a Hack; maybe define Read/Show manually
|
|
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))
|
|
|
|
class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
|
|
label :: a -> Widget
|
|
label = toWidget . toPathPiece
|
|
|
|
cssClass :: a -> ButtonCssClass
|
|
cssClass _ = BCDefault
|
|
|
|
|
|
|
|
{- Abort is not useful (press Back instead); Delete should be different:
|
|
data StandardButton = BtnDelete | BtnAbort | BtnSave
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
|
|
instance PathPiece StandardButton where -- for displaying the button only, not really for paths
|
|
toPathPiece = showToPathPiece
|
|
fromPathPiece = readFromPathPiece
|
|
|
|
instance Button StandardButton where
|
|
label BtnDelete = "Löschen"
|
|
label BtnAbort = "Abbrechen"
|
|
label BtnSave = "Speichern"
|
|
|
|
cssClass BtnDelete = BCWarning
|
|
cssClass BtnAbort = BCDefault
|
|
cssClass BtnSave = BCPrimary
|
|
-}
|
|
|
|
data SubmitButton = BtnSubmit
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
|
|
instance PathPiece SubmitButton where
|
|
toPathPiece = showToPathPiece
|
|
fromPathPiece = readFromPathPiece
|
|
|
|
instance Button SubmitButton where
|
|
label BtnSubmit = "Submit"
|
|
|
|
cssClass BtnSubmit = BCPrimary
|
|
|
|
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
|
|
-- data LinkButton = LinkButton (Route UniWorX)
|
|
-- deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
--
|
|
-- instance PathPiece LinkButton where
|
|
-- LinkButton route = ???
|
|
|
|
linkButton :: Widget -> ButtonCssClass -> Route UniWorX -> Widget
|
|
linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
|
|
-- [whamlet|
|
|
-- <form method=post action=@{url}>
|
|
-- <input type="hidden" name="_formid" value="identify-linkButton">
|
|
-- <button .btn .#{bcc2txt cls} type=submit value="Link to @{url}">^{lbl}
|
|
-- |]
|
|
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
|
|
|
|
|
|
buttonField :: Button a => a -> Field Handler a
|
|
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
|
|
where
|
|
fieldEnctype = UrlEncoded
|
|
|
|
fieldView fid name attrs _val _ =
|
|
[whamlet|
|
|
<button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
|
|
|]
|
|
|
|
fieldParse [] _ = return $ Right Nothing
|
|
fieldParse [str] _
|
|
| str == toPathPiece btn = return $ Right $ Just btn
|
|
| otherwise = return $ Left "Wrong button value"
|
|
fieldParse _ _ = return $ Left "Multiple button values"
|
|
|
|
|
|
combinedButtonField :: Button a => [a] -> AForm Handler [Maybe a]
|
|
combinedButtonField btns = traverse b2f btns
|
|
where
|
|
b2f b = aopt (buttonField b) "" Nothing
|
|
|
|
submitButton :: AForm Handler ()
|
|
submitButton = void $ combinedButtonField [BtnSubmit]
|
|
|
|
{-
|
|
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
|
|
combinedButtonField btns inner csrf = do
|
|
buttonIdent <- newFormIdent
|
|
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
|
|
(results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
|
|
(innerRes,innerWdgt) <- inner
|
|
let widget = do
|
|
[whamlet|
|
|
#{csrf}
|
|
^{innerWdgt}
|
|
<div .btn-group>
|
|
$forall bView <- btnViews
|
|
^{fvInput bView}
|
|
|]
|
|
let result = case (accResult result, innerRes) of
|
|
(FormSuccess b, FormSuccess i) -> FormSuccess (b,i)
|
|
_ -> FormFailure ["Something went wrong"] -- TODO
|
|
return (result,widget)
|
|
where
|
|
accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
|
|
accResult = Foldable.foldr accResult' FormMissing
|
|
|
|
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
|
|
accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
|
|
accResult' (FormSuccess (Just x)) _ = FormSuccess x
|
|
accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
|
|
accResult' (FormSuccess Nothing) x = x
|
|
accResult' FormMissing _ = FormMissing
|
|
accResult' (FormFailure errs) _ = FormFailure errs
|
|
-}
|
|
|
|
-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
|
|
buttonForm :: (Button a) => Form a
|
|
buttonForm csrf = do
|
|
buttonIdent <- newFormIdent
|
|
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
|
|
(results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
|
|
let widget = do
|
|
[whamlet|
|
|
#{csrf}
|
|
$forall bView <- btnViews
|
|
^{fvInput bView}
|
|
|]
|
|
return (accResult results,widget)
|
|
where
|
|
accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
|
|
accResult = Foldable.foldr accResult' FormMissing
|
|
|
|
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
|
|
accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
|
|
accResult' (FormSuccess (Just x)) _ = FormSuccess x
|
|
accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
|
|
accResult' (FormSuccess Nothing) x = x
|
|
accResult' FormMissing _ = FormMissing
|
|
accResult' (FormFailure errs) _ = FormFailure errs
|
|
|
|
|
|
---------------------------------------
|
|
-- Buttons (old version, deprecated) --
|
|
---------------------------------------
|
|
|
|
formBtnSave :: (Text,Text,Text)
|
|
formBtnSave = ("save" ,"Speichern" ,"btn-primary")
|
|
|
|
formBtnAbort :: (Text,Text,Text)
|
|
formBtnAbort = ("abort" ,"Abbrechen" ,"btn-default")
|
|
|
|
formBtnDelete ::(Text,Text,Text)
|
|
formBtnDelete = ("delete","Löschen" ,"btn-warning")
|
|
|
|
formActionSave :: Maybe Text
|
|
formActionSave = Just $ fst3 formBtnSave
|
|
|
|
formActionAbort :: Maybe Text
|
|
formActionAbort = Just $ fst3 formBtnAbort
|
|
|
|
formActionDelete :: Maybe Text
|
|
formActionDelete = Just $ fst3 formBtnDelete
|
|
|
|
defaultFormActions :: [(Text,Text,Text)]
|
|
defaultFormActions = [ formBtnDelete
|
|
, formBtnAbort
|
|
, formBtnSave
|
|
]
|
|
|
|
-- Post-Buttons
|
|
postButtonForm :: Text -> Form ()
|
|
postButtonForm lblId = identifyForm lblId buttonF
|
|
where
|
|
buttonF = renderAForm FormStandard $ pure () <* bootstrapSubmit bProps
|
|
bProps :: BootstrapSubmit Text
|
|
bProps = fromString $ unpack lblId
|
|
|
|
|
|
------------
|
|
-- Fields --
|
|
------------
|
|
|
|
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
|
|
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intField
|
|
|
|
posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
|
|
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") $ intField
|
|
|
|
minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
|
|
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
|
|
|
|
|
|
--termField: see Utils.Term
|
|
|
|
schoolField :: Field Handler SchoolId
|
|
schoolField = selectField schools
|
|
where
|
|
schools = optionsPersistKey [] [Asc SchoolName] schoolName
|
|
|
|
schoolEntField :: Field Handler (Entity School)
|
|
schoolEntField = selectField schools
|
|
where
|
|
schools = optionsPersist [] [Asc SchoolName] schoolName
|
|
|
|
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
|
|
sheetTypeAFormReq d Nothing =
|
|
-- TODO, offer options to choose between Normal/Bonus/Pass
|
|
(Normal . toPoints) <$> areq (natField "Punkte") d Nothing
|
|
sheetTypeAFormReq d (Just (Normal p)) =
|
|
-- TODO, offer options to choose between Normal/Bonus/Pass
|
|
(Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
|
|
|
|
utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
|
|
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
|
|
utcTimeField = Field
|
|
{ fieldParse = parseHelper $ readTime
|
|
, fieldView = \theId name attrs val isReq ->
|
|
[whamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{either id showTime val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where
|
|
fieldTimeFormat :: String
|
|
--fieldTimeFormat = "%e.%m.%y %k:%M"
|
|
fieldTimeFormat = "%Y-%m-%eT%H:%M"
|
|
|
|
readTime :: Text -> Either FormMessage UTCTime
|
|
readTime t =
|
|
case parseTimeM True germanTimeLocale fieldTimeFormat (T.unpack t) of
|
|
(Just time) -> Right time
|
|
Nothing -> Left $ MsgInvalidEntry $ "Datum/Zeit Format: tt.mm.yy hh:mm " ++ t
|
|
|
|
showTime :: UTCTime -> Text
|
|
showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)
|
|
|
|
|
|
fsb :: Text -> FieldSettings site
|
|
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
|
|
|
|
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
|
|
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
|
|
where
|
|
newAttrs :: [(Text,Text)] -> [(Text,Text)]
|
|
newAttrs [] = [(attr,valu)]
|
|
newAttrs (p@(a,v):t)
|
|
| attr==a = (a,T.append valu $ cons ' ' v):t
|
|
| otherwise = p:(newAttrs t)
|
|
|
|
addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
|
|
addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
|
|
where
|
|
newAttrs :: [(Text,Text)] -> [(Text,Text)]
|
|
newAttrs [] = [(attr,T.intercalate " " valus)]
|
|
newAttrs (p@(a,v):t)
|
|
| attr==a = (a,T.intercalate " " (v:valus)):t
|
|
| otherwise = p:(newAttrs t)
|
|
|
|
addClass :: Text -> FieldSettings site -> FieldSettings site
|
|
addClass = addAttr "class"
|
|
|
|
addClasses :: [Text] -> FieldSettings site -> FieldSettings site
|
|
addClasses = addAttrs "class"
|
|
|
|
addName :: Text -> FieldSettings site -> FieldSettings site
|
|
addName nm fs = fs { fsName = Just nm }
|
|
|
|
addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
|
|
addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
|
|
|
|
addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
|
|
addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
|
|
|
|
|
|
setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
|
|
setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
|
|
|
|
setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
|
|
setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
|
|
|
|
setTooltip :: String -> FieldSettings site -> FieldSettings site
|
|
setTooltip tt fs
|
|
| null tt = fs { fsTooltip = Nothing }
|
|
| otherwise = fs { fsTooltip = Just $ fromString tt }
|
|
|