338 lines
16 KiB
Haskell
338 lines
16 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Admin.Test
|
|
( getAdminTestR
|
|
, postAdminTestR
|
|
, getAdminTestPdfR
|
|
) where
|
|
|
|
import Import
|
|
import Utils.Print
|
|
|
|
import Handler.Utils
|
|
import Jobs
|
|
|
|
import Data.Char (isDigit)
|
|
import qualified Data.Text as Text
|
|
-- import qualified Data.Text.IO as Text
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Text.Pandoc as P
|
|
import qualified Text.Pandoc.PDF as P
|
|
import qualified Text.Pandoc.Builder as P
|
|
|
|
-- just to test i18nHamlet
|
|
import Text.Hamlet
|
|
-- import Handler.Utils.I18n
|
|
|
|
import Handler.Admin.Test.Download (testDownload)
|
|
|
|
|
|
-- BEGIN - Buttons needed only here
|
|
data ButtonCreate = CreateMath | CreateInf | CrashApp -- 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"
|
|
btnLabel CrashApp = "Crash Application"
|
|
|
|
btnClasses CreateMath = [BCIsButton, BCInfo]
|
|
btnClasses CreateInf = [BCIsButton, BCPrimary]
|
|
btnClasses CrashApp = [BCIsButton, BCDanger]
|
|
-- 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
|
|
)
|
|
<*> pure def
|
|
)
|
|
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"
|
|
(FormSuccess CrashApp) -> addMessage Error "Crash Button betätigt" >> error "Crash Button"
|
|
FormMissing -> return ()
|
|
_other -> addMessage Warning "KEIN Knopf erkannt"
|
|
|
|
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
|
|
formResultModal emailResult AdminTestR $ \(email, ls) -> do
|
|
mapWriterT runDBJobs $ do
|
|
lift . queueDBJob $ JobSendTestEmail email ls
|
|
tell . pure $ Message Success [shamlet|Email-test gestartet|] (Just IconEmail)
|
|
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
|
|
-> ListLength -- ^ Previous shape of massinput
|
|
-> (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 liveliness nudge submitBtn = guardOn (allowAdd 0 0 liveliness) $ \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 >> fvWidget addView >> fvWidget 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 >> fvWidget 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, fvWidget -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
|
|
|
|
((i18nResult, fvWidget -> i18nWidget), i18nEnc) <- runFormPost . identifyForm ("i18n-stored-markup" :: Text) $ i18nField htmlField True (\_ -> Nothing) ("i18n-stored-markup" :: Text) "" True Nothing
|
|
|
|
testDownloadWidget <- testDownload
|
|
|
|
testHamlet1 <- withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet")
|
|
--let testHamlet2 = $(i18nHamletFile "test")
|
|
let testHamlet2 = testHamlet1
|
|
btnModalText = [whamlet|<button type="button" class=#{unwords $ map toPathPiece [BCIsButton, BCDanger]}>
|
|
Button-Modal
|
|
|]
|
|
|
|
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:var(--font-monospace);">
|
|
#{tshow res}
|
|
|]
|
|
|
|
i18nIdent <- newIdent
|
|
let i18nForm' = wrapForm i18nWidget FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ AdminTestR :#: i18nIdent
|
|
, formEncoding = i18nEnc
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just i18nIdent
|
|
}
|
|
[whamlet|
|
|
<h2>I18n-Form
|
|
^{i18nForm'}
|
|
$case i18nResult
|
|
$of FormMissing
|
|
$of FormFailure errs
|
|
<ul>
|
|
$forall err <- errs
|
|
<li>#{err}
|
|
$of FormSuccess res
|
|
<pre .json>
|
|
#{toYAML res}
|
|
|]
|
|
|
|
[whamlet|
|
|
<section>
|
|
<h2>_{MsgTestDownload}
|
|
^{testDownloadWidget}
|
|
|]
|
|
|
|
[whamlet|
|
|
<section>
|
|
<h2>Test i18nHamlet 1
|
|
#{testHamlet1}
|
|
<section>
|
|
<h2>Test i18nHamlet 2
|
|
#{testHamlet2}
|
|
|]
|
|
i18n $ MsgPrintDebugForStupid "DebugForStupid"
|
|
|
|
|
|
|
|
|
|
getAdminTestPdfR :: Handler TypedContent
|
|
getAdminTestPdfR = do
|
|
-- uUser <- maybeAuth -- to determine language for test
|
|
templates <- liftIO $ do
|
|
letter_tp <- P.compileTemplate "" templateRenewal
|
|
din5008 <- P.compileTemplate "" templateDIN5008
|
|
now <- getCurrentTime
|
|
return (now, letter_tp, din5008)
|
|
case templates of
|
|
(_,Left err,_) -> sendResponseStatus internalServerError500 $ "Markdown template error: \n" <> err
|
|
(_,_,Left err) -> sendResponseStatus internalServerError500 $ "LaTeX template error: \n" <> err
|
|
(now, Right templ, Right latex) -> do
|
|
content <- liftIO . P.runIO $ do
|
|
let texopts = []
|
|
readeropts = def { P.readerExtensions = P.pandocExtensions }
|
|
writeropts1 = def { P.writerTemplate = Just templ }
|
|
writeropts2 = def { P.writerTemplate = Just latex }
|
|
-- https://github.com/jgm/pandoc/issues/1950
|
|
-- using markdown as a template for itself for interpolation:
|
|
doc1 <- P.readMarkdown readeropts templateRenewal
|
|
doc2 <- P.writeMarkdown writeropts1 doc1
|
|
doc3 <- P.readMarkdown readeropts doc2
|
|
P.makePDF "lualatex" texopts P.writeLaTeX writeropts2 $
|
|
P.setDate (P.text . tshow $ utctDay now) doc3
|
|
case content of
|
|
Right (Right bs) -> do
|
|
liftIO $ LBS.writeFile "/tmp/generated.pdf" bs
|
|
mbEncPdf <- encryptPDF "tomatenmarmelade" bs
|
|
case mbEncPdf of
|
|
Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err
|
|
Right encPdf -> do
|
|
liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf
|
|
sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict bs) now
|
|
Right (Left err) -> sendResponseStatus internalServerError500 $ decodeUtf8 $ LBS.toStrict $ "LaTeX compile error: \n" <> err
|
|
Left err -> sendResponseStatus internalServerError500 $ "Pandoc error: \n" <> P.renderError err
|