Merge branch 'master' into stundenplan

CHANGELOG.md

@@ -2,6 +2,24 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [22.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.1...v22.0.0) (2020-11-06)
+
+
+### ⚠ BREAKING CHANGES
+
+* **html-field:** StoredMarkup
+
+### Bug Fixes
+
+* **html-field:** introduce stored-markup ([e25e8a2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e25e8a2f4ca65afc29acc8a3884df9acf77d4398))
+
+### [21.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.0...v21.1.1) (2020-11-06)
+
+
+### Bug Fixes
+
+* **course:** better explanation for material access ([78c5bc5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/78c5bc5258c9305deafac18b010dc6a41e5ea864))
+
 ## [21.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.3...v21.1.0) (2020-11-05)
 
 

messages/uniworx/de-de-formal.msg

@@ -2590,7 +2590,12 @@ CourseNewsActionDelete: Löschen
 CourseNewsActionCreate: Neue Nachricht
 CourseMaterial: Material
 CourseMaterialFree: Das Kursmaterial ist ohne Anmeldung frei zugänglich
-CourseMaterialNotFree: Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
+CourseMaterialNotFree: Das Kursmaterial ist nur für Mitglieder des Kurses einsehbar, also z.B. für Teilnehmer, Tutoren, Korrektoren und Verwalter.
+
+CourseSheetsFoundHere: Die Übungsblatter zum Kurs finden Sie hier
+CourseSheetsNoneVisible: Aktuell gibt es zu diesem Kurs keine Übungsblätter, oder nur Übungsblätter auf die Sie keinen Zugriff haben (z.B. aufgrund von Fristen bzgl. der Sichtbarkeit).
+CourseMaterialsFoundHere: Material zum Kurs finden Sie hier
+CourseMaterialsNoneVisible: Aktuell gibt es zu diesem Kurs kein Material, oder nur Material auf das Sie keinen Zugriff haben (z.B. aufgrund von Fristen bzgl. der Sichtbarkeit).
 
 CourseNewsVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Teilnehmer verwirren könnte.
 CourseNewsVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für noch unfertige Nachrichten

messages/uniworx/en-eu.msg

@@ -2589,8 +2589,13 @@ CourseNewsActionEdit: Edit
 CourseNewsActionDelete: Delete
 CourseNewsActionCreate: Create new item
 CourseMaterial: Material
-CourseMaterialFree: Course material is publicly accessable
+CourseMaterialFree: Course material is publicly accessible
-CourseMaterialNotFree: Only course participants may access course material
+CourseMaterialNotFree: Course material is only accessible to members of the course, e.g. for participants, tutors, correctors or administratiors.
+
+CourseSheetsFoundHere: Exercise sheets for this course are available here
+CourseSheetsNoneVisible: Currently there are no exercise sheets for this course or only exercise sheets to which you don't have access (e.g. because of visibility settings)
+CourseMaterialsFoundHere: Material for this course is available here
+CourseMaterialsNoneVisible: Currently there is no material for this course or only material to which you don't have access (e.g. because of visibility settings)
 
 CourseNewsVisibleFromEditWarning: This item of course news has already been published and should no longer be changed sind this might confuse participants.
 CourseNewsVisibleFromTip: If left empty this item is never visible. Leave empty for unfinished items

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             CourseName
-    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
@@ -40,7 +40,7 @@ CourseEvent
     course CourseId
     room CourseEventRoom
     time Occurrences
-    note Html Maybe
+    note StoredMarkup Maybe
     lastChanged UTCTime default=now()
 CourseEventScheduleOpt                 -- opt-in/-out for course event display in a user's schedule (TODO: currently for all occurrences of a course event; separate opt-ins/-outs per occurrence in CourseEventTime instead?)
     courseEvent CourseEventId
@@ -84,7 +84,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
 ExamOccurrenceScheduleOpt
   examOccurrence ExamOccurrenceId

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

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "21.1.0",
+  "version": "22.0.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "21.1.0",
+  "version": "22.0.0",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 21.1.0
+version: 22.0.0
 
 dependencies:
   - base

src/Database/Esqueleto/Utils.hs

@@ -25,7 +25,7 @@ module Database.Esqueleto.Utils
   , max, min
   , abs
   , SqlProject(..)
-  , (->.)
+  , (->.), (#>>.)
   , fromSqlKey
   , selectCountRows
   , selectMaybe
@@ -373,6 +373,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/Show.hs

@@ -28,7 +28,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAuth <- maybeAuthPair
   now <- liftIO getCurrentTime
-  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,mCourseScheduleOpt) <- runDB . maybeT notFound $ do
+  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen, mCourseScheduleOpt, mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do
     [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
        <- lift . E.select . E.from $
          \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@@ -90,6 +90,7 @@ getCShowR tid ssh csh = do
       lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
       mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
       mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
+
       return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete)
 
     mCourseScheduleOpt <- case mbAuth of
@@ -130,7 +131,19 @@ getCShowR tid ssh csh = do
 
     mayReRegister <- lift . courseMayReRegister $ Entity cid course
 
