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

Merge branch 'master' into 'live'

Browse Source 
Master

Closes #179

See merge request !72
This commit is contained in:
Steffen Jost 2018-09-18 16:38:53 +02:00
commit 5c60f800fe
44 changed files with 1062 additions and 262 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
ChangeLog.md
View File

@ -1,4 +1,16 @@
* Version 06.08.2016
* Version 18.09.2018
Tooltips funktionieren auch ohne JavaScript
Kurskürzel müssen nur innerhalb eines Instituts eindeutig sein
User Data zeigt nun alle momentan gespeicherten Datensätze an
Unterstützung von Tabellenzusammenfassungen, z.B. Punktsummen
Intelligente Verteilung von Abgaben auf Korrektoren (z.B. bei Krankheit)
* Version 06.08.2018
Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen

18
db.hs
View File

@ -71,6 +71,7 @@ fillDb = do
, userMatrikelnummer = Nothing
, userEmail = "G.Kleen@campus.lmu.de"
, userDisplayName = "Gregor Kleen"
, userSurname = "Kleen"
, userMaxFavourites = 6
, userTheme = ThemeDefault
, userDateTimeFormat = userDefaultDateTimeFormat
@ -84,6 +85,7 @@ fillDb = do
, userMatrikelnummer = Nothing
, userEmail = "felix.hamann@campus.lmu.de"
, userDisplayName = "Felix Hamann"
, userSurname = "Hamann"
, userMaxFavourites = userDefaultMaxFavourites
, userTheme = ThemeDefault
, userDateTimeFormat = userDefaultDateTimeFormat
@ -97,6 +99,7 @@ fillDb = do
, userMatrikelnummer = Nothing
, userEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost"
, userSurname = "Jost"
, userMaxFavourites = 14
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
@ -110,6 +113,7 @@ fillDb = do
, userMatrikelnummer = Nothing
, userEmail = "max@campus.lmu.de"
, userDisplayName = "Max Musterstudent"
, userSurname = "Musterstudent"
, userMaxFavourites = 7
, userTheme = ThemeAberdeenReds
, userDateTimeFormat = userDefaultDateTimeFormat
@ -117,6 +121,20 @@ fillDb = do
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
}
void . insert $ User
{ userPlugin = "LDAP"
, userIdent = "tester@campus.lmu.de"
, userMatrikelnummer = Just "999"
, userEmail = "tester@campus.lmu.de"
, userDisplayName = "Tina Tester"
, userSurname = "von Terror"
, userMaxFavourites = 5
, userTheme = ThemeAberdeenReds
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
}
void . insert $ Term
{ termName = summer2017
, termStart = fromGregorian 2017 04 09

26
messages/uniworx/de.msg
View File

@ -27,6 +27,9 @@ InvalidInput: Eingaben bitte korrigieren.
Term: Semester
TermPlaceholder: W/S + vierstellige Jahreszahl
SchoolListHeading: Übersicht über verwaltete Institute
SchoolHeading school@SchoolName: Übersicht #{display school}
LectureStart: Beginn Vorlesungen
Course: Kurs
@ -72,15 +75,15 @@ CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
Sheet: Blatt
SheetList tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
SheetNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
SheetNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
SheetTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
SheetNameDup tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht.
SheetExercise: Aufgabenstellung
SheetHint: Hinweis
@ -125,9 +128,11 @@ SubmissionFile: Datei zur Abgabe
SubmissionFiles: Abgegebene Dateien
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
SubmissionGroupName: Gruppenname
CorrectionsTitle: Zugewiesene Korrekturen
CourseCorrectionsTitle: Korrekturen für diesen Kurs
CorrectorsHead sheetName@SheetName: Korrektoren für Blatt #{sheetName}
CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
@ -165,6 +170,10 @@ Correctors: Korrektoren
CorState: Status
CorByTut: Nach Tutorium
CorProportion: Anteil
CorByProportionOnly proportion@Rational: #{display proportion} Anteile
CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium
CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium
DeleteRow: Zeile entfernen
ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
@ -235,7 +244,9 @@ RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
FileTitle: Dateiname
FileModified: Letzte Änderung
FileCorrected: Korrigiert
Corrected: Korrigiert
FileCorrected: Korrigiert (Dateien)
FileCorrectedDeleted: Korrigiert (gelöscht)
RatingUpdated: Korrektur gespeichert
RatingDeleted: Korrektur zurückgesetzt
@ -246,6 +257,7 @@ NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
AdminFor: Administrator
LecturerFor: Dozent
LecturersFor: Dozenten
UserListTitle: Komprehensive Benutzerliste
DateTimeFormat: Datums- und Uhrzeitformat
@ -259,8 +271,10 @@ AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC ko
IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren
LastEdits: Letzte Änderungen
EditedBy name@Text time@Text: Durch #{name} um #{time}
EditedBy name@Text time@Text: #{time} durch #{name}
LastEdit: Letzte Änderung
LastEditByUser: Ihre letzte Bearbeitung
NoEditByUser: Nicht von Ihnen bearbeitet
SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.

1
models
View File

@ -4,6 +4,7 @@ User json
matrikelnummer Text Maybe
email (CI Text)
displayName Text
surname Text
maxFavourites Int default=12
theme Theme default='Default'
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"

20
routes
View File

@ -41,12 +41,15 @@
/profile ProfileR GET POST !free !free
/profile/data ProfileDataR GET !free !free
/terms TermShowR GET !free
/terms/current TermCurrentR GET !free
/terms/edit TermEditR GET POST
/terms/#TermId/edit TermEditExistR GET
!/terms/#TermId TermCourseListR GET !free
!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free
/term TermShowR GET !free
/term/current TermCurrentR GET !free
/term/edit TermEditR GET POST
/term/#TermId/edit TermEditExistR GET
!/term/#TermId TermCourseListR GET !free
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
/school SchoolListR GET
/school/#SchoolId SchoolShowR GET
-- For Pattern Synonyms see Foundation
@ -74,6 +77,11 @@
/correctors SCorrR GET POST
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
-- /user/#CryptoUUIDUser
-- /users
-- /correctors
/corrections CorrectionsR GET POST !corrector !lecturer
/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer

1
src/Application.hs
View File

@ -52,6 +52,7 @@ import Handler.Profile
import Handler.Users
import Handler.Admin
import Handler.Term
import Handler.School
import Handler.Course
import Handler.Sheet
import Handler.Submission

34
src/Foundation.hs
View File

@ -145,7 +145,7 @@ pattern CSubmissionR tid ssh csh shn cid ptn
-- Menus and Favourites
data MenuItem = MenuItem
{ menuItemLabel :: Text
, menuItemIcon :: Maybe Text
, menuItemIcon :: Maybe Text
, menuItemRoute :: Route UniWorX
, menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked)
}
@ -205,6 +205,15 @@ instance RenderMessage UniWorX CorrectorState where
CorrectorExcused -> renderMessage' MsgCorrectorExcused
where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX Load where
renderMessage foundation ls = \case
(Load {byTutorial=Nothing , byProportion=p}) -> renderMessage' $ MsgCorByProportionOnly p
(Load {byTutorial=Just True , byProportion=p}) -> renderMessage' $ MsgCorByProportionIncludingTutorial p
(Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p
where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
@ -995,6 +1004,13 @@ pageHeading (TermSchoolCourseListR tid ssh)
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgTermSchoolCourseListHeading tid school
pageHeading (SchoolListR)
= Just $ i18nHeading MsgSchoolListHeading
pageHeading (SchoolShowR ssh)
= Just $ do
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgSchoolHeading school
pageHeading (CourseListR)
= Just $ i18nHeading $ MsgCourseListTitle
pageHeading CourseNewR
@ -1161,6 +1177,7 @@ instance YesodAuth UniWorX where
userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
userEmail' = lookup (Attr "mail") ldapData
userDisplayName' = lookup (Attr "displayName") ldapData
userSurname' = lookup (Attr "sn") ldapData
userEmail <- if
| Just [bs] <- userEmail'
@ -1174,6 +1191,12 @@ instance YesodAuth UniWorX where
-> return userDisplayName
| otherwise
-> throwError $ ServerError "Could not retrieve user name"
userSurname <- if
| Just [bs] <- userSurname'
, Right userSurname <- Text.decodeUtf8' bs
-> return userSurname
| otherwise
-> throwError $ ServerError "Could not retrieve user surname"
userMatrikelnummer <- if
| Just [bs] <- userMatrikelnummer'
, Right userMatrikelnummer <- Text.decodeUtf8' bs
@ -1193,10 +1216,11 @@ instance YesodAuth UniWorX where
, userDownloadFiles = userDefaultDownloadFiles
, ..
}
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
, UserDisplayName =. userDisplayName
, UserEmail =. userEmail
]
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
, UserDisplayName =. userDisplayName
, UserSurname =. userSurname
, UserEmail =. userEmail
]
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate

