Cleanup and minor reorg, HTML for Users

src/Aggreact/Comments/Views.hs

@@ -1,24 +1,24 @@
-{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DuplicateRecordFields      #-}
+{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Strict                     #-}
+{-# LANGUAGE Strict                #-}
-{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
 
-{-# LANGUAGE BlockArguments             #-}
+{-# LANGUAGE BlockArguments        #-}
-{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE ExplicitForAll             #-}
+{-# LANGUAGE ExplicitForAll        #-}
-{-# LANGUAGE NamedWildCards             #-}
+{-# LANGUAGE NamedWildCards        #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
-{-# LANGUAGE NumericUnderscores         #-}
+{-# LANGUAGE NumericUnderscores    #-}
-{-# LANGUAGE OverloadedLists            #-}
+{-# LANGUAGE OverloadedLists       #-}
-{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE PartialTypeSignatures      #-}
+{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
 {- |
 Module      : Aggreact.Comments
 Description : Example of a library file.
@@ -38,27 +38,27 @@ module Aggreact.Comments.Views
 where
 
 --------------------------------------------------------------------------------
-import           Protolude                      hiding (get, put)
+import           Protolude                   hiding (get, put)
 
 --------------------------------------------------------------------------------
 import           Aggreact.Comments.Types
-import           Aggreact.Html                  (boilerplate, loginWidget,
+import           Aggreact.Html               (boilerplate, cvt, extlink,
-                                                 urlEncode, cvt, extlink)
+                                              urlEncode)
-import           Aggreact.User                  (NewUser (..), User)
+import           Aggreact.User               (NewUser (..), User, loginWidget)
 
 --------------------------------------------------------------------------------
-import           Data.Aeson                     (ToJSON (..))
+import           Data.Aeson                  (ToJSON (..))
-import           Data.Duration                  (approximativeDuration)
+import           Data.Duration               (approximativeDuration)
-import qualified Data.IxSet.Typed               as IxSet
+import qualified Data.IxSet.Typed            as IxSet
-import           Data.String                    (IsString (..))
+import           Data.String                 (IsString (..))
-import           Data.Time                      (UTCTime, diffUTCTime)
+import           Data.Time                   (UTCTime, diffUTCTime)
-import           Data.Time.Clock.Serialize      ()
+import           Data.Time.Clock.Serialize   ()
-import           Data.Time.Format               ()
+import           Data.Time.Format            ()
-import qualified Data.UUID                      as UUID
+import qualified Data.UUID                   as UUID
-import           Database.Store                 (DefaultMetas (..), Entity (..))
+import           Database.Store              (DefaultMetas (..), Entity (..))
-import           Text.Blaze.Html5               ((!))
+import           Text.Blaze.Html5            ((!))
-import qualified Text.Blaze.Html5               as H
+import qualified Text.Blaze.Html5            as H
-import qualified Text.Blaze.Html5.Attributes    as A
+import qualified Text.Blaze.Html5.Attributes as A
 
 
 -- * Single Comment Page

src/Aggreact/Homepage.hs

@@ -42,9 +42,8 @@ import           Protolude
 import           Aggreact.Comments           (Comment, CommentHandler(..),
                                               Slug (..), displayOneComment)
 import           Aggreact.Css                (genCss)
-import           Aggreact.Html               (boilerplate, loginWidget,
+import           Aggreact.Html               (boilerplate, urlEncode)
-                                              urlEncode)
+import           Aggreact.User               (User,loginWidget)
-import           Aggreact.User               (User)
 import           Clay                        (Css)
 import           Data.String                 (IsString (..))
 import           Data.Time                   (UTCTime, getCurrentTime)

src/Aggreact/Html.hs

@@ -30,7 +30,6 @@ Main datastructures
 module Aggreact.Html
  ( boilerplate
  , urlEncode
- , loginWidget
  , LoginPage(..)
  , cvt
  , extlink
@@ -47,9 +46,6 @@ import qualified Text.Blaze.Html5            as H
 import qualified Text.Blaze.Html5.Attributes as A
 import           Text.Printf
 
-import           Aggreact.User               (NewUser (..), User)
-import           Database.Store              (Entity (..))
-
 container :: H.Html -> H.Html
 container = H.div ! A.class_ "container"
 
@@ -68,10 +64,6 @@ data LoginPage = LoginPage
 instance H.ToMarkup LoginPage where
   toMarkup _ = boilerplate (return ()) loginPage
 
-loginWidget :: Maybe User -> H.Markup
-loginWidget Nothing                = H.a ! A.href "/login" $ H.text "Login"
-loginWidget (Just (Entity _ nu _)) = H.span $ H.text (toS (nick nu))
-
 boilerplate :: H.Markup -> H.Markup -> H.Html
 boilerplate headerHtml innerHtml =
   H.html $ do

src/Aggreact/User.hs

@@ -1,7 +1,8 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DuplicateRecordFields      #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE TypeOperators              #-}
@@ -21,7 +22,6 @@
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE TupleSections              #-}
 
 {- |
 Module      : Aggreact.User
@@ -42,9 +42,13 @@ where
 
 import           Protolude                        hiding (pass)
 
+import           Aggreact.Html                    (boilerplate, cvt, urlEncode)
+
+
 import qualified Crypto.Scrypt                    as Crypt
 import           Data.Aeson                       (FromJSON (..), ToJSON (..))
 import           Data.Data                        (Data (..))
+import qualified Data.UUID                      as UUID
 import           Database.SQLite.Simple           (NamedParam (..),
                                                    SQLData (..))
 import           Database.SQLite.Simple.FromField (FromField (..),
@@ -63,9 +67,13 @@ import qualified Database.Store.CRUD              as CRUD
 import qualified Database.Store.Search            as Search
 import qualified Generics.SOP                     as SOP
 import           Servant
-import           Servant.Errors as Err
+import           Servant.Auth.Server              (AuthResult (..),
-import           Servant.HTML.Blaze (HTML)
+                                                   FromJWT (..), ToJWT (..))
-import           Servant.Auth.Server (AuthResult(..),FromJWT(..),ToJWT(..))
+import           Servant.Errors                   as Err
+import           Servant.HTML.Blaze               (HTML)
+import           Text.Blaze.Html5                 ((!))
+import qualified Text.Blaze.Html5                 as H
+import qualified Text.Blaze.Html5.Attributes      as A
 
 -- NewUser
 data NewUser =
@@ -128,8 +136,8 @@ deriving anyclass instance ToJSON     Role
 
 instance FromField Role where
   fromField f = case fieldData f of
-    SQLText "User" -> return User
+    SQLText "User" -> pure User
-    SQLText "Admin" -> return Admin
+    SQLText "Admin" -> pure Admin
     _ -> returnError ConversionFailed f "need a text containing User or Admin"
 instance ToField    Role where toField = toField . (show :: Role -> Text)
 instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Role ': rest) where
@@ -171,7 +179,7 @@ initDBUsers conf adminUser = do
   (SR (SQL.Paginated admins _ _)) <- searchUsers' dbstore (Filter ["role" := Admin])
   case admins of
     [] -> void $ createUser' dbstore adminUser
-    _  -> return ()
+    _  -> pure ()
   pure dbstore
 
 stopDBUsers' :: DBStore -> IO ()
@@ -229,15 +237,15 @@ checkUserLogin uh loginNick loginPass = do
                                (Crypt.Pass (toS loginPass))
                                (Crypt.EncryptedPass (toS (password (val user))))
       if goodPassword
-        then return (Just user)
+        then pure (Just user)
-        else return Nothing
+        else pure Nothing
-    _      -> return Nothing
+    _      -> pure Nothing
 
 -- * User API
 
 type UserAPI =
-  "users" :> Capture "userid" Id :> Get '[JSON] User
+  "users" :> Capture "userid" Id :> Get '[HTML,JSON] UserPage
-  :<|> "users" :> Capture "userid" Id :> Delete '[JSON] Bool
+  :<|> "users" :> Capture "userid" Id :> Delete '[HTML,JSON] UserDeletedPage
   -- :<|> "users" :> Get '[HTML,JSON] [User]
   -- :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
   --              :> PostCreated '[HTML,JSON] User
@@ -248,25 +256,84 @@ userAPI :: UserHandler
 userAPI userHandler authResult =
   let muser = case authResult of
         (Servant.Auth.Server.Authenticated user) -> Just user
-        _ -> Nothing
+        _                                        -> Nothing
   in
-       getUserById userHandler
+       getUserById muser userHandler
   :<|> deleteUserById muser userHandler
   -- :<|> liftIO . searchUsers userHandler []
   -- :<|> liftIO . createUser userHandler
 
-getUserById :: UserHandler -> Id -> Handler User
+-- GET User
-getUserById userHandler userId = do
+getUserById :: Maybe User -> UserHandler -> Id -> Handler UserPage
+getUserById muser userHandler userId = do
   mu <- liftIO $ readUser userHandler userId
   case mu of
     Nothing -> Err.notFound "user not found"
-    Just u -> return u
+    Just u  -> pure (UserPage u muser)
+
+data UserPage =
+  UserPage
+  { user :: User
+  , muser :: Maybe User
+  }
+
+instance ToJSON UserPage where
+  toJSON = toJSON . user
+
+instance H.ToMarkup UserPage where
+  toMarkup UserPage{..} = boilerplate (loginWidget muser) $ do
+    let n = toS (nick (val user))
+    H.h2 $ do
+      H.a ! A.href ("/users/" <> cvt (urlEncode n)) $ H.text (toS n)
+      showUser user
+
+showUser :: User -> H.Markup
+showUser user = do
+  let cid = UUID.toString (toS (id user))
+      nu = val user
+  H.div $ do
+    H.label "nick"
+    H.text (toS (nick nu))
+  H.div $ do
+    H.label "created"
+    H.text (show (created (metas user)))
+  H.div $ do
+    H.label "id"
+    H.text (toS cid)
+
+-- DELETE User
+data UserDeletedPage =
+  UserDeletedPage
+  { deleted     :: Bool
+  , deletedUser :: User
+  , muser       :: Maybe User
+  }
+
+instance ToJSON UserDeletedPage where
+  toJSON = toJSON . deletedUser
+
+instance H.ToMarkup UserDeletedPage where
+  toMarkup UserDeletedPage{..} = boilerplate (loginWidget muser) $ do
+    let n = toS (nick (val deletedUser))
+    H.h2 $
+      H.text ("User " <> n <> if deleted then " was deleted" else " couldn't be deleted!")
 
 deleteUserById :: Maybe User -- ^ Logged User
                -> UserHandler
                -> Id -- ^ User id to delete
-               -> Handler Bool
+               -> Handler UserDeletedPage
 deleteUserById Nothing _ _ = unauthorized "Only admins can delete users"
 deleteUserById (Just u) userHandler userId
-  | role (val u) == Admin = liftIO $ deleteUser userHandler userId
+  | role (val u) == Admin = do
+      userToDelete <- liftIO $ readUser userHandler userId
+      case userToDelete of
+        Nothing -> notFound "User not found!"
+        Just utd -> UserDeletedPage
+                    <$> liftIO (deleteUser userHandler userId)
+                    <*> pure utd
+                    <*> pure (Just u)
   | otherwise = forbidden "Only admins can delete users"
+
+loginWidget :: Maybe User -> H.Markup
+loginWidget Nothing                = H.a ! A.href "/login" $ H.text "Login"
+loginWidget (Just (Entity _ nu _)) = H.span $ H.text (toS (nick nu))