228 lines
11 KiB
Haskell
228 lines
11 KiB
Haskell
module Handler.Admin.Test
|
|
( getAdminTestR
|
|
, postAdminTestR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Jobs
|
|
|
|
import Data.Char (isDigit)
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
-- BEGIN - Buttons needed only here
|
|
data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonCreate
|
|
instance Finite ButtonCreate
|
|
|
|
nullaryPathPiece ''ButtonCreate camelToPathPiece
|
|
|
|
instance Button UniWorX ButtonCreate where
|
|
btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
|
|
btnLabel CreateInf = "Informatik"
|
|
|
|
btnClasses CreateMath = [BCIsButton, BCInfo]
|
|
btnClasses CreateInf = [BCIsButton, BCPrimary]
|
|
-- END Button needed only here
|
|
|
|
emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
|
|
emailTestForm = (,)
|
|
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
|
|
<*> ( MailContext
|
|
<$> (Languages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
|
|
<*> (toMailDateTimeFormat
|
|
<$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
|
|
)
|
|
)
|
|
where
|
|
toMailDateTimeFormat dt d t = \case
|
|
SelFormatDateTime -> dt
|
|
SelFormatDate -> d
|
|
SelFormatTime -> t
|
|
|
|
makeDemoForm :: Int -> Form (Int,Bool,Double)
|
|
makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ (,,)
|
|
<$> areq (minIntFieldI n ("Zahl" :: Text)) (fromString $ "Ganzzahl > " ++ show n) Nothing
|
|
<* aformSection MsgFormBehaviour
|
|
<*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
|
|
<*> areq doubleField "Fliesskommazahl" Nothing
|
|
-- NO LONGER DESIRED IN AFORMS:
|
|
-- <* submitButton
|
|
return $ case result of
|
|
FormSuccess fsres
|
|
| errorMsgs <- validateResult fsres
|
|
, not $ null errorMsgs -> (FormFailure errorMsgs, widget)
|
|
_otherwise -> (result, widget)
|
|
where
|
|
validateResult :: (Int,Bool,Double) -> [Text]
|
|
validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
|
|
validateResult _other = []
|
|
|
|
|
|
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
|
|
getAdminTestR = postAdminTestR
|
|
postAdminTestR = do
|
|
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
|
|
let btnForm = wrapForm btnWdgt def
|
|
{ formAction = Just $ SomeRoute AdminTestR
|
|
, formEncoding = btnEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
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" :: 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)})|] (Just IconEmail)
|
|
return jId
|
|
runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
|
|
addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
|
|
|
|
let emailWidget' = wrapForm emailWidget def
|
|
{ formAction = Just . SomeRoute $ AdminTestR
|
|
, formEncoding = emailEnctype
|
|
, formAttrs = [("uw-async-form", "")]
|
|
}
|
|
|
|
|
|
let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
|
|
((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
|
|
formResult demoResult demoFormAction
|
|
let showDemoResult = [whamlet|
|
|
$maybe (i,b,d) <- formResult' demoResult
|
|
Received values:
|
|
<ul>
|
|
<li>#{show i}
|
|
<li>#{show b}
|
|
<li>#{show d}
|
|
$nothing
|
|
No form values received, due to #
|
|
$# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
|
|
$case demoResult
|
|
$of FormSuccess _
|
|
$# Already dealt with above, to showecase usage of formResult' as normally done.
|
|
success, which should not happen here.
|
|
$of FormMissing
|
|
Form data missing, probably empty.
|
|
$of FormFailure msgs
|
|
<ul>
|
|
$forall m <- msgs
|
|
<li>#{m}
|
|
|]
|
|
let testTooltipMsg = toWidget [whamlet| So sehen aktuell Tooltips via iconTooltip aus. |] :: WidgetFor UniWorX ()
|
|
|
|
msgInfoTooltip <- messageI Info ("Info-Tooltip via messageI" :: Text)
|
|
msgSuccessTooltip <- messageI Success ("Success-Tooltip via messageI" :: Text)
|
|
msgWarningTooltip <- messageI Warning ("Warning-Tooltip via messageI" :: Text)
|
|
msgErrorTooltip <- messageI Error ("Error-Tooltip via messageI" :: Text)
|
|
|
|
msgNonDefaultIconTooltip <- messageIconI Info IconEmail ("Info-Tooltip mit lustigem Icon" :: Text)
|
|
|
|
{- The following demonstrates the use of @massInput@.
|
|
|
|
@massInput@ takes as arguments:
|
|
- A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
|
|
- Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
|
|
- An initial value to pre-fill the field with
|
|
|
|
@massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
|
|
-}
|
|
let
|
|
-- We define the fields of the configuration struct @MassInput@:
|
|
|
|
-- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
|
|
--
|
|
-- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
|
|
mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
|
|
-> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
|
|
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
|
-> FieldView UniWorX -- ^ Submit-Button for this add-widget
|
|
-> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
|
|
mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
|
|
(addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
|
|
let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
|
|
addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
|
|
return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
|
|
mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
|
|
|
|
-- | Make a single massInput-Cell
|
|
--
|
|
-- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
|
|
mkCellForm :: ListPosition -- ^ Position of this cell
|
|
-> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
|
|
-> Maybe Int -- ^ Initial cell result from Argument to `massInput`
|
|
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
|
-> Form Int
|
|
mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
|
|
(intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
|
|
return (intRes, toWidget csrf >> fvInput intView)
|
|
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
|
|
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
|
|
-> ListPosition -- ^ Coordinate to delete
|
|
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
|
|
deleteCell = miDeleteList
|
|
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
|
|
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
|
allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
|
|
-- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
|
|
buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
|
|
|
|
-- The actual call to @massInput@ is comparatively simple:
|
|
|
|
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
|
|
|
|
|
|
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
|
|
siteLayout locallyDefinedPageHeading $ do
|
|
-- defaultLayout $ do
|
|
setTitle "Uni2work Admin Testpage"
|
|
$(i18nWidgetFile "admin-test")
|
|
|
|
[whamlet|<h2>Formular Demonstration|]
|
|
wrapForm formWidget FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ AdminTestR :#: FIDAdminDemo
|
|
, formEncoding = formEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just FIDAdminDemo
|
|
}
|
|
showDemoResult
|
|
|
|
miIdent <- newIdent
|
|
let miForm' = wrapForm miForm FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ AdminTestR :#: miIdent
|
|
, formEncoding = miEnc
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just miIdent
|
|
}
|
|
[whamlet|
|
|
<h2>Mass-Input
|
|
^{miForm'}
|
|
$case miResult
|
|
$of FormMissing
|
|
$of FormFailure errs
|
|
<ul>
|
|
$forall err <- errs
|
|
<li>#{err}
|
|
$of FormSuccess res
|
|
<p style="white-space:pre-wrap; font-family:monospace;">
|
|
#{tshow res}
|
|
|]
|