fix(html-field): introduce stored-markup

BREAKING CHANGE: StoredMarkup

models/allocations.model

@@ -3,8 +3,8 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
     school              SchoolId        -- school that manages this central allocation, not necessarily school of courses
     shorthand           AllocationShorthand -- practical shorthand
     name                AllocationName
-    description         Html Maybe      -- description for prospective students
+    description         StoredMarkup Maybe      -- description for prospective students
-    staffDescription    Html Maybe      -- description seen by prospective lecturers only
+    staffDescription    StoredMarkup Maybe      -- description seen by prospective lecturers only
     staffRegisterFrom   UTCTime Maybe   -- lectureres may register courses
     staffRegisterTo     UTCTime Maybe   -- course registration stops
     -- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards

models/courses.model

@@ -5,7 +5,7 @@ DegreeCourse json   -- for which degree programmes this course is appropriate fo
     UniqueDegreeCourse course degree terms
 Course    -- Information about a single course; contained info is always visible to all users
     name             (CI Text)
-    description      Html Maybe    -- user-defined large Html, ought to contain module description
+    description      StoredMarkup Maybe    -- user-defined large Html, ought to contain module description
     linkExternal     Text Maybe    -- arbitrary user-defined url for external course page
     shorthand        (CI Text)     -- practical shorthand of course name, used for identification
     term             TermId        -- semester this course is taught
@@ -21,7 +21,7 @@ Course    -- Information about a single course; contained info is always visible
     registerSecret   Text Maybe    -- enrolement maybe protected by a simple common passphrase
     materialFree     Bool          -- False: only enrolled users may see course materials not stored in this table
     applicationsRequired       Bool default=false
-    applicationsInstructions   Html Maybe
+    applicationsInstructions   StoredMarkup Maybe
     applicationsText           Bool default=false
     applicationsFiles          UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb"
     applicationsRatingsVisible Bool default=false
@@ -33,7 +33,7 @@ CourseEvent
     course CourseId
     room Text
     time Occurrences
-    note Html Maybe
+    note StoredMarkup Maybe
     lastChanged UTCTime default=now()
 
 CourseAppInstructionFile
@@ -72,7 +72,7 @@ CourseParticipant                      -- course enrolement
 CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
     course       CourseId
     user         UserId
-    note         Html          -- arbitrary user-defined text; visible only to lecturer of this course
+    note         StoredMarkup  -- arbitrary user-defined text; visible only to lecturer of this course
     UniqueCourseUserNote user course
 CourseUserNoteEdit             -- who edited a participants course note when
     user         UserId

models/courses/materials.model

@@ -2,7 +2,7 @@ Material -- course material for disemination to course participants
   course          CourseId
   name            (CI Text)
   type            (CI Text) Maybe
-  description     Html Maybe
+  description     StoredMarkup Maybe
   visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before
   lastEdit        UTCTime
   UniqueMaterial course name

models/courses/news.model

@@ -3,8 +3,8 @@ CourseNews
     visibleFrom         UTCTime Maybe
     participantsOnly    Bool
     title               Text Maybe
-    content             Html
+    content             StoredMarkup
-    summary             Html Maybe
+    summary             StoredMarkup Maybe
     lastEdit            UTCTime
 CourseNewsFile
     news     CourseNewsId

models/exams.model

@@ -16,7 +16,7 @@ Exam
   closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification)
   publicStatistics Bool
   gradingMode ExamGradingMode
-  description Html Maybe
+  description StoredMarkup Maybe
   examMode ExamMode
   staff Text Maybe
   UniqueExam course name
@@ -35,7 +35,7 @@ ExamOccurrence
   capacity Natural
   start UTCTime
   end UTCTime Maybe
-  description Html Maybe
+  description StoredMarkup Maybe
   UniqueExamOccurrence exam name
 ExamRegistration
   exam ExamId

models/sheets.model

@@ -1,10 +1,10 @@
 Sheet   -- exercise sheet for a given course
     course          CourseId
     name            (CI Text)
-    description     Html Maybe
+    description     StoredMarkup Maybe
     type            SheetType        -- Does it count towards overall course grade?
     grouping        SheetGroup       -- May participants submit in groups of certain sizes?
