From ef73431f7b93e975a9c56ef34bdc2f5e2b84b064 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 19 Jun 2019 10:24:13 +0200 Subject: [PATCH 01/12] Added dev login --- test/Database.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/test/Database.hs b/test/Database.hs index ea044ac75..5c4abe89f 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -176,6 +176,24 @@ fillDb = do , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } + svaupel <- insert User + { userIdent = "vaupel.sarah@campus.lmu.de" + , userAuthentication = AuthLDAP + , userLastAuthentication = Nothing + , userTokensIssuedAfter = Nothing + , userMatrikelnummer = Nothing + , userEmail = "vaupel.sarah@campus.lmu.de" + , userDisplayName = "Sarah Vaupel" + , userSurname = "Vaupel" + , userMaxFavourites = 14 + , userTheme = ThemeMossGreen + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def + } void . repsert (TermKey summer2017) $ Term { termName = summer2017 , termStart = fromGregorian 2017 04 09 @@ -210,9 +228,12 @@ fillDb = do void . insert' $ UserAdmin fhamann ifi void . insert' $ UserAdmin jost ifi void . insert' $ UserAdmin jost mi + void . insert' $ UserAdmin svaupel ifi + void . insert' $ UserAdmin svaupel mi void . insert' $ UserLecturer gkleen ifi void . insert' $ UserLecturer fhamann ifi void . insert' $ UserLecturer jost ifi + void . insert' $ UserLecturer svaupel ifi let sdBsc = StudyDegreeKey' 82 sdMst = StudyDegreeKey' 88 From 84070a5565d77dc820cb75fdc9717e27b8409f8e Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 19 Jun 2019 21:54:23 +0200 Subject: [PATCH 02/12] Replaced DisplayAble Text instance, started adding ToMarkup instances for keys, attempted adding interface for CryptoIDs (TODO) --- src/Data/CryptoID/Instances.hs | 18 ++++++++++++++++++ src/Data/Maybe/Instances.hs | 13 +++++++++++++ src/Foundation.hs | 4 ++++ src/Handler/Corrections.hs | 2 +- src/Handler/Course.hs | 10 +++++----- src/Handler/Home.hs | 10 +++++----- src/Handler/Profile.hs | 1 + src/Handler/Sheet.hs | 2 +- src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 12 ++++++------ src/Import/NoModel.hs | 2 ++ src/Model.hs | 17 +++++++++++++++++ src/Utils.hs | 6 ------ templates/correction-user.hamlet | 2 +- templates/mail/submissionRated.hamlet | 2 +- templates/profileData.hamlet | 10 +++++----- templates/submission.hamlet | 2 +- 17 files changed, 82 insertions(+), 33 deletions(-) create mode 100644 src/Data/CryptoID/Instances.hs create mode 100644 src/Data/Maybe/Instances.hs diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs new file mode 100644 index 000000000..e98207784 --- /dev/null +++ b/src/Data/CryptoID/Instances.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.CryptoID.Instances + ( + ) where + +-- import qualified Data.CryptoID as CID + +-- import Data.CaseInsensitive (CI) +-- import qualified Data.CaseInsensitive as CI + +-- import Text.Blaze (ToMarkup(..)) + +-- import ClassyPrelude + +-- TODO: markup instance for UUIDs +-- instance ToMarkup c => ToMarkup (CID.CryptoID c s) where +-- toMarkup = toMarkup . CID.ciphertext \ No newline at end of file diff --git a/src/Data/Maybe/Instances.hs b/src/Data/Maybe/Instances.hs new file mode 100644 index 000000000..4b6eaf9e8 --- /dev/null +++ b/src/Data/Maybe/Instances.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Maybe.Instances + ( + ) where + +import ClassyPrelude + +import Text.Blaze (ToMarkup(..), string) + +instance ToMarkup a => ToMarkup (Maybe a) where + toMarkup Nothing = string "" + toMarkup (Just x) = toMarkup x \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index 3be718bb7..885a060de 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -91,15 +91,18 @@ import qualified Data.Aeson as JSON import Data.FileEmbed (embedFile) +-- TODO: remove once CryptoID is an instance of ToMarkup instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => DisplayAble (E.CryptoID namespace (CI FilePath)) where display = toPathPiece +-- TODO: remove instance DisplayAble TermId where display = termToText . unTermKey +-- TODO: remove instance DisplayAble SchoolId where display = CI.original . unSchoolKey @@ -215,6 +218,7 @@ maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text -> Text maybeDisplay _ Nothing _ = mempty maybeDisplay before (Just x) after = before <> (display x) <> after +-- TODO: decouple from DisplayAble -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index dc8cb791e..9f68b6fbb 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -126,7 +126,7 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row -> ssh = course ^. _4 csh = course ^. _2 shn = sheetName $ entityVal sheet - in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] + in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|] colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $ diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5abd1e624..9c3c768e4 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -53,7 +53,7 @@ colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) - [whamlet|#{display courseName}|] + [whamlet|_{courseName}|] -- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do @@ -70,7 +70,7 @@ colDescription = sortable Nothing mempty colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> - anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] + anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|] -- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) @@ -89,17 +89,17 @@ colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> - anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|] + anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|] colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> - anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|] + anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolName}|] colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> - anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|] + anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|] colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index b907ecf50..978e4711c 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -33,14 +33,14 @@ homeOpenCourses = do colonnade = mconcat [ -- dbRow sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> - textCell $ display $ courseTerm course + textCell $ display $ courseTerm course -- TODO: ToText instance for Key Term , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> - textCell $ display $ courseSchool course + textCell $ display $ courseSchool course -- TODO: ToText instance , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do let tid = courseTerm course ssh = courseSchool course csh = courseShorthand course - anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh) + anchorCell (CourseR tid ssh csh CShowR) (toWidget csh) , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] @@ -121,9 +121,9 @@ homeUpcomingSheets uid = do , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> textCell $ display ssh , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } -> - anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh) + anchorCell (CourseR tid ssh csh CShowR) (toWidget csh) , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } -> - anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn) + anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget shn) , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> cell $ formatTime SelFormatDateTime deadline >>= toWidget , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } -> diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 403e133c7..611e82cdb 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -45,6 +45,7 @@ makeSettingForm template html = do <*> notificationForm (stgNotificationSettings <$> template) return (result, widget) -- no validation required here where + -- TODO: replace display themeList = [Option (display t) t (toPathPiece t) | t <- universeF] -- -- Version with proper grouping: diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c14424251..9717a04df 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -236,7 +236,7 @@ getSheetListR tid ssh csh = do mkRoute = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' SubShowR - in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|]) + in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|]) -- TODO: replace display , sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} -> let stats = sheetTypeSum sheetType in -- for statistics over all shown rows diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 8af2f6620..01b0055d9 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -41,7 +41,7 @@ getUsersR = do (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) - (toWidget . display $ userMatrikelnummer) + (toWgt userMatrikelnummer) -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 620e6776b..6f400d0c7 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -185,7 +185,7 @@ termCell :: IsDBTable m a => TermId -> DBCell m a termCell tid = anchorCell link name where link = TermCourseListR tid - name = text2widget $ display tid + name = toWgt tid termCellCL :: IsDBTable m a => CourseLink -> DBCell m a termCellCL (tid,_,_) = termCell tid @@ -194,11 +194,11 @@ schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a schoolCell (Just tid) ssh = anchorCell link name where link = TermSchoolCourseListR tid ssh - name = text2widget $ display ssh + name = toWgt ssh schoolCell Nothing ssh = anchorCell link name where link = SchoolShowR ssh - name = text2widget $ display ssh + name = toWgt ssh schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh @@ -207,7 +207,7 @@ courseCellCL :: IsDBTable m a => CourseLink -> DBCell m a courseCellCL (tid,ssh,csh) = anchorCell link name where link = CourseR tid ssh csh CShowR - name = citext2widget csh + name = toWgt csh courseCell :: IsDBTable m a => Course -> DBCell m a courseCell Course{..} = anchorCell link name `mappend` desc @@ -228,7 +228,7 @@ sheetCell crse shn = ssh = crse ^. _2 csh = crse ^. _3 link= CSheetR tid ssh csh shn SShowR - in anchorCell link $ display2widget shn + in anchorCell link $ toWgt shn submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a submissionCell crse shn sid = @@ -237,7 +237,7 @@ submissionCell crse shn sid = csh = crse ^. _3 mkCid = encrypt sid mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR - mkText = display2widget + mkText = display2widget -- TODO: replace with toWgt once there is a ToMarkup instance for CryptoIDs in anchorCellM' mkCid mkRoute mkText correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index d2ba81705..79000ecfe 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -76,6 +76,8 @@ import Language.Haskell.TH.Instances as Import () import Data.List.NonEmpty.Instances as Import () import Data.NonNull.Instances as Import () import Data.Monoid.Instances as Import () +import Data.Maybe.Instances as Import () +import Data.CryptoID.Instances as Import () import Data.Set.Instances as Import () import Data.HashMap.Strict.Instances as Import () import Data.HashSet.Instances as Import () diff --git a/src/Model.hs b/src/Model.hs index c86406275..f2caba32f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -23,6 +23,9 @@ import Utils.Message (MessageStatus) import Settings.Cluster (ClusterSettingsKey) +import Text.Blaze (ToMarkup(..)) + + -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities -- at: @@ -38,3 +41,17 @@ deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime + +-- ToMarkup instances for displaying certain database primary keys +-- TODO: work in progress, populate with more instances +-- TODO: is there a better place for this? + +instance ToMarkup (Key School) where + toMarkup = toMarkup . unSchoolKey + +instance ToMarkup (Key Term) where + toMarkup = toMarkup . termToText . unTermKey + +-- TODO: unfinished +-- instance ToMarkup (Key Submission) where +-- toMarkup = toMarkup . unSubmissionKey \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index 4f565befe..55124298b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -251,12 +251,6 @@ class DisplayAble a where default display :: Show a => a -> Text display = pack . show -instance DisplayAble Text where - display = id - --- instance DisplayAble String where --- display = pack - instance DisplayAble Int instance DisplayAble Int64 instance DisplayAble Integer diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index 0a639bf81..848557260 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -6,7 +6,7 @@ $maybe Entity _ User{userDisplayName} <- corrector _{MsgRatingBy} - #{display userDisplayName} + #{userDisplayName} $maybe time <- submissionRatingTime _{MsgRatingTime} diff --git a/templates/mail/submissionRated.hamlet b/templates/mail/submissionRated.hamlet index 63afe4ee5..e632a5bef 100644 --- a/templates/mail/submissionRated.hamlet +++ b/templates/mail/submissionRated.hamlet @@ -27,7 +27,7 @@ $newline never
_{MsgRatingBy}
- #{display userDisplayName} + #{userDisplayName} $maybe time <- submissionRatingTime'
_{MsgRatingTime} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 1946b98b6..28d23e806 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -9,7 +9,7 @@
_{MsgEMail}
#{mailtoHtml userEmail}
_{MsgIdent} -
#{display userIdent} +
#{userIdent}
_{MsgLastLogin}
$maybe llogin <- lastLogin @@ -23,7 +23,7 @@ $forall (E.Value institute) <- admin_rights
  • - #{display institute} + #{institute} $if not $ null lecturer_rights
    _{MsgLecturerFor}
    @@ -31,14 +31,14 @@ $forall (E.Value institute) <- lecturer_rights
  • - #{display institute} + #{institute} $if not $ null lecture_corrector
    Korrektor