{-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes, OverloadedStrings #-} module Clckwrks.Authenticate.Page.ViewUsers where import Clckwrks.Admin.Template (template) import Clckwrks.Monad import Clckwrks.URL (ClckURL(..)) import Clckwrks.Authenticate.Monad () import Clckwrks.ProfileData.URL(ProfileDataURL(..)) import Data.Maybe (maybe) import Data.Foldable (toList) import qualified Data.Text as Text import Happstack.Server (Response, ServerPartT, ok, toResponse) import Happstack.Authenticate.Core (Email(..), GetUsers(..), User(..), UserId(..), Username(..)) import Language.Haskell.HSX.QQ (hsx) import Web.Plugins.Core (Plugin(..), getPluginState) import Web.Routes (showURL) viewUsers :: ClckT ClckURL (ServerPartT IO) Response viewUsers :: ClckT ClckURL (ServerPartT IO) Response viewUsers = do Set User us <- GetUsers -> ClckT ClckURL (ServerPartT IO) (EventResult GetUsers) forall event (m :: * -> *). (QueryEvent event, GetAcidState m (EventState event), Functor m, MonadIO m, MonadState ClckState m) => event -> m (EventResult event) query GetUsers GetUsers String -> () -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML -> ClckT ClckURL (ServerPartT IO) Response forall (m :: * -> *) url headers body. (Happstack m, EmbedAsChild (ClckT url m) headers, EmbedAsChild (ClckT url m) body) => String -> headers -> body -> ClckT url m Response template String "View Users" () (XMLGenT (ClckT ClckURL (ServerPartT IO)) XML -> ClckT ClckURL (ServerPartT IO) Response) -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML -> ClckT ClckURL (ServerPartT IO) Response forall a b. (a -> b) -> a -> b $ [hsx| <div> <h2>Users</h2> <table class="table"> <thead> <tr><th>UserId</th><th>Username</th><th>Email</th></tr> </thead> <tbody> <% mapM mkRow (toList us) %> </tbody> </table> </div> |] where mkRow :: User -> XMLGenT m (XMLType m) mkRow User u = do Text epdf <- URL (XMLGenT m) -> XMLGenT m Text forall (m :: * -> *). MonadRoute m => URL m -> m Text showURL (ProfileDataURL -> ClckURL Profile (UserId -> ProfileDataURL EditProfileDataFor (User -> UserId _userId User u))) [hsx| <tr><td><a href=(Text.unpack epdf)><% show $ _unUserId $ _userId u %></a></td><td><% _unUsername $ _username u %></td><td><% maybe (Text.empty) _unEmail (_email u) %></td></tr> |]