-    markingText     Html Maybe       -- Instructons for correctors, included in marking templates
+    markingText     StoredMarkup Maybe -- Instructons for correctors, included in marking templates
     visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before
     activeFrom      UTCTime Maybe    -- Download of questions and submission is permitted afterwards
     activeTo        UTCTime Maybe    -- Submission is only permitted before

models/system-messages.model

@@ -11,14 +11,14 @@ SystemMessage
     lastChanged         UTCTime default=now()
     lastUnhide          UTCTime default=now()
     defaultLanguage     Lang -- Language of @content@ and @summary@
-    content             Html -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
+    content             StoredMarkup -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
-    summary             Html Maybe
+    summary             StoredMarkup Maybe
 
 SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers
     message             SystemMessageId
     language            Lang
-    content             Html
+    content             StoredMarkup
-    summary             Html Maybe
+    summary             StoredMarkup Maybe
     UniqueSystemMessageTranslation message language
 
 SystemMessageHidden

src/Database/Esqueleto/Utils.hs

@@ -25,7 +25,7 @@ module Database.Esqueleto.Utils
   , max, min
   , abs
   , SqlProject(..)
-  , (->.)
+  , (->.), (#>>.)
   , fromSqlKey
   , selectCountRows
   , selectMaybe
@@ -367,6 +367,12 @@ infixl 8 ->.
 (->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
 (->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t
 
+infixl 8 #>>.
+
+(#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text))
+(#>>.) expr t = E.unsafeSqlBinOp "#>>" expr $ E.val t
+
+
 fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64)
 fromSqlKey = E.veryUnsafeCoerceSqlExprValue
 

src/Foundation/SiteLayout.hs

@@ -454,7 +454,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
       case summary of
         Just s ->
           addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
-        Nothing -> addMessage systemMessageSeverity content
+        Nothing -> addMessage systemMessageSeverity $ toHtml content
 
       tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
         HashMap.singleton cID mempty{ userSystemMessageShown = Just now }

src/Handler/Course/Edit.hs

@@ -34,14 +34,14 @@ data CourseForm = CourseForm
         , cfShort       :: CourseShorthand
         , cfSchool      :: SchoolId
         , cfTerm        :: TermId
-        , cfDesc        :: Maybe Html
+        , cfDesc        :: Maybe StoredMarkup
         , cfLink        :: Maybe Text
         , cfVisFrom     :: Maybe UTCTime
         , cfVisTo       :: Maybe UTCTime
         , cfMatFree     :: Bool
         , cfAllocation  :: Maybe AllocationCourseForm
         , cfAppRequired         :: Bool
-        , cfAppInstructions     :: Maybe Html
+        , cfAppInstructions     :: Maybe StoredMarkup
         , cfAppInstructionFiles :: Maybe FileUploads
         , cfAppText             :: Bool
         , cfAppFiles            :: UploadMode

src/Handler/Course/Events/Form.hs

@@ -15,7 +15,7 @@ data CourseEventForm = CourseEventForm
   { cefType             :: CI Text
   , cefRoom             :: Text
   , cefTime             :: Occurrences
-  , cefNote             :: Maybe Html
+  , cefNote             :: Maybe StoredMarkup
   }
 
 courseEventForm :: Maybe CourseEventForm -> Form CourseEventForm

src/Handler/Course/List.hs

@@ -81,7 +81,12 @@ makeCourseTable whereClause colChoices psValidator = do
         return (course, participants, registered, school)
       lecturerQuery cid (user `E.InnerJoin` lecturer) = do
         E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
-        E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
+        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
+             E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
+        return user
+      isCourseAdminQuery cid (user `E.InnerJoin` lecturer) = do
+        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
+        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
         return user
       isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course
         E.&&. E.just (user E.^. UserId) E.==. E.val muid
@@ -135,8 +140,8 @@ makeCourseTable whereClause colChoices psValidator = do
         , ( "lecturer", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> E.exists $ E.from $ \t -> do
-                  user <- lecturerQuery (course E.^. CourseId) t
+                  user <- isCourseAdminQuery (course E.^. CourseId) t
-                  E.where_ $ E.any (E.hasInfix (user E.^. UserSurname) . E.val) (criterias :: Set.Set Text)
+                  E.where_ $ E.any (E.hasInfix (user E.^. UserDisplayName) . E.val) (criterias :: Set.Set Text)
           )
         , ( "openregistration", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Bool) of
               Nothing -> E.val True
@@ -167,7 +172,7 @@ makeCourseTable whereClause colChoices psValidator = do
               Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
               Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                        E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
-                       E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+                       E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
           )
         ]
     , dbtFilterUI = \mPrev -> mconcat $ catMaybes

src/Handler/Course/News/Form.hs

@@ -12,8 +12,8 @@ import qualified Data.Conduit.List as C
 
 data CourseNewsForm = CourseNewsForm
   { cnfTitle            :: Maybe Text
-  , cnfSummary          :: Maybe Html
+  , cnfSummary          :: Maybe StoredMarkup
-  , cnfContent          :: Html
+  , cnfContent          :: StoredMarkup
   , cnfParticipantsOnly :: Bool
   , cnfVisibleFrom      :: Maybe UTCTime
   , cnfFiles            :: Maybe FileUploads

src/Handler/Course/User.hs

@@ -29,6 +29,7 @@ import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Conduit.Combinators as C
+import qualified Data.Text.Lazy as LT
 
 
 data ExamAction = ExamDeregister
@@ -226,7 +227,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
         maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
         deleteBy thisUniqueNote
         addMessageI Info MsgCourseUserNoteDeleted
-      _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
+      _ | ((==) `on` fmap (LT.strip . renderHtml . markupOutput)) mbNote noteText -> return () -- no changes
       (Just note) -> do
         dozentId <- requireAuthId
         (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]

src/Handler/Course/Users.hs

@@ -174,7 +174,7 @@ data UserTableCsv = UserTableCsv
   , csvUserStudyFeatures :: UserTableStudyFeatures
   , csvUserSubmissionGroup :: Maybe SubmissionGroupName
   , csvUserRegistration :: UTCTime
-  , csvUserNote :: Maybe Html
+  , csvUserNote :: Maybe StoredMarkup
   , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
   , csvUserExams :: [ExamName]
   , csvUserSheets :: Map SheetName (SheetType, Maybe Points)

src/Handler/Exam/Form.hs

@@ -22,12 +22,14 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
 import qualified Control.Monad.State.Class as State
-import Text.Blaze.Html.Renderer.String (renderHtml)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import qualified Data.Text.Lazy as LT
 
 
 data ExamForm = ExamForm
   { efName :: ExamName
-  , efDescription :: Maybe Html
+  , efDescription :: Maybe StoredMarkup
   , efStart :: Maybe UTCTime
   , efEnd :: Maybe UTCTime
   , efVisibleFrom :: Maybe UTCTime
@@ -56,7 +58,7 @@ data ExamOccurrenceForm = ExamOccurrenceForm
   , eofCapacity :: Natural
   , eofStart :: UTCTime
   , eofEnd :: Maybe UTCTime
-  , eofDescription :: Maybe Html
+  , eofDescription :: Maybe StoredMarkup
   } deriving (Read, Show, Eq, Generic, Typeable)
 
 instance Ord ExamOccurrenceForm where
@@ -231,7 +233,7 @@ examOccurrenceForm prev = wFormToAForm $ do
                  <*> eofCapacityRes
                  <*> eofStartRes
                  <*> eofEndRes
-                 <*> (assertM (not . null . renderHtml) <$> eofDescRes)
+                 <*> eofDescRes
              , $(widgetFile "widgets/massinput/examRooms/form")
              )
 
@@ -430,7 +432,7 @@ validateExam cId oldExam = do
       [ (/=) `on` eofRoom
       , (/=) `on` eofStart
       , (/=) `on` eofEnd
-      , (/=) `on` fmap renderHtml . eofDescription
+      , (/=) `on` fmap (LT.strip . renderHtml . markupOutput) . eofDescription
       ]
 
     guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b

src/Handler/Exam/Users.hs

@@ -181,7 +181,7 @@ data ExamUserTableCsv = ExamUserTableCsv
   , csvEUserBonus :: Maybe (Maybe Points)
   , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
   , csvEUserExamResult :: Maybe ExamResultPassedGrade
-  , csvEUserCourseNote :: Maybe Html
+  , csvEUserCourseNote :: Maybe StoredMarkup
   }
   deriving (Generic)
 makeLenses_ ''ExamUserTableCsv
@@ -345,7 +345,7 @@ data ExamUserCsvAction
     }
   | ExamUserCsvSetCourseNoteData
     { examUserCsvActUser :: UserId
-    , examUserCsvActCourseNote :: Maybe Html
+    , examUserCsvActCourseNote :: Maybe StoredMarkup
     }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions

