Use dbTable in /users

messages/de.msg

@@ -190,4 +190,8 @@ CourseMembersCount num@Int64: #{display num}
 CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
 
 NoTableContent: Kein Tabelleninhalt
-NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
+NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
+
+AdminFor: Administrator
+LecturerFor: Dozent
+UserListTitle: Komprehensive Benutzerliste

src/Handler/Users.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Handler.Users where
 
@@ -11,39 +12,64 @@ import Import
 -- import Data.Text
 import Handler.Utils
 
-import Colonnade hiding (fromMaybe)
-import Yesod.Colonnade
+import qualified Data.Map as Map
 
--- import qualified Database.Esqueleto as E
--- import           Database.Esqueleto      ((^.))
+import Colonnade hiding (fromMaybe)
+
+import qualified Database.Esqueleto as E
 
 
 getUsersR :: Handler Html
 getUsersR = do
-  -- TODO: Esqueleto, combine the two queries into one
-  (users,schools) <- runDB $ (,)
-    <$> (selectList [] [Asc UserDisplayName]
-        >>= mapM (\usr -> (,,)
-          <$> pure usr
-          <*> selectList [UserAdminUser    ==. entityKey usr] [Asc UserAdminSchool]
-          <*> selectList [UserLecturerUser ==. entityKey usr] [Asc UserLecturerSchool]
-        ))
-    <*> selectList [] [Asc SchoolShorthand]
-  let schoolnames = entities2map schools
-  let getSchoolname = \sid ->
-        case lookup sid schoolnames of
-          Nothing -> "???"
-          (Just school) -> schoolShorthand school
-  let colonnadeUsers = mconcat $
-        [ headed "User" $ \u -> do
-            cID <- encrypt $ entityKey $ fst3 u
-            let name = display $ userDisplayName $ entityVal $ fst3 u
-            [whamlet|<a href=@{AdminUserR cID}>#{name}|]
-        , headed "Admin"   $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool   .entityVal) $ snd3 u)
-        , headed "Lecturer" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u)
+  let
+    colonnadeUsers = dbColonnade . mconcat $
+      [ dbRow
+      , sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
+          (AdminUserR <$> encrypt uid)
+          (toWidget . display $ userDisplayName)
+      , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty
+          { dbCellContents = do
+              schools <- E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
+                E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
+                E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+                E.orderBy [E.asc $ school E.^. SchoolShorthand]
+                return $ school E.^. SchoolShorthand
+              return [whamlet|
+                  <ul>
+                    $forall (E.Value sh) <- schools
+                      <li>#{sh}
+                |]
+          }
+      , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty
+          { dbCellContents = do
+              schools <- E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
+                E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
+                E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
+                E.orderBy [E.asc $ school E.^. SchoolShorthand]
+                return $ school E.^. SchoolShorthand
+              return [whamlet|
+                  <ul>
+                    $forall (E.Value sh) <- schools
+                      <li>#{sh}
+                |]
+          }
+      ]
+    psValidator = def
+      & defaultSorting [("display-name", SortAsc)]
+  
+  userList <- dbTable psValidator $ DBTable
+    { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
+    , dbtColonnade = colonnadeUsers
+    , dbtSorting   = Map.fromList
+        [ ( "display-name"
+          , SortColumn $ \user -> user E.^. UserDisplayName
+          )
         ]
-        -- ++  map (\school -> headed (text2widget $ schoolName $ entityVal school) (\u -> "xx")) schools
+    , dbtFilter    = mempty
+    , dbtStyle     = def
+    , dbtIdent     = "users" :: Text
+    }
+  
   defaultLayout $ do
-    setTitle "Comprehensive User List"
-    let userList = encodeWidgetTable tableSortable colonnadeUsers users
+    setTitleI MsgUserListTitle
     $(widgetFile "users")

src/Handler/Utils/Table/Pagination.hs

@@ -22,7 +22,7 @@ module Handler.Utils.Table.Pagination
   , FilterColumn(..), IsFilterColumn
   , DBRow(..), DBOutput
   , DBStyle(..), DBEmptyStyle(..)
-  , DBTable(..), IsDBTable(..)
+  , DBTable(..), IsDBTable(..), DBCell(..)
   , PaginationSettings(..), PaginationInput(..), piIsUnset
   , PSValidator(..)
   , defaultFilter, defaultSorting
@@ -33,6 +33,7 @@ module Handler.Utils.Table.Pagination
   , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
   , formCell, DBFormResult, getDBFormResult
   , dbRow, dbSelect
+  , (&)
   ) where
 
 import Handler.Utils.Table.Pagination.Types
@@ -146,7 +147,7 @@ instance Default DBStyle where
   def = DBStyle
     { dbsEmptyStyle = def
     , dbsEmptyMessage = MsgNoTableContent
-    , dbsAttrs = [ ("class", "table table-striped table-hover table-sortable") ]
+    , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
     }
 
 data DBTable m x = forall a r r' h i t.

templates/users.hamlet

@@ -1,8 +1,2 @@
 <div .ui.container>
-
-    <p .bg-danger>
-      This page is only for development purposes.
-
-    <h1>
-      User list
-    ^{userList}
+  ^{userList}