From 45563750acf0f27a7418cb6924a8668b49425564 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 10 Sep 2018 14:38:19 +0200 Subject: [PATCH] School Handler Stub; Profile shows own courses with lean dbTable --- routes | 14 +++-- src/Application.hs | 1 + src/Handler/Profile.hs | 43 +++++++++++++-- src/Handler/School.hs | 53 ++++++++++++++++++ src/Handler/Utils/Table/Convenience.hs | 76 +++++++++++++++++++++++++- templates/profileData.hamlet | 5 ++ 6 files changed, 181 insertions(+), 11 deletions(-) create mode 100644 src/Handler/School.hs diff --git a/routes b/routes index d58947041..9604556ad 100644 --- a/routes +++ b/routes @@ -41,13 +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 /course/ CourseListR GET !free diff --git a/src/Application.hs b/src/Application.hs index 93bd35d76..c5b69f55f 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 6033da345..8c6d40a49 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -195,6 +195,38 @@ getProfileDataR = do -- mr <- getMessageRender -- Tabelle mit eigenen Kursen + ownCourseTable <- do + let procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) + procData = id + dbTableWidget' def $ 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.^. CourseId + , course E.^. CourseShorthand + ) + , dbtColonnade = mconcat + [ colsCourseLink' $ _dbrOutput +-- [ colsCourseLink $ (over each _unValue) . o_dbrOutput + ] + , dbtProj = return + , dbtSorting = Map.fromList + [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) + ] + , dbtFilter = Map.fromList + [ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + ] + } + -- Tabelle mit allen Teilnehmer: Kurs (link), Datum courseTable <- do let @@ -223,19 +255,22 @@ getProfileDataR = do { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = courseData , dbtColonnade = mconcat - [ colCourseDescrG + [ colsCourseCompleteG , sortable (Just "time") (i18nCell MsgRegistered) $ do regTime <- view $ _dbrOutput . _2 . _unValue return $ timeCell regTime ] , dbtProj = return , dbtSorting = Map.fromList - [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) + [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) + , ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) , ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration) ] , dbtFilter = Map.fromList - [ - ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand ) + [ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) + , ( "term" , FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) -- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) ] , dbtStyle = def diff --git a/src/Handler/School.hs b/src/Handler/School.hs new file mode 100644 index 000000000..fcd328996 --- /dev/null +++ b/src/Handler/School.hs @@ -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.Convenience +-- +-- -- 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 + diff --git a/src/Handler/Utils/Table/Convenience.hs b/src/Handler/Utils/Table/Convenience.hs index 0aea84073..de0169257 100644 --- a/src/Handler/Utils/Table/Convenience.hs +++ b/src/Handler/Utils/Table/Convenience.hs @@ -13,16 +13,51 @@ import Utils.Lens import Handler.Utils -- import Handler.Utils.Table.Pagination +import qualified Database.Esqueleto as E (Value(..)) + +-- newtype CourseLink = CourseLink (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId +type CourseLink = (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId +type CourseLink' = (E.Value TermId, E.Value SchoolId, E.Value CourseId, E.Value CourseShorthand) -- cannot be in Types due to CourseId + + -- Special cells timeCell :: IsDBTable m a => UTCTime -> DBCell m a timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget --- Just for documentation purposes; inline the code instead: +-- 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 + +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 + +courseLinkCell :: IsDBTable m a => CourseLink -> DBCell m a +courseLinkCell (tid,ssh,_cid,csh) = anchorCell link name + where + link = CourseR tid ssh csh CShowR + name = citext2widget csh + +courseLinkCell' :: IsDBTable m a => CourseLink' -> DBCell m a +courseLinkCell' (E.Value tid, E.Value ssh,_cid,E.Value 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 @@ -33,6 +68,7 @@ courseCell (Course {..}) = anchorCell link name `mappend` desc (Just descr) -> cell [whamlet| ^{modalStatic descr} |] + -- Generic Columns colCourseDescr :: (HasEntity c Course, HasDBRow s r, IsDBTable m a) => @@ -53,5 +89,43 @@ colCourseDescrG = crs <- view course return $ courseCell crs +colsCourseCompleteG :: (HasCourse s, IsDBTable m a) => Colonnade Sortable s (DBCell m a) +colsCourseCompleteG = mconcat + [ sortable (Just "term") (i18nCell MsgTerm) $ do + crs <- view course + return $ termCell $ courseTerm crs + , sortable (Just "school") (i18nCell MsgCourseSchool) $ do + crs <- view course + return $ schoolCell (Just $ courseTerm crs) (courseSchool crs) + , sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view course + return $ courseCell crs + ] + +colsCourseLink :: (IsDBTable m a) => Getting CourseLink s CourseLink -> Colonnade Sortable s (DBCell m a) +colsCourseLink getter = mconcat + [ sortable (Just "term") (i18nCell MsgTerm) $ do + crs <- view getter + return $ termCell $ crs ^. _1 + , sortable (Just "school") (i18nCell MsgCourseSchool) $ do + crs <- view getter + return $ schoolCell (Just $ crs ^. _1) (crs ^. _2) + , sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view getter + return $ courseLinkCell crs + ] + +colsCourseLink' :: (IsDBTable m a) => Getting CourseLink' s CourseLink' -> Colonnade Sortable s (DBCell m a) +colsCourseLink' getter = mconcat + [ sortable (Just "term") (i18nCell MsgTerm) $ do + crs <- view getter + return $ termCell $ crs ^. _1 . _unValue + , sortable (Just "school") (i18nCell MsgCourseSchool) $ do + crs <- view getter + return $ schoolCell (Just $ crs ^. _1 . _unValue) (crs ^. _2 . _unValue) + , sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view getter + return $ courseLinkCell' crs + ] diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 163063188..091daee66 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -8,6 +8,11 @@ TODO: Hier alle Daten in Tabellen anzeigen! +
+

Eigene Kurse +
+ ^{ownCourseTable} +

Kursanmeldungen