src/Handler/Help.hs

@@ -67,7 +67,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do
     <$> hfReferer'
     <*> hfUserId'
     <*> hfSubject'
-    <*> hfRequest'
+    <*> (fmap markupOutput <$> hfRequest')
     <*> hfError'
 
 validateHelpForm :: FormValidator HelpForm Handler ()

src/Handler/Material.hs

@@ -19,7 +19,7 @@ import Handler.Utils.Delete
 data MaterialForm = MaterialForm
       { mfName         :: MaterialName
       , mfType         :: Maybe (CI Text)
-      , mfDescription  :: Maybe Html
+      , mfDescription  :: Maybe StoredMarkup
       , mfVisibleFrom  :: Maybe UTCTime
       , mfFiles        :: Maybe FileUploads
       }

src/Handler/Sheet/Form.hs

@@ -26,7 +26,7 @@ type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
 
 data SheetForm = SheetForm
       { sfName         :: SheetName
-      , sfDescription  :: Maybe Html
+      , sfDescription  :: Maybe StoredMarkup
       , sfRequireExamRegistration :: Maybe ExamId
       , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads
       , sfPersonalF :: Maybe SheetPersonalisedFilesForm
@@ -39,7 +39,7 @@ data SheetForm = SheetForm
       , sfGrouping     :: SheetGroup
       , sfType         :: SheetType
       , sfAutoDistribute :: Bool
-      , sfMarkingText  :: Maybe Html
+      , sfMarkingText  :: Maybe StoredMarkup
       , sfAnonymousCorrection :: Bool
       , sfCorrectors   :: Loads
       -- Keine SheetId im Formular!

src/Handler/Utils/Communication.hs

@@ -210,7 +210,7 @@ commR CommunicationRoute{..} =  do
     <$> recipientAForm
     <*  aformMessage recipientsListMsg
     <*> aopt textField (fslI MsgCommSubject) Nothing
-    <*> areq htmlField (fslI MsgCommBody) Nothing
+    <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
   formResult commRes $ \case
     (comm, BtnCommunicationSend) -> do
       runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs

src/Handler/Utils/Form.hs

@@ -2124,25 +2124,25 @@ examModeForm mPrev = examMode
   where
     examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
     
-    examAidsEither :: Iso' ExamAids (Either Html ExamAidsPreset)
+    examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset)
     examAidsEither = iso examAidsToEither examAidsFromEither
       where examAidsToEither (ExamAidsPreset p) = Right p
             examAidsToEither (ExamAidsCustom c) = Left  c
             examAidsFromEither (Right p) = ExamAidsPreset p
             examAidsFromEither (Left  c) = ExamAidsCustom c
-    examOnlineEither :: Iso' ExamOnline (Either Html ExamOnlinePreset)
+    examOnlineEither :: Iso' ExamOnline (Either StoredMarkup ExamOnlinePreset)
     examOnlineEither = iso examOnlineToEither examOnlineFromEither
       where examOnlineToEither (ExamOnlinePreset p) = Right p
             examOnlineToEither (ExamOnlineCustom c) = Left  c
             examOnlineFromEither (Right p) = ExamOnlinePreset p
             examOnlineFromEither (Left  c) = ExamOnlineCustom c
-    examSynchronicityEither :: Iso' ExamSynchronicity (Either Html ExamSynchronicityPreset)
+    examSynchronicityEither :: Iso' ExamSynchronicity (Either StoredMarkup ExamSynchronicityPreset)
     examSynchronicityEither = iso examSynchronicityToEither examSynchronicityFromEither
       where examSynchronicityToEither (ExamSynchronicityPreset p) = Right p
             examSynchronicityToEither (ExamSynchronicityCustom c) = Left  c
             examSynchronicityFromEither (Right p) = ExamSynchronicityPreset p
             examSynchronicityFromEither (Left  c) = ExamSynchronicityCustom c
-    examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either Html ExamRequiredEquipmentPreset)
+    examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either StoredMarkup ExamRequiredEquipmentPreset)
     examRequiredEquipmentEither = iso examRequiredEquipmentToEither examRequiredEquipmentFromEither
       where examRequiredEquipmentToEither (ExamRequiredEquipmentPreset p) = Right p
             examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left  c

