Generic Columns module allowing generic sorting and filtering.

Done for an initial part of course participant table.

build.sh

@@ -1,3 +1,4 @@
 #!/usr/bin/env bash
 
 exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev
+echo Build task completed.

src/Database/Esqueleto/Utils.hs

@@ -5,9 +5,11 @@ module Database.Esqueleto.Utils
   , isInfixOf, hasInfix
   , any, all
   , SqlIn(..)
+  , mkInFilter
   ) where
 
 import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
+import qualified Data.Set as Set
 import qualified Data.Foldable as F
 import qualified Database.Esqueleto as E
 import Database.Esqueleto.Utils.TH
@@ -51,3 +53,22 @@ all :: Foldable f =>
 all test = F.foldr (\needle acc -> acc E.&&. test needle) true
 
 $(sqlInTuples [2..16])
+
+
+-- | generic filter creation for dbTable
+--   Given a lens-like function, make filter
+-- What I thought:
+-- mkFilter :: (Foldable f, E.From query expr backend a)
+--    => (a -> E.SqlExpr (E.Value b))
+--    -> a
+--    -> f b
+--    -> E.SqlExpr (E.Value Bool)
+-- What is inferred:
+mkInFilter :: (PersistField a)
+  =>  (t -> E.SqlExpr (E.Value a))
+  -> t
+  -> Set.Set a
+  -> E.SqlExpr (E.Value Bool)
+mkInFilter lenslike row criterias
+  | Set.null criterias = true
+  | otherwise      = (lenslike row) `E.in_` E.valList (Set.toList criterias)

src/Handler/Course.hs

@@ -8,10 +8,12 @@ import Utils.Lens
 import Utils.Form
 -- import Utils.DB
 import Handler.Utils
-import Handler.Utils.Table.Cells
 import Handler.Utils.Course
 import Handler.Utils.Delete
 import Handler.Utils.Database
+import Handler.Utils.Table.Cells
+import Handler.Utils.Table.Columns
+import Database.Esqueleto.Utils
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -691,6 +693,32 @@ _userTableNote = _dbrOutput . _3
 _userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
 _userTableFeatures = _dbrOutput . _4
 
+_rowUserSemester :: Traversal' UserTableData Int
+_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
+
+
+-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
+queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
+queryUser ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user
+
+-- queryUserName :: UserTableExpr -> E.SqlExpr (E.Value Text)
+-- queryUserName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName
+
+-- queryUserDisplayName :: UserTableExpr -> E.SqlExpr (E.Value Text)
+-- queryUserDisplayName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName
+
+queryUserFeatures :: UserTableExpr -> (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
+queryUserFeatures ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` studyFeatures) = studyFeatures
+
+queryUserSemester :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
+queryUserSemester = aux . queryUserFeatures
+  where aux (features `E.InnerJoin` _degree `E.InnerJoin` _terms)
+          = features E.?. StudyFeaturesSemester
+
+-- Deprecated in favour of newer implementation
+queryUserSemester' :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
+queryUserSemester' ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` (features `E.InnerJoin` _degree `E.InnerJoin` _terms) )
+    = features E.?. StudyFeaturesSemester
 
 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
 colUserComment tid ssh csh =
@@ -703,19 +731,26 @@ colUserComment tid ssh csh =
 
 colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
 colUserSemester = sortable (Just "course-user-semesternr") (i18nCell MsgStudyFeatureAge) $
-    foldMap numCell . preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester)
+    foldMap numCell . preview _rowUserSemester
 
 colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
 colUserField = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $
     foldMap htmlCell . view (_userTableFeatures . _3)
 
+colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserFieldShort = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $
+    foldMap (htmlCell . shortStudyTerms) . view (_userTableFeatures . _3)
+
 colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
 colUserDegree = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $
     foldMap htmlCell . preview (_userTableFeatures . _2 . _Just)
 
+colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserDegreeShort = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $
+    foldMap (htmlCell . shortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
+
 makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
 makeCourseUserTable cid colChoices psValidator =
-  -- return [whamlet|TODO|] -- TODO
   -- -- psValidator has default sorting and filtering
   let dbtIdent     = "courseUsers" :: Text
       dbtStyle     = def
@@ -723,8 +758,18 @@ makeCourseUserTable cid colChoices psValidator =
       dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserId
       dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
       dbtColonnade = colChoices
-      dbtSorting   = Map.fromList [] -- TODO
+      dbtSorting   = Map.fromList
-      dbtFilter    = Map.fromList [] -- TODO
+        [ sortUserName        queryUser
+        , sortUserDisplayName queryUser
+        , sortUserMatriclenr  queryUser
+        , ( "course-user-semesternr", SortColumn queryUserSemester) -- $ -- preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester))
+        -- TODO
+        ]
+      dbtFilter    = Map.fromList
+        [ filterUserName queryUser
+        , ( "course-user-semesternr", FilterColumn $ mkInFilter queryUserSemester)
+        -- TODO
+        ]
       dbtFilterUI  = mempty -- TODO
       dbtParams    = def
   in dbTableWidget' psValidator DBTable{..}
@@ -735,20 +780,20 @@ getCUsersR tid ssh csh = do
   Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
   let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
       colChoices  = mconcat
