user data. search.

src/DBOp/CRUDUser.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TypeFamilies          #-}
 
@@ -68,6 +69,15 @@ updateUserGroupingByUsername username grouping = do
     set user [UsersGroupId =. val (entityKey x)]
     where_ (user ^. UsersUsername ==. val username)
 
+qbuilder ::
+     (PersistField a, Esqueleto query expr backend, PersistEntity ent)
+  => expr (Entity ent)
+  -> EntityField ent a
+  -> Maybe a
+  -> expr (Value Bool)
+qbuilder _ _ Nothing           = val True
+qbuilder ent accessor (Just v) = ent ^. accessor ==. val v
+
 selectUsersByConditions ::
      ( PersistUniqueRead backend
      , PersistQueryRead backend
@@ -88,6 +98,57 @@ selectUsersByConditions mgid musername memail = do
          &&. user ^. UsersGroupId ==. group ^. GroupsId)
       orderBy [asc (user ^. UsersUsername)]
       return (user, group ^. GroupsGrouping)
-  where
-    qbuilder _ _ Nothing = (val True)
-    qbuilder user accessor (Just v) = (user ^. accessor ==. val v)
+
+selectUsersBySearchConditions ::
+     ( PersistUniqueRead backend
+     , PersistQueryRead backend
+     , BackendCompatible SqlBackend backend
+     , MonadIO m
+     )
+  => Maybe Text
+  -> Maybe (Key Groups)
+  -> SortBy
+  -> Bool
+  -> ReaderT backend m [(Value Grouping, Entity Users)]
+selectUsersBySearchConditions username groupid orderby ascending = do
+  select $
+    from $ \(user, group) -> do
+      where_
+        (qbuilder group GroupsId groupid
+         &&. qbuilder user UsersUsername username
+         &&. user ^. UsersGroupId ==. group ^. GroupsId)
+      ordering ascending user orderby
+      return (group ^. GroupsGrouping, user)
+
+ordering ::
+     Esqueleto query expr backend
+  => Bool
+  -> expr (Entity Users)
+  -> SortBy
+  -> query ()
+ordering b user Username   = orderBy [(chooseAscension b) (user ^. UsersUsername)]
+ordering b user Registered = orderBy [(chooseAscension b) (user ^. UsersJoinTime)]
+ordering b user PostCount  = orderBy [(chooseAscension b) (user ^. UsersRepliesPosted)]
+
+chooseAscension :: (Esqueleto query expr backend, PersistField a) => Bool -> expr (Value a) -> expr OrderBy
+chooseAscension True e  = asc e
+chooseAscension False e = desc e
+
+selectAllUsers ::
+     ( PersistUniqueRead backend
+     , PersistQueryRead backend
+     , BackendCompatible SqlBackend backend
+     , MonadIO m
+     )
+  => Bool
+  -> ReaderT backend m [(Value Grouping, Entity Users)]
+selectAllUsers ascending = do
+  let op =
+        if ascending
+          then asc
+          else desc
+  select $
+    from $ \(user, group) -> do
+      where_ (user ^. UsersGroupId ==. group ^. GroupsId)
+      orderBy [op (user ^. UsersUsername)]
+      return (group ^. GroupsGrouping, user)

src/Flux/.#User.hs

+iaji@melati.6460:1526569009
\ No newline at end of file

src/Flux/User.hs

@@ -13,6 +13,8 @@ import           Yesod.Auth.Util.PasswordStore
 import           DBOp.CRUDGroup
 import           DBOp.CRUDUser
 
+import Flux.Miscellaneous
+
 unusedUser ::
      ( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
      , PersistQueryRead (YesodPersistBackend (HandlerSite m))
@@ -78,3 +80,21 @@ getUsersByConditions mgid musername memail = do
   userandgroup <-
     liftHandler $ runDB $ selectUsersByConditions mgid musername memail
   return $ map (\(user, Value group) -> (user, group)) userandgroup
+
+getAllUsers ::
+     ( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
+     , PersistQueryRead (YesodPersistBackend (HandlerSite m))
+     , PersistUniqueRead (YesodPersistBackend (HandlerSite m))
+     , YesodPersist (HandlerSite m)
+     , MonadHandler m
+     )
+  => Bool
+  -> m [(Grouping, Entity Users)]
+getAllUsers ascending = do
+  groupandusers <- liftHandler $ runDB $ selectAllUsers ascending
+  return $ map (\(Value a, x) -> (a, x)) groupandusers
+
+searchUserByConditions username groupid orderby ascending = do
+  groupandusers <- liftHandler $ runDB $ selectUsersBySearchConditions username groupid orderby ascending
+  return $ map (\(Value a, x) -> (a, x)) groupandusers
+

src/Foundation.hs

@@ -55,6 +55,7 @@ mkYesodData
     /post/#Int64             PostR               GET
     /post/#Int64/edit        PostEditR           GET POST
     /post/#Int64/report      PostReportR         GET POST
+    /userlist                UserListR           GET POST
   |]
 
 type Form a = Html -> MForm (HandlerFor App) (FormResult a, Widget)
@@ -218,3 +219,14 @@ profileRouteToText :: Route App -> Text
 profileRouteToText ProfileR  = "Common Information"
 profileRouteToText (UserR _) = "Common Information of user"
 profileRouteToText _         = "Not Needed"
+
+data SortBy
+  = Username
+  | Registered
+  | PostCount
+  deriving (Eq, Enum, Bounded)
+
+instance Show SortBy where
+  show Username   = "Username"
+  show Registered = "Registration Date"
+  show PostCount  = "Post Count"

src/Handler/User.hs

@@ -9,6 +9,7 @@ import           Import
 import           Data.Time.LocalTime
 import           Database.Persist.Sql
 
