administer user. prep. search and display.

Cirkeltrek.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 79d1f04a49c5644f4f9793d1ced51e6072187e4c6a949b5859fc10a4915fa81a
+-- hash: be478473889e1800099c7765403b2d8cd40e42891190aaa39a9ddd3be71daf73
 
 name:           Cirkeltrek
 version:        0.0.0
@@ -24,6 +24,7 @@ library
       Flux.Adm.Forum
       Flux.Forum
       Flux.Home
+      Flux.Miscellaneous
       Flux.Post
       Flux.Topic
       Flux.User
@@ -32,6 +33,7 @@ library
       Handler.Adm.Ban
       Handler.Adm.Category
       Handler.Adm.Forum
+      Handler.Adm.User
       Handler.Forum
       Handler.Home
       Handler.Post

src/Application.hs

@@ -31,6 +31,7 @@ import           Handler.Adm
 import           Handler.Adm.Category
 import           Handler.Adm.Forum
 import           Handler.Adm.Ban
+import           Handler.Adm.User
 import           Handler.Forum
 import           Handler.Topic
 import           Handler.Post

src/DBOp/CRUDGroup.hs

@@ -43,3 +43,16 @@ selectGroupByUsername username = do
          &&. user ^. UsersUsername ==. val username)
       limit 1
       return (user ^. UsersId, group ^. GroupsId, group ^. GroupsGrouping)
+
+selectAllGroups ::
+     ( PersistUniqueRead backend
+     , PersistQueryRead backend
+     , BackendCompatible SqlBackend backend
+     , MonadIO m
+     )
+  => ReaderT backend m [Entity Groups]
+selectAllGroups = do
+  select $
+    from $ \group -> do
+      orderBy [asc (group ^. GroupsGrouping)]
+      return group

src/DBOp/CRUDUser.hs

@@ -67,3 +67,17 @@ updateUserGroupingByUsername username grouping = do
   update $ \user -> do
     set user [UsersGroupId =. val (entityKey x)]
     where_ (user ^. UsersUsername ==. val username)
+
+selectUsersByConditions mgid musername memail = do
+  select $
+    from $ \(user, group) -> do
+      where_
+        (    qbuilder user UsersGroupId mgid
+         &&. qbuilder user UsersUsername musername
+         &&. qbuilder user UsersEmail memail
+         &&. 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)

src/Flux/Miscellaneous.hs

+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+module Flux.Miscellaneous where
+
+import Import
+
+import DBOp.CRUDGroup
+
+getAllGroups ::
+     ( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
+     , PersistQueryRead (YesodPersistBackend (HandlerSite m))
+     , PersistUniqueRead (YesodPersistBackend (HandlerSite m))
+     , YesodPersist (HandlerSite m)
+     , MonadHandler m
+     )
+  => m [Entity Groups]
+getAllGroups = liftHandler $ runDB $ selectAllGroups

src/Flux/User.hs

@@ -7,6 +7,7 @@ module Flux.User where
 
 import           Import
 
+import           Database.Esqueleto
 import           Yesod.Auth.Util.PasswordStore
 
 import           DBOp.CRUDGroup
@@ -26,7 +27,7 @@ unusedUser username email = do
   users <- liftHandler $ runDB $ selectUserByUsernameOrEmail username email
   case users of
     [] -> return ()