19
src/Handler/Corrections.hs
View File

@ -23,6 +23,7 @@ import Import
import Handler.Utils
import Handler.Utils.Submission
import Handler.Utils.Table.Cells
-- import Handler.Utils.Zip
import Data.Set (Set)
@ -86,24 +87,24 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
let csh = course ^. _2
tid = course ^. _3
let tid = course ^. _3
ssh = course ^. _4
csh = course ^. _2
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
let csh = course ^. _2
tid = course ^. _3
let tid = course ^. _3
ssh = course ^. _4
csh = course ^. _2
shn = sheetName $ entityVal sheet
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty
DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr
DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
@ -125,6 +126,11 @@ colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName)
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
@ -178,7 +184,7 @@ makeCorrectionsTable whereClause colChoices psValidator = do
, SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
)
, ( "corrector"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
)
, ( "rating"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
@ -354,6 +360,7 @@ postCCorrectionsR tid ssh csh = do
, dbRow
, colSheet
, colCorrector
, colSMatrikel
, colSubmittors
, colSubmissionLink
, colRating

50
src/Handler/Course.hs
View File

@ -16,7 +16,12 @@
module Handler.Course where
import Import
import Control.Lens
import Utils.Lens
import Utils.TH
import Handler.Utils
import Handler.Utils.Table.Cells
-- import Data.Time
import qualified Data.Text as T
@ -33,7 +38,7 @@ import qualified Database.Esqueleto as E
import qualified Data.UUID.Cryptographic as UUID
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
@ -42,16 +47,12 @@ colCourse = sortable (Just "course") (i18nCell MsgCourse)
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
[whamlet|#{display courseName}|]
colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourseDescr = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] )
( case courseDescription of
Nothing -> mempty
(Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
)
colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
course <- view $ _dbrOutput . _1 . _entityVal
return $ courseCell course
colDescription :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing (i18nCell MsgCourseDescription)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
case courseDescription of
@ -91,7 +92,8 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
maybe mempty timeCell courseRegisterFrom
-- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
@ -100,7 +102,7 @@ colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> textCell $ case courseCapacity of
$ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
Nothing -> MsgCourseMembersCount currentParticipants
Just max -> MsgCourseMembersCountLimited currentParticipants max
@ -161,9 +163,12 @@ makeCourseTable whereClause colChoices psValidator = do
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
)
, ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
-- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
-- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
-- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
-- )
, ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
)
, ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
@ -249,17 +254,20 @@ getTermCourseListR tid = do
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do
(courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
dependent <- (,,)
<$> get (courseSchool course) -- join -- just fetch full school name here
<*> count [CourseParticipantCourse ==. cid] -- join
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
Nothing -> return False
(Just aid) -> do
regL <- getBy (UniqueParticipant aid cid)
return $ isJust regL)
return $ (courseEnt,dependent)
(Just aid) -> do regL <- getBy (UniqueParticipant aid cid)
return $ isJust regL)
lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return $ user E.^. UserDisplayName
return $ (courseEnt,dependent,E.unValue <$> lecturers)
let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
@ -335,7 +343,7 @@ courseDeleteHandler = undefined
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
courseEditHandler isGet course = do
$logDebug "€€€€€€ courseEditHandler started"
-- $logDebug "€€€€€€ courseEditHandler started"
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm
case result of

20
src/Handler/Home.hs
View File

@ -67,16 +67,16 @@ homeAnonymous = do
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat
[ -- dbRow
sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
textCell $ display $ courseTerm course
, sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
textCell $ display $ courseSchool course
, sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
, 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)
, sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
]
((), courseTable) <- dbTable def $ DBTable
@ -156,17 +156,17 @@ homeUser uid = do
colonnade = mconcat
[ -- dbRow
-- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
textCell $ display tid
, sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
textCell $ display ssh
, sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
, 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)
, sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
, 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)
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
, sortable (Just "done") (i18nCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
case mbsid of
Nothing -> mempty
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)

355
src/Handler/Profile.hs
View File

