diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 03152e5be..f8ffdbd15 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -21,7 +21,7 @@ import Control.Lens import Utils.Lens import Utils.TH import Handler.Utils -import Handler.Utils.Table.Convenience +import Handler.Utils.Table.Cells -- import Data.Time import qualified Data.Text as T diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 2e9bc70d9..32004395a 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -17,11 +17,12 @@ module Handler.Profile where import Import import Handler.Utils -import Handler.Utils.Table.Convenience +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 @@ -150,7 +151,7 @@ postProfileR = do ---------------------------------------- -- TODO: Are these really a good idea? --- If yes: Move to appropriate Place: Utils.Lens and Utils.Table.Convenience +-- 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] @@ -173,11 +174,15 @@ getProfileDataR = do -- mr <- getMessageRender -- Tabelle mit eigenen Kursen - ownCourseTable <- do -- TODO: only display when non-empty + (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 - dbTableWidget' def $ DBTable + + validator = def + & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)] + + dbTableWidget validator $ DBTable { dbtIdent = "courseOwnership" :: Text , dbtStyle = def , dbtSQLQuery = \(course `E.InnerJoin` lecturer) -> do @@ -185,15 +190,20 @@ getProfileDataR = do E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid return ( course E.^. CourseTerm , course E.^. CourseSchool - , course E.^. CourseId , course E.^. CourseShorthand ) + , dbtProj = \x -> return $ x & _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) , dbtColonnade = mconcat [ dbRow - , colsCourseLink' $ _dbrOutput --- [ colsCourseLink $ (over each _unValue) . _dbrOutput -- different types in Tuple prevents "over each" + , 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) ] - , dbtProj = return , 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 ) @@ -208,39 +218,34 @@ getProfileDataR = do -- Tabelle mit allen Teilnehmer: Kurs (link), Datum courseTable <- do - let - withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + 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 - -- should be inlined --- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (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 $ courseCell course + validator = def + & defaultSorting [("time",SortDesc)] --- termCol = sortable (Just "school") (i18nCell MsgCourseSchool) $ do --- Course{..} <- view $ _dbrOutput . _1 . _entityVal --- return $ anchorCell (TermsSchoolCourseListR - --- courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) --- -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value UTCTime)) 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' def $ DBTable + dbTableWidget' validator $ DBTable { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = courseData + , dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue , dbtColonnade = mconcat [ dbRow - , colsCourseDescr $ _dbrOutput . _1 . _entityVal + , 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 . _unValue + regTime <- view $ _dbrOutput . _2 return $ timeCell regTime - ] - , dbtProj = return + ] , dbtSorting = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) @@ -261,14 +266,18 @@ getProfileDataR = 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 - let validator = def -- DUPLICATED CODE: Handler.Corrections + + 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 @@ -279,41 +288,37 @@ getProfileDataR = do E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid let crse = ( course E.^. CourseTerm , course E.^. CourseSchool - , course E.^. CourseId , 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 - , colsCourseLink' $ _dbrOutput . _1 - , sortable (Just "sheet") (i18nCell MsgSheet) $ do - shn <- view $ _dbrOutput . _2 . _unValue - crse <- view $ _dbrOutput . _1 - let tid = crse ^. _1 . _unValue - ssh = crse ^. _2 . _unValue - csh = crse ^. _4 . _unValue - link= CSheetR tid ssh csh shn SShowR - return $ anchorCell link $ display2widget shn - - , sortable (toNothing "submission") (i18nCell MsgSubmission) $ do -- TODO: use submissionCell?! - shn <- view $ _dbrOutput . _2 . _unValue - sid <- view $ _dbrOutput . _3 . _entityKey - crse <- view $ _dbrOutput . _1 - - - let tid = crse ^. _1 . _unValue - ssh = crse ^. _2 . _unValue - csh = crse ^. _4 . _unValue - mkCid = encrypt (sid :: SubmissionId) -- TODO: executed twice - mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR - return $ anchorCellM' mkCid mkRoute display2widget - , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do - regTime <- view $ _dbrOutput . _4 . _unValue - return $ maybe mempty timeCell regTime + , 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) ] - , dbtProj = return , 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 ) diff --git a/src/Handler/School.hs b/src/Handler/School.hs index fcd328996..9952a682d 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -21,7 +21,7 @@ import Import -- import Utils.Lens -- import Utils.TH -- import Handler.Utils --- import Handler.Utils.Table.Convenience +-- import Handler.Utils.Table.Cells -- -- -- import Data.Time -- import qualified Data.Text as T diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index c45c061da..e0cee175b 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -23,7 +23,7 @@ import Import hiding (joinPath) -- import Yesod.Form.Bootstrap3 import Handler.Utils -import Handler.Utils.Table.Convenience +import Handler.Utils.Table.Cells import Network.Mime diff --git a/src/Handler/Utils/Table/Convenience.hs b/src/Handler/Utils/Table/Cells.hs similarity index 60% rename from src/Handler/Utils/Table/Convenience.hs rename to src/Handler/Utils/Table/Cells.hs index 76126c572..0d8c76262 100644 --- a/src/Handler/Utils/Table/Convenience.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -5,25 +5,26 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE FlexibleContexts #-} -module Handler.Utils.Table.Convenience where +module Handler.Utils.Table.Cells where import Import +import Data.Monoid (Any(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) + 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 --- TODO: can we get rid of this type through lenses? -type CourseLink' = (E.Value TermId, E.Value SchoolId, E.Value CourseId, E.Value CourseShorthand) -- cannot be in Types due to CourseId +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 @@ -48,13 +49,7 @@ schoolCell Nothing ssh = anchorCell link name 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 +courseLinkCell (tid,ssh,csh) = anchorCell link name where link = CourseR tid ssh csh CShowR name = citext2widget csh @@ -68,27 +63,27 @@ courseCell (Course {..}) = anchorCell link name `mappend` desc Nothing -> mempty (Just descr) -> cell [whamlet| ^{modalStatic descr} |] -sheetCell :: IsDBTable m a => (CourseLink', E.Value SheetName) -> DBCell m a -sheetCell (crse, E.Value shn) = - let tid = crse ^. _1 . _unValue - ssh = crse ^. _2 . _unValue - csh = crse ^. _4 . _unValue +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', E.Value SheetName, Entity Submission) -> DBCell m a -submissionCell (crse, E.Value shn, submission) = - let tid = crse ^. _1 . _unValue - ssh = crse ^. _2 . _unValue - csh = crse ^. _4 . _unValue - sid = entityKey submission - mkCid = encrypt (sid :: SubmissionId) -- TODO: executed twice -- FIXED here, but not everywhere! +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 --- Generic Columns +{-# DEPRECATED colCourseDescr, colsCourseDescr, colsCourseLink "Bad idea, write columns yourself you lazy bat!" #-} +-- Generic Columns -- We want to avoid these due to the literals occuring colCourseDescr :: IsDBTable m a => Getting Course s Course -> Colonnade Sortable s (DBCell m a) colCourseDescr getter = sortable (Just "course") (i18nCell MsgCourse) $ do @@ -120,18 +115,3 @@ colsCourseLink getter = mconcat 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/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index b051470b5..945492ec7 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 @@ -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, .. } diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 269b3b9bc..ce23adae7 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -15,7 +15,8 @@ import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here --- TODO: is this the right place? + + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) emptyOrIn criterion testSet diff --git a/src/index.md b/src/index.md index bfac4bea2..eb0870ba4 100644 --- a/src/index.md +++ b/src/index.md @@ -75,7 +75,7 @@ Handler.Utils.Table.Pagination Handler.Utils.Table.Pagination.Types : `Sortable`-Headedness for colonnade -Handler.Utils.Table.Convenience +Handler.Utils.Table.Cells : extends dbTable with UniWorX specific functions, such as special courseCell Handler.Utils.Templates diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index a74a762a3..2b8f4246c 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -8,10 +8,11 @@ TODO: Hier alle Daten in Tabellen anzeigen! -
-

Eigene Kurse + $if hasRows
- ^{ownCourseTable} +

Eigene Kurse +
+ ^{ownCourseTable}

Kursanmeldungen