684 lines
26 KiB
Haskell
684 lines
26 KiB
Haskell
module Handler.Utils.Form
|
|
( module Handler.Utils.Form
|
|
, module Utils.Form
|
|
, MonadWriter(..)
|
|
) where
|
|
|
|
import Utils.Form
|
|
|
|
import Handler.Utils.Form.Types
|
|
|
|
import Handler.Utils.DateTime
|
|
|
|
import Import hiding (cons)
|
|
import qualified Data.Char as Char
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
-- import Yesod.Core
|
|
import qualified Data.Text as T
|
|
-- import Yesod.Form.Types
|
|
import Yesod.Form.Functions (parseHelper)
|
|
import Yesod.Form.Bootstrap3
|
|
|
|
import Handler.Utils.Zip
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Database.Esqueleto 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.Trans.Writer (execWriterT, WriterT)
|
|
import Control.Monad.Except (runExceptT)
|
|
import Control.Monad.Writer.Class
|
|
|
|
import Data.Scientific (Scientific)
|
|
import Data.Ratio
|
|
import Text.Read (readMaybe)
|
|
import Text.Blaze (ToMarkup)
|
|
import Text.Hamlet (shamletFile)
|
|
|
|
import Utils.Lens
|
|
|
|
import Data.Aeson (eitherDecodeStrict')
|
|
import Data.Aeson.Text (encodeToLazyText)
|
|
|
|
----------------------------
|
|
-- Buttons (new version ) --
|
|
----------------------------
|
|
|
|
data ButtonDelete = BtnDelete
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonDelete
|
|
instance Finite ButtonDelete
|
|
|
|
nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonDelete id
|
|
instance Button UniWorX ButtonDelete where
|
|
btnClasses BtnDelete = [BCIsButton, BCDanger]
|
|
|
|
data ButtonRegister = BtnRegister | BtnDeregister
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonRegister
|
|
instance Finite ButtonRegister
|
|
|
|
nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonRegister id
|
|
instance Button UniWorX ButtonRegister where
|
|
btnClasses BtnRegister = [BCIsButton, BCPrimary]
|
|
btnClasses BtnDeregister = [BCIsButton, BCDanger]
|
|
|
|
data ButtonHijack = BtnHijack
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonHijack
|
|
instance Finite ButtonHijack
|
|
|
|
nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonHijack id
|
|
instance Button UniWorX ButtonHijack where
|
|
btnClasses BtnHijack = [BCIsButton, BCDefault]
|
|
|
|
data ButtonSubmitDelete = BtnSubmit' | BtnDelete'
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe ButtonSubmitDelete
|
|
instance Finite ButtonSubmitDelete
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'"
|
|
instance Button UniWorX ButtonSubmitDelete where
|
|
btnClasses BtnSubmit' = [BCIsButton, BCPrimary]
|
|
btnClasses BtnDelete' = [BCIsButton, BCDanger]
|
|
|
|
btnValidate _ BtnSubmit' = True
|
|
btnValidate _ BtnDelete' = False
|
|
|
|
nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
|
|
|
|
|
|
-- -- 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 -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
|
|
linkButton lbl cls url = do
|
|
url' <- toTextUrl url
|
|
[whamlet|
|
|
$newline never
|
|
<a href=#{url'} class=#{unwords $ map toPathPiece 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}>
|
|
|
|
|
|
-- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
|
|
buttonForm :: (Button UniWorX a, Finite a) => Form a
|
|
buttonForm csrf = do
|
|
(res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
|
|
return (res, [whamlet|
|
|
$newline never
|
|
#{csrf}
|
|
$forall bView <- fViews
|
|
^{fvInput bView}
|
|
|])
|
|
|
|
|
|
|
|
------------
|
|
-- Fields --
|
|
------------
|
|
|
|
-- ciField moved to Utils.Form
|
|
|
|
routeField :: ( Monad m
|
|
, HandlerSite m ~ UniWorX
|
|
) => Field m (Route UniWorX)
|
|
routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
|
|
|
|
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
|
|
|
|
pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions
|
|
pointsFieldMax Nothing = pointsField
|
|
pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField
|
|
|
|
termsActiveField :: Field Handler TermId
|
|
termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
|
|
|
termsAllowedField :: Field Handler TermId
|
|
termsAllowedField = selectField $ do
|
|
mayEditTerm <- isAuthorized TermEditR True
|
|
let termFilter | Authorized <- mayEditTerm = []
|
|
| otherwise = [TermActive ==. True]
|
|
optionsPersistKey termFilter [Desc TermStart] termName
|
|
|
|
termsSetField :: [TermId] -> Field Handler TermId
|
|
termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
|
|
-- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
|
|
|
|
termsActiveOrSetField :: [TermId] -> Field Handler TermId
|
|
termsActiveOrSetField tids = selectField $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName
|
|
where terms = map unTermKey tids
|
|
-- termActiveOld :: Field Handler TermIdentifier
|
|
-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
|
|
|
termNewField :: Field Handler TermIdentifier
|
|
termNewField = checkMMap (return.termFromText) termToText textField
|
|
|
|
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 [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
|
|
|
|
uploadModeField :: Field Handler UploadMode
|
|
uploadModeField = selectField optionsFinite
|
|
|
|
submissionModeField :: Field Handler SheetSubmissionMode
|
|
submissionModeField = selectField optionsFinite
|
|
|
|
pseudonymWordField :: Field Handler PseudonymWord
|
|
pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
|
|
where
|
|
doCheck (CI.mk -> w)
|
|
| Just w' <- find (== w) pseudonymWordlist
|
|
= return $ Right w'
|
|
| otherwise
|
|
= return . Left $ MsgUnknownPseudonymWord (CI.original w)
|
|
|
|
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 =
|
|
[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 = 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
|
|
|
|
|
|
data SheetGrading' = Points' | PassPoints' | PassBinary'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
|
|
|
instance Universe SheetGrading'
|
|
instance Finite SheetGrading'
|
|
|
|
nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
|
|
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
|
|
|
|
|
|
data SheetType' = NotGraded' | Normal' | Bonus' | Informational'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
|
|
|
instance Universe SheetType'
|
|
instance Finite SheetType'
|
|
|
|
nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
|
|
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
|
|
|
|
|
|
data SheetGroup' = NoGroups' | Arbitrary' | RegisteredGroups'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
|
|
|
instance Universe SheetGroup'
|
|
instance Finite SheetGroup'
|
|
|
|
nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
|
|
embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
|
|
|
|
sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
|
|
sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
|
|
where
|
|
selOptions = Map.fromList
|
|
[ ( Points', Points <$> maxPointsReq )
|
|
, ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
|
|
, ( PassBinary', pure PassBinary)
|
|
]
|
|
classify' :: SheetGrading -> SheetGrading'
|
|
classify' = \case
|
|
Points {} -> Points'
|
|
PassPoints {} -> PassPoints'
|
|
PassBinary {} -> PassBinary'
|
|
|
|
maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints)
|
|
passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)
|
|
|
|
|
|
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
|
|
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
|
|
where
|
|
selOptions = Map.fromList
|
|
[ ( Normal', Normal <$> gradingReq )
|
|
, ( Bonus' , Bonus <$> gradingReq )
|
|
, ( Informational', Informational <$> gradingReq )
|
|
, ( NotGraded', pure NotGraded )
|
|
]
|
|
gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
|
|
& setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
|
|
|
|
classify' :: SheetType -> SheetType'
|
|
classify' = \case
|
|
Bonus {} -> Bonus'
|
|
Normal {} -> Normal'
|
|
Informational {} -> Informational'
|
|
NotGraded -> NotGraded'
|
|
|
|
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
|
|
sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
|
|
let
|
|
selOptions = Map.fromList
|
|
[ ( Arbitrary', Arbitrary
|
|
<$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
|
|
)
|
|
, ( RegisteredGroups', pure RegisteredGroups )
|
|
, ( NoGroups', pure NoGroups )
|
|
]
|
|
(res, selView) <- multiAction selOptions (classify' <$> template)
|
|
|
|
fvId <- maybe newIdent return fsId
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
return (res,
|
|
[ FieldView
|
|
{ fvLabel = toHtml $ mr fsLabel
|
|
, fvTooltip = toHtml . mr <$> fsTooltip
|
|
, fvId
|
|
, fvInput = selView
|
|
, fvErrors = case res of
|
|
FormFailure [e] -> Just $ toHtml e
|
|
_ -> Nothing
|
|
, fvRequired = True
|
|
}
|
|
])
|
|
|
|
where
|
|
classify' :: SheetGroup -> SheetGroup'
|
|
classify' = \case
|
|
Arbitrary _ -> Arbitrary'
|
|
RegisteredGroups -> RegisteredGroups'
|
|
NoGroups -> NoGroups'
|
|
|
|
|
|
{-
|
|
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{_ltuResult} -> Right _ltuResult
|
|
Just LTUNone{} -> Left MsgIllDefinedUTCTime
|
|
Just LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
|
|
Nothing -> Left MsgInvalidDateTimeFormat
|
|
|
|
langField :: Bool -- ^ Only allow values from `appLanguages`
|
|
-> Field (HandlerT UniWorX IO) Lang
|
|
langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
|
|
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
|
|
|
|
jsonField :: ( ToJSON a, FromJSON a
|
|
, MonadHandler m
|
|
, RenderMessage (HandlerSite m) UniWorXMessage
|
|
, RenderMessage (HandlerSite m) FormMessage
|
|
)
|
|
=> Bool {-^ Hidden? -}
|
|
-> Field m a
|
|
jsonField hide = Field{..}
|
|
where
|
|
inputType :: Text
|
|
inputType
|
|
| hide = "hidden"
|
|
| otherwise = "text"
|
|
fieldParse [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v
|
|
fieldParse [] [] = return $ Right Nothing
|
|
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
|
fieldView theId name attrs val isReq = liftWidgetT [whamlet|
|
|
<input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
|
|
|]
|
|
fieldEnctype = UrlEncoded
|
|
|
|
secretJsonField :: ( ToJSON a, FromJSON a
|
|
, MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Field m a
|
|
secretJsonField = Field{..}
|
|
where
|
|
fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
|
|
fieldParse [] [] = return $ Right Nothing
|
|
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
|
fieldView theId name attrs val _isReq = do
|
|
val' <- traverse (encodedSecretBox SecretBoxShort) val
|
|
[whamlet|
|
|
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|
|
|]
|
|
fieldEnctype = UrlEncoded
|
|
|
|
|
|
funcForm :: forall k v m.
|
|
( Finite k, Ord k
|
|
, MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
|
|
funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
|
|
where
|
|
funcForm' :: AForm m (k -> v)
|
|
funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
|
|
funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
|
|
funcFieldView (res, fvInput) = do
|
|
mr <- getMessageRender
|
|
let fvLabel = toHtml $ mr fsLabel
|
|
fvTooltip = fmap (toHtml . mr) fsTooltip
|
|
fvRequired = isRequired
|
|
fvErrors
|
|
| FormFailure (err:_) <- res = Just $ toHtml err
|
|
| otherwise = Nothing
|
|
fvId <- maybe newIdent return fsId
|
|
return (res, pure FieldView{..})
|
|
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
|
|
|
|
|
|
|
|
|
|
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
|
|
|
|
fsUniq :: (Text -> Text) -> Text -> FieldSettings site
|
|
fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
|
|
|
|
|
|
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
|
|
|
|
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
|
|
|
|
apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
|
=> Field m a -> FieldSettings site -> Maybe a -> AForm m a
|
|
-- ^ Pseudo required
|
|
apreq f fs mx = formToAForm $ do
|
|
mr <- getMessageRender
|
|
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
|
|
|
|
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
|
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
|
|
wpreq f fs mx = mFormToWForm $ do
|
|
mr <- getMessageRender
|
|
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
|
|
|
|
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
|
=> Map action (AForm (HandlerT UniWorX IO) a)
|
|
-> Maybe action
|
|
-> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
|
|
multiAction acts defAction = do
|
|
mr <- getMessageRender
|
|
let
|
|
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
|
|
(actionRes, actionView) <- mreq (selectField $ return options) "" defAction
|
|
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
|
|
let mToWidget (_, []) = return Nothing
|
|
mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
|
|
widgets <- mapM mToWidget results
|
|
let actionWidgets = Map.foldrWithKey accWidget [] widgets
|
|
accWidget _act Nothing = id
|
|
accWidget act (Just w) = cons $(widgetFile "widgets/multiAction")
|
|
actionResults = Map.map fst results
|
|
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))
|
|
|
|
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
|
=> FieldSettings UniWorX
|
|
-> Map action (AForm (HandlerT UniWorX IO) a)
|
|
-> Maybe action
|
|
-> AForm (HandlerT UniWorX IO) a
|
|
multiActionA FieldSettings{..} acts defAction = formToAForm $ do
|
|
(res, selView) <- multiAction acts defAction
|
|
|
|
fvId <- maybe newIdent return fsId
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
return (res,
|
|
[ FieldView
|
|
{ fvLabel = toHtml $ mr fsLabel
|
|
, fvTooltip = toHtml . mr <$> fsTooltip
|
|
, fvId
|
|
, fvInput = selView
|
|
, fvErrors = case res of
|
|
FormFailure [e] -> Just $ toHtml e
|
|
_ -> Nothing
|
|
, fvRequired = True
|
|
}
|
|
])
|
|
|
|
formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
|
|
formResultModal res finalDest handler = maybeT_ $ do
|
|
messages <- case res of
|
|
FormMissing -> mzero
|
|
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero
|
|
FormSuccess val -> lift . execWriterT $ handler val
|
|
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
if
|
|
| isModal -> sendResponse $ toJSON messages
|
|
| otherwise -> do
|
|
forM_ messages $ \Message{..} -> addMessage messageClass messageContent
|
|
redirect finalDest
|
|
|
|
|
|
-- TODO / WIP: form groups, needs cleanup once it works
|
|
infoField :: (Monad m, HandlerSite m ~ UniWorX, ToMarkup t) => t -> Field m () --TODO if kept, move to fields, more likely delete this workaround
|
|
infoField txt = Field { fieldEnctype = UrlEncoded
|
|
, fieldParse = const $ const $ return $ Right $ Just ()
|
|
, fieldView = \_theId _name _attrs _val _isReq ->
|
|
[whamlet|#{txt}|]
|
|
}
|
|
aformSection :: (Monad m, ToMarkup t) => t -> AForm m ()
|
|
aformSection = formToAForm . fmap (second pure) . formSection
|
|
|
|
formSection :: (Monad m, ToMarkup t) => t -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
|
|
formSection formSectionTitle = return (FormSuccess (), infoView)
|
|
where
|
|
flabel :: Html
|
|
flabel = $(shamletFile "./templates/widgets/form-section-title.shamlet") -- TODO: Why must this be fully qualified?
|
|
infoView = FieldView
|
|
{ fvLabel = flabel
|
|
, fvTooltip = Nothing
|
|
, fvId = "formSection"
|
|
, fvErrors = Nothing
|
|
, fvRequired = False
|
|
, fvInput = mempty
|
|
}
|
|
|
|
infoForm :: Text -> Form () -- TODO: WIP, delete
|
|
infoForm infoText csrf =
|
|
let widget = [whamlet|#{csrf}
|
|
<h3 .form-group-title>#{infoText}
|
|
|]
|
|
in return (FormSuccess (), widget)
|
|
|
|
aFormGroup :: (MonadHandler m, HandlerSite m ~ UniWorX) => String -> AForm m a -> AForm m a
|
|
aFormGroup groupTitle innerForm =
|
|
-- THIS IS JUST A WORKAROUND, SERIOUS ATTEMPT COMMENTED OUT BELOW
|
|
grpHeader *> innerForm
|
|
where
|
|
emptyT :: Text
|
|
emptyT = ""
|
|
grpHeader = aopt (infoField emptyT) (fromString groupTitle) Nothing
|
|
-- -- attempt through double converision
|
|
-- where mInner = do
|
|
-- let (result, ($ []) -> fieldViews) = aFormToForm innerForm
|
|
-- return (result, $(widgetFile "widgets/aform-group"))
|
|
|
|
formGroup :: Text -> Form a -> Form a
|
|
formGroup groupTitle innerForm csrf = do
|
|
(result,fGroup) <- innerForm csrf
|
|
return (result,$(widgetFile "widgets/form-group")) |