@ -1,12 +1,15 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
module Handler.Profile where
@ -14,10 +17,14 @@ module Handler.Profile where
import Import
import Handler.Utils
import Handler.Utils.Table.Cells
import Utils.Lens
-- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade
import Data.Monoid (Any(..))
import qualified Data.Map as Map
-- import qualified Data.Set as Set
import qualified Database.Esqueleto as E
-- import Database.Esqueleto ((^.))
@ -106,11 +113,10 @@ getProfileR = do
return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand)
)
<*>
(E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
(E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
)
<*>
@ -150,41 +156,320 @@ getProfileDataR = do
-- mr <- getMessageRender
-- Tabelle mit eigenen Kursen
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
courseTable <- do
let -- should be inlined
-- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a)
courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad
Course{..} <- view $ _dbrOutput . _1 . _entityVal -- view == ^.
-- "preview _left" in order to match Either (result is Maybe)
return $ anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
(citext2widget courseName)
--courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant)))
-- -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity CourseParticipant))
courseData = \(course `E.InnerJoin` participant) -> do
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
return (course, participant)
dbTableWidget' def $ DBTable
{ dbtIdent = "courseMembership" :: Text
, dbtSQLQuery = courseData
, dbtColonnade = mconcat
[ courseCol
]
, dbtProj = return
, dbtSorting = Map.fromList
[ ( "course"
, SortColumn $ \(course `E.InnerJoin` _) -> course E.^. CourseName )
]
, dbtFilter = mempty
, dbtStyle = def
}
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
-- Tabelle mit allen Korrektor-Aufgaben
-- Tabelle mit allen Tutorials
enrolledCoursesTable <- mkEnrolledCoursesTable uid
-- Tabelle mit allen Klausuren und Noten
examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionTable <- mkSubmissionTable uid
-- Tabelle mit allen Abgabegruppen
submissionGroupTable <- mkSubmissionGroupTable uid
-- Tabelle mit allen Korrektor-Aufgaben
correctionsTable <- mkCorrectionsTable uid
-- Tabelle mit allen Tutorials
tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO
defaultLayout $ do
$(widgetFile "profileData")
$(widgetFile "dsgvDisclaimer")
mkOwnedCoursesTable :: UserId -> Handler (Bool, Widget)
-- Table listing all courses that the given user is a lecturer for
mkOwnedCoursesTable =
let dbtIdent = "courseOwnership" :: Text
dbtStyle = def
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
return ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
dbtProj = \x -> return $ x & _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
dbtColonnade = mconcat
[ dbRow
, sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do
tid <- view (_dbrOutput . _1)
return $ indicatorCell -- return True if one cell is produced here
`mappend` termCell tid
, sortable (Just "school") (i18nCell MsgCourseSchool) $
schoolCell <$> view (_dbrOutput . _1 . re _Just)
<*> view (_dbrOutput . _2 )
, sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput)
]
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)]
dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool )
]
dbtFilter = Map.fromList
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> (dbTableWidget validator DBTable{..})
mkEnrolledCoursesTable :: UserId -> Handler Widget
-- Table listing all courses that the given user is enrolled in
mkEnrolledCoursesTable =
let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
withType = id
validator = def & defaultSorting [("time",SortDesc)]
in \uid -> dbTableWidget' validator
DBTable
{ dbtIdent = "courseMembership" :: Text
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
return (course, participant E.^. CourseParticipantRegistration)
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
, dbtColonnade = mconcat
[ dbRow
, sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view ( _courseTerm . re _Just)
<*> view ( _courseSchool )
, sortable (Just "course") (i18nCell MsgCourse) $
courseCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "time") (i18nCell MsgRegistered) $ do
regTime <- view $ _dbrOutput . _2
return $ timeCell regTime
]
, dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName )
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool)
, ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration)
]
, dbtFilter = Map.fromList
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName )
, ( "term" , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
]
, dbtStyle = def
}
mkSubmissionTable :: UserId -> Handler Widget
-- Table listing all submissions for the given user
mkSubmissionTable =
let dbtIdent = "submissions" :: Text
dbtStyle = def
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) -> do
E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
let sht = ( sheet E.^. SheetName
)
return (crse, sht, submission, lastSubEdit uid submission)
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
E.sub_select . E.from $ \subEdit -> do
E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid
return . E.max_ $ subEdit E.^. SubmissionEditTime
dbtProj = \x -> return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _2 %~ E.unValue
& _dbrOutput . _4 %~ E.unValue
dbtColonnade = mconcat
[ dbRow
, sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just)
<*> view ( _2 )
, sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
sheetCell <$> view _1
<*> view _2
, sortable (toNothingS "submission") (i18nCell MsgSubmission) . magnify _dbrOutput $
submissionCell <$> view _1
<*> view _2
<*> view (_3 . _entityKey)
-- , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do
-- regTime <- view $ _dbrOutput . _4
-- return $ maybe mempty timeCell regTime
, sortable (Just "edit") (i18nCell MsgLastEditByUser) $
maybe mempty timeCell <$> view (_dbrOutput . _4)
]
validator = def -- DUPLICATED CODE: Handler.Corrections
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
& restrictSorting (\name _ -> name /= "corrector")
& defaultSorting [("edit",SortDesc)]
dbtSorting' uid = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool )
, ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName )
, ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) -> lastSubEdit uid submission )
]
dbtFilter = Map.fromList
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid
in dbTableWidget' validator $ DBTable {..}
-- in do dbtSQLQuery <- dbtSQLQuery'
-- dbtSorting <- dbtSorting'
-- return $ dbTableWidget' validator $ DBTable {..}
mkSubmissionGroupTable :: UserId -> Handler Widget
-- Table listing all submissions for the given user
mkSubmissionGroupTable =
let dbtIdent = "subGroups" :: Text
dbtStyle = def
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sgroup `E.InnerJoin` sguser) -> do
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
return (crse, sgroup, lastSGEdit sgroup)
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
dbtProj = \x -> return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _3 %~ E.unValue
dbtColonnade = mconcat
[ dbRow
, sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just)
<*> view ( _2 )
, sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
maybe mempty textCell <$> view _submissionGroupName
, sortable (Just "edit") (i18nCell MsgLastEdit) $
maybe mempty timeCell <$> view (_dbrOutput . _3)
]
validator = def -- DUPLICATED CODE: Handler.Corrections
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
& restrictSorting (\name _ -> name /= "corrector")
& defaultSorting [("edit",SortDesc)]
dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
, ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName )
, ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _ ) -> lastSGEdit sgroup)
]
dbtFilter = Map.fromList
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..}
mkCorrectionsTable :: UserId -> Handler Widget
-- Table listing all corrections made by the given user
mkCorrectionsTable =
let dbtIdent = "corrections" :: Text
dbtStyle = def
-- TODO Continue here
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
return (crse, sheet E.^. SheetName, corrector)
dbtProj = \x -> return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _2 %~ E.unValue
dbtColonnade = mconcat
[ dbRow
, sortable (Just "term") (i18nCell MsgTerm) $
termCellCL <$> view (_dbrOutput . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) $
schoolCellCL <$> view (_dbrOutput . _1)
, sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
sheetCell <$> view _1 <*> view _2
, sortable (Just "cstate") (i18nCell MsgCorState) $
correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
, sortable (toNothing "cload") (i18nCell MsgCorProportion) $
correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal)
]
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)]
dbtSorting = Map.fromList
[ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
, ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
, ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _) -> sheet E.^. SheetName )
, ( "cstate", SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs) -> cs E.^. SheetCorrectorState )
]
dbtFilter = Map.fromList
[ ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..}

53
src/Handler/School.hs Normal file
View File

@ -0,0 +1,53 @@
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
module Handler.School where
import Import
-- import Control.Lens
-- import Utils.Lens
-- import Utils.TH
-- import Handler.Utils
-- import Handler.Utils.Table.Cells
--
-- -- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
-- -- import Yesod.Form.Bootstrap3
--
-- import qualified Data.Set as Set
-- import qualified Data.Map as Map
--
-- import Colonnade hiding (fromMaybe,bool)
--
-- import qualified Database.Esqueleto as E
--
-- import qualified Data.UUID.Cryptographic as UUID
getSchoolListR :: Handler Html
getSchoolListR = do
-- muid <- maybeAuthId
defaultLayout $ do
[whamlet|TODO: Liste aller Institute |] -- TODO
getSchoolShowR :: SchoolId -> Handler Html
getSchoolShowR ssh = do -- TODO
-- muid <- maybeAuthId
defaultLayout $ do
[whamlet|TODO: Informationen zu einem Institut |] -- TODO

29
src/Handler/Sheet.hs
View File