+import           Flux.Miscellaneous
 import           Flux.User
 
 data RegisterForm = RegisterForm
@@ -24,6 +25,33 @@ registerForm =
   <*> areq passwordField "Password" Nothing
   <*> areq emailField "Email" Nothing
 
+data SearchUserForm = SearchUserForm
+  { searchUserFormUsername  :: Maybe Text
+  , searchUserFormGroup     :: Maybe Int64
+  , searchUserFormSortBy    :: SortBy
+  , searchUserFormAscending :: Bool
+  }
+
+searchUserForm :: [Entity Groups] -> Form SearchUserForm
+searchUserForm groups = renderDivs $
+  SearchUserForm
+  <$> aopt textField "Username" Nothing
+  <*> aopt (selectFieldList glist) "Groups" Nothing
+  <*> areq (selectFieldList slist) "Sort By" Nothing
+  <*> areq (selectFieldList alist) "Sort Order" Nothing
+  where
+    glist :: [(Text, Int64)]
+    glist =
+      map
+        (\x ->
+           ( pack . show . groupsGrouping $ entityVal x
+           , fromSqlKey . entityKey $ x))
+        groups
+    slist :: [(Text, SortBy)]
+    slist = map (pack . show &&& id) [minBound .. maxBound]
+    alist :: [(Text, Bool)]
+    alist = [("Ascending", True), ("Descending", False)]
+
 getRegisterR :: Handler Html
 getRegisterR = do
   isNotLoggedIn
@@ -58,3 +86,35 @@ getUserR uid = do
   (ruid, name, group) <- allowedToPost
   user'@(Entity uid' user) <- getUserById $ toSqlKey uid
   profileLayout ruid name group user' $(widgetFile "profile-info")
+
+getUserListR :: Handler Html
+getUserListR = do
+  (uid, name, group) <- allowedToPost
+  let users = [] :: [(Grouping, Entity Users)]
+  ad <- getGroup Administrator
+  mo <- getGroup Moderator
+  me <- getGroup Member
+  (wid, enct) <- generateFormPost $ searchUserForm [ad, mo, me]
+  defaultLayout $ do
+    setTitle "User List"
+    $(widgetFile "user-list")
+
+postUserListR :: Handler Html
+postUserListR = do
+  (uid, name, group) <- allowedToPost
+  ad <- getGroup Administrator
+  mo <- getGroup Moderator
+  me <- getGroup Member
+  ((res, wid), enct) <- runFormPost $ searchUserForm [ad, mo, me]
+  case res of
+    FormSuccess r -> do
+      let (username, groupid, orderby, ascending) =
+            ( searchUserFormUsername r
+            , toSqlKey <$> searchUserFormGroup r
+            , searchUserFormSortBy r
+            , searchUserFormAscending r)
+      users <- searchUserByConditions username groupid orderby ascending
+      defaultLayout $ do
+        setTitle "User List"
+        $(widgetFile "user-list")
+    _ -> error ""

templates/adm.hamlet

@@ -6,7 +6,7 @@
       <li .navigation-item>
         <a .navigation-link [email protected]{AdmR} title="Management"> Management
       <li .navigation-item>
-        <a .navigation-link href="#" title="Users"> Users
+        <a .navigation-link href=@{UserListR} title="Users"> Users
     <ul .navigation-list.float-right>
       <li .navigation-item>
         <a .navigation-link [email protected]{ProfileR}> Profile

templates/def.hamlet

@@ -9,15 +9,15 @@
             <li .navigation-item>
               <a .navigation-link [email protected]{AdmR}> Administration
             <li .navigation-item>
-              <a .navigation-link href="#" title="Users"> Users
+              <a .navigation-link href=@{UserListR} title="Users"> Users
           $of Moderator
             <li .navigation-item>
               <a .navigation-link [email protected]{AdmR}> Administration
             <li .navigation-item>
-              <a .navigation-link href="#" title="Users"> Users
+              <a .navigation-link href=@{UserListR} title="Users"> Users
           $of Member
             <li .navigation-item>
-              <a .navigation-link href="#" title="Users"> Users
+              <a .navigation-link href=@{UserListR} title="Users"> Users
           $of Banned
         
     <ul .navigation-list.float-right>

templates/profile.hamlet

@@ -8,15 +8,15 @@
           <li .navigation-item>
             <a .navigation-link [email protected]{AdmR} title="Management"> Management
           <li .navigation-item>
-            <a .navigation-link href="#" title="Users"> Users
+            <a .navigation-link href=@{UserListR} title="Users"> Users
         $of Moderator
           <li .navigation-item>
             <a .navigation-link [email protected]{AdmR} title="Management"> Management
           <li .navigation-item>
-            <a .navigation-link href="#" title="Users"> Users
+            <a .navigation-link href=@{UserListR} title="Users"> Users
         $of Member
           <li .navigation-item>
-            <a .navigation-link href="#" title="Users"> Users
+            <a .navigation-link href=@{UserListR} title="Users"> Users
         $of Banned
     <ul .navigation-list.float-right>
       <li .navigation-item>

templates/user-list.hamlet

+<form method=post [email protected]{UserListR} enctype=#{enct}>
+  ^{wid}
+  <input .button-primary name=search value=search type=submit>
+
+<table>
+  <thead>
+    <tr>
+      <th> Username
+      <th> Title
+      <th> Posts
+      <th> Registered
+  <tbody>
+    $forall (group, Entity keyuser (Users _ uname email _ joined ts rp)) <- users
+      <tr>
+        <td>
+          <a [email protected]{UserR $ fromSqlKey keyuser}> #{uname}
+        <td> #{show group}
+        <td> #{rp}
+        <td> #{show $ utcToLocalTime timeZone joined}