diff --git a/routes b/routes index 835f50270..c1344548d 100644 --- a/routes +++ b/routes @@ -6,6 +6,7 @@ / HomeR GET POST /profile ProfileR GET +/users UsersR GET /term TermShowR GET /term/edit TermEditR GET POST diff --git a/src/Application.hs b/src/Application.hs index 4b558617d..33a3fd07b 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 68a196b09..4af75fead 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs new file mode 100644 index 000000000..4b7fb55ad --- /dev/null +++ b/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") diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 277310908..10127afa0 100644 --- a/src/Handler/Utils.hs +++ b/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}|] + diff --git a/templates/home.hamlet b/templates/home.hamlet index 0d20c2862..2e274b4e1 100644 --- a/templates/home.hamlet +++ b/templates/home.hamlet @@ -48,10 +48,13 @@