@ -274,7 +274,7 @@ getSShowR tid ssh csh shn = do
-- return desired columns
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype
, sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName))
(\(E.Value fName,_,_) -> str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
@ -349,7 +349,32 @@ getSFileR tid ssh csh shn typ title = do
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetNewR tid ssh csh = do
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
E.limit 1
return sheet
let template = case lastSheets of
((Entity {entityVal=Sheet{..}}):_) -> Just $ SheetForm
{ sfName = stepTextCounterCI sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfMarkingText = sheetMarkingText
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
, sfActiveFrom = addOneWeek sheetActiveFrom
, sfActiveTo = addOneWeek sheetActiveTo
, sfSheetF = Nothing
, sfHintFrom = addOneWeek <$> sheetHintFrom
, sfHintF = Nothing
, sfSolutionFrom = addOneWeek <$> sheetSolutionFrom
, sfSolutionF = Nothing
, sfMarkingF = Nothing
}
_other -> Nothing
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
insertUnique $ newSheet
handleSheetEdit tid ssh csh Nothing template action

70
src/Handler/Submission.hs
View File

@ -23,6 +23,7 @@ import Import hiding (joinPath)
-- import Yesod.Form.Bootstrap3
import Handler.Utils
import Handler.Utils.Table.Cells
import Network.Mime
@ -30,6 +31,7 @@ import Control.Monad.Trans.Maybe
import Control.Monad.State.Class
import Control.Monad.Trans.State.Strict (StateT)
import Data.Monoid (Any(..))
import Data.Maybe (fromJust)
import qualified Data.Maybe
import qualified Data.Text as Text
@ -56,9 +58,9 @@ import Colonnade hiding (bool, fromMaybe)
import qualified Yesod.Colonnade as Yesod
import qualified Text.Blaze.Html5.Attributes as HA
numberOfSubmissionEditDates :: Int64
numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
-- DEPRECATED: We always show all edits!
-- numberOfSubmissionEditDates :: Int64
-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
@ -105,8 +107,11 @@ getSubmissionOwnR tid ssh csh shn = do
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
uid <- requireAuthId
msmid <- traverse decrypt mcid
uid <- requireAuthId
msmid <- traverse decrypt mcid
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
case msmid of
@ -135,7 +140,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail
return (sheet,buddies,[])
return (sheet, map E.unValue buddies, [])
(E.Value smid:_) -> do
cID <- encrypt smid
addMessageI "info" $ MsgSubmissionAlreadyExists
@ -145,23 +150,31 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
shid' <- submissionSheet <$> get404 smid
-- fetch buddies from current submission
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail
-- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime]
lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
E.limit numberOfSubmissionEditDates
return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime)
lastEdits <- forM lastEditValues $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
(Any isOwner, buddies) <- do
submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
E.orderBy [E.asc $ user E.^. UserEmail]
return $ (user E.^. UserId, user E.^. UserEmail)
let breakUserFromBuddies (E.Value userID, E.Value email)
| uid == userID = (Any True , [])
| otherwise = (Any False, [email])
return $ foldMap breakUserFromBuddies submittors
lastEdits <- do
raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
-- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
let userName = if isOwner || maySubmit
then E.just $ user E.^. UserDisplayName
else E.nothing
return $ (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (sheet,buddies,lastEdits)
let unpackZips = True -- undefined -- TODO
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
mCID <- runDB $ do
res' <- case res of
(FormMissing ) -> return $ FormMissing
@ -242,13 +255,10 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
Nothing -> return ()
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True
-- Maybe construct a table to display uploaded archive files
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
colonnadeFiles cid = mconcat
[ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
[ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)
origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig
corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
@ -257,17 +267,17 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
| Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
([whamlet|#{fileTitle'}|])
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
, sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of
, sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of
Nothing -> cell mempty
Just (_, Entity _ File{..})
| isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
([whamlet|_{MsgFileCorrected}|])
| otherwise -> textCell MsgFileCorrected
, sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
| otherwise -> i18nCell MsgCorrected
, sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
origTime = fileModified . entityVal . snd <$> mOrig
corrTime = fileModified . entityVal . snd <$> mCorr
Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
in textCell $ display fileTime
in timeCell fileTime
]
coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))
coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md)
@ -303,6 +313,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
defaultLayout $ do
setTitleI $ MsgSubmissionEditHead tid ssh csh shn
let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))
urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
$(widgetFile "submission")

14
src/Handler/Users.hs
View File

