fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Replaced DisplayAble Text instance, started adding ToMarkup instances for keys, attempted adding interface for CryptoIDs (TODO)

Browse Source
This commit is contained in:
Sarah Vaupel 2019-06-19 21:54:23 +02:00
parent f818fa7de1
commit 84070a5565
17 changed files with 82 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/Data/CryptoID/Instances.hs Normal file
View File

@ -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

13
src/Data/Maybe/Instances.hs Normal file
View File

@ -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

4
src/Foundation.hs
View File

@ -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"

2
src/Handler/Corrections.hs
View File

@ -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) $

10
src/Handler/Course.hs
View File

@ -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)

10
src/Handler/Home.hs
View File

@ -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) } ->

1
src/Handler/Profile.hs
View File

@ -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:

2
src/Handler/Sheet.hs
View File

@ -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

2
src/Handler/Users.hs
View File

@ -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)

12
src/Handler/Utils/Table/Cells.hs
View File

@ -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

2
src/Import/NoModel.hs
View File

@ -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 ()

17
src/Model.hs
View File

@ -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

6
src/Utils.hs
View File

@ -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

2
templates/correction-user.hamlet
View File

@ -6,7 +6,7 @@
$maybe Entity _ User{userDisplayName} <- corrector
<tr .table__row>
<th .table__th>_{MsgRatingBy}
<td .table__td>#{display userDisplayName}
<td .table__td>#{userDisplayName}
$maybe time <- submissionRatingTime
<tr .table__row>
<th .table__th>_{MsgRatingTime}

2
templates/mail/submissionRated.hamlet
View File

@ -27,7 +27,7 @@ $newline never
<dt>
_{MsgRatingBy}
<dd>
#{display userDisplayName}
#{userDisplayName}
$maybe time <- submissionRatingTime'
<dt>
_{MsgRatingTime}

10
templates/profileData.hamlet
View File

@ -9,7 +9,7 @@
<dt .deflist__dt> _{MsgEMail}
<dd .deflist__dd> #{mailtoHtml userEmail}
<dt .deflist__dt> _{MsgIdent}
<dd .deflist__dd> #{display userIdent}
<dd .deflist__dd> #{userIdent}
<dt .deflist__dt> _{MsgLastLogin}
<dd .deflist__dd>
$maybe llogin <- lastLogin
@ -23,7 +23,7 @@
$forall (E.Value institute) <- admin_rights
<li .list-ul__item>
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
#{institute}
$if not $ null lecturer_rights
<dt .deflist__dt>_{MsgLecturerFor}
<dd .deflist__dd>
@ -31,14 +31,14 @@
$forall (E.Value institute) <- lecturer_rights
<li .list-ul__item>
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
#{institute}
$if not $ null lecture_corrector
<dt .deflist__dt> Korrektor
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
<li .list-ul__item>
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
<a href=@{CourseR tid ssh csh CShowR}>#{tid}-#{ssh}-#{csh}
$if not $ null studies
<dt .deflist__dt> Studiengänge
<dd .deflist__dd>
@ -58,7 +58,7 @@
<td .table__td>_{field}#{notUsedT studyFeaturesField}
<td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
<td .table__td>_{studyFeaturesType}
<td .table__td>#{display studyFeaturesSemester}
<td .table__td>#{studyFeaturesSemester}
<td .table__td>#{hasTickmark studyFeaturesValid}
<td .table__td>^{formatTimeW SelFormatDateTime studyFeaturesUpdated}

2
templates/submission.hamlet
View File

@ -20,7 +20,7 @@ $maybe cID <- mcid
$maybe name <- mbName
<li>_{MsgEditedBy name time}
$nothing
<li>#{display time}
<li>#{time}
$if maySubmit
<section>