School Handler Stub; Profile shows own courses with lean dbTable

routes

@@ -41,13 +41,15 @@
 /profile                    ProfileR          GET POST        !free                             !free
 /profile/data               ProfileDataR      GET             !free                             !free
 
-/terms                      TermShowR         GET             !free
+/term                      TermShowR         GET             !free
-/terms/current              TermCurrentR      GET             !free
+/term/current              TermCurrentR      GET             !free
-/terms/edit                 TermEditR         GET POST
+/term/edit                 TermEditR         GET POST
-/terms/#TermId/edit         TermEditExistR    GET
+/term/#TermId/edit         TermEditExistR    GET
-!/terms/#TermId             TermCourseListR   GET             !free
+!/term/#TermId             TermCourseListR   GET             !free
-!/terms/#TermId/#SchoolId   TermSchoolCourseListR  GET             !free
+!/term/#TermId/#SchoolId   TermSchoolCourseListR  GET             !free
 
+/school                    SchoolListR       GET
+/school/#SchoolId          SchoolShowR       GET
 
 -- For Pattern Synonyms see Foundation
 /course/                    CourseListR       GET             !free

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

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.^. CourseName  )
-                ( "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)
 --               , ( "time"  , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
               ]
           , dbtStyle     = def

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
+

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| <span style="float:right"> ^{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
+  ]
 
 

templates/profileData.hamlet

@@ -8,6 +8,11 @@
 
   <em> TODO: Hier alle Daten in Tabellen anzeigen!
 
+  <div .container>
+    <h2> Eigene Kurse
+    <div .container>
+      ^{ownCourseTable}
+
   <div .container>
     <h2> Kursanmeldungen
     <div .container>