src/Handler/Utils/Pandoc.hs

@@ -9,6 +9,9 @@ import Import.NoFoundation
 import Handler.Utils.I18n
 
 import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LT
+
+import Control.Monad.Error.Class (liftEither)
 
 import qualified Text.Pandoc as P
 
@@ -24,27 +27,39 @@ data HtmlFieldKind
 instance Universe HtmlFieldKind
 instance Finite HtmlFieldKind
 
-htmlField, htmlFieldSmall :: MonadLogger m => Field m Html
+htmlField, htmlFieldSmall :: MonadLogger m => Field m StoredMarkup
 htmlField = htmlField' HtmlFieldNormal
 htmlFieldSmall = htmlField' HtmlFieldSmall
 
 
-htmlField' :: MonadLogger m => HtmlFieldKind -> Field m Html
+htmlField' :: MonadLogger m => HtmlFieldKind -> Field m StoredMarkup
 htmlField' fieldKind = Field{..}
   where
     fieldEnctype = UrlEncoded
 
-    fieldParse (t : _) _
+    fieldParse ((Text.strip -> t) : _) _ = runExceptT . runMaybeT $ do
-      = return . fmap (assertM' $ not . null . renderHtml) . parseMarkdown $ Text.strip t
+      html <- assertM' (not . null . LT.strip . renderHtml) =<< liftEither (parseMarkdown t)
+      return StoredMarkup
+        { markupInputFormat = MarkupMarkdown
+        , markupInput = fromStrict t
+        , markupOutput = html
+        }
     fieldParse []     _ = return $ Right Nothing
 
     fieldView theId name attrs val isReq = do
-      val' <- either return (maybeT (return mempty) . renderMarkdown) val
+      val'
+        <- let toMarkdown StoredMarkup{..} = case markupInputFormat of
+                 MarkupMarkdown -> return $ toStrict markupInput
+                 MarkupHtml -> renderMarkdown markupOutput
+                 MarkupPlaintext -> plaintextToMarkdown $ toStrict markupInput
+            in either return (maybeT (return mempty) . toMarkdown) val
+                    
       let markdownExplanation = $(i18nWidgetFile "markdown-explanation")
       $(widgetFile "widgets/html-field")
 
     parseMarkdown  = parseMarkdownWith  markdownReaderOptions htmlWriterOptions
     renderMarkdown = renderMarkdownWith htmlReaderOptions     markdownWriterOptions
+    plaintextToMarkdown = plaintextToMarkdownWith markdownWriterOptions
 
 parseMarkdownWith :: P.ReaderOptions -> P.WriterOptions -> Text -> Either (SomeMessage site) Html
 parseMarkdownWith readerOptions writerOptions text =
@@ -60,6 +75,14 @@ renderMarkdownWith readerOptions writerOptions html =
   where
     logPandocError = $logErrorS "renderMarkdown" . tshow
 
+plaintextToMarkdownWith :: (MonadLogger m, MonadPlus m) => P.WriterOptions -> Text -> m Text
+plaintextToMarkdownWith writerOptions text =
+  either (\e -> logPandocError e >> mzero) return . P.runPure $
+    P.writeMarkdown writerOptions pandoc
+  where
+    logPandocError = $logErrorS "renderMarkdown" . tshow
+    pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
+
 
 htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
 htmlReaderOptions = markdownReaderOptions

src/Model/Migration.hs

@@ -990,6 +990,27 @@ customMigrations = Map.fromListWith (>>)
   , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|]
     , return () -- Unused; used to create and fill `ChangelogItemFirstSeen`
     )
