Merge branch 'master' into 284-massinput
This commit is contained in:
commit
705fdec695
@ -2,7 +2,7 @@ SystemMessage
|
||||
from UTCTime Maybe
|
||||
to UTCTime Maybe
|
||||
authenticatedOnly Bool
|
||||
severity MessageClass
|
||||
severity MessageStatus
|
||||
defaultLanguage Lang
|
||||
content Html
|
||||
summary Html Maybe
|
||||
|
||||
@ -220,7 +220,7 @@ instance RenderMessage UniWorX MsgLanguage where
|
||||
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
|
||||
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
|
||||
|
||||
embedRenderMessage ''UniWorX ''MessageClass ("Message" <>)
|
||||
embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
|
||||
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
|
||||
embedRenderMessage ''UniWorX ''StudyFieldType id
|
||||
embedRenderMessage ''UniWorX ''SheetFileType id
|
||||
|
||||
@ -20,6 +20,8 @@ import Database.Persist.Sql (fromSqlKey)
|
||||
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
|
||||
import Control.Monad.Trans.Writer (mapWriterT)
|
||||
|
||||
-- BEGIN - Buttons needed only here
|
||||
data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
@ -55,7 +57,7 @@ emailTestForm = (,)
|
||||
SelFormatTime -> t
|
||||
|
||||
makeDemoForm :: Int -> Form (Int,Bool,Double)
|
||||
makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used identForm instead!
|
||||
makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ (,,)
|
||||
<$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
|
||||
<* aformSection MsgFormBehaviour
|
||||
@ -76,23 +78,20 @@ makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used i
|
||||
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
|
||||
getAdminTestR = postAdminTestR
|
||||
postAdminTestR = do
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate)
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
|
||||
case btnResult of
|
||||
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
|
||||
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
|
||||
FormMissing -> return ()
|
||||
_other -> addMessage Warning "KEIN Knopf erkannt"
|
||||
|
||||
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
|
||||
case emailResult of
|
||||
(FormSuccess (email, ls)) -> do
|
||||
jId <- runDB $ do
|
||||
jId <- queueJob $ JobSendTestEmail email ls
|
||||
addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
|
||||
return jId
|
||||
writeJobCtl $ JobCtlPerform jId
|
||||
FormMissing -> return ()
|
||||
(FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
|
||||
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
|
||||
formResultModal emailResult AdminTestR $ \(email, ls) -> do
|
||||
jId <- mapWriterT runDB $ do
|
||||
jId <- queueJob $ JobSendTestEmail email ls
|
||||
tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
|
||||
return jId
|
||||
writeJobCtl $ JobCtlPerform jId
|
||||
|
||||
let emailWidget' = [whamlet|
|
||||
<form method=post action=@{AdminTestR} enctype=#{emailEnctype} data-ajax-submit>
|
||||
|
||||
@ -353,6 +353,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
, dbParamsFormResult = _1
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
-- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown)
|
||||
-- gradingSummary <- do
|
||||
@ -614,13 +615,13 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
(fslpI MsgRatingPoints "Punktezahl")
|
||||
(Just submissionRatingPoints)
|
||||
|
||||
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
|
||||
((corrResult, corrForm), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
|
||||
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
|
||||
<*> pointsForm
|
||||
<*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
|
||||
<* submitButton
|
||||
|
||||
((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identForm FIDcorrectionUpload . renderAForm FormStandard $
|
||||
((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
|
||||
areq (zipFileField True) (fslI MsgRatingFiles) Nothing
|
||||
<* submitButton
|
||||
|
||||
@ -693,7 +694,7 @@ getCorrectionUserR tid ssh csh shn cid = do
|
||||
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
||||
getCorrectionsUploadR = postCorrectionsUploadR
|
||||
postCorrectionsUploadR = do
|
||||
((uploadRes, upload), uploadEncoding) <- runFormPost . identForm FIDcorrectionsUpload . renderAForm FormStandard $
|
||||
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
|
||||
areq (zipFileField True) (fslI MsgCorrUploadField) Nothing
|
||||
<* submitButton
|
||||
|
||||
|
||||
@ -286,7 +286,7 @@ getCShowR tid ssh csh = do
|
||||
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
|
||||
mRegAt <- traverse (formatTime SelFormatDateTime) registered
|
||||
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
|
||||
(regWidget, regEnctype) <- generateFormPost $ identifyForm FIDCourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course
|
||||
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
|
||||
siteLayout (toWgt $ courseName course) $ do
|
||||
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
|
||||
@ -312,7 +312,7 @@ postCRegisterR tid ssh csh = do
|
||||
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
registered <- isJust <$> getBy (UniqueParticipant aid cid)
|
||||
return (cid, course, registered)
|
||||
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
|
||||
((regResult,_), _) <- runFormPost $ identifyForm FIDCourseRegister $ registerForm registered $ courseRegisterSecret course
|
||||
case regResult of
|
||||
(FormSuccess codeOk)
|
||||
| registered -> do
|
||||
@ -528,7 +528,7 @@ courseToForm (Entity cid Course{..}) = CourseForm
|
||||
}
|
||||
|
||||
makeCourseForm :: Maybe CourseForm -> Form CourseForm
|
||||
makeCourseForm template = identForm FIDcourse $ \html -> do
|
||||
makeCourseForm template = identifyForm FIDcourse $ \html -> do
|
||||
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
|
||||
-- let editCid = cfCourseId =<< template -- possible start for refactoring
|
||||
|
||||
|
||||
@ -27,7 +27,7 @@ data SettingsForm = SettingsForm
|
||||
}
|
||||
|
||||
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
|
||||
makeSettingForm template = identForm FIDsettings $ \html -> do
|
||||
makeSettingForm template = identifyForm FIDsettings $ \html -> do
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
|
||||
<$ aformSection MsgFormCosmetics
|
||||
<*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
|
||||
|
||||
@ -90,7 +90,7 @@ getFtIdMap sId = do
|
||||
return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
|
||||
|
||||
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
|
||||
makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
|
||||
oldFileIds <- (return.) <$> case msId of
|
||||
Nothing -> return $ partitionFileType mempty
|
||||
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
|
||||
@ -780,7 +780,7 @@ postSCorrR = getSCorrR
|
||||
getSCorrR tid ssh csh shn = do
|
||||
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
|
||||
|
||||
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
||||
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
||||
|
||||
case res of
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||
|
||||
@ -49,7 +49,7 @@ import System.FilePath
|
||||
|
||||
|
||||
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
|
||||
makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsubmission $ \html -> do
|
||||
makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do
|
||||
let
|
||||
fileUploadForm = case uploadMode of
|
||||
NoUpload -> pure Nothing
|
||||
|
||||
@ -35,7 +35,7 @@ postMessageR cID = do
|
||||
|
||||
let
|
||||
mkForm = do
|
||||
((modifyRes, modifyView), modifyEnctype) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard
|
||||
((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
|
||||
$ SystemMessage
|
||||
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
|
||||
<*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
|
||||
@ -51,7 +51,7 @@ postMessageR cID = do
|
||||
|
||||
modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
|
||||
cID' <- encrypt tId
|
||||
runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
|
||||
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
|
||||
$ (,)
|
||||
<$> fmap (Entity tId)
|
||||
( SystemMessageTranslation
|
||||
@ -64,7 +64,7 @@ postMessageR cID = do
|
||||
|
||||
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
|
||||
|
||||
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
||||
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
||||
$ SystemMessageTranslation
|
||||
<$> pure smId
|
||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
|
||||
@ -215,6 +215,7 @@ postMessageListR = do
|
||||
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
, dbtIdent = "messages" :: Text
|
||||
}
|
||||
@ -246,7 +247,7 @@ postMessageListR = do
|
||||
FormSuccess (_, _selection) -- prop> null _selection
|
||||
-> addMessageI Error MsgSystemMessageEmptySelection
|
||||
|
||||
((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
|
||||
((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
|
||||
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
|
||||
<*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
|
||||
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
|
||||
|
||||
@ -145,7 +145,7 @@ getTermShowR = do
|
||||
, dbtIdent = "terms" :: Text
|
||||
}
|
||||
defaultLayout $ do
|
||||
setTitle "Freigeschaltete Semester"
|
||||
setTitleI MsgTermsHeading
|
||||
$(widgetFile "terms")
|
||||
|
||||
getTermEditR :: Handler Html
|
||||
|
||||
@ -51,7 +51,7 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet
|
||||
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
|
||||
|
||||
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
|
||||
confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
|
||||
confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
|
||||
where
|
||||
addDeleteTargets :: Form a -> Form a
|
||||
addDeleteTargets form csrf = do
|
||||
|
||||
@ -564,42 +564,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
|
||||
, 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
|
||||
@ -654,5 +618,5 @@ formResultModal res finalDest handler = maybeT_ $ do
|
||||
if
|
||||
| isModal -> sendResponse $ toJSON messages
|
||||
| otherwise -> do
|
||||
forM_ messages $ \Message{..} -> addMessage messageClass messageContent
|
||||
forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
|
||||
redirect finalDest
|
||||
|
||||
@ -461,6 +461,19 @@ instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x
|
||||
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
||||
def = DBParamsDB
|
||||
|
||||
data DBParamsFormIdent where
|
||||
DBParamsFormTableIdent :: DBParamsFormIdent
|
||||
DBParamsFormOverrideIdent :: forall t. PathPiece t => t -> DBParamsFormIdent
|
||||
DBParamsFormNoIdent :: DBParamsFormIdent
|
||||
|
||||
instance Default DBParamsFormIdent where
|
||||
def = DBParamsFormTableIdent
|
||||
|
||||
unDBParamsFormIdent :: DBTable m x -> DBParamsFormIdent -> Maybe Text
|
||||
unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toPathPiece dbtIdent
|
||||
unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
|
||||
unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing
|
||||
|
||||
instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
|
||||
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
|
||||
{ dbParamsFormMethod :: StdMethod
|
||||
@ -470,6 +483,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
, dbParamsFormAdditional :: Form a
|
||||
, dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
|
||||
, dbParamsFormResult :: Lens' x (FormResult a)
|
||||
, dbParamsFormIdent :: DBParamsFormIdent
|
||||
}
|
||||
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget)
|
||||
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
|
||||
@ -492,7 +506,15 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
dbWidget _ _ = return . snd
|
||||
dbHandler _ _ f = return . over _2 f
|
||||
-- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
|
||||
runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) . dbParamsFormEvaluate . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) . dbParamsFormWrap dbtParams . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
|
||||
runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
|
||||
= fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
|
||||
. dbParamsFormEvaluate
|
||||
. fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x)))
|
||||
. dbParamsFormWrap dbtParams
|
||||
. maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent)
|
||||
. addPIHiddenField dbtable pi
|
||||
. addPreviousHiddenField dbtable pKeys
|
||||
. withFragment
|
||||
|
||||
dbInvalidateResult DBParamsForm{..} reason result = do
|
||||
reasonTxt <- getMessageRender <*> pure reason
|
||||
@ -510,6 +532,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La
|
||||
, dbParamsFormAdditional = \_ -> return (pure (), mempty)
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
, dbParamsFormResult = lens (\_ -> pure ()) (\s _ -> s)
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
|
||||
dbParamsFormWrap :: Monoid x => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
|
||||
@ -605,9 +628,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
|
||||
|
||||
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
|
||||
(filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
|
||||
(filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
|
||||
|
||||
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
|
||||
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
|
||||
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
|
||||
<* autosubmitButton
|
||||
return (filterRes', pagesizeRes')
|
||||
|
||||
@ -3,7 +3,7 @@ module Import.NoFoundation
|
||||
, MForm
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField)
|
||||
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
|
||||
import Model as Import
|
||||
import Model.Types.JSON as Import
|
||||
import Model.Migration as Import
|
||||
|
||||
@ -19,7 +19,7 @@ import Data.Aeson (Value)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.CaseInsensitive.Instances ()
|
||||
|
||||
import Utils.Message (MessageClass)
|
||||
import Utils.Message (MessageStatus)
|
||||
import Settings.Cluster (ClusterSettingsKey)
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
@ -39,7 +39,7 @@ import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
import Utils hiding (MessageClass(..))
|
||||
import Utils hiding (MessageStatus(..))
|
||||
import Control.Lens
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
28
src/Utils.hs
28
src/Utils.hs
@ -25,6 +25,7 @@ import Utils.PathPiece as Utils
|
||||
import Utils.Message as Utils
|
||||
import Utils.Lang as Utils
|
||||
import Control.Lens as Utils (none)
|
||||
import Utils.Parameters as Utils
|
||||
|
||||
|
||||
import Text.Blaze (Markup, ToMarkup)
|
||||
@ -580,32 +581,7 @@ getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
|
||||
-- GET Parameters --
|
||||
--------------------
|
||||
|
||||
data GlobalGetParam = GetReferer
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe GlobalGetParam
|
||||
instance Finite GlobalGetParam
|
||||
nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
|
||||
|
||||
lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result)
|
||||
lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident)
|
||||
|
||||
hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
|
||||
hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
|
||||
|
||||
|
||||
data GlobalPostParam = PostDeleteTarget
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe GlobalPostParam
|
||||
instance Finite GlobalPostParam
|
||||
nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
|
||||
|
||||
lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
|
||||
lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
|
||||
|
||||
hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
|
||||
hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
|
||||
-- Moved to Utils.Parameters
|
||||
|
||||
---------------------------------
|
||||
-- Custom HTTP Request-Headers --
|
||||
|
||||
@ -2,9 +2,11 @@
|
||||
|
||||
module Utils.Form where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
|
||||
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
|
||||
import Settings
|
||||
|
||||
import Utils.Parameters
|
||||
|
||||
-- import Text.Blaze (toMarkup) -- for debugging
|
||||
import qualified Text.Blaze.Internal as Blaze (null)
|
||||
import qualified Data.Text as T
|
||||
@ -18,6 +20,8 @@ import qualified Data.Map.Lazy as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Reader.Class (MonadReader(..))
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
import Data.List ((!!))
|
||||
|
||||
@ -209,7 +213,9 @@ data FormIdentifier
|
||||
| FIDSystemMessageAddTranslation
|
||||
| FIDDBTableFilter
|
||||
| FIDDBTablePagesize
|
||||
| FIDDBTable
|
||||
| FIDDelete
|
||||
| FIDCourseRegister
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
instance PathPiece FormIdentifier where
|
||||
@ -217,11 +223,32 @@ instance PathPiece FormIdentifier where
|
||||
toPathPiece = showToPathPiece
|
||||
|
||||
|
||||
identForm :: (Monad m, PathPiece ident)
|
||||
=> ident -- ^ Form identification
|
||||
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
|
||||
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
|
||||
identForm = identifyForm . toPathPiece
|
||||
identifyForm' :: (Monad m, PathPiece ident, Eq ident)
|
||||
=> Lens' x (FormResult a)
|
||||
-> ident -- ^ Form identification
|
||||
-> (Html -> MForm m (x, widget))
|
||||
-> (Html -> MForm m (x, widget))
|
||||
identifyForm' resLens identVal form fragment = do
|
||||
-- Create hidden <input>.
|
||||
let fragment' =
|
||||
[shamlet|
|
||||
<input .form-identifier type=hidden name=#{toPathPiece PostFormIdentifier} value=#{toPathPiece identVal}>
|
||||
#{fragment}
|
||||
|]
|
||||
|
||||
-- Check if we got its value back.
|
||||
hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier
|
||||
|
||||
-- Run the form proper (with our hidden <input>). If the
|
||||
-- data is missing, then do not provide any params to the
|
||||
-- form, which will turn its result into FormMissing. Also,
|
||||
-- doing this avoids having lots of fields with red errors.
|
||||
let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l))
|
||||
| otherwise = id
|
||||
fmap (over (_1 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment'
|
||||
|
||||
identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
|
||||
identifyForm = identifyForm' id
|
||||
|
||||
{- Hinweise zur Erinnerung:
|
||||
- identForm primär, wenn es mehr als ein Formular pro Handler gibt
|
||||
@ -512,4 +539,42 @@ prismAForm p outer form = review p <$> form inner
|
||||
where
|
||||
inner = outer >>= preview p
|
||||
|
||||
---------------------------------------------
|
||||
-- Special variants of @mopt@, @mreq@, ... --
|
||||
---------------------------------------------
|
||||
|
||||
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)
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Utils.Message
|
||||
( MessageClass(..)
|
||||
, UnknownMessageClass(..)
|
||||
( MessageStatus(..)
|
||||
, UnknownMessageStatus(..)
|
||||
, addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
|
||||
, Message(..)
|
||||
, messageI, messageIHamlet, messageFile, messageWidget
|
||||
@ -25,64 +25,64 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
|
||||
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
||||
|
||||
|
||||
data MessageClass = Error | Warning | Info | Success
|
||||
data MessageStatus = Error | Warning | Info | Success
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)
|
||||
|
||||
instance Universe MessageClass
|
||||
instance Finite MessageClass
|
||||
instance Universe MessageStatus
|
||||
instance Finite MessageStatus
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
} ''MessageClass
|
||||
} ''MessageStatus
|
||||
|
||||
nullaryPathPiece ''MessageClass camelToPathPiece
|
||||
derivePersistField "MessageClass"
|
||||
nullaryPathPiece ''MessageStatus camelToPathPiece
|
||||
derivePersistField "MessageStatus"
|
||||
|
||||
newtype UnknownMessageClass = UnknownMessageClass Text
|
||||
newtype UnknownMessageStatus = UnknownMessageStatus Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Exception UnknownMessageClass
|
||||
instance Exception UnknownMessageStatus
|
||||
|
||||
|
||||
data Message = Message
|
||||
{ messageClass :: MessageClass
|
||||
{ messageStatus :: MessageStatus
|
||||
, messageContent :: Html
|
||||
}
|
||||
|
||||
instance Eq Message where
|
||||
a == b = ((==) `on` messageClass) a b && ((==) `on` renderHtml . messageContent) a b
|
||||
a == b = ((==) `on` messageStatus) a b && ((==) `on` renderHtml . messageContent) a b
|
||||
|
||||
instance Ord Message where
|
||||
a `compare` b = (compare `on` messageClass) a b `mappend` (compare `on` renderHtml . messageContent) a b
|
||||
a `compare` b = (compare `on` messageStatus) a b `mappend` (compare `on` renderHtml . messageContent) a b
|
||||
|
||||
instance ToJSON Message where
|
||||
toJSON Message{..} = object
|
||||
[ "class" .= messageClass
|
||||
[ "status" .= messageStatus
|
||||
, "content" .= renderHtml messageContent
|
||||
]
|
||||
|
||||
instance FromJSON Message where
|
||||
parseJSON = withObject "Message" $ \o -> do
|
||||
messageClass <- o .: "class"
|
||||
messageStatus <- o .: "status"
|
||||
messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
|
||||
return Message{..}
|
||||
|
||||
|
||||
addMessage :: MonadHandler m => MessageClass -> Html -> m ()
|
||||
addMessage :: MonadHandler m => MessageStatus -> Html -> m ()
|
||||
addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc)
|
||||
|
||||
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
|
||||
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m ()
|
||||
addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
|
||||
|
||||
messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m Message
|
||||
messageI messageClass msg = do
|
||||
messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message
|
||||
messageI messageStatus msg = do
|
||||
messageContent <- toHtml . ($ msg) <$> getMessageRender
|
||||
return Message{..}
|
||||
|
||||
addMessageIHamlet :: ( MonadHandler m
|
||||
, RenderMessage (HandlerSite m) msg
|
||||
, HandlerSite m ~ site
|
||||
) => MessageClass -> HtmlUrlI18n msg (Route site) -> m ()
|
||||
) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m ()
|
||||
addMessageIHamlet mc iHamlet = do
|
||||
mr <- getMessageRender
|
||||
ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
|
||||
@ -90,22 +90,22 @@ addMessageIHamlet mc iHamlet = do
|
||||
messageIHamlet :: ( MonadHandler m
|
||||
, RenderMessage (HandlerSite m) msg
|
||||
, HandlerSite m ~ site
|
||||
) => MessageClass -> HtmlUrlI18n msg (Route site) -> m Message
|
||||
) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m Message
|
||||
messageIHamlet mc iHamlet = do
|
||||
mr <- getMessageRender
|
||||
Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr)
|
||||
|
||||
addMessageFile :: MessageClass -> FilePath -> ExpQ
|
||||
addMessageFile :: MessageStatus -> FilePath -> ExpQ
|
||||
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
|
||||
|
||||
messageFile :: MessageClass -> FilePath -> ExpQ
|
||||
messageFile :: MessageStatus -> FilePath -> ExpQ
|
||||
messageFile mc tPath = [e|messageIHamlet mc $(ihamletFile tPath)|]
|
||||
|
||||
addMessageWidget :: forall m site.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ site
|
||||
, Yesod site
|
||||
) => MessageClass -> WidgetT site IO () -> m ()
|
||||
) => MessageStatus -> WidgetT site IO () -> m ()
|
||||
-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
|
||||
addMessageWidget mc wgt = do
|
||||
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
|
||||
@ -115,7 +115,7 @@ messageWidget :: forall m site.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ site
|
||||
, Yesod site
|
||||
) => MessageClass -> WidgetT site IO () -> m Message
|
||||
) => MessageStatus -> WidgetT site IO () -> m Message
|
||||
messageWidget mc wgt = do
|
||||
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
|
||||
messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
|
||||
|
||||
78
src/Utils/Parameters.hs
Normal file
78
src/Utils/Parameters.hs
Normal file
@ -0,0 +1,78 @@
|
||||
module Utils.Parameters
|
||||
( GlobalGetParam(..)
|
||||
, lookupGlobalGetParam, hasGlobalGetParam
|
||||
, lookupGlobalGetParamForm, hasGlobalGetParamForm
|
||||
, globalGetParamField
|
||||
, GlobalPostParam(..)
|
||||
, lookupGlobalPostParam, hasGlobalPostParam
|
||||
, lookupGlobalPostParamForm, hasGlobalPostParamForm
|
||||
, globalPostParamField
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
|
||||
import Utils.PathPiece
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Universe
|
||||
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
|
||||
data GlobalGetParam = GetReferer
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe GlobalGetParam
|
||||
instance Finite GlobalGetParam
|
||||
nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
|
||||
|
||||
lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result)
|
||||
lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident)
|
||||
|
||||
hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
|
||||
hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
|
||||
|
||||
|
||||
lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result)
|
||||
lookupGlobalGetParamForm ident = runMaybeT $ do
|
||||
ps <- MaybeT askParams
|
||||
MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece
|
||||
|
||||
hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool
|
||||
hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
|
||||
|
||||
globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
|
||||
globalGetParamField ident Field{fieldParse} = runMaybeT $ do
|
||||
ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
|
||||
fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
|
||||
MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs)
|
||||
|
||||
data GlobalPostParam = PostFormIdentifier
|
||||
| PostDeleteTarget
|
||||
| PostMassInputShape
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe GlobalPostParam
|
||||
instance Finite GlobalPostParam
|
||||
nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
|
||||
|
||||
lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
|
||||
lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
|
||||
|
||||
hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
|
||||
hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
|
||||
|
||||
lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result)
|
||||
lookupGlobalPostParamForm ident = runMaybeT $ do
|
||||
ps <- MaybeT askParams
|
||||
MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece
|
||||
|
||||
hasGlobalPostParamForm :: Monad m => GlobalPostParam -> MForm m Bool
|
||||
hasGlobalPostParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
|
||||
|
||||
globalPostParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
|
||||
globalPostParamField ident Field{fieldParse} = runMaybeT $ do
|
||||
ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
|
||||
fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
|
||||
MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs)
|
||||
@ -1,5 +1,74 @@
|
||||
.async-form-response {
|
||||
margin: 20px 0;
|
||||
position: relative;
|
||||
width: 100%;
|
||||
font-size: 18px;
|
||||
text-align: center;
|
||||
padding-top: 60px;
|
||||
}
|
||||
|
||||
.async-form-response::before,
|
||||
.async-form-response::after {
|
||||
position: absolute;
|
||||
top: 0px;
|
||||
left: 50%;
|
||||
display: block;
|
||||
}
|
||||
|
||||
.async-form-response--success::before {
|
||||
content: '';
|
||||
width: 17px;
|
||||
height: 28px;
|
||||
border: solid #069e04;
|
||||
border-width: 0 5px 5px 0;
|
||||
transform: translateX(-50%) rotate(45deg);
|
||||
}
|
||||
|
||||
.async-form-response--info::before {
|
||||
content: '';
|
||||
width: 5px;
|
||||
height: 30px;
|
||||
top: 10px;
|
||||
background-color: #777;
|
||||
transform: translateX(-50%);
|
||||
}
|
||||
.async-form-response--info::after {
|
||||
content: '';
|
||||
width: 5px;
|
||||
height: 5px;
|
||||
background-color: #777;
|
||||
transform: translateX(-50%);
|
||||
}
|
||||
|
||||
.async-form-response--warning::before {
|
||||
content: '';
|
||||
width: 5px;
|
||||
height: 30px;
|
||||
background-color: rgb(255, 187, 0);
|
||||
transform: translateX(-50%);
|
||||
}
|
||||
.async-form-response--warning::after {
|
||||
content: '';
|
||||
width: 5px;
|
||||
height: 5px;
|
||||
top: 35px;
|
||||
background-color: rgb(255, 187, 0);
|
||||
transform: translateX(-50%);
|
||||
}
|
||||
|
||||
.async-form-response--error::before {
|
||||
content: '';
|
||||
width: 5px;
|
||||
height: 40px;
|
||||
background-color: #940d0d;
|
||||
transform: translateX(-50%) rotate(-45deg);
|
||||
}
|
||||
.async-form-response--error::after {
|
||||
content: '';
|
||||
width: 5px;
|
||||
height: 40px;
|
||||
background-color: #940d0d;
|
||||
transform: translateX(-50%) rotate(45deg);
|
||||
}
|
||||
|
||||
.async-form-loading {
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
left: 50%;
|
||||
top: 50%;
|
||||
transform: translate(-50%, -50%) scale(0.8, 0.8);
|
||||
display: block;
|
||||
display: flex;
|
||||
background-color: rgba(255, 255, 255, 1);
|
||||
min-width: 60vw;
|
||||
min-height: 100px;
|
||||
@ -26,10 +26,6 @@
|
||||
z-index: 200;
|
||||
transform: translate(-50%, -50%) scale(1, 1);
|
||||
}
|
||||
|
||||
.modal__content {
|
||||
margin: 20px 0;
|
||||
}
|
||||
}
|
||||
|
||||
@media (max-width: 1024px) {
|
||||
@ -96,3 +92,8 @@
|
||||
color: white;
|
||||
}
|
||||
}
|
||||
|
||||
.modal__content {
|
||||
margin: 20px 0;
|
||||
width: 100%;
|
||||
}
|
||||
|
||||
@ -89,6 +89,7 @@
|
||||
alertElements.forEach(initAlert);
|
||||
|
||||
return {
|
||||
scope: alertsEl,
|
||||
destroy: function() {},
|
||||
};
|
||||
};
|
||||
|
||||
@ -57,6 +57,7 @@
|
||||
initAsidenavSubmenus();
|
||||
|
||||
return {
|
||||
scope: asideEl,
|
||||
destroy: function() {},
|
||||
};
|
||||
};
|
||||
|
||||
@ -6,9 +6,12 @@
|
||||
var ASYNC_FORM_RESPONSE_CLASS = 'async-form-response';
|
||||
var ASYNC_FORM_LOADING_CLASS = 'async-form-loading';
|
||||
var ASYNC_FORM_MIN_DELAY = 600;
|
||||
var DEFAULT_FAILURE_MESSAGE = 'The response we received from the server did not match what we expected. Please let us know this happened via the help widget in the top navigation.';
|
||||
|
||||
window.utils.asyncForm = function(formElement, options) {
|
||||
|
||||
options = options || {};
|
||||
|
||||
var lastRequestTimestamp = 0;
|
||||
|
||||
function setup() {
|
||||
@ -16,19 +19,27 @@
|
||||
}
|
||||
|
||||
function processResponse(response) {
|
||||
var responseElement = document.createElement('div');
|
||||
responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS);
|
||||
responseElement.innerHTML = response.content;
|
||||
var responseElement = makeResponseElement(response.content, response.status);
|
||||
var parentElement = formElement.parentElement;
|
||||
|
||||
// make sure there is a delay between click and response
|
||||
var delay = Math.max(0, ASYNC_FORM_MIN_DELAY + lastRequestTimestamp - Date.now());
|
||||
|
||||
setTimeout(function() {
|
||||
parentElement.insertBefore(responseElement, formElement);
|
||||
formElement.remove();
|
||||
}, delay);
|
||||
}
|
||||
|
||||
function makeResponseElement(content, status) {
|
||||
var responseElement = document.createElement('div');
|
||||
status = status || 'info';
|
||||
responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS);
|
||||
responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS + '--' + status);
|
||||
responseElement.innerHTML = content;
|
||||
return responseElement;
|
||||
}
|
||||
|
||||
function submitHandler(event) {
|
||||
event.preventDefault();
|
||||
|
||||
@ -47,17 +58,28 @@
|
||||
|
||||
window.utils.httpClient.post(url, headers, body)
|
||||
.then(function(response) {
|
||||
return response.json();
|
||||
if (response.headers.get("content-type").indexOf("application/json") !== -1) {// checking response header
|
||||
return response.json();
|
||||
} else {
|
||||
throw new TypeError('Unexpected Content-Type. Expected Content-Type: "application/json". Requested URL:' + url + '"');
|
||||
}
|
||||
}).then(function(response) {
|
||||
processResponse(response[0])
|
||||
processResponse(response[0]);
|
||||
}).catch(function(error) {
|
||||
console.error('could not fetch or process response from ' + url, { error });
|
||||
var failureMessage = DEFAULT_FAILURE_MESSAGE;
|
||||
if (options.i18n && options.i18n.asyncFormFailure) {
|
||||
failureMessage = options.i18n.asyncFormFailure;
|
||||
}
|
||||
processResponse({ content: failureMessage });
|
||||
|
||||
formElement.classList.remove(ASYNC_FORM_LOADING_CLASS);
|
||||
});
|
||||
}
|
||||
|
||||
setup();
|
||||
|
||||
return {
|
||||
scope: formElement,
|
||||
destroy: function() {},
|
||||
};
|
||||
};
|
||||
|
||||
@ -217,7 +217,9 @@
|
||||
}
|
||||
|
||||
function destroyUtils() {
|
||||
utilInstances.forEach(function(utilInstance) {
|
||||
utilInstances.filter(function(utilInstance) {
|
||||
return !!utilInstance;
|
||||
}).forEach(function(utilInstance) {
|
||||
utilInstance.destroy();
|
||||
});
|
||||
}
|
||||
@ -225,6 +227,7 @@
|
||||
init();
|
||||
|
||||
return {
|
||||
scope: wrapper,
|
||||
destroy: destroyUtils,
|
||||
};
|
||||
};
|
||||
|
||||
@ -159,6 +159,7 @@
|
||||
setup();
|
||||
|
||||
return {
|
||||
scope: formElement,
|
||||
destroy: function() {},
|
||||
};
|
||||
}
|
||||
|
||||
@ -124,6 +124,7 @@
|
||||
init();
|
||||
|
||||
return {
|
||||
scope: wrapper,
|
||||
destroy: destroy,
|
||||
};
|
||||
};
|
||||
|
||||
@ -48,12 +48,15 @@
|
||||
form.classList.add(JS_INITIALIZED);
|
||||
|
||||
function destroyUtils() {
|
||||
utilInstances.forEach(function(utilInstance) {
|
||||
utilInstances.filter(function(utilInstance) {
|
||||
return !!utilInstance;
|
||||
}).forEach(function(utilInstance) {
|
||||
utilInstance.destroy();
|
||||
});
|
||||
}
|
||||
|
||||
return {
|
||||
scope: form,
|
||||
destroy: destroyUtils,
|
||||
};
|
||||
};
|
||||
@ -97,6 +100,7 @@
|
||||
}
|
||||
|
||||
return {
|
||||
scope: form,
|
||||
destroy: function() {},
|
||||
};
|
||||
};
|
||||
@ -138,6 +142,7 @@
|
||||
}
|
||||
|
||||
return {
|
||||
scope: form,
|
||||
destroy: function() {},
|
||||
};
|
||||
};
|
||||
@ -149,6 +154,7 @@
|
||||
}
|
||||
|
||||
return {
|
||||
scope: form,
|
||||
destroy: function() {},
|
||||
};
|
||||
};
|
||||
|
||||
@ -38,12 +38,15 @@
|
||||
});
|
||||
|
||||
function destroyUtils() {
|
||||
utilInstances.forEach(function(utilInstance) {
|
||||
utilInstances.filter(function(utilInstance) {
|
||||
return !!utilInstance;
|
||||
}).forEach(function(utilInstance) {
|
||||
utilInstance.destroy();
|
||||
});
|
||||
}
|
||||
|
||||
return {
|
||||
scope: wrapper,
|
||||
destroy: destroyUtils,
|
||||
};
|
||||
};
|
||||
@ -135,6 +138,7 @@
|
||||
});
|
||||
|
||||
return {
|
||||
scope: input,
|
||||
destroy: function() {},
|
||||
};
|
||||
}
|
||||
@ -169,6 +173,7 @@
|
||||
setup();
|
||||
|
||||
return {
|
||||
scope: input,
|
||||
destroy: function() {},
|
||||
};
|
||||
}
|
||||
@ -195,6 +200,7 @@
|
||||
}
|
||||
|
||||
return {
|
||||
scope: input,
|
||||
destroy: function() {},
|
||||
};
|
||||
}
|
||||
@ -218,6 +224,7 @@
|
||||
}
|
||||
|
||||
return {
|
||||
scope: input,
|
||||
destroy: function() {},
|
||||
};
|
||||
}
|
||||
|
||||
@ -140,12 +140,15 @@
|
||||
setup();
|
||||
|
||||
function destroyUtils() {
|
||||
utilInstances.forEach(function(utilInstance) {
|
||||
utilInstances.filter(function(utilInstance) {
|
||||
return !!utilInstance;
|
||||
}).forEach(function(utilInstance) {
|
||||
utilInstance.destroy();
|
||||
});
|
||||
}
|
||||
|
||||
return {
|
||||
scope: modalElement,
|
||||
destroy: destroyUtils,
|
||||
};
|
||||
};
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
window.utils = window.utils || {};
|
||||
|
||||
var registeredSetupListeners = {};
|
||||
var activeInstances = {};
|
||||
|
||||
/**
|
||||
* setup function to initiate a util (utilName) on a scope (sope) with options (options).
|
||||
@ -13,57 +14,98 @@
|
||||
*/
|
||||
|
||||
window.utils.setup = function(utilName, scope, options) {
|
||||
|
||||
var utilInstance;
|
||||
|
||||
if (!utilName || !scope) {
|
||||
return;
|
||||
}
|
||||
|
||||
options = options || {};
|
||||
|
||||
var listener = function(event) {
|
||||
var utilInstance;
|
||||
|
||||
if (event.detail.targetUtil !== utilName) {
|
||||
return false;
|
||||
}
|
||||
|
||||
if (options.setupFunction) {
|
||||
utilInstance = options.setupFunction(scope, options);
|
||||
} else {
|
||||
var util = window.utils[utilName];
|
||||
if (!util) {
|
||||
throw new Error('"' + utilName + '" is not a known js util');
|
||||
}
|
||||
|
||||
utilInstance = util(scope, options);
|
||||
}
|
||||
};
|
||||
|
||||
window.utils.teardown(utilName);
|
||||
if (registeredSetupListeners[utilName] && !options.singleton) {
|
||||
registeredSetupListeners[utilName].push(listener);
|
||||
} else {
|
||||
registeredSetupListeners[utilName] = [ listener ];
|
||||
// i18n
|
||||
if (window.I18N) {
|
||||
options.i18n = window.I18N;
|
||||
}
|
||||
|
||||
document.addEventListener('setup', listener);
|
||||
if (activeInstances[utilName]) {
|
||||
var instanceWithSameScope = activeInstances[utilName]
|
||||
.filter(function(instance) { return !!instance; })
|
||||
.find(function(instance) {
|
||||
return instance.scope === scope;
|
||||
});
|
||||
var isAlreadySetup = !!instanceWithSameScope;
|
||||
|
||||
document.dispatchEvent(new CustomEvent('setup', {
|
||||
detail: { targetUtil: utilName, module: 'none' },
|
||||
bubbles: true,
|
||||
cancelable: true,
|
||||
}));
|
||||
if (isAlreadySetup) {
|
||||
console.warn('Trying to setup a JS utility that\'s already been set up', { utility: utilName, scope, options });
|
||||
}
|
||||
}
|
||||
|
||||
function setup() {
|
||||
var listener = function(event) {
|
||||
if (event.detail.targetUtil !== utilName) {
|
||||
return false;
|
||||
}
|
||||
|
||||
if (options.setupFunction) {
|
||||
utilInstance = options.setupFunction(scope, options);
|
||||
} else {
|
||||
var util = window.utils[utilName];
|
||||
if (!util) {
|
||||
throw new Error('"' + utilName + '" is not a known js util');
|
||||
}
|
||||
|
||||
utilInstance = util(scope, options);
|
||||
}
|
||||
|
||||
if (utilInstance) {
|
||||
if (activeInstances[utilName] && Array.isArray(activeInstances[utilName])) {
|
||||
activeInstances[utilName].push(utilInstance);
|
||||
} else {
|
||||
activeInstances[utilName] = [ utilInstance ];
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
if (registeredSetupListeners[utilName] && Array.isArray(registeredSetupListeners[utilName])) {
|
||||
window.utils.teardown(utilName);
|
||||
}
|
||||
|
||||
if (!registeredSetupListeners[utilName] || Array.isArray(registeredSetupListeners[utilName])) {
|
||||
registeredSetupListeners[utilName] = [];
|
||||
}
|
||||
registeredSetupListeners[utilName].push(listener);
|
||||
|
||||
document.addEventListener('setup', listener);
|
||||
|
||||
document.dispatchEvent(new CustomEvent('setup', {
|
||||
detail: { targetUtil: utilName, module: 'none' },
|
||||
bubbles: true,
|
||||
cancelable: true,
|
||||
}));
|
||||
}
|
||||
|
||||
setup();
|
||||
|
||||
return utilInstance;
|
||||
};
|
||||
|
||||
window.utils.teardown = function(utilName) {
|
||||
window.utils.teardown = function(utilName, destroy) {
|
||||
if (registeredSetupListeners[utilName]) {
|
||||
registeredSetupListeners[utilName].forEach(function(listener) {
|
||||
document.removeEventListener('setup', listener);
|
||||
});
|
||||
registeredSetupListeners[utilName]
|
||||
.filter(function(listener) { return !!listener })
|
||||
.forEach(function(listener) {
|
||||
document.removeEventListener('setup', listener);
|
||||
});
|
||||
delete registeredSetupListeners[utilName];
|
||||
}
|
||||
|
||||
if (destroy === true && activeInstances[utilName]) {
|
||||
activeInstances[utilName]
|
||||
.filter(function(instance) { return !!instance })
|
||||
.forEach(function(instance) {
|
||||
instance.destroy();
|
||||
});
|
||||
delete activeInstances[utilName];
|
||||
}
|
||||
}
|
||||
})();
|
||||
|
||||
@ -70,6 +70,7 @@
|
||||
});
|
||||
|
||||
return {
|
||||
scope: wrapper,
|
||||
destroy: function() {},
|
||||
};
|
||||
};
|
||||
|
||||
@ -86,9 +86,5 @@
|
||||
$(t).tabgroup();
|
||||
});
|
||||
}
|
||||
|
||||
return {
|
||||
destroy: function() {},
|
||||
};
|
||||
});
|
||||
})($);
|
||||
|
||||
@ -35,14 +35,16 @@ function setupDatepicker(wrapper) {
|
||||
});
|
||||
}
|
||||
|
||||
document.addEventListener('DOMContentLoaded', function() {
|
||||
var I18N = {
|
||||
filesSelected: 'Dateien ausgewählt', // TODO: interpolate these to be translated
|
||||
selectFile: 'Datei auswählen',
|
||||
selectFiles: 'Datei(en) auswählen',
|
||||
};
|
||||
// this global I18N object will be picked up automatically by the setup util
|
||||
window.I18N = {
|
||||
filesSelected: 'Dateien ausgewählt', // TODO: interpolate these to be translated
|
||||
selectFile: 'Datei auswählen',
|
||||
selectFiles: 'Datei(en) auswählen',
|
||||
asyncFormFailure: 'Da ist etwas schief gelaufen, das tut uns Leid.<br>Falls das erneut passiert schicke uns gerne eine kurze Beschreibung dieses Ereignisses über das Hilfe-Widget rechts oben.<br><br>Vielen Dank für deine Hilfe',
|
||||
};
|
||||
|
||||
document.addEventListener('DOMContentLoaded', function() {
|
||||
window.utils.setup('flatpickr', document.body, { setupFunction: setupDatepicker });
|
||||
window.utils.setup('showHide', document.body);
|
||||
window.utils.setup('inputs', document.body, { i18n: I18N });
|
||||
window.utils.setup('inputs', document.body);
|
||||
});
|
||||
|
||||
Loading…
Reference in New Issue
Block a user