From e25e8a2f4ca65afc29acc8a3884df9acf77d4398 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Nov 2020 20:39:43 +0100 Subject: [PATCH] fix(html-field): introduce stored-markup BREAKING CHANGE: StoredMarkup --- models/allocations.model | 4 +- models/courses.model | 8 +- models/courses/materials.model | 2 +- models/courses/news.model | 4 +- models/exams.model | 4 +- models/sheets.model | 4 +- models/system-messages.model | 8 +- src/Database/Esqueleto/Utils.hs | 8 +- src/Foundation/SiteLayout.hs | 2 +- src/Handler/Course/Edit.hs | 4 +- src/Handler/Course/Events/Form.hs | 2 +- src/Handler/Course/List.hs | 13 +- src/Handler/Course/News/Form.hs | 4 +- src/Handler/Course/User.hs | 3 +- src/Handler/Course/Users.hs | 2 +- src/Handler/Exam/Form.hs | 12 +- src/Handler/Exam/Users.hs | 4 +- src/Handler/Help.hs | 2 +- src/Handler/Material.hs | 2 +- src/Handler/Sheet/Form.hs | 4 +- src/Handler/Utils/Communication.hs | 2 +- src/Handler/Utils/Form.hs | 8 +- src/Handler/Utils/Pandoc.hs | 33 ++++- src/Model/Migration.hs | 21 +++ src/Model/Types.hs | 1 + src/Model/Types/Changelog.hs | 1 + src/Model/Types/Exam.hs | 9 +- src/Model/Types/Markup.hs | 133 ++++++++++++++++++ .../stored-markup.de-de-formal.hamlet | 2 + .../i18n/changelog/stored-markup.en-eu.hamlet | 2 + test/Database/Fill.hs | 2 +- test/Model/TypesSpec.hs | 25 +++- 32 files changed, 277 insertions(+), 58 deletions(-) create mode 100644 src/Model/Types/Markup.hs create mode 100644 templates/i18n/changelog/stored-markup.de-de-formal.hamlet create mode 100644 templates/i18n/changelog/stored-markup.en-eu.hamlet diff --git a/models/allocations.model b/models/allocations.model index 0bbebbea5..e4e96f6b2 100644 --- a/models/allocations.model +++ b/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 - staffDescription Html Maybe -- description seen by prospective lecturers only + description StoredMarkup Maybe -- description for prospective students + 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 diff --git a/models/courses.model b/models/courses.model index 6033ff0a9..f9b4a0526 100644 --- a/models/courses.model +++ b/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 diff --git a/models/courses/materials.model b/models/courses/materials.model index fd1d19fb7..3a4767ec5 100644 --- a/models/courses/materials.model +++ b/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 diff --git a/models/courses/news.model b/models/courses/news.model index fdd2c0254..c31312d2e 100644 --- a/models/courses/news.model +++ b/models/courses/news.model @@ -3,8 +3,8 @@ CourseNews visibleFrom UTCTime Maybe participantsOnly Bool title Text Maybe - content Html - summary Html Maybe + content StoredMarkup + summary StoredMarkup Maybe lastEdit UTCTime CourseNewsFile news CourseNewsId diff --git a/models/exams.model b/models/exams.model index 4963e4075..295f2e768 100644 --- a/models/exams.model +++ b/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 diff --git a/models/sheets.model b/models/sheets.model index f54426040..6f0bb6176 100644 --- a/models/sheets.model +++ b/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 diff --git a/models/system-messages.model b/models/system-messages.model index 0d5cd5611..e8dfbd9ad 100644 --- a/models/system-messages.model +++ b/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 - summary Html Maybe + content StoredMarkup -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified + 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 - summary Html Maybe + content StoredMarkup + summary StoredMarkup Maybe UniqueSystemMessageTranslation message language SystemMessageHidden diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 66061ec3e..396f497f6 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 8ca6c3b29..9f151bca7 100644 --- a/src/Foundation/SiteLayout.hs +++ b/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 } diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index d1a340740..54590756e 100644 --- a/src/Handler/Course/Edit.hs +++ b/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 diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index ecc01b8e9..be55771dd 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/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 diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index a996fc3e5..2ab517fce 100644 --- a/src/Handler/Course/List.hs +++ b/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 - E.where_ $ E.any (E.hasInfix (user E.^. UserSurname) . E.val) (criterias :: Set.Set Text) + user <- isCourseAdminQuery (course E.^. CourseId) t + 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 diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs index 5d5aeb599..33e9a1938 100644 --- a/src/Handler/Course/News/Form.hs +++ b/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 - , cnfContent :: Html + , cnfSummary :: Maybe StoredMarkup + , cnfContent :: StoredMarkup , cnfParticipantsOnly :: Bool , cnfVisibleFrom :: Maybe UTCTime , cnfFiles :: Maybe FileUploads diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index de8747fc4..f8147faf4 100644 --- a/src/Handler/Course/User.hs +++ b/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] diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index f6c31ef4e..9775952b4 100644 --- a/src/Handler/Course/Users.hs +++ b/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) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 2a19dfa4f..cc8d0c273 100644 --- a/src/Handler/Exam/Form.hs +++ b/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 diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 6e76ed20b..eb3f4aba1 100644 --- a/src/Handler/Exam/Users.hs +++ 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 diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index 4c2bd4f0b..f6070369e 100644 --- a/src/Handler/Help.hs +++ b/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 () diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index c0679cd31..37367fa70 100644 --- a/src/Handler/Material.hs +++ b/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 } diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 56c0943a3..73c65cdcb 100644 --- a/src/Handler/Sheet/Form.hs +++ b/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! diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 153ba69ea..5a3a5486d 100644 --- a/src/Handler/Utils/Communication.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2c3ee4dcd..4a7f6ec8b 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 diff --git a/src/Handler/Utils/Pandoc.hs b/src/Handler/Utils/Pandoc.hs index e4f3d49e1..50dc3dc5a 100644 --- a/src/Handler/Utils/Pandoc.hs +++ b/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 : _) _ - = return . fmap (assertM' $ not . null . renderHtml) . parseMarkdown $ Text.strip t + fieldParse ((Text.strip -> t) : _) _ = runExceptT . runMaybeT $ do + 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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 1e2864dfd..c85065220 100644 --- a/src/Model/Migration.hs +++ b/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); + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index a8e437f17..5c140edbd 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Model/Types/Changelog.hs b/src/Model/Types/Changelog.hs index f0b64a502..e0d855ba8 100644 --- a/src/Model/Types/Changelog.hs +++ b/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 diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 6938ef227..98835feb3 100644 --- a/src/Model/Types/Exam.hs +++ b/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 diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs new file mode 100644 index 000000000..d4b0a1035 --- /dev/null +++ b/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" diff --git a/templates/i18n/changelog/stored-markup.de-de-formal.hamlet b/templates/i18n/changelog/stored-markup.de-de-formal.hamlet new file mode 100644 index 000000000..486abbabb --- /dev/null +++ b/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. diff --git a/templates/i18n/changelog/stored-markup.en-eu.hamlet b/templates/i18n/changelog/stored-markup.en-eu.hamlet new file mode 100644 index 000000000..35e529249 --- /dev/null +++ b/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. diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8139235f4..29cdb615b 100644 --- a/test/Database/Fill.hs +++ b/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|

It is fun!

Come to where the functional is!

diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 2836b9149..917079d8d 100644 --- a/test/Model/TypesSpec.hs +++ b/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