+  , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|]
+    , [executeQQ|
+        ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationDescription} TYPE jsonb USING (CASE WHEN @{AllocationDescription} IS NOT NULL THEN to_json(@{AllocationDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationStaffDescription} TYPE jsonb USING (CASE WHEN @{AllocationStaffDescription} IS NOT NULL THEN to_json(@{AllocationStaffDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseApplicationsInstructions} TYPE jsonb USING (CASE WHEN @{CourseApplicationsInstructions} IS NOT NULL THEN to_json(@{CourseApplicationsInstructions}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{CourseEvent} ALTER COLUMN @{CourseEventNote} TYPE jsonb USING (CASE WHEN @{CourseEventNote} IS NOT NULL THEN to_json(@{CourseEventNote}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{CourseUserNote} ALTER COLUMN @{CourseUserNoteNote} TYPE jsonb USING (CASE WHEN @{CourseUserNoteNote} IS NOT NULL THEN to_json(@{CourseUserNoteNote}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Material} ALTER COLUMN @{MaterialDescription} TYPE jsonb USING (CASE WHEN @{MaterialDescription} IS NOT NULL THEN to_json(@{MaterialDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsContent} TYPE jsonb USING (CASE WHEN @{CourseNewsContent} IS NOT NULL THEN to_json(@{CourseNewsContent}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsSummary} TYPE jsonb USING (CASE WHEN @{CourseNewsSummary} IS NOT NULL THEN to_json(@{CourseNewsSummary}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Exam} ALTER COLUMN @{ExamDescription} TYPE jsonb USING (CASE WHEN @{ExamDescription} IS NOT NULL THEN to_json(@{ExamDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{ExamOccurrence} ALTER COLUMN @{ExamOccurrenceDescription} TYPE jsonb USING (CASE WHEN @{ExamOccurrenceDescription} IS NOT NULL THEN to_json(@{ExamOccurrenceDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetDescription} TYPE jsonb USING (CASE WHEN @{SheetDescription} IS NOT NULL THEN to_json(@{SheetDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetMarkingText} TYPE jsonb USING (CASE WHEN @{SheetMarkingText} IS NOT NULL THEN to_json(@{SheetMarkingText}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageContent} TYPE jsonb USING (CASE WHEN @{SystemMessageContent} IS NOT NULL THEN to_json(@{SystemMessageContent}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END);
+      |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -18,3 +18,4 @@ import Model.Types.Languages as Types
 import Model.Types.File as Types
 import Model.Types.User as Types
 import Model.Types.Changelog as Types
+import Model.Types.Markup as Types

src/Model/Types/Changelog.hs

@@ -38,6 +38,7 @@ classifyChangelogItem = \case
   ChangelogExamAchievementParticipantDuplication  -> ChangelogItemBugfix
   ChangelogFormsTimesReset                        -> ChangelogItemBugfix
   ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
+  ChangelogStoredMarkup                           -> ChangelogItemBugfix
   _other                                          -> ChangelogItemFeature
 
 changelogItemDays :: Map ChangelogItem Day

src/Model/Types/Exam.hs

@@ -43,6 +43,7 @@ module Model.Types.Exam
 import Import.NoModel
 import Model.Types.Common
 import Model.Types.TH.PathPiece
+import Model.Types.Markup
 
 import qualified Data.Text as Text
 import qualified Data.Map as Map
@@ -439,7 +440,7 @@ instance Enum ExamPartNumber where
 
 data ExamAids
   = ExamAidsPreset { examAidsPreset :: ExamAidsPreset }
-  | ExamAidsCustom { examAidsCustom :: Html }
+  | ExamAidsCustom { examAidsCustom :: StoredMarkup }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data ExamAidsPreset
@@ -460,7 +461,7 @@ pathPieceJSON ''ExamAidsPreset
 
 data ExamOnline
   = ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset }
-  | ExamOnlineCustom { examOnlineCustom :: Html }
+  | ExamOnlineCustom { examOnlineCustom :: StoredMarkup }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data ExamOnlinePreset
@@ -481,7 +482,7 @@ pathPieceJSON ''ExamOnlinePreset
 
 data ExamSynchronicity
   = ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset }
-  | ExamSynchronicityCustom { examSynchronicityCustom :: Html }
+  | ExamSynchronicityCustom { examSynchronicityCustom :: StoredMarkup }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data ExamSynchronicityPreset
@@ -502,7 +503,7 @@ pathPieceJSON ''ExamSynchronicityPreset
 
 data ExamRequiredEquipment
   = ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset }
-  | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: Html }
+  | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: StoredMarkup }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data ExamRequiredEquipmentPreset

src/Model/Types/Markup.hs

@@ -0,0 +1,133 @@
+module Model.Types.Markup
+  ( MarkupFormat(..)
+  , StoredMarkup(..)
+  , htmlToStoredMarkup, plaintextToStoredMarkup, preEscapedToStoredMarkup
+  , esqueletoMarkupOutput
+  ) where
+
+import Import.NoModel
+
+import Text.Blaze (ToMarkup(..))
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import qualified Data.Text.Lazy as LT
+import qualified Data.ByteString.Lazy as LBS
+import Data.Text.Encoding (decodeUtf8')
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+
+import qualified Data.Csv as Csv
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Internal.Internal as E
+import Database.Persist.Sql
+
+
+data MarkupFormat
+  = MarkupMarkdown
+  | MarkupHtml
+  | MarkupPlaintext
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1
+pathPieceJSON ''MarkupFormat
+
+data StoredMarkup = StoredMarkup
+  { markupInputFormat :: MarkupFormat
+  , markupInput       :: LT.Text
+  , markupOutput      :: Html
+  } deriving (Read, Show, Generic, Typeable)
+
+htmlToStoredMarkup :: Html -> StoredMarkup
+htmlToStoredMarkup html = StoredMarkup
+  { markupInputFormat = MarkupHtml
+  , markupInput = renderHtml html
+  , markupOutput = html
+  }
+plaintextToStoredMarkup :: Textual t => t -> StoredMarkup
+plaintextToStoredMarkup (repack -> t) = StoredMarkup
+  { markupInputFormat = MarkupPlaintext
+  , markupInput = t
+  , markupOutput = toMarkup t
+  }
+preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup
+preEscapedToStoredMarkup (repack -> t) = StoredMarkup
+  { markupInputFormat = MarkupHtml
+  , markupInput = fromStrict t
+  , markupOutput = preEscapedToMarkup t
+  }
+
+esqueletoMarkupOutput :: E.SqlExpr (E.Value StoredMarkup) -> E.SqlExpr (E.Value Html)
+esqueletoMarkupOutput sMarkup = E.maybe (E.val mempty) E.veryUnsafeCoerceSqlExprValue $ E.maybe (sMarkup E.#>>. "{}") E.just (sMarkup E.#>>. "{\"markup-output\"}")
+
+instance Eq StoredMarkup where
+  (==) = (==) `on` LT.strip . renderHtml . markupOutput
+instance Ord StoredMarkup where
+  compare = comparing $ LT.strip . renderHtml . markupOutput
+
+instance ToJSON StoredMarkup where
+  toJSON StoredMarkup{..}
+    | markupInputFormat == MarkupHtml
+    , renderHtml markupOutput == markupInput
+    = Aeson.String $ toStrict markupInput
+    | otherwise
+    = Aeson.object
+        [ "input-format"  Aeson..= markupInputFormat
+        , "markup-input"  Aeson..= markupInput
+        , "markup-output" Aeson..= markupOutput
+        ]
+instance FromJSON StoredMarkup where
+  parseJSON v = case v of
+    Aeson.String t -> return $ preEscapedToStoredMarkup t
+    Aeson.Object o -> do
+      markupInputFormat <- o Aeson..: "input-format"
+      markupInput       <- o Aeson..: "markup-input"
+      markupOutput      <- o Aeson..: "markup-output"
+      return StoredMarkup{..}
+    other -> Aeson.typeMismatch "StoredMarkup" other
+
+instance IsString StoredMarkup where
+  fromString = preEscapedToStoredMarkup
+instance ToMarkup StoredMarkup where
+  toMarkup = markupOutput
+instance ToWidget site StoredMarkup where
+  toWidget = toWidget . toMarkup
+
+instance Semigroup StoredMarkup where
+  a <> b
+    | markupInputFormat a == markupInputFormat b
+    = StoredMarkup
+      { markupInputFormat = markupInputFormat a
+      , markupInput = ((<>) `on` markupInput) a b -- this seems optimistic...
+      , markupOutput = ((<>) `on` markupOutput) a b
+      }
+    | null $ markupInput a
+    = b
+    | null $ markupInput b
+    = a
+    | otherwise
+    = StoredMarkup
+      { markupInputFormat = MarkupHtml
+      , markupInput = renderHtml $ ((<>) `on` markupOutput) a b
+      , markupOutput = ((<>) `on` markupOutput) a b
+      }
+instance Monoid StoredMarkup where
+  mempty = fromString mempty
+
+instance Csv.ToField StoredMarkup where
+  toField = Csv.toField . markupOutput
+instance Csv.FromField StoredMarkup where
+  parseField = fmap htmlToStoredMarkup . Csv.parseField
+
+instance PersistField StoredMarkup where
+  fromPersistValue (PersistDbSpecific bs) = first pack $ Aeson.eitherDecodeStrict' bs
+  fromPersistValue (PersistByteString bs) = first pack $ Aeson.eitherDecodeStrict' bs
+                                                     <|> bimap show preEscapedToStoredMarkup (decodeUtf8' bs)
+  fromPersistValue (PersistText t) = first pack $ Aeson.eitherDecodeStrict' (encodeUtf8 t)
+                                              <|> return (preEscapedToStoredMarkup t)
+  fromPersistValue _ = Left "StoredMarkup values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
+  toPersistValue = PersistDbSpecific . LBS.toStrict . Aeson.encode
+instance PersistFieldSql StoredMarkup where
+  sqlType _ = SqlOther "jsonb"

templates/i18n/changelog/stored-markup.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Html-Felder speichern nun den genauen Markdown-Eingabetext, sodass erneutes Editieren nicht mehr zu verändertem oder invaliden Markup führen sollte.

templates/i18n/changelog/stored-markup.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Html fields now store the exact markdown input. Therefore repeated editing should no longer result in changed or invalid markup.

test/Database/Fill.hs

@@ -556,7 +556,7 @@ fillDb = do
       nbrs = [1,2,3,27,7,1]
   ffp <- insert' Course
     { courseName = "Fortgeschrittene Funktionale Programmierung"
-    , courseDescription = Just [shamlet|
+    , courseDescription = Just $ htmlToStoredMarkup [shamlet|
         <h2>It is fun!
         <p>Come to where the functional is!
         <section>

test/Model/TypesSpec.hs

@@ -18,7 +18,7 @@ import Yesod.Auth.Util.PasswordStore
 import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey)
 
 import Text.Blaze.Html
-import Text.Blaze.Renderer.Text
+import Text.Blaze.Html.Renderer.Text (renderHtml)
 
 import qualified Data.Set as Set
 
@@ -215,7 +215,13 @@ instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key r
 
 instance Arbitrary Html where
   arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary
-  shrink = map preEscapedToHtml . shrink . renderMarkup
+  shrink = map preEscapedToHtml . shrink . renderHtml
+
+instance Arbitrary StoredMarkup where
+  arbitrary = oneof
+    [ htmlToStoredMarkup <$> arbitrary
+    , (plaintextToStoredMarkup :: Text -> StoredMarkup) <$> arbitrary
+    ]
 
 instance Arbitrary OccurrenceSchedule where
   arbitrary = genericArbitrary
@@ -389,6 +395,8 @@ spec = do
       [ persistFieldLaws, jsonLaws, binaryLaws ]
     lawsCheckHspec (Proxy @ExamPartNumber)
       [ persistFieldLaws, jsonLaws, pathPieceLaws, csvFieldLaws, eqLaws, ordLaws ]
+    lawsCheckHspec (Proxy @StoredMarkup)
+      [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws, csvFieldLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $
@@ -448,6 +456,19 @@ spec = do
       t "{\"user\": {\"mode\": \"upload-specific\", \"specific-files\": [{\"name\": \"abgabe6.pdf\", \"label\": \"Abgabe 6\", \"required\": true}]}, \"corrector\": false}"
       t "{\"user\": {\"mode\": \"upload-specific\", \"specific-files\": [{\"name\": \"abgabe10.pdf\", \"label\": \"Abgabe 10\", \"required\": true}, {\"name\": \"deckblatt10.pdf\", \"label\": \"Deckblatt 10\", \"required\": true}]}, \"corrector\": false}"
       t "{\"user\": {\"mode\": \"no-upload\"}, \"corrector\": false}"
+  describe "StoredMarkup" $ do
+    it "decodes from Html via json" . property $
+      \html -> case Aeson.eitherDecode (Aeson.encode html) of
+        Left _ -> False
+        Right StoredMarkup{..} -> ((==) `on` renderHtml) markupOutput html
+                               && markupInputFormat == MarkupHtml
+                               && renderHtml html == markupInput
+    it "decodes from Html via persistent" . property $
+      \html -> case fromPersistValue (toPersistValue html) of
+        Left _ -> False
+        Right StoredMarkup{..} -> ((==) `on` renderHtml) markupOutput html
+                               && markupInputFormat == MarkupHtml
+                               && renderHtml html == markupInput
 
 termExample :: (TermIdentifier, Text) -> Expectation
 termExample (term, encoded) = example $ do