fix(html-field): introduce stored-markup
BREAKING CHANGE: StoredMarkup
This commit is contained in:
Gregor Kleen
parent
549b95882d
commit
e25e8a2f4c
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 }
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -67,7 +67,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do
|
||||
<$> hfReferer'
|
||||
<*> hfUserId'
|
||||
<*> hfSubject'
|
||||
<*> hfRequest'
|
||||
<*> (fmap markupOutput <$> hfRequest')
|
||||
<*> hfError'
|
||||
|
||||
validateHelpForm :: FormValidator HelpForm Handler ()
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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!
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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);
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -38,6 +38,7 @@ classifyChangelogItem = \case
|
||||
ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
|
||||
ChangelogFormsTimesReset -> ChangelogItemBugfix
|
||||
ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
|
||||
ChangelogStoredMarkup -> ChangelogItemBugfix
|
||||
_other -> ChangelogItemFeature
|
||||
|
||||
changelogItemDays :: Map ChangelogItem Day
|
||||
|
||||
@ -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
|
||||
|
||||
133
src/Model/Types/Markup.hs
Normal file
133
src/Model/Types/Markup.hs
Normal file
@ -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"
|
||||
@ -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.
|
||||
2
templates/i18n/changelog/stored-markup.en-eu.hamlet
Normal file
2
templates/i18n/changelog/stored-markup.en-eu.hamlet
Normal file
@ -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.
|
||||
@ -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>
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user