diff --git a/frontend/src/app.sass b/frontend/src/app.sass
index b819e5d4a..6b65ab057 100644
--- a/frontend/src/app.sass
+++ b/frontend/src/app.sass
@@ -854,6 +854,12 @@ th, td
dd + dt, .dd + dt, dd + .dt, .dd + .dt
margin-top: 17px
+.explanation
+ font-style: italic
+ font-size: 0.9rem
+ font-weight: 600
+ color: var(--color-fontsec)
+
// SORTABLE TABLE-HEADERS
.table__th.sortable
position: relative
diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index de61d9ffd..d8ef3d1de 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -138,7 +138,6 @@ CourseMembersCountLimited n@Int max@Int: #{n}/#{max}
CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"}
CourseName: Name
CourseDescription: Beschreibung
-CourseDescriptionTip: Beliebiges Html-Markup ist gestattet
CourseHomepageExternal: Externe Homepage
CourseShorthand: Kürzel
CourseShorthandUnique: Muss nur innerhalb Institut und Semester eindeutig sein. Wird verbatim in die Url der Kursseite übernommen.
@@ -1340,7 +1339,6 @@ NavigationFavourites: Favoriten
CommSubject: Betreff
CommBody: Nachricht
-CommBodyTip: Das Eingabefeld akzeptiert derzeit ausschließlich Html. U.A. Zeilumbrüche werden dementsprechend ignoriert und müssen manuell mit
eingefügt werden.
CommRecipients: Empfänger
CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen.
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index 19a403532..224cb684a 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -138,7 +138,6 @@ CourseMembersCountLimited n max: #{n}/#{max}
CourseMembersCountOf n mbNum: #{n} #{maybeToMessage "of " mbNum " "}participants
CourseName: Title
CourseDescription: Description
-CourseDescriptionTip: You may use arbitrary Html-Markup
CourseHomepageExternal: External homepage
CourseShorthand: Shorthand
CourseShorthandUnique: Needs to be unique within school and semester. Will be used verbatim within the url of the course page.
@@ -1339,7 +1338,6 @@ NavigationFavourites: Favourites
CommSubject: Subject
CommBody: Message
-CommBodyTip: This input field currently accepts only Html. Line breaks are thus ignored and must be designated manually by inserting
in the appropriate places.
CommRecipients: Recipients
CommRecipientsTip: You always receive a copy of the message
CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties.
diff --git a/package.yaml b/package.yaml
index a81ac2588..32a5bd8df 100644
--- a/package.yaml
+++ b/package.yaml
@@ -139,6 +139,7 @@ dependencies:
- wai-middleware-prometheus
- extended-reals
- rfc5051
+ - pandoc
other-extensions:
- GeneralizedNewtypeDeriving
diff --git a/src/Foundation.hs b/src/Foundation.hs
index b76e29fc1..d79b5a45e 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -221,9 +221,6 @@ getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8
appTZ :: TZ
appTZ = $(includeSystemTZ "Europe/Berlin")
-appLanguages :: NonEmpty Lang
-appLanguages = "de-de-formal" :| ["en-eu"]
-
appLanguagesOpts :: ( MonadHandler m
, HandlerSite m ~ UniWorX
) => m (OptionList Lang)
diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs
index df110ddbb..aa7933300 100644
--- a/src/Foundation/I18n.hs
+++ b/src/Foundation/I18n.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Foundation.I18n
- ( UniWorXMessage(..)
+ ( appLanguages
+ , UniWorXMessage(..)
, ShortTermIdentifier(..)
, MsgLanguage(..)
, ShortSex(..)
@@ -36,6 +37,10 @@ import Text.Shakespeare.Text (st)
import GHC.Exts (IsList(..))
+appLanguages :: NonEmpty Lang
+appLanguages = "de-de-formal" :| ["en-eu"]
+
+
pluralDE :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ Singular
diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs
index 2b1b2fa7e..9c4805798 100644
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@@ -27,8 +27,6 @@ import Jobs.Queue
import Handler.Course.LecturerInvite
-import Text.Blaze.Html.Renderer.Text (renderHtml)
-
import qualified Data.Conduit.List as C
@@ -273,15 +271,15 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
<* bool (pure ()) (aformMessage multipleTermsMsg) (length userTerms > 1)
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
- <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder)
- & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
+ <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder))
+ (cfDesc <$> template)
<*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
(cfLink <$> template)
<*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
<* aformSection MsgCourseFormSectionRegistration
<*> allocationForm
<*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)
- <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template))
+ <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template)
<*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template)
<*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template)
<*> uploadModeForm (cfAppFiles <$> template)
diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs
index eb4edaf0a..992b1099c 100644
--- a/src/Handler/Course/News/Form.hs
+++ b/src/Handler/Course/News/Form.hs
@@ -7,8 +7,6 @@ module Handler.Course.News.Form
import Import
import Handler.Utils
-import Text.Blaze.Renderer.Text (renderMarkup)
-
import qualified Data.Conduit.List as C
import qualified Data.Set as Set
@@ -41,11 +39,11 @@ courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard
(fslI MsgCourseNewsTitle)
(cnfTitle <$> template)
cnfSummary' <- wopt
- (htmlField & guardField (not . null . renderMarkup))
+ htmlField
(fslI MsgCourseNewsSummary & setTooltip MsgCourseNewsSummaryTip)
(cnfSummary <$> template)
cnfContent' <- wreq
- (htmlField & guardField (not . null . renderMarkup))
+ htmlField
(fslI MsgCourseNewsContent)
(cnfContent <$> template)
cnfParticipantsOnly' <- wpopt checkBoxField (fslI MsgCourseNewsParticipantsOnly) (cnfParticipantsOnly <$> template)
diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs
index 9a35b8e62..9b9806169 100644
--- a/src/Handler/Course/User.hs
+++ b/src/Handler/Course/User.hs
@@ -61,13 +61,15 @@ postCUserR tid ssh csh uCId = do
return (studyfeat, studydegree, studyterms)
return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
let editByWgt = [whamlet|
- $forall (etime,_eemail,ename,_esurname) <- noteEdits
-
- _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
+ $newline never
+
+ $forall (etime,_eemail,ename,_esurname) <- noteEdits
+ -
+ _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
|] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
- aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
+ aopt (annotateField editByWgt htmlField) (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
let noteFrag :: Text
noteFrag = "notes"
noteWidget = wrapForm noteView FormSettings
diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs
index 57eae65f1..b6df32911 100644
--- a/src/Handler/Exam/Form.hs
+++ b/src/Handler/Exam/Form.hs
@@ -79,7 +79,7 @@ examForm template html = do
flip (renderAForm FormStandard) html $ ExamForm
<$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
- <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
+ <*> aopt htmlField (fslI MsgExamDescription) (efDescription <$> template)
<*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed)
<* aformSection MsgExamFormTimes
<*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index e080ba0b9..91a2f9939 100644
--- a/src/Handler/Material.hs
+++ b/src/Handler/Material.hs
@@ -64,7 +64,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
<*> aopt (textField & cfStrip & guardField (not . null) & cfCI & addDatalist typeOptions)
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
(mfType <$> template)
- <*> aopt htmlField (fslpI MsgMaterialDescription "Html")
+ <*> aopt htmlField (fslI MsgMaterialDescription)
(mfDescription <$> template)
<*> aopt utcTimeField (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip)
((mfVisibleFrom <$> template) <|> pure (Just ctime))
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 93b6f64ba..c54f701ef 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -113,7 +113,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
- <*> aopt htmlField (fslpI MsgSheetDescription "Html") (sfDescription <$> template)
+ <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
<* aformSection MsgSheetFormFiles
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
@@ -139,7 +139,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
- <*> aopt htmlField (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
+ <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
return $ case result of
FormSuccess sheetResult
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index 3ae62b70f..13ebabe6d 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -33,8 +33,8 @@ postMessageR cID = do
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageDefaultLanguage)
- <*> areq htmlField' (fslpI MsgSystemMessageContent "Html") (Just systemMessageContent)
- <*> aopt htmlField' (fslpI MsgSystemMessageSummary "Html") (Just systemMessageSummary)
+ <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
+ <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)
ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts
@@ -47,8 +47,8 @@ postMessageR cID = do
( SystemMessageTranslation
<$> pure systemMessageTranslationMessage
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
- <*> areq htmlField' (fslpI MsgSystemMessageContent "Html") (Just systemMessageTranslationContent)
- <*> aopt htmlField' (fslpI MsgSystemMessageSummary "Html") (Just systemMessageTranslationSummary)
+ <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
+ <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
)
<*> combinedButtonFieldF ""
@@ -58,8 +58,8 @@ postMessageR cID = do
$ SystemMessageTranslation
<$> pure smId
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) Nothing
- <*> areq htmlField' (fslpI MsgSystemMessageContent "Html") Nothing
- <*> aopt htmlField' (fslpI MsgSystemMessageSummary "Html") Nothing
+ <*> areq htmlField (fslI MsgSystemMessageContent) Nothing
+ <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
formResult modifyRes $ modifySystemMessage smId
@@ -260,8 +260,8 @@ postMessageListR = do
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just $ NonEmpty.head appLanguages)
- <*> areq htmlField' (fslpI MsgSystemMessageContent "Html") Nothing
- <*> aopt htmlField' (fslpI MsgSystemMessageSummary "Html") Nothing
+ <*> areq htmlField (fslI MsgSystemMessageContent) Nothing
+ <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
case addRes of
FormMissing -> return ()
diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs
index da9ed5a2e..e648530ad 100644
--- a/src/Handler/Utils/Communication.hs
+++ b/src/Handler/Utils/Communication.hs
@@ -170,8 +170,8 @@ commR CommunicationRoute{..} = do
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
<$> recipientAForm
<* aformMessage recipientsListMsg
- <*> aopt textField (fslI MsgCommSubject) Nothing
- <*> areq htmlField (fslpI MsgCommBody "Html" & setTooltip MsgCommBodyTip) Nothing
+ <*> aopt textField (fslI MsgCommSubject) Nothing
+ <*> areq htmlField (fslI MsgCommBody) Nothing
formResult commRes $ \comm -> do
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 55565fc65..dd9cadba6 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -1,6 +1,7 @@
module Handler.Utils.Form
( module Handler.Utils.Form
, module Handler.Utils.Form.MassInput
+ , module Handler.Utils.Pandoc
, module Utils.Form
, MonadWriter(..)
) where
@@ -9,6 +10,8 @@ import Utils.Form
import Handler.Utils.Form.Types
+import Handler.Utils.Pandoc
+
import Handler.Utils.DateTime
import Import
@@ -327,6 +330,7 @@ annotateField :: ToWidget (HandlerSite m) wgt => wgt -> Field m a -> Field m a
annotateField ann field@Field{fieldView=fvf} =
let fvf' idt nmt atts ei bl =
[whamlet|
+ $newline never
^{fvf idt nmt atts ei bl}
^{ann}
|]
@@ -339,12 +343,6 @@ routeField :: ( Monad m
) => Field m (Route UniWorX)
routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
--- | Variant that simply removes leading and trailing white space
-htmlField' :: Field Handler Html
-htmlField' = htmlField
- { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
- }
-
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg $ intMinField 0
diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs
index 8cb60c63a..03ae640e6 100644
--- a/src/Handler/Utils/I18n.hs
+++ b/src/Handler/Utils/I18n.hs
@@ -3,7 +3,9 @@ module Handler.Utils.I18n
, i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles
) where
-import Import
+import Import.NoFoundation
+import Foundation.Type
+import Foundation.I18n
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
@@ -71,7 +73,7 @@ i18nWidgetFiles basename = do
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
ws <- newName "ws" -- Name for dispatch function
letE
- [ funD ws $ [ clause [litP $ stringL kind, litP $ stringL l] (normalB [e|$(widgetFile $ "i18n" > basename > kind <.> l) :: Widget|]) []
+ [ funD ws $ [ clause [litP $ stringL kind, litP $ stringL l] (normalB [e|$(widgetFile $ "i18n" > basename > kind <.> l) :: WidgetFor UniWorX ()|]) []
| (unpack -> kind, ls) <- Map.toList availableTranslations'
, l <- unpack <$> NonEmpty.toList ls
] ++ [ clause [wildP, wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
diff --git a/src/Handler/Utils/Pandoc.hs b/src/Handler/Utils/Pandoc.hs
new file mode 100644
index 000000000..041bd6b6d
--- /dev/null
+++ b/src/Handler/Utils/Pandoc.hs
@@ -0,0 +1,74 @@
+module Handler.Utils.Pandoc
+ ( htmlField, htmlFieldSmall
+ , htmlReaderOptions, markdownReaderOptions
+ , markdownWriterOptions, htmlWriterOptions
+ ) where
+
+import Import.NoFoundation
+import Handler.Utils.I18n
+
+import qualified Data.Text as Text
+
+import qualified Text.Pandoc as P
+
+import Text.Blaze (preEscapedText)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import Text.HTML.SanitizeXSS (sanitizeBalance)
+
+
+data HtmlFieldKind
+ = HtmlFieldNormal
+ | HtmlFieldSmall
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe HtmlFieldKind
+instance Finite HtmlFieldKind
+
+htmlField, htmlFieldSmall :: MonadLogger m => Field m Html
+htmlField = htmlField' HtmlFieldNormal
+htmlFieldSmall = htmlField' HtmlFieldSmall
+
+
+htmlField' :: MonadLogger m => HtmlFieldKind -> Field m Html
+htmlField' fieldKind = Field{..}
+ where
+ fieldEnctype = UrlEncoded
+
+ fieldParse (t : _) _
+ = return . fmap (assertM' $ not . null . renderHtml) . parseMarkdown $ Text.strip t
+ fieldParse [] _ = return $ Right Nothing
+
+ fieldView theId name attrs val isReq = do
+ val' <- either return (maybeT (return mempty) . renderMarkdown) val
+ let markdownExplanation = $(i18nWidgetFile "markdown-explanation")
+ $(widgetFile "widgets/html-field")
+
+parseMarkdown :: Text -> Either (SomeMessage site) Html
+parseMarkdown text =
+ bimap pandocError (preEscapedText . sanitizeBalance) . P.runPure $
+ P.writeHtml5String htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text
+ where
+ pandocError = SomeMessage . tshow
+
+renderMarkdown :: (MonadLogger m, MonadPlus m) => Html -> m Text
+renderMarkdown html =
+ either (\e -> logPandocError e >> mzero) return . P.runPure $
+ P.writeMarkdown markdownWriterOptions =<< P.readHtml htmlReaderOptions (toStrict $ renderHtml html)
+ where
+ logPandocError = $logErrorS "renderMarkdown" . tshow
+
+
+htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
+htmlReaderOptions = markdownReaderOptions
+markdownReaderOptions = def
+ { P.readerExtensions = P.pandocExtensions
+ & P.enableExtension P.Ext_hard_line_breaks
+ & P.enableExtension P.Ext_autolink_bare_uris
+ , P.readerTabStop = 2
+ }
+
+markdownWriterOptions, htmlWriterOptions :: P.WriterOptions
+markdownWriterOptions = def
+ { P.writerExtensions = P.readerExtensions markdownReaderOptions
+ , P.writerTabStop = P.readerTabStop markdownReaderOptions
+ }
+htmlWriterOptions = markdownWriterOptions
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 59c3c02a2..618a783b6 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -17,6 +17,7 @@ import ClassyPrelude.Yesod as Import
, embed
, try, embed, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_
, fail
+ , htmlField
)
import UnliftIO.Async.Utils as Import
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 3a3e2e8f6..4fa7681b5 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -53,10 +53,6 @@ import Utils.Frontend.Notification
import Data.Proxy
-import Text.HTML.SanitizeXSS (sanitizeBalance)
-import Text.Blaze (preEscapedText)
-import Text.Blaze.Html.Renderer.Pretty (renderHtml)
-
import Data.Monoid (Endo(..))
@@ -643,12 +639,6 @@ secretJsonField :: forall m a.
=> Field m a
secretJsonField = secretJsonField' $ fieldView (hiddenField :: Field m Text)
-htmlFieldSmall :: forall m. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Html
-htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField
- where
- sanitize :: Text -> m (Either FormMessage Html)
- sanitize = return . Right . preEscapedText . sanitizeBalance
-
fileFieldMultiple :: Monad m => Field m [FileInfo]
fileFieldMultiple = Field
{ fieldParse = \_ files -> return $ case files of
diff --git a/stack.yaml b/stack.yaml
index d0852e051..d52b84385 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -69,5 +69,20 @@ extra-deps:
- extended-reals-0.2.3.0
+ - pandoc-2.9.2
+ - doclayout-0.3
+ - emojis-0.1
+ - hslua-module-system-0.2.1
+ - ipynb-0.1
+ - jira-wiki-markup-1.0.0
+ - HsYAML-0.2.1.0
+ - cmark-gfm-0.2.1
+ - doctemplates-0.8.1
+ - haddock-library-1.8.0
+ - pandoc-types-1.20
+ - skylighting-0.8.3.2
+ - skylighting-core-0.8.3.2
+ - texmath-0.12.0.1
+
resolver: lts-13.21
allow-newer: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 8e2842628..b96e82ebb 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -284,6 +284,104 @@ packages:
sha256: 29629bb0ac41c49671b7f792e540165ee091eb24ffd0eaff229a2f40cc03f3af
original:
hackage: extended-reals-0.2.3.0
+- completed:
+ hackage: pandoc-2.9.2@sha256:fa04b214c79328a4519093a5e82fe961a21179539165b98773a6f8bfb66bc662,36181
+ pantry-tree:
+ size: 88080
+ sha256: 95eeae57b3d00eb7fa1accacab31e032f4d535c8c2cb992891a20d694eb00339
+ original:
+ hackage: pandoc-2.9.2
+- completed:
+ hackage: doclayout-0.3@sha256:06c03875b1645e6ab835c40f9b73fd959b6c4232c01d06f07debedfae46723f2,2059
+ pantry-tree:
+ size: 425
+ sha256: ed2fc2dd826fbba67cb8018979be437b215735fab90dcc49ad30b296f7005eed
+ original:
+ hackage: doclayout-0.3
+- completed:
+ hackage: emojis-0.1@sha256:3cd86b552ad71c118a7822128c97054b6cf22bc4ff5b8f7e3eb0b356202aeecd,1907
+ pantry-tree:
+ size: 426
+ sha256: 0af0e5f0ba2af10a2eda8b96b41ff77d2229d90682c1220723a13b9582c4a41b
+ original:
+ hackage: emojis-0.1
+- completed:
+ hackage: hslua-module-system-0.2.1@sha256:7c498e51df885be5fd9abe9b762372ff4f125002824d8e11a7d5832154a7a1c3,2216
+ pantry-tree:
+ size: 508
+ sha256: 19a1e580174d2e02da4942887b2330804e8ceeed1ff4fd178a1bec4663e474ea
+ original:
+ hackage: hslua-module-system-0.2.1
+- completed:
+ hackage: ipynb-0.1@sha256:5b5240a9793781da557f82891d49cea63d71c8c5d3500fa3eac9fd702046b520,1926
+ pantry-tree:
+ size: 812
+ sha256: df171745ba4d6625eb71167a37237776cd10929994b05578b040592e2d5d5579
+ original:
+ hackage: ipynb-0.1
+- completed:
+ hackage: jira-wiki-markup-1.0.0@sha256:24484791e650c80c452348e2523decc9a410aa965f79c0734c1e257f93b25cd1,3576
+ pantry-tree:
+ size: 1178
+ sha256: 60c39181a59a497be6c754e1cbf03461d9c4950bd4c523ca1efe1bd11e6f6b4f
+ original:
+ hackage: jira-wiki-markup-1.0.0
+- completed:
+ hackage: HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311
+ pantry-tree:
+ size: 1340
+ sha256: 21f61bf9cad31674126b106071dd9b852e408796aeffc90eec1792f784107eff
+ original:
+ hackage: HsYAML-0.2.1.0
+- completed:
+ hackage: cmark-gfm-0.2.1@sha256:f49c10f6f1f8f41cb5d47e69ad6593dc45d2b28a083bbe22926d9f5bebf479b5,5191
+ pantry-tree:
+ size: 4555
+ sha256: 309d25e57e2c6d43834accc1f3a0f79150b9646f412957488d100e9cf7c37100
+ original:
+ hackage: cmark-gfm-0.2.1
+- completed:
+ hackage: doctemplates-0.8.1@sha256:be34c3210d9ebbba1c10100e30d8c3ba3b6c34653ec2ed15f09e5d05055aa37d,3111
+ pantry-tree:
+ size: 2303
+ sha256: 9d4d8e7a85166ffd951b02f87be540607b55084c04730932346072329adf4913
+ original:
+ hackage: doctemplates-0.8.1
+- completed:
+ hackage: haddock-library-1.8.0@sha256:293544a80c3d817a021fec69c430e808914a9d86db0c6bd6e96a386607a66627,3850
+ pantry-tree:
+ size: 3397
+ sha256: 2fb23fd09565829807a0368011cd57ea13e9a79fa4c65a47810aaf9a528427c2
+ original:
+ hackage: haddock-library-1.8.0
+- completed:
+ hackage: pandoc-types-1.20@sha256:8393b1a73b8a6a1f3feaeb3a6592c176461082c3e4d897f1b316b1a58dd84c39,3999
+ pantry-tree:
+ size: 855
+ sha256: cdaa66d381a21406434e7a733c9b9291a3bc44b623e7a9f97ef335283770f3fa
+ original:
+ hackage: pandoc-types-1.20
+- completed:
+ hackage: skylighting-0.8.3.2@sha256:8b8573cd8820129a4c00675f52606f0f4c04c65d2e631e9e0e3d793cefdb534c,9730
+ pantry-tree:
+ size: 10380
+ sha256: cfe063d17444f6e12a8884cab7b2ec76afba9925be04155af605931793eac1f3
+ original:
+ hackage: skylighting-0.8.3.2
+- completed:
+ hackage: skylighting-core-0.8.3.2@sha256:1f7cb6c8bb9299a83c50ae1f4b00d3808e27e4401807c530c8c3df956ad26d23,8058
+ pantry-tree:
+ size: 13279
+ sha256: 1cc0d70bd3f066bf8382206721a1e3854b78fbd067ece3d76ddbfc1c4e73fd2b
+ original:
+ hackage: skylighting-core-0.8.3.2
+- completed:
+ hackage: texmath-0.12.0.1@sha256:f68e0d01b34f53552deb506ba0b53b5cbba1bc5d87cc0d3de1bb5662d00ca5db,6569
+ pantry-tree:
+ size: 274222
+ sha256: 7bcd4a5c93f645b84fc93285e4868d7a418c66408f115710a73ad5370df9edc2
+ original:
+ hackage: texmath-0.12.0.1
snapshots:
- completed:
size: 498180
diff --git a/templates/i18n/markdown-explanation/de-de-formal.hamlet b/templates/i18n/markdown-explanation/de-de-formal.hamlet
new file mode 100644
index 000000000..bf81c0ea1
--- /dev/null
+++ b/templates/i18n/markdown-explanation/de-de-formal.hamlet
@@ -0,0 +1,3 @@
+$newline never
+Dieses Eingabefeld akzeptiert #{iconLink}Pandoc-Markdown (Englisch).
+Nach dem Abschicken wird das eingegebene Markdown umgewandelt und als HTML weiterverarbeitet bzw. gespeichert.
diff --git a/templates/i18n/markdown-explanation/en-eu.hamlet b/templates/i18n/markdown-explanation/en-eu.hamlet
new file mode 100644
index 000000000..e9a19802b
--- /dev/null
+++ b/templates/i18n/markdown-explanation/en-eu.hamlet
@@ -0,0 +1,3 @@
+$newline never
+This field accepts #{iconLink}Pandoc-Markdown.
+After sending, the content of will be converted into HTML before being processed further or saved.
diff --git a/templates/widgets/html-field.hamlet b/templates/widgets/html-field.hamlet
new file mode 100644
index 000000000..315e9aaca
--- /dev/null
+++ b/templates/widgets/html-field.hamlet
@@ -0,0 +1,9 @@
+$newline never
+$case fieldKind
+ $of HtmlFieldNormal
+