@ -33,9 +33,9 @@ getUsersR = do
let
dbtColonnade = dbColonnade . mconcat $
[ dbRow
, sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
(AdminUserR <$> encrypt uid)
(toWidget . display $ userDisplayName)
(nameWidget userDisplayName userSurname)
, sortable (Just "matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
(AdminUserR <$> encrypt uid)
(toWidget . display $ userMatrikelnummer)
@ -73,22 +73,22 @@ getUsersR = do
|]
]
psValidator = def
& defaultSorting [("display-name", SortAsc)]
& defaultSorting [("name", SortAsc),("display-name", SortAsc)]
((), userList) <- dbTable psValidator $ DBTable
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
, dbtColonnade
, dbtProj = return
, dbtSorting = Map.fromList
[ ( "display-name"
[ ( "name"
, SortColumn $ \user -> user E.^. UserSurname
)
, ( "display-name"
, SortColumn $ \user -> user E.^. UserDisplayName
)
, ( "matriculation"
, SortColumn $ \user -> user E.^. UserMatrikelnummer
)
-- , ( "last-name"
-- , SortColumn $ \user -> (last . impureNonNull . words) <$> (user E.^. UserDisplayName)
-- )
]
, dbtFilter = mempty
, dbtStyle = def

14
src/Handler/Utils.hs
View File

@ -11,6 +11,8 @@ module Handler.Utils
import Import
import qualified Data.Text as T
import Handler.Utils.DateTime as Handler.Utils
import Handler.Utils.Form as Handler.Utils
import Handler.Utils.Table as Handler.Utils
@ -31,3 +33,15 @@ downloadFiles = do
Nothing -> do
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
return userDefaultDownloadFiles
nameWidget :: Text -> Text -> Widget
nameWidget displayName surname
| null surname = toWidget displayName
| otherwise = case reverse $ T.splitOn surname displayName of
[_notContained] -> [whamlet|#{displayName} (<b .surname>#{surname}</b>)|]
(suffix:prefixes) ->
let prefix = T.intercalate surname $ reverse prefixes
in [whamlet|#{prefix}<b .surname>#{surname}</b>#{suffix}|]
[] -> error "Data.Text.splitOn returned empty list in violation of specification."

18
src/Handler/Utils/DateTime.hs
View File

@ -8,10 +8,10 @@
module Handler.Utils.DateTime
( utcToLocalTime
, localTimeToUTC, TZ.LocalToUTCResult(..)
, formatTime'
, formatTime
, formatTime, formatTime', formatTimeW
, getTimeLocale, getDateTimeFormat
, validDateTimeFormats, dateTimeFormatOptions
, addOneWeek
) where
import Import
@ -20,6 +20,7 @@ import Data.Time.Zones hiding (localTimeToUTCFull)
import qualified Data.Time.Zones as TZ
import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
import Data.Time.Clock (addUTCTime,nominalDay)
import qualified Data.Time.Format as Time
import Data.Set (Set)
@ -51,6 +52,12 @@ formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> p
formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t -> m Text
formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj)
-- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text
-- formatTimeH = formatTime
formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
formatTimeW s t = toWidget =<< formatTime s t
getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
getTimeLocale = getTimeLocale' <$> languages
@ -125,3 +132,10 @@ dateTimeFormatOptions sel = do
return $ (dateTime, fmt)
optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel
addOneWeek :: UTCTime -> UTCTime
addOneWeek = addUTCTime (7 * nominalDay)
-- addOneTerm? -> Move Handler.Utils.DateTime

99
src/Handler/Utils/Table/Cells.hs Normal file
View File

@ -0,0 +1,99 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
module Handler.Utils.Table.Cells where
import Import
import Data.Monoid (Any(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Utils.Lens
import Handler.Utils
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
--------------------
-- Special cells
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
indicatorCell = mempty & cellContents %~ (tell (Any True) *>)
-- Datatype cells
timeCell :: IsDBTable m a => UTCTime -> DBCell m a
timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
userCell :: IsDBTable m a => Text -> Text -> DBCell m a
userCell displayName surname = cell $ nameWidget displayName surname
-- Just for documentation purposes; inline this code instead:
maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
maybeTimeCell = maybe mempty timeCell
termCell :: IsDBTable m a => TermId -> DBCell m a
termCell tid = anchorCell link name
where
link = TermCourseListR tid
name = text2widget $ display tid
termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
termCellCL (tid,_,_) = termCell tid
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
schoolCell Nothing ssh = anchorCell link name
where
link = SchoolShowR ssh
name = text2widget $ display ssh
schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a
schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh
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
courseCell :: IsDBTable m a => Course -> DBCell m a
courseCell (Course {..}) = anchorCell link name `mappend` desc
where
link = CourseR courseTerm courseSchool courseShorthand CShowR
name = citext2widget courseName
desc = case courseDescription of
Nothing -> mempty
(Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
sheetCell crse shn =
let tid = crse ^. _1
ssh = crse ^. _2
csh = crse ^. _3
link= CSheetR tid ssh csh shn SShowR
in anchorCell link $ display2widget shn
submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
submissionCell crse shn sid =
let tid = crse ^. _1
ssh = crse ^. _2
csh = crse ^. _3
mkCid = encrypt sid
mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
mkText cid = display2widget cid
in anchorCellM' mkCid mkRoute mkText
correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a
correctorStateCell sc =
i18nCell $ sheetCorrectorState sc
correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
correctorLoadCell sc =
i18nCell $ sheetCorrectorLoad sc

43
src/Handler/Utils/Table/Pagination.hs
View File

@ -21,7 +21,7 @@
module Handler.Utils.Table.Pagination
( SortColumn(..), SortDirection(..)
, FilterColumn(..), IsFilterColumn
, DBRow(..), HasDBRow(..)
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
, DBStyle(..), DBEmptyStyle(..)
, DBTable(..), IsDBTable(..), DBCell(..)
, cellAttrs, cellContents
@ -34,7 +34,7 @@ module Handler.Utils.Table.Pagination
, dbTableWidget, dbTableWidget'
, widgetColonnade, formColonnade, dbColonnade
, cell, textCell, stringCell, i18nCell
, anchorCell, anchorCell', anchorCellM
, anchorCell, anchorCell', anchorCellM, anchorCellM'
, tickmarkCell
, listCell
, formCell, DBFormResult, getDBFormResult
@ -45,6 +45,7 @@ module Handler.Utils.Table.Pagination
) where
import Handler.Utils.Table.Pagination.Types
import Utils.Lens.TH
import Import hiding (Proxy(..))
import qualified Database.Esqueleto as E
@ -134,7 +135,7 @@ data PaginationSettings = PaginationSettings
, psShortcircuit :: Bool
}
makeClassy_ ''PaginationSettings
makeLenses_ ''PaginationSettings
instance Default PaginationSettings where
def = PaginationSettings
@ -153,7 +154,7 @@ data PaginationInput = PaginationInput
, piShortcircuit :: Bool
}
makeClassy_ ''PaginationInput
makeLenses_ ''PaginationInput
piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and
@ -169,7 +170,7 @@ data DBRow r = DBRow
, dbrIndex, dbrCount :: Int64
} deriving (Show, Read, Eq, Ord)
makeClassy_ ''DBRow
makeLenses_ ''DBRow
instance Functor DBRow where
fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
@ -485,10 +486,14 @@ dbColonnade = id
cell :: IsDBTable m a => Widget -> DBCell m a
cell wgt = dbCell # ([], return wgt)
textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
textCell = cell . toWidget . (pack :: [Char] -> Text) . otoList
stringCell = textCell
i18nCell = textCell
textCell msg = cell [whamlet|_{msg}|]
i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
i18nCell msg = cell $ do
mr <- getMessageRender
toWidget $ mr msg
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
tickmarkCell True = textCell (tickmark :: Text)
@ -498,6 +503,7 @@ tickmarkCell False = mempty
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
anchorCell = anchorCellM . return
{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-}
anchorCell' :: IsDBTable m a
=> (r -> Route UniWorX)
-> (r -> Widget)
@ -505,13 +511,18 @@ anchorCell' :: IsDBTable m a
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a
anchorCellM routeM widget = cell $ do
route <- routeM
authResult <- liftHandlerT $ isAuthorized route False
anchorCellM routeM widget = anchorCellM' routeM id (const widget)
anchorCellM' :: IsDBTable m a => (WidgetT UniWorX IO x) -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
anchorCellM' xM x2route x2widget = cell $ do
x <- xM
let route = x2route x
widget = x2widget x
authResult <- liftHandlerT $ isAuthorized route False
case authResult of
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
_otherwise -> widget -- don't show prohibited link
if
| Authorized <- authResult -> $(widgetFile "table/cell/link")
| otherwise -> widget
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
listCell xs mkCell = review dbCell . ([], ) $ do
@ -544,12 +555,12 @@ formCell genIndex genForm input = FormCell
-- Predefined colonnades
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
=> Setter' a Bool
-> (r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ textCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])

23
src/Model/Migration.hs
View File

@ -12,6 +12,8 @@ module Model.Migration
import ClassyPrelude.Yesod
import Utils (lastMaybe)
import Model
import Model.Migration.Version
import Data.Map (Map)
@ -23,6 +25,7 @@ import qualified Data.Set as Set
import Database.Persist.Sql
import Database.Persist.Postgresql
import Text.Read (readMaybe)
import Data.CaseInsensitive (CI)
-- Database versions must follow https://pvp.haskell.org:
@ -151,6 +154,26 @@ customMigrations = Map.fromListWith (>>)
ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
|]
)
, ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|]
, whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now.
correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |]
forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of
Just load -> update uid [SheetCorrectorLoad =. load]
_other -> error $ "Could not parse Load: " <> show str
[executeQQ|
ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE json USING "load"::json;
|]
)
, ( AppliedMigrationKey [migrationVersion|3.0.0|] [version|3.1.0|]
, whenM (tableExists "user") $ do
userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
[executeQQ|
ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' ';
|]
forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
Just name -> update uid [UserSurname =. name]
_other -> error $ "Empty userDisplayName found"
)
]

13
src/Model/Types.hs
View File