-        [ colUserParticipantLink tid ssh csh
+        [ colUserNameLink (CourseR tid ssh csh . CUserR)
         , colUserEmail
         , colUserMatriclenr
-        , colUserDegree
+        , colUserDegreeShort
-        , colUserField
+        , colUserFieldShort
         , colUserSemester
         , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
         , colUserComment tid ssh csh
         ]
-      psValidator = def
+      psValidator = def & defaultSortingByName
   tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator
   siteLayout heading $ do
     setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
-    -- TODO: creat hamlet wrapper
+    -- TODO: create hamlet wrapper
     tableWidget
 
 

src/Handler/Utils/Table/Cells.hs

@@ -173,30 +173,3 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
 correctorLoadCell sc =
   i18nCell $ sheetCorrectorLoad sc
 
-
---------------------------------
--- Generic Columns
--- reuse encourages consistency
---
--- if it works out, turn into its own module
--- together with filters and sorters
-
-
--- | Does not work, since we have now show Instance for RenderMesage UniWorX msg
-colUser :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a  (DBCell m c)
-colUser msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
-
-colUserParticipant :: (IsDBTable m c, HasUser a) => Colonnade Sortable a  (DBCell m c)
-colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMembers) cellHasUser
-
-colUserParticipantLink :: (IsDBTable m c, HasEntity a User) => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable a (DBCell m c)
-colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMembers) (cellHasUserLink courseLink)
-  where
-    -- courseLink :: CryptoUUIDUser -> Route UniWorX
-    courseLink = CourseR tid ssh csh . CUserR
-
-colUserMatriclenr ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
-colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
-
-colUserEmail ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
-colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail

src/Handler/Utils/Table/Columns.hs

@@ -0,0 +1,87 @@
+module Handler.Utils.Table.Columns where
+
+import Import
+
+-- import Data.CaseInsensitive (CI)
+-- import qualified Data.CaseInsensitive as CI
+
+-- import Data.Monoid (Any(..))
+-- import Control.Monad.Writer.Class (MonadWriter(..))
+-- import Control.Monad.Trans.Writer (WriterT)
+
+-- import Text.Blaze (ToMarkup(..))
+
+import qualified Database.Esqueleto as E
+import Database.Esqueleto.Utils
+
+import Utils.Lens
+import Handler.Utils
+import Handler.Utils.Table.Cells
+
+
+--------------------------------
+-- Generic Columns
+-- reuse encourages consistency
+--
+-- The constant string for sort/filter keys
+-- should never be mentioned outside of this module
+-- to ensure consistency!
+--
+-- Each section should have the following parts:
+--  * colXYZ  : column definitions plus variants
+--  * sortXYZ  : sorting definitions for these columns
+--  * fltrXYZ  : filter  definitions for these columns
+--  * additional helper, such as default sorting
+
+
+---------------
+-- User names
+
+-- | Generic sort key from msg does not work, since we have no show Instance for RenderMesage UniWorX msg. Dangerous anyway!
+colUserName' :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a  (DBCell m c)
+colUserName' msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
+
+colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a  (DBCell m c)
+colUserName = sortable (Just "user-surname") (i18nCell MsgCourseMembers) cellHasUser
+
+colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
+colUserNameLink userLink = sortable (Just "user-surname") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
+
+-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
+--   TOOD: We want to sort first by UserSurname and then by UserDisplayName, not supportet by dbTable
+--   see also @defaultSortingName@
+sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserName = sortUserSurname
+
+sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserSurname queryUser = ( "user-surname", SortColumn $ compose queryUser (E.^. UserSurname))
+
+sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserDisplayName queryUser = ( "user-display-name", SortColumn $ compose queryUser (E.^. UserDisplayName))
+
+defaultSortingByName :: PSValidator m x -> PSValidator m x
+defaultSortingByName = defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"]
+
+filterUserName :: (IsFilterColumn t (a2 -> Set Text -> E.SqlExpr (E.Value Bool)), IsString a1)
+  => (a2 -> E.SqlExpr (Entity User))
+  -> (a1, FilterColumn t)
+filterUserName queryUser = ( "user-surname", FilterColumn $ mkInFilter queryName )
+  where
+    queryName = compose queryUser (E.^. UserSurname)
+
+
+-------------------
+-- Matriclenumber
+colUserMatriclenr ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
+colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
+
+sortUserMatriclenr :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ compose queryUser (E.^. UserMatrikelnummer))
+
+
+
+----------------
+-- User E-Mail
+colUserEmail ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
+colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail
+

src/Utils.hs

@@ -340,6 +340,14 @@ invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
 invertMap = groupMap . map swap . Map.toList
 
 
+---------------
+-- Functions --
+---------------
+
+-- | Just @flip (.)@ for convenient formatting in some rare cases
+compose :: (a -> b) -> (b -> c) -> (a -> c)
+compose = flip (.)
+
 
 -----------
 -- Maybe --
@@ -473,8 +481,6 @@ throwExceptT :: ( Exception e, MonadThrow m )
              => ExceptT e m a -> m a
 throwExceptT = exceptT throwM return
 
-
-
 ------------
 -- Monads --
 ------------