436 lines
16 KiB
Haskell
436 lines
16 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Handler.Utils.Form
|
|
( module Handler.Utils.Form
|
|
, module Utils.Form
|
|
) where
|
|
|
|
import Utils.Form
|
|
|
|
import Handler.Utils.Form.Types
|
|
import Handler.Utils.Templates
|
|
|
|
import Handler.Utils.DateTime
|
|
import qualified Data.Time as Time
|
|
|
|
import Import
|
|
import qualified Data.Char as Char
|
|
import Data.String (IsString(..))
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
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 Web.PathPieces (showToPathPiece, readFromPathPiece)
|
|
|
|
import Handler.Utils.Zip
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Internal.Sql as E
|
|
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
|
|
import Control.Monad.Writer.Class
|
|
|
|
import Data.Scientific (Scientific)
|
|
import Data.Ratio
|
|
import Text.Read (readMaybe)
|
|
|
|
----------------------------
|
|
-- Buttons (new version ) --
|
|
----------------------------
|
|
|
|
data BtnDelete = BtnDelete | BtnAbort
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
|
|
instance PathPiece BtnDelete where -- for displaying the button only, not really for paths
|
|
toPathPiece = showToPathPiece
|
|
fromPathPiece = readFromPathPiece
|
|
|
|
instance Button UniWorX BtnDelete where
|
|
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
|
|
label BtnAbort = [whamlet|_{MsgBtnAbort}|]
|
|
|
|
cssClass BtnDelete = BCDanger
|
|
cssClass BtnAbort = BCDefault
|
|
|
|
data RegisterButton = BtnRegister | BtnDeregister
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
|
|
instance PathPiece RegisterButton where
|
|
toPathPiece = showToPathPiece
|
|
fromPathPiece = readFromPathPiece
|
|
|
|
instance Button UniWorX RegisterButton where
|
|
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
|
|
label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
|
|
|
|
cssClass BtnRegister = BCPrimary
|
|
cssClass BtnDeregister = BCDanger
|
|
|
|
data AdminHijackUserButton = BtnHijack
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
|
|
instance PathPiece AdminHijackUserButton where
|
|
toPathPiece = showToPathPiece
|
|
fromPathPiece = readFromPathPiece
|
|
|
|
instance Button UniWorX AdminHijackUserButton where
|
|
label BtnHijack = [whamlet|_{MsgBtnHijack}|]
|
|
|
|
cssClass BtnHijack = BCDefault
|
|
|
|
|
|
-- -- 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 UniWorX -> 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}>
|
|
|
|
simpleLink :: Widget -> Route UniWorX -> Widget
|
|
simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
|
|
|
|
|
|
{-
|
|
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 UniWorX 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
|
|
|
|
|
|
|
|
------------
|
|
-- Fields --
|
|
------------
|
|
|
|
ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a)
|
|
ciField = convertField CI.mk CI.original
|
|
|
|
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
|
|
natFieldI msg = checkBool (>= 0) msg intField
|
|
|
|
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
|
|
|
|
natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
|
|
natIntField = natField
|
|
|
|
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
|
|
|
|
pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
|
|
pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
|
|
where
|
|
fieldEnctype = UrlEncoded
|
|
fieldView theId name attrs val isReq
|
|
= [whamlet|
|
|
$newline never
|
|
<input id=#{theId} name=#{name} *{attrs} type=number step="0.01" :isReq:required value=#{either id tshow val}>
|
|
|]
|
|
fieldParse = parseHelper $ \t -> do
|
|
sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
|
|
return . fromRational $ round (sci * 100) % 100
|
|
|
|
--termField: see Utils.Term
|
|
|
|
schoolField :: Field Handler SchoolId
|
|
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
|
|
|
|
schoolFieldEnt :: Field Handler (Entity School)
|
|
schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
|
|
|
|
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
|
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolId <-. userSchools] [Asc SchoolName] schoolName
|
|
|
|
zipFileField :: Bool -- ^ Unpack zips?
|
|
-> Field Handler (Source Handler File)
|
|
zipFileField doUnpack = Field{..}
|
|
where
|
|
fieldEnctype = Multipart
|
|
fieldParse _ files
|
|
| [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
|
|
| null files = return $ Right Nothing
|
|
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
|
|
fieldView fieldId fieldName attrs _ req = do
|
|
[whamlet|
|
|
$newline never
|
|
<input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
|
|
|]
|
|
|
|
multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
|
|
multiFileField permittedFiles' = Field{..}
|
|
where
|
|
fieldEnctype = Multipart
|
|
fieldParse vals files
|
|
| null files
|
|
, null vals = return $ Right Nothing
|
|
| otherwise = return . Right . Just $ do
|
|
pVals <- lift permittedFiles'
|
|
let
|
|
decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
|
|
decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
|
|
yieldMany vals
|
|
.| C.filter (/= unpackZips)
|
|
.| C.map fromPathPiece .| C.catMaybes
|
|
.| C.mapMaybeM decrypt'
|
|
.| C.filter (`elem` pVals)
|
|
.| C.map Left
|
|
let
|
|
handleFile :: FileInfo -> Source Handler File
|
|
handleFile
|
|
| doUnpack = sourceFiles
|
|
| otherwise = yieldM . acceptFile
|
|
mapM_ handleFile files .| C.map Right
|
|
where
|
|
doUnpack = unpackZips `elem` vals
|
|
fieldView fieldId fieldName attrs val req = do
|
|
pVals <- handlerToWidget permittedFiles'
|
|
sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
|
|
let
|
|
toFUI (E.Value fuiId', E.Value fuiTitle) = do
|
|
fuiId <- encrypt fuiId'
|
|
fuiHtmlId <- newIdent
|
|
let fuiChecked
|
|
| Right sentVals' <- sentVals = fuiId' `elem` sentVals'
|
|
| otherwise = True
|
|
return FileUploadInfo{..}
|
|
fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
|
|
E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
|
|
E.orderBy [E.asc $ file E.^. FileTitle]
|
|
return (file E.^. FileId, file E.^. FileTitle)
|
|
$(widgetFile "multiFileField")
|
|
unpackZips :: Text
|
|
unpackZips = "unpack-zip"
|
|
takeLefts :: Monad m => ConduitM (Either b a) b m ()
|
|
takeLefts = awaitForever $ \case
|
|
Right _ -> return ()
|
|
Left r -> yield r
|
|
|
|
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)
|
|
sheetTypeAFormReq d (Just (NotGraded)) = pure NotGraded
|
|
|
|
|
|
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
|
|
sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
|
|
-- TODO, offer options to choose between Arbitrary/Registered/NoGroups
|
|
Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
|
|
sheetGroupAFormReq d _other = -- TODO
|
|
-- TODO, offer options to choose between Arbitrary/Registered/NoGroups
|
|
Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
|
|
|
|
{-
|
|
dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
|
|
dayTimeField fs mutc = do
|
|
let (mbDay,mbTime) = case mutcs of
|
|
Nothing -> return (Nothing,Nothing)
|
|
(Just utc) ->
|
|
|
|
(dayResult, dayView) <- mreq dayField fs
|
|
|
|
(result, view) <- (,) <$> dayField <*> timeField
|
|
where
|
|
(mbDay,mbTime)
|
|
| (Just utc) <- mutc =
|
|
let lt = utcToLocalTime ??? utcs
|
|
in (Just $ localDay lt, Just $ localTimeOfDay lt)
|
|
| otherwise = (Nothing,Nothing)
|
|
-}
|
|
|
|
|
|
utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
|
|
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
|
|
-- Browser returns LocalTime
|
|
utcTimeField = Field
|
|
{ fieldParse = parseHelperGen $ readTime
|
|
, fieldView = \theId name attrs val isReq -> do
|
|
val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
|
|
[whamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{val'}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where
|
|
fieldTimeFormat :: String
|
|
--fieldTimeFormat = "%e.%m.%y %k:%M"
|
|
fieldTimeFormat = "%Y-%m-%dT%H:%M"
|
|
|
|
-- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
|
|
readTime :: Text -> Either UniWorXMessage UTCTime
|
|
readTime t =
|
|
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
|
|
(Just (LTUUnique time _)) -> Right time
|
|
(Just (LTUNone _ _)) -> Left MsgIllDefinedUTCTime
|
|
(Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
|
|
Nothing -> Left MsgInvalidDateTimeFormat
|
|
|
|
|
|
fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
|
|
fsm = bfs -- TODO: get rid of Bootstrap
|
|
|
|
fsb :: Text -> FieldSettings site -- DEPRECATED
|
|
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
|
|
|
|
optionsPersistCryptoId :: forall site backend a msg.
|
|
( YesodPersist site
|
|
, PersistQueryRead backend
|
|
, HasCryptoUUID (Key a) (HandlerT site IO)
|
|
, RenderMessage site msg
|
|
, YesodPersistBackend site ~ backend
|
|
, PersistRecordBackend a backend
|
|
)
|
|
=> [Filter a]
|
|
-> [SelectOpt a]
|
|
-> (a -> msg)
|
|
-> HandlerT site IO (OptionList (Entity a))
|
|
optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
|
|
mr <- getMessageRender
|
|
pairs <- runDB $ selectList filts ords
|
|
cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e
|
|
return $ map (\(cId, e@(Entity key value)) -> Option
|
|
{ optionDisplay = mr (toDisplay value)
|
|
, optionInternalValue = e
|
|
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
|
|
}) cPairs
|
|
|
|
optionsFinite :: ( MonadHandler m, Finite a, RenderMessage site msg, HandlerSite m ~ site, PathPiece a )
|
|
=> (a -> msg) -> m (OptionList a)
|
|
optionsFinite toMsg = do
|
|
mr <- getMessageRender
|
|
let
|
|
mkOption a = Option
|
|
{ optionDisplay = mr $ toMsg a
|
|
, optionInternalValue = a
|
|
, optionExternalValue = toPathPiece a
|
|
}
|
|
return . mkOptionList $ mkOption <$> universeF
|
|
|
|
mforced :: (site ~ HandlerSite m, MonadHandler m)
|
|
=> Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
|
|
mforced Field{..} FieldSettings{..} val = do
|
|
tell fieldEnctype
|
|
name <- maybe newFormIdent return fsName
|
|
theId <- lift $ maybe newIdent return fsId
|
|
mr <- getMessageRender
|
|
let fsAttrs' = fsAttrs <> [("disabled", "")]
|
|
return ( FormSuccess val
|
|
, FieldView
|
|
{ fvLabel = toHtml $ mr fsLabel
|
|
, fvTooltip = toHtml <$> fmap mr fsTooltip
|
|
, fvId = theId
|
|
, fvInput = fieldView theId name fsAttrs' (Right val) False
|
|
, fvErrors = Nothing
|
|
, fvRequired = False
|
|
}
|
|
)
|
|
|
|
aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
|
=> Field m a -> FieldSettings site -> a -> AForm m a
|
|
aforced field settings val = formToAForm $ second pure <$> mforced field settings val
|
|
|
|
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
|
=> Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
|
|
-> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
|
|
multiAction acts = do
|
|
mr <- getMessageRender
|
|
let
|
|
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
|
|
(actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
|
|
results <- sequence acts
|
|
let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
|
|
actionResults = Map.map fst results
|
|
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))
|