347 lines
17 KiB
Haskell
347 lines
17 KiB
Haskell
{-# 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
|
|
|
|
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 ((^.))
|
|
|
|
|
|
|
|
data SettingsForm = SettingsForm
|
|
{ stgMaxFavourties :: Int
|
|
, stgTheme :: Theme
|
|
, stgDateTime :: DateTimeFormat
|
|
, stgDate :: DateTimeFormat
|
|
, stgTime :: DateTimeFormat
|
|
, stgDownloadFiles :: Bool
|
|
}
|
|
|
|
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
|
|
makeSettingForm template = identForm FIDsettings $ \html -> do
|
|
let themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
|
|
<$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
|
|
(fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
|
|
<*> areq (selectField . return $ mkOptionList themeList)
|
|
(fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template)
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
|
|
<*> areq checkBoxField (fslI MsgDownloadFiles
|
|
& setTooltip MsgDownloadFilesTip
|
|
) (stgDownloadFiles <$> template)
|
|
<* submitButton
|
|
return (result, widget) -- no validation required here
|
|
|
|
|
|
|
|
getProfileR :: Handler Html
|
|
getProfileR = do
|
|
(uid, User{..}) <- requireAuthPair
|
|
let settingsTemplate = Just $ SettingsForm
|
|
{ stgMaxFavourties = userMaxFavourites
|
|
, stgTheme = userTheme
|
|
, stgDateTime = userDateTimeFormat
|
|
, stgDate = userDateFormat
|
|
, stgTime = userTimeFormat
|
|
, stgDownloadFiles = userDownloadFiles
|
|
}
|
|
((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
|
|
case res of
|
|
(FormSuccess SettingsForm{..}) -> do
|
|
runDB $ do
|
|
update uid [ UserMaxFavourites =. stgMaxFavourties
|
|
, UserTheme =. stgTheme
|
|
, UserDateTimeFormat =. stgDateTime
|
|
, UserDateFormat =. stgDate
|
|
, UserTimeFormat =. stgTime
|
|
, UserDownloadFiles =. stgDownloadFiles
|
|
]
|
|
when (stgMaxFavourties < userMaxFavourites) $ do
|
|
-- prune Favourites to user-defined size
|
|
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
|
|
[ Desc CourseFavouriteTime
|
|
, OffsetBy $ stgMaxFavourties
|
|
]
|
|
mapM_ delete oldFavs
|
|
addMessageI "info" $ MsgSettingsUpdate
|
|
redirect ProfileR -- TODO: them change does not happen without redirect
|
|
|
|
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
|
_ -> return ()
|
|
|
|
|
|
(admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$>
|
|
(E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
|
|
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
|
|
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
|
|
return (school E.^. SchoolShorthand)
|
|
)
|
|
<*>
|
|
(E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
|
|
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
|
|
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
|
|
return (school E.^. SchoolShorthand)
|
|
)
|
|
<*>
|
|
(E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand)
|
|
)
|
|
<*>
|
|
(E.select $ 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)
|
|
)
|
|
<*>
|
|
(E.select $ E.from $ \(participant `E.InnerJoin` course) -> do
|
|
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, participant E.^. CourseParticipantRegistration)
|
|
)
|
|
<*>
|
|
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
|
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
|
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
|
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
|
return (studydegree E.^. StudyDegreeName
|
|
,studyterms E.^. StudyTermsName
|
|
,studyfeat E.^. StudyFeaturesType
|
|
,studyfeat E.^. StudyFeaturesSemester)
|
|
)
|
|
let formText = Just MsgSettings
|
|
actionUrl = ProfileR
|
|
settingsForm = $(widgetFile "formPageI18n")
|
|
defaultLayout $ do
|
|
setTitle . toHtml $ userIdent <> "'s User page"
|
|
$(widgetFile "profile")
|
|
$(widgetFile "dsgvDisclaimer")
|
|
|
|
postProfileR :: Handler Html
|
|
postProfileR = do
|
|
-- TODO
|
|
getProfileR
|
|
|
|
----------------------------------------
|
|
-- TODO: Are these really a good idea?
|
|
-- If yes: Move to appropriate Place: Utils.Lens and Utils.Table.Cells
|
|
--
|
|
-- Or Maybe make Course an instance of Data.Data and use biplate instead?
|
|
-- λ> ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [String]
|
|
-- ["a","b","c","d","e","f"]
|
|
-- it :: [String]
|
|
-- *Main Control.Lens Data.Data.Lens
|
|
-- λ> ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [Int]
|
|
-- []
|
|
-- it :: [Int]
|
|
-- *Main Control.Lens Data.Data.Lens
|
|
-- λ> ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [Integer]
|
|
-- [7,9,8]
|
|
-- it :: [Integer]
|
|
|
|
|
|
|
|
getProfileDataR :: Handler Html
|
|
getProfileDataR = do
|
|
(uid, User{..}) <- requireAuthPair
|
|
-- mr <- getMessageRender
|
|
|
|
-- Tabelle mit eigenen Kursen
|
|
(Any hasRows, ownCourseTable) <- do -- TODO: only display when non-empty
|
|
let 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
|
|
|
|
validator = def
|
|
& defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)]
|
|
|
|
dbTableWidget validator $ DBTable
|
|
{ dbtIdent = "courseOwnership" :: Text
|
|
, dbtStyle = def
|
|
, dbtSQLQuery = \(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 `mappend` termCell tid
|
|
, sortable (Just "school") (i18nCell MsgCourseSchool) $
|
|
schoolCell <$> view (_dbrOutput . _1 . re _Just)
|
|
<*> view (_dbrOutput . _2 )
|
|
, sortable (Just "course") (i18nCell MsgCourse) $
|
|
courseLinkCell <$> view (_dbrOutput)
|
|
]
|
|
, dbtSorting = Map.fromList
|
|
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) -- consider PatternSynonyms. Drawback: not enclosed with table, since they must be at Top-Level. Maybe make Lenses for InnerJoins then?
|
|
, ( "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 )
|
|
]
|
|
}
|
|
|
|
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
|
|
courseTable <- do
|
|
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)]
|
|
|
|
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 E.^. CourseParticipantRegistration)
|
|
dbTableWidget' validator $ DBTable
|
|
{ dbtIdent = "courseMembership" :: Text
|
|
, dbtSQLQuery = courseData
|
|
, 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
|
|
}
|
|
|
|
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
|
|
submissionTable <- do
|
|
let 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
|
|
|
|
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)]
|
|
|
|
lastSubEdit 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
|
|
|
|
dbTableWidget' validator $ DBTable
|
|
{ dbtIdent = "submissions" :: Text
|
|
, dbtStyle = def
|
|
, dbtSQLQuery = \(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 submission)
|
|
, 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) $
|
|
courseLinkCell <$> view (_dbrOutput . _1)
|
|
, sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
|
|
sheetCell <$> view _1
|
|
<*> view _2
|
|
, sortable (toNothing "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 MsgSubmissionEditUser) $
|
|
maybe mempty timeCell <$> view (_dbrOutput . _4)
|
|
]
|
|
, dbtSorting = 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 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 )
|
|
]
|
|
}
|
|
|
|
-- Tabelle mit allen Abgabegruppen
|
|
--TODO
|
|
-- Tabelle mit allen Tutorials
|
|
tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO
|
|
-- Tabelle mit allen Korrektor-Aufgaben
|
|
correctorTable <- return [whamlet| TOOD: Korrekturen anzeigen |] -- TODO
|
|
-- Tabelle mit allen Klausuren und Noten
|
|
examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO
|
|
defaultLayout $ do
|
|
$(widgetFile "profileData")
|
|
$(widgetFile "dsgvDisclaimer")
|