@ -88,6 +88,8 @@ pToI = fromPoints
fromPoints :: Integral a => Points -> a -- deprecated
fromPoints = round
instance DisplayAble Points
data SheetType
= Bonus { maxPoints :: Points }
| Normal { maxPoints :: Points }
@ -201,7 +203,12 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
, byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders
}
deriving (Show, Read, Eq, Ord)
derivePersistField "Load"
deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load
instance Semigroup Load where
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
@ -237,6 +244,8 @@ seasonFromChar c
where
(~=) = (==) `on` CI.mk
instance DisplayAble Season
data TermIdentifier = TermIdentifier
{ year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
, season :: Season
@ -337,6 +346,8 @@ data StudyFieldType = FieldPrimary | FieldSecondary
deriving (Eq, Ord, Enum, Show, Read, Bounded)
derivePersistField "StudyFieldType"
instance DisplayAble StudyFieldType
data Theme
= ThemeDefault
| ThemeLavender

90
src/Utils.hs
View File

@ -1,8 +1,9 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
@ -15,7 +16,7 @@ module Utils
import ClassyPrelude.Yesod
-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import Data.Foldable as Fold
import Data.Foldable as Fold hiding (length)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
@ -27,6 +28,11 @@ import Utils.PathPiece as Utils
import Text.Blaze (Markup, ToMarkup)
import Data.Char (isDigit)
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
import Numeric (showFFloat)
import Control.Lens
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
@ -45,6 +51,8 @@ import Instances.TH.Lift ()
import Text.Shakespeare.Text (st)
-----------
-- Yesod --
-----------
@ -80,6 +88,7 @@ unsupportedAuthPredicate = do
|]
---------------------
-- Text and String --
---------------------
@ -112,15 +121,21 @@ str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
String -> WidgetT site m ()
str2widget s = [whamlet|#{s}|]
display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) =>
a -> WidgetT site m ()
display2widget = text2widget . display
withFragment :: ( Monad m
) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
-- Convert anything to Text, and I don't care how
-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
{-# DEPRECATED display "Create RenderMessage Instances instead!" #-}
class DisplayAble a where
display :: a -> Text
-- Default definitions for types belonging to Show (allows empty instance declarations)
default display :: Show a => a -> Text
display = pack . show
instance DisplayAble Text where
display = id
@ -128,6 +143,19 @@ instance DisplayAble Text where
instance DisplayAble String where
display = pack
instance DisplayAble Int
instance DisplayAble Int64
instance DisplayAble Integer
instance DisplayAble Rational where
display r = showFFloat (Just 2) (rat2float r) ""
& pack
& dropWhileEnd ('0'==)
& dropWhileEnd ('.'==)
where
rat2float :: Rational -> Double
rat2float = fromRational
instance DisplayAble a => DisplayAble (Maybe a) where
display Nothing = ""
display (Just x) = display x
@ -138,9 +166,12 @@ instance DisplayAble a => DisplayAble (E.Value a) where
instance DisplayAble a => DisplayAble (CI a) where
display = display . CI.original
-- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
{- We do not want DisplayAble for every Show-Class:
We want to explicitly verify that the resulting text can be displayed to the User!
For example: UTCTime values were shown without proper format rendering!
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
display = pack . show
-}
textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent x = lz <> (pack $ show rx) <> "%"
@ -151,6 +182,24 @@ textPercent x = lz <> (pack $ show rx) <> "%"
rx = fromIntegral (round' $ 1000.0*x) / 10.0
lz = if rx < 10.0 then "0" else ""
stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounterCI = CI.map stepTextCounter
stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounter text
| (Just i) <- readMay number =
let iplus1 = tshow (succ i :: Int)
zeroip = justifyRight (length number) '0' iplus1
in prefix <> zeroip <> suffix
| otherwise = text
where -- no splitWhile nor findEnd in Data.Text
suffix = takeWhileEnd (not . isDigit) text
number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)"
-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"]
------------
-- Tuples --
@ -168,12 +217,22 @@ trd3 (_,_,z) = z
-- snd3 = $(projNI 3 2)
-----------
-- Lists --
-----------
-- notNull = not . null
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
lastMaybe [h] = Just h
lastMaybe (_:t) = lastMaybe t
lastMaybe' :: [a] -> Maybe a
lastMaybe' l = fmap snd $ l ^? _Snoc
mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
mergeAttrs = mergeAttrs' `on` sort
where
@ -191,6 +250,8 @@ mergeAttrs = mergeAttrs' `on` sort
mergeAttrs' [] xs2 = xs2
mergeAttrs' xs1 [] = xs1
----------
-- Maps --
----------
@ -210,6 +271,8 @@ partMap = Map.fromListWith mappend
invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
invertMap = groupMap . map swap . Map.toList
-----------
-- Maybe --
-----------
@ -218,6 +281,12 @@ toMaybe :: Bool -> a -> Maybe a
toMaybe True = Just
toMaybe False = const Nothing
toNothing :: a -> Maybe b
toNothing = const Nothing
toNothingS :: String -> Maybe b
toNothingS = const Nothing
maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
maybeAdd (Just x) (Just y) = Just (x + y)
maybeAdd Nothing y = y
@ -252,6 +321,8 @@ instance Ord a => Ord (NTop (Maybe a)) where
compare _ (NTop Nothing) = LT
compare (NTop (Just x)) (NTop (Just y)) = compare x y
---------------
-- Exception --
---------------
@ -281,16 +352,17 @@ catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) ->
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
------------
-- Monads --
------------
shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
shortCircuitM sc mx my op = do
shortCircuitM sc mx my bop = do
x <- mx
case sc x of
True -> return x
False -> op <$> pure x <*> my
False -> bop <$> pure x <*> my
guardM :: MonadPlus m => m Bool -> m ()

12
src/Utils/DB.hs
View File

@ -10,10 +10,20 @@ import ClassyPrelude.Yesod
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
-- import Database.Persist -- currently not needed here
emptyOrIn :: PersistField typ =>
E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
emptyOrIn criterion testSet
| Set.null testSet = E.val True
| otherwise = criterion `E.in_` E.valList (Set.toList testSet)
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty

1
src/Utils/DateTime.hs
View File

@ -28,6 +28,7 @@ import Instances.TH.Lift ()
deriving instance Lift TimeZone
deriving instance Lift TimeLocale
-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
-> ExpQ

23
src/Utils/Lens.hs
View File

@ -7,9 +7,28 @@ module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation
import Control.Lens as Utils.Lens
import Utils.Lens.TH
makeClassy_ ''Entity
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
makeClassy_ ''SheetCorrector
_unValue :: Lens' (E.Value a) a
_unValue f (E.Value a) = E.Value <$> f a
_InnerJoinLeft :: Lens' (E.InnerJoin l r) l -- forall f. Functor f => (a -> f a) -> s -> f s
_InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l
_InnerJoinRight :: Lens' (E.InnerJoin l r) r
_InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r
makeLenses_ ''Entity
makeLenses_ ''Course
makeLenses_ ''SheetCorrector
makeLenses_ ''SubmissionGroup
-- makeClassy_ ''Load

47
src/Utils/Lens/TH.hs Normal file
View File