-    return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,mCourseScheduleOpt)
+    mayViewSheets <- hasReadAccessTo $ CourseR tid ssh csh SheetListR
+    sheets <- lift . E.select . E.from $ \sheet -> do
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+      return $ sheet E.^. SheetName
+    mayViewAnySheet <- anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
+
+    mayViewMaterials <- hasReadAccessTo $ CourseR tid ssh csh MaterialListR
+    materials <- lift . E.select . E.from $ \material -> do
+      E.where_ $ material E.^. MaterialCourse E.==. E.val cid
+      return $ material E.^. MaterialName
+    mayViewAnyMaterial <- anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
+
+    return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen, mCourseScheduleOpt, mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial))
 
   let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
   mDereg <- traverse (formatTime SelFormatDateTime) mDereg'

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/Sheet/PersonalisedFiles.hs

@@ -153,9 +153,10 @@ sinkPersonalisedSheetFiles cid sid keep
      openSinks <- State.get
      lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded
      let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks
-     lift . lift $ deleteWhere [ PersonalisedSheetFileSheet  <-. sinkSheets
+     unless keep $
-                               , PersonalisedSheetFileUser  /<-. sinkUsers
+       lift . lift $ deleteWhere [ PersonalisedSheetFileSheet  <-. sinkSheets
-                               ]
+                                 , PersonalisedSheetFileUser  /<-. sinkUsers
+                                 ]
 
    msgUnreferenced ((), unreferenced) = unless (null collated && null uncollated) $
      addMessageModal msgStatus msgTrigger $ Right msgWidget

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

@@ -2136,25 +2136,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"

src/Utils/DB.hs

@@ -139,3 +139,17 @@ put :: ( MonadIO m
 put v = do
   forM_ (persistUniqueKeys v) deleteBy
   insert v
+
+selectMaybe :: forall record backend m.
+               ( MonadIO m
+               , PersistQueryRead backend
+               , PersistRecordBackend record backend
+               )
+            => [Filter record] -> [SelectOpt record]
+            -> ReaderT backend m (Maybe (Entity record))
+selectMaybe fltrs opts = listToMaybe <$> selectList fltrs (LimitTo 1 : opts')
+  where opts' = filter (not . isLimit) opts
+        isLimit = \case
+          LimitTo _ -> True
+          _other    -> False
+  

templates/course.hamlet

@@ -232,10 +232,27 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
   <dt .deflist__dt>
     _{MsgCourseMaterial}
   <dd .deflist__dd>
-    $if courseMaterialFree course
+    $if mayViewSheets
-      _{MsgCourseMaterialFree}
+      <p>
-    $else
+        $if mayViewAnySheet
-      _{MsgCourseMaterialNotFree}
+          _{MsgCourseSheetsFoundHere}: #
+          <a href=@{CourseR tid ssh csh SheetListR}>
+            _{MsgMenuSheetList}
+        $else
+          _{MsgCourseSheetsNoneVisible}
+    $if mayViewMaterials
+      <p>
+        $if mayViewAnyMaterial
+          _{MsgCourseMaterialsFoundHere}: #
+          <a href=@{CourseR tid ssh csh MaterialListR}>
+            _{MsgMenuMaterialList}
+        $else
+          _{MsgCourseMaterialsNoneVisible}
+    <p .explanation>
+      $if courseMaterialFree course
+        _{MsgCourseMaterialFree}
+      $else
+        _{MsgCourseMaterialNotFree}
   
   $if hasExams
     <dt .deflist__dt>_{MsgCourseExams}

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

@@ -31,6 +31,9 @@ import Data.List (genericLength)
 
 import qualified Data.Conduit.Combinators as C
 
+import System.Directory (getModificationTime)
+import System.FilePath.Glob (glob)
+
 
 testdataDir :: FilePath
 testdataDir = "testdata"
@@ -602,7 +605,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>
@@ -1332,3 +1335,19 @@ fillDb = do
         _other -> return mempty
   
   liftIO . LBS.writeFile (testdataDir </> "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities
+
+  forM_ universeF $ \changelogItem -> do
+    let ptn = "templates/i18n/changelog/" <> unpack (toPathPiece changelogItem) <> ".*"
+    files <- liftIO $ glob ptn
+    mTime <- fmap minimum . fromNullable <$> mapM (liftIO . getModificationTime) files
+    whenIsJust mTime $ \(utctDay -> firstSeen) -> do
+      oldFirstSeen <- selectMaybe [ ChangelogItemFirstSeenItem ==. changelogItem ] [ Asc ChangelogItemFirstSeenFirstSeen ]
+      case oldFirstSeen of
+        Just (Entity firstSeenId oldEntry)
+          | changelogItemFirstSeenFirstSeen oldEntry > firstSeen
+            -> update firstSeenId [ ChangelogItemFirstSeenFirstSeen =. firstSeen ]
+        Just _
+            -> return ()
+        Nothing
+            -> insert_ $ ChangelogItemFirstSeen changelogItem firstSeen
+        

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 . getPrintableString <$> 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