-    _ -> invalidArgs ["Username and/or email has been used."]
+    _  -> invalidArgs ["Username and/or email has been used."]
 
 getUserById ::
      ( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
@@ -40,7 +41,7 @@ getUserById ::
 getUserById uid = do
   users <- liftHandler $ runDB $ selectUserById uid
   case users of
-    [] -> notFound
+    []  -> notFound
     x:_ -> return x
 
 registerUser ::
@@ -72,3 +73,8 @@ registerUser username password email = do
           (Just $ decodeUtf8 password')
           email
           now
+
+getUsersByConditions mgid musername memail = do
+  userandgroup <-
+    liftHandler $ runDB $ selectUsersByConditions mgid musername memail
+  return $ map (\(user, Value group) -> (user, group)) userandgroup

src/Foundation.hs

@@ -44,6 +44,7 @@ mkYesodData
     /admin/forum         AdmForumR      GET POST
     /admin/ban           AdmBanR        GET POST
     /admin/ban/options   AdmBanOptionsR POST
+    /admin/user          AdmUserR       GET POST
     /forum/#Int64        ForumR         GET POST
     /forum/#Int64/#Int64 ForumPageR     GET
     /topic/#Int64        TopicR         GET POST
@@ -190,6 +191,8 @@ adminRouteToText AdmBanR        = "Manage Ban"
 adminRouteToText AdmBanOptionsR = "Ban Options"
 adminRouteToText AdmCategoryR   = "Manage Categories"
 adminRouteToText AdmForumR      = "Manage Forums"
+adminRouteToText AdmUserR       = "Manage User"
+adminRouteToText _              = "Fix Me"
 
 profileLayout ::
      Key Users -> Text -> Grouping -> Entity Users -> Widget -> Handler Html
@@ -208,4 +211,6 @@ allowedToEditProfile uid group profileid =
   profileid == uid || group == Administrator || group == Moderator
 
 profileRouteToText :: Route App -> Text
-profileRouteToText ProfileR = "Common Information"
+profileRouteToText ProfileR  = "Common Information"
+profileRouteToText (UserR _) = "Common Information of user"
+profileRouteToText _         = "Not Needed"

src/Handler/Adm/User.hs

+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Handler.Adm.User where
+
+import           Import
+
+import           Database.Esqueleto
+
+import           Flux.Miscellaneous
+import           Flux.User
+
+data SearchUserForm = SearchUserForm
+  { searchUserFormGroupId  :: Maybe Int64
+  , searchUserFormUsername :: Maybe Text
+  , searchUserFormEmail    :: Maybe Text
+  }
+
+groupToHtml :: Grouping -> Html
+groupToHtml = toHtml . show
+
+searchUserForm :: [Entity Groups] -> Form SearchUserForm
+searchUserForm groups =
+  renderDivs $ SearchUserForm
+  <$> aopt (selectFieldList glist) "Groups" Nothing
+  <*> aopt textField "Username" Nothing
+  <*> aopt textField "Email" Nothing
+  where
+    glist :: [(Text, Int64)]
+    glist =
+      map
+        (\x ->
+           ( pack . show . groupsGrouping $ entityVal x
+           , fromSqlKey . entityKey $ x))
+        groups
+
+getAdmUserR :: Handler Html
+getAdmUserR = do
+  (uid, name, group) <- allowedToMod
+  groups <- getAllGroups
+  (wid, enct) <- generateFormPost $ searchUserForm groups
+  let users = []
+  adminLayout uid name group $ do
+    setTitle "Manage Users"
+    $(widgetFile "adm-user")
+
+postAdmUserR :: Handler Html
+postAdmUserR = do
+  (uid, name, group) <- allowedToMod
+  groups <- getAllGroups
+  ((res, wid), enct) <- runFormPost $ searchUserForm groups
+  let (mgid, musername, memail) =
+        case res of
+          FormSuccess r ->
+            ( toSqlKey <$> searchUserFormGroupId r
+            , searchUserFormUsername r
+            , searchUserFormEmail r)
+          _ -> (Nothing, Nothing, Nothing)
+  users <- getUsersByConditions mgid musername memail
+  adminLayout uid name group $ do
+    setTitle "Users"
+    $(widgetFile "adm-user")

src/Handler/User.hs

@@ -50,9 +50,8 @@ postRegisterR = do
 
 getProfileR :: Handler Html
 getProfileR = do
-  (ruid, name, group) <- allowedToPost
-  user'@(Entity uid' user) <- getUserById  ruid
-  profileLayout ruid name group user' $(widgetFile "profile-info")
+  (uid, _, _) <- allowedToPost
+  redirect $ UserR $ fromSqlKey uid
 
 getUserR :: Int64 -> Handler Html
 getUserR uid = do

templates/adm-user.hamlet

+<h4> Search User
+<form [email protected]{AdmUserR} method=post enctype=#{enct}>
+  ^{wid}
+  <input .button name=search value=search type=submit>
+
+<h4> Result
+<form action="#" method=post enctype=#{enct}>
+  <table>
+    <thead>
+      <th> Username
+      <th> Email
+      <th> Status
+      <th> Posts
+      <th> Actions
+      <th> Select
+    <tbody>
+      $forall (user, g) <- users
+        <tr>
+          <td>
+            <a [email protected]{UserR $ fromSqlKey $ entityKey user}> #{usersUsername $ entityVal user}
+          <td> #{usersEmail $ entityVal user}
+          <td> #{groupToHtml g}
+          <td> #{usersRepliesPosted $ entityVal user}
+          <td>
+            <a href="#"> Show posts
+          <td>
+            <input name=user-id value=#{fromSqlKey $ entityKey user} type=checkbox>
+  $case group
+    $of Administrator
+      <input .button name=promote value=ban type=submit>
+      <input .button name=promote value=change type=submit>
+    $of Moderator
+      <input .button name=promote value=ban type=submit>
+    $of _

templates/adm.hamlet

@@ -29,7 +29,7 @@
         <tr>
           <td> <a [email protected]{AdmR}> Index
         <tr>
-          <td> <a href="#"}> Users
+          <td> <a href=@{AdmUserR}> Users
         <tr>
           <td> <a [email protected]{AdmBanR}> Bans
         <tr>

templates/def.hamlet

@@ -8,7 +8,7 @@
           $of Administrator
             <li .navigation-item>
               <a .navigation-link [email protected]{AdmR}> Administration
-          $of Administrator
+          $of Moderator
             <li .navigation-item>
               <a .navigation-link [email protected]{AdmR}> Administration
           $of Member