@ -0,0 +1,47 @@
module Utils.Lens.TH where
import Control.Lens
import Control.Lens.Internal.FieldTH
import Language.Haskell.TH
-- import Control.Lens.Misc
{- NOTE: The code for lensRules_ and makeLenses_ was stolen from package lens-misc-0.0.2.0,
which was currently unavailable in our stack snapshot.
See https://github.com/louispan/lens-misc
-}
-- | A 'LensRules' used by 'makeLenses_'.
lensRules_ :: LensRules
lensRules_ = lensRules
& lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))]
-- | Build lenses (and traversals) with a sensible default configuration.
-- Works the same as 'makeLenses' except that
-- the resulting lens is also prefixed with an underscore.
--
-- /e.g./
--
-- @
-- data FooBar
-- = Foo { x, y :: 'Int' }
-- | Bar { x :: 'Int' }
-- 'makeLenses' ''FooBar
-- @
--
-- will create
--
-- @
-- _x :: 'Lens'' FooBar 'Int'
-- _x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a
-- _x f (Bar a) = Bar \<$\> f a
-- _y :: 'Traversal'' FooBar 'Int'
-- _y f (Foo a b) = (\\b\' -> Foo a b\') \<$\> f b
-- _y _ c\@(Bar _) = pure c
-- @
--
-- @
-- 'makeLenses_' = 'makeLensesWith' 'lensRules_'
-- @
makeLenses_ :: Name -> DecsQ
makeLenses_ = makeFieldOptics lensRules_

16
src/Utils/PathPiece.hs
View File

@ -38,14 +38,14 @@ nullaryToPathPiece nullaryType manglers = do
splitCamel :: Text -> [Text]
splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
where
helper hadChange words thisWord [] = reverse thisWord : words
helper hadChange words [] (c:cs) = helper True words [c] cs
helper hadChange words ws@(w:ws') (c:cs)
helper _hadChange items thisWord [] = reverse thisWord : items
helper _hadChange items [] (c:cs) = helper True items [c] cs
helper hadChange items ws@(w:ws') (c:cs)
| sameCategory w c
, null ws' = helper False words (c:ws) cs
| sameCategory w c = helper hadChange words (c:ws) cs
| null ws' = helper True words (c:ws) cs
| not hadChange = helper True (reverse ws':words) [c,w] cs
| otherwise = helper True (reverse ws:words) [c] cs
, null ws' = helper False items (c:ws) cs
| sameCategory w c = helper hadChange items (c:ws) cs
| null ws' = helper True items (c:ws) cs
| not hadChange = helper True (reverse ws':items) [c,w] cs
| otherwise = helper True (reverse ws :items) [c] cs
sameCategory = (==) `on` Char.generalCategory

2
src/Utils/TH.hs
View File

@ -17,14 +17,12 @@ import Language.Haskell.TH
------------
-- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
{-
projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth
-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
projNI n i = lamE [pat] rhs
where pat = tupP (map varP xs)
rhs = varE (xs !! (i - 1))
xs = [ mkName $ "x" ++ show j | j <- [1..n] ]
-}
---------------
-- Functions --

5
src/index.md
View File

@ -74,7 +74,10 @@ Handler.Utils.Table.Pagination
Handler.Utils.Table.Pagination.Types
: `Sortable`-Headedness for colonnade
Handler.Utils.Table.Cells
: extends dbTable with UniWorX specific functions, such as special courseCell
Handler.Utils.Templates
: Modals

30
templates/correction-user.hamlet
View File

@ -1,39 +1,39 @@
<div .scrolltable>
<table .table .table--striped .table--hover .table--vertical>
<tr .table__row>
<th .table__th> _{MsgSubmission}
<td .table__td> #{display cid}
<th .table__th>_{MsgSubmission}
<td .table__td>#{display cid}
$maybe Entity _ User{..} <- corrector
<tr .table__row>
<th .table__th> _{MsgRatingBy}
<td .table__td> #{display userDisplayName}
<th .table__th>_{MsgRatingBy}
<td .table__td>#{display userDisplayName}
$maybe time <- submissionRatingTime
<tr .table__row>
<th .table__th> _{MsgRatingTime}
<td .table__td> #{display time}
<th .table__th>_{MsgRatingTime}
<td .table__td>^{formatTimeW SelFormatDateTime time}
$maybe points <- submissionRatingPoints
$case sheetType
$of Bonus{..}
<tr .table__row>
<th .table__th> _{MsgAchievedBonusPoints}
<td .table__td> _{MsgAchievedOf points maxPoints}
<th .table__th>_{MsgAchievedBonusPoints}
<td .table__td>_{MsgAchievedOf points maxPoints}
$of Normal{..}
<tr .table__row>
<th .table__th> _{MsgAchievedNormalPoints}
<td .table__td> _{MsgAchievedOf points maxPoints}
<th .table__th>_{MsgAchievedNormalPoints}
<td .table__td>_{MsgAchievedOf points maxPoints}
$of Pass{..}
<tr .table__row>
<th .table__th> _{MsgPassedResult}
<th .table__th>_{MsgPassedResult}
<td .table__td>
$if points >= passingPoints
_{MsgPassed}
$else
_{MsgNotPassed}
<tr .table__row>
<th .table__th> _{MsgAchievedPassPoints}
<td .table__td> _{MsgPassAchievedOf points passingPoints maxPoints}
<th .table__th>_{MsgAchievedPassPoints}
<td .table__td>_{MsgPassAchievedOf points passingPoints maxPoints}
$of NotGraded
$maybe comment <- ratingComment
<tr .table__row>
<th .table__th> _{MsgRatingComment}
<td .table__td style="white-space: pre;"> #{comment}
<th .table__th>_{MsgRatingComment}
<td .table__td style="white-space: pre;">#{comment}

11
templates/course.hamlet
View File

@ -5,11 +5,22 @@
<dd .deflist__dd>
<div>
#{schoolName school}
$maybe descr <- courseDescription course
<dt .deflist__dt>_{MsgCourseDescription}
<dd .deflist__dd>
<div>
#{descr}
$with numlecs <- length lecturers
$if numlecs > 1
<dt .deflist__dt>_{MsgLecturersFor}
$else
<dt .deflist__dt>_{MsgLecturerFor}
<dd .deflist__dd>
<div>
#{T.intercalate ", " lecturers}
$maybe link <- courseLinkExternal course
<dt .deflist__dt>Website
<dd .deflist__dd>

2
templates/default-layout.hamlet
View File

@ -15,6 +15,8 @@
<div .main__content-body>
<h1>
<!-- $maybe back <- lastMaybe parents
<a .breadcrumbs__link href="@{fst back}">#{snd back} -->
$maybe headline <- contentHeadline
^{headline}
$nothing

4
templates/default-layout.lucius
View File

@ -1,7 +1,7 @@
:root {
/* THEME INDEPENDENT COLORS */
--color-error: #ff3860;
--color-warning: #ffdd57;
--color-error: #8c0707;
--color-warning: #fc9900;
--color-success: #23d160;
--color-info: #c4c4c4;
--color-lightblack: #1A2A36;

1
templates/dsgvDisclaimer.hamlet
View File

@ -14,4 +14,3 @@
Bitte melden Sie etwaige Probleme an #
<a href="mailto:jost@tcs.ifi.lmu.de">
jost@tcs.ifi.lmu.de

3
templates/dsgvDisclaimer.lucius
View File

@ -3,10 +3,9 @@
border-radius: 3px;
padding: 10px 20px 20px;
margin: 40px 0;
color: var(--color-lighter);
color: var(--color-dark);
box-shadow: 0 0 4px 2px inset currentColor;
padding-left: 20%;
color: #318dc5 ;
&::before {
content: 'i';

4
templates/profile.hamlet
View File

@ -59,10 +59,10 @@
<dt .deflist__dt> Teilnehmer
<dd .deflist__dd>
<dl .deflist>
$forall (E.Value tid, E.Value ssh, E.Value csh, regSince) <- participant
$forall (E.Value tid, E.Value ssh, E.Value csh, E.Value regSince) <- participant
<dt .deflist__dt>
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
<dd .deflist__dd>
seit #{display regSince}
seit ^{formatTimeW SelFormatDateTime regSince}
^{settingsForm}

36
templates/profileData.hamlet
View File

@ -8,10 +8,44 @@
<em> TODO: Hier alle Daten in Tabellen anzeigen!
$if hasRows
<div .container>
<h2> Eigene Kurse
<div .container>
^{ownedCoursesTable}
<div .container>
<h2> Kursanmeldungen
<div .container>
^{courseTable}
^{enrolledCoursesTable}
<div .container>
<h2> Noten
<div .container>
^{examTable}
<div .container>
<h2> Übungsgruppen
<div .container>
^{tutorialTable}
<div .container>
<h2> Abgabegruppen
<div .container>
^{submissionGroupTable}
<div .container>
<h2> Abgaben
<div .container>
^{submissionTable}
<em>Hinweis:
Bei Gruppenabgaben wird kein Datum angezeigt,
falls Sie die Gruppenabgabe nie selbst hochgeladen haben.
<div .container>
<h2> _{MsgCorrector}
<div .container>
^{correctionsTable}
<h2>
<em> TODO: Knopf zum Löschen aller Daten erstellen

2
templates/standalone/alerts.julius
View File

@ -6,7 +6,7 @@
window.utils.alert = function(alertEl) {
var closeEl = document.createElement('DIV');
var dataDecay = alertEl.dataset.decay;
var autoDecay = 3;
var autoDecay = 30;
if (dataDecay) {
autoDecay = parseInt(dataDecay, 10);
}

39
templates/standalone/alerts.lucius
View File

@ -2,13 +2,13 @@
/**
.alert
Regular Info Alert
Disappears automatically after 3 seconds
Disappears after x seconds if sepcified via data-decay='x'
Disappears automatically after 30 seconds
Disappears after x seconds if explicitly specified via data-decay='x' on html element
Can be told not to disappear with data-decay='0'
.alert-warning, .alert-error
Warning or Error alert
Don't disappear, only difference is color
These don't disappear, only difference is color
.alert-warning is orange regardless of user's selected theme
.alert-error is red regardless of user's selected theme
@ -23,20 +23,12 @@
flex-direction: column;
}
@media (min-width: 768px) {
.alerts {
top: 150px;
bottom: auto;
}
}
.alert {
position: relative;
display: inline-block;
background-color: var(--color-dark);
font-size: 1rem;
color: #f3f3f3;
color: var(--color-lightwhite);
z-index: 0;
max-height: 200px;
transition: all .3s ease-in-out;
@ -116,8 +108,6 @@
top: 0;
width: 60px;
height: 100%;
/* TODO: remove next line as soon as messagerenderer-error in julius gets resolved */
color: var(--color-dark);
transition: all .3s ease;
z-index: 40;
@ -138,7 +128,6 @@
top: 50%;
left: 50%;
display: flex;
color: rgba(255, 255, 255, 0.5);
align-items: center;
justify-content: center;
transform: translate(-50%, -50%);
@ -158,31 +147,11 @@
.alert-warning {
background-color: var(--color-warning);
color: var(--color-dark);
.alert__close {
color: var(--color-warning);
/* TODO: remove me as soon as messagerenderer-error in julius gets resolved */
&::before {
color: var(--color-dark);
}
}
}
.alert-danger,
.alert-error {
background-color: var(--color-error);
color: var(--color-lightwhite);
.alert__close {
color: var(--color-error);
/* TODO: remove me as soon as messagerenderer-error in julius gets resolved */
&::before {
color: var(--color-lightwhite);
}
}
}
.alert--invisible {

17
templates/standalone/tooltip.julius
View File

@ -3,7 +3,6 @@
window.utils = window.utils || {};
// allows for multiple file uploads with separate inputs
window.utils.tooltip = function(tt) {
var handle = tt.querySelector('.tooltip__handle');
var content = tt.querySelector('.tooltip__content');
@ -55,13 +54,15 @@
document.addEventListener('DOMContentLoaded', function() {
// initialize tooltips set via `data-tooltip`
Array.from(document.querySelectorAll('[data-tooltip]')).forEach(function(el) {
window.utils.tooltipFromAttribute(el)
});
// JS-TOOLTIPS NOT USED CURRENTLY.
// initialize tooltips set via `data-tooltip`
// Array.from(document.querySelectorAll('[data-tooltip]')).forEach(function(el) {
// window.utils.tooltipFromAttribute(el)
// });
// initialize tooltips
Array.from(document.querySelectorAll('.js-tooltip')).forEach(function(tt) {
window.utils.tooltip(tt);
});
// Array.from(document.querySelectorAll('.js-tooltip')).forEach(function(tt) {
// window.utils.tooltip(tt);
// });
});

21
templates/standalone/tooltip.lucius
View File

@ -2,8 +2,8 @@
position: relative;
display: inline-block;
.hidden {
display: none;
&:hover .tooltip__content {
display: inline-block;
}
}
@ -17,15 +17,16 @@
color: white;
display: inline-block;
text-align: center;
cursor: default;
margin: 0 10px;
cursor: default;
}
.tooltip__content {
position: absolute;
display: none;
top: -10px;
transform: translateY(-100%);
left: 3px;
right: 3px;
width: 275px;
z-index: 10;
background-color: #fafafa;
@ -33,16 +34,6 @@
padding: 13px 17px;
box-shadow: 0 0 20px 4px rgba(0, 0, 0, 0.1);
&.to-left {
left: auto;
right: 3px;
&::after {
left: auto;
right: 10px;
}
}
&::after {
content: '';
width: 16px;
@ -50,7 +41,7 @@
background-color: #fafafa;
transform: rotate(45deg);
position: absolute;
left: 10px;
right: 10px;
bottom: -8px;
}
}

20
templates/submission.hamlet
View File

@ -1,17 +1,23 @@
$maybe cID <- mcid
<section>
<h2>
<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv
(<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>)
$if not (null lastEdits)
<h3>_{MsgLastEdits}
<ul>
$forall (name,time) <- lastEdits
<li>_{MsgEditedBy name time}
<a href=@{urlArchive cID}>Archiv
(<a href=@{urlOriginal cID}>Original</a>)
$maybe fileTable <- mFileTable
<h3>_{MsgSubmissionFiles}
^{fileTable}
$if not (null lastEdits)
<h3>_{MsgLastEdits}
<ul>
$forall (mbName,time) <- lastEdits
$maybe name <- mbName
<li>_{MsgEditedBy name time}
$nothing
<li>#{display time}
$if maySubmit
<section>
<form .form-horizontal method=post action=@{actionUrl} enctype=#{formEnctype}>

1
templates/widgets/asidenav.lucius
View File

@ -181,6 +181,7 @@
width: 0;
overflow: hidden;
z-index: -1;
box-shadow: 0 0 13px rgba(0, 0, 0, 0.4);
}
@media (max-width: 425px) {

3
templates/widgets/pageactionprime.hamlet
View File

@ -7,9 +7,6 @@ $if hasPageActions
$of PageActionPrime (MenuItem label _mIcon route _callback)
<li .pagenav__list-item>
<a .pagenav__link-wrapper href=@{route}>#{label}
$of _
$forall menuType <- menuTypes
$case menuType
$of PageActionSecondary (MenuItem label _mIcon route _callback)
<li .pagenav__list-item>
<a .pagenav__link-wrapper href=@{route}>#{label}