User Overview page added, no user-editing yet

routes

@@ -6,6 +6,7 @@
 
 /        HomeR    GET POST
 /profile ProfileR GET
+/users   UsersR   GET
 
 /term                       TermShowR         GET 
 /term/edit                  TermEditR         GET POST

src/Application.hs

@@ -42,6 +42,7 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
 import Handler.Common
 import Handler.Home
 import Handler.Profile
+import Handler.Users
 import Handler.Term
 import Handler.Course
 import Handler.Sheet

src/Foundation.hs

@@ -178,6 +178,7 @@ instance Yesod UniWorX where
     makeLogger = return . appLogger
 
 isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult
+isAuthorizedDB UsersR _ = adminAccess Nothing
 isAuthorizedDB (SubmissionR cID)      _ = submissionAccess $ Right cID
 isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
 isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName
@@ -266,6 +267,11 @@ defaultLinks = -- Define the menu items of the header.
       , menuItemRoute = CourseListR
       , menuItemAccessCallback = return True
       }                    
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Users"
+      , menuItemRoute = UsersR
+      , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
+      }
   , NavbarRight $ MenuItem
       { menuItemLabel = "Profile"
       , menuItemRoute = ProfileR

src/Handler/Users.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Handler.Users where
+
+import Import
+-- import Data.Text
+import Handler.Utils
+
+import Colonnade hiding (fromMaybe)
+import Yesod.Colonnade
+
+-- import qualified Database.Esqueleto as E
+-- import           Database.Esqueleto      ((^.))
+
+
+getUsersR :: Handler Html
+getUsersR = do
+  -- TODO: Esqueleto, combine the two queries into one
+  users <- runDB $
+    (selectList [] [Asc UserDisplayName])
+    >>= (mapM (\usr -> (,,)
+      <$> (pure usr)
+      <*> (selectList [UserAdminUser    ==. (entityKey usr)] [Asc UserAdminSchool])
+      <*> (selectList [UserLecturerUser ==. (entityKey usr)] [Asc UserLecturerSchool])
+    ))
+  schools <- runDB $ 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" $ text2widget.userDisplayName.entityVal.fst3
+        , headed "Admin for Schools"   $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool   .entityVal) $ snd3 u)
+        , headed "Lecturer at Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u)
+        ]
+  defaultLayout $ do
+    setTitle "Comprehensive User List"
+    let userList = encodeHeadedWidgetTable tableDefault colonnadeUsers users
+    $(widgetFile "users")

src/Handler/Utils.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Handler.Utils
   ( module Handler.Utils
@@ -19,6 +20,8 @@ import Handler.Utils.Submission as Handler.Utils
 
 import Text.Blaze (Markup)
 
+import Data.Map (Map)
+import qualified Data.Map as Map
 
 tickmark :: IsString a => a
 tickmark = fromString "✔"
@@ -26,3 +29,11 @@ tickmark = fromString "✔"
 withFragment :: ( Monad m
                 ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
 withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
+
+entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
+entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
+
+text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+                Text -> WidgetT site m ()
+text2widget t = [whamlet|#{t}|]
+

templates/home.hamlet

@@ -48,10 +48,13 @@
         <div .row>
             <div .col-lg-12>
                 <div .page-header>
-                    <h2 #design>Teilweise funktionierende Abschnitte
+                    <h3 #design>Teilweise funktionierende Abschnitte
                                           
                     <ul .list-group>
 
+                      <li .list-group-item>
+                        <a href=@{UsersR}>Benutzer Verwaltung
+
                       <li .list-group-item>
                         <a href=@{TermShowR}>Semester Verwaltung
                         
@@ -59,12 +62,15 @@
                         <a href=@{CourseEditR}>Kurse anlegen
                         editieren und anzeigen
 
-                    <h2 #design>Funktionen zum Testen 
+                       <li .list-group-item>
+                        <a href=@{SubmissionListR}>Dateien hochladen und abrufen  
+                        
+                    <h3 #design>Funktionen zum Testen 
                                           
                     <ul .list-group>
 
                       <li .list-group-item>
-                        Institut einmalig in Datenbank einfügen:
+                        Knopf-Test:
                           <form .form-inline method=post action=@{HomeR} enctype=#{btnEnctype}>
                             ^{btnWdgt}
                         

templates/users.hamlet

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