Cleanup and minor reorg, HTML for Users
This commit is contained in:
parent
a87f0e928b
commit
179a47aeed
4 changed files with 125 additions and 67 deletions
|
@ -42,9 +42,9 @@ import Protolude hiding (get, put)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Aggreact.Comments.Types
|
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 (..))
|
||||||
|
|
|
@ -42,9 +42,8 @@ import Protolude
|
||||||
import Aggreact.Comments (Comment, CommentHandler(..),
|
import Aggreact.Comments (Comment, CommentHandler(..),
|
||||||
Slug (..), displayOneComment)
|
Slug (..), displayOneComment)
|
||||||
import Aggreact.Css (genCss)
|
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 Clay (Css)
|
||||||
import Data.String (IsString (..))
|
import Data.String (IsString (..))
|
||||||
import Data.Time (UTCTime, getCurrentTime)
|
import Data.Time (UTCTime, getCurrentTime)
|
||||||
|
|
|
@ -30,7 +30,6 @@ Main datastructures
|
||||||
module Aggreact.Html
|
module Aggreact.Html
|
||||||
( boilerplate
|
( boilerplate
|
||||||
, urlEncode
|
, urlEncode
|
||||||
, loginWidget
|
|
||||||
, LoginPage(..)
|
, LoginPage(..)
|
||||||
, cvt
|
, cvt
|
||||||
, extlink
|
, extlink
|
||||||
|
@ -47,9 +46,6 @@ import qualified Text.Blaze.Html5 as H
|
||||||
import qualified Text.Blaze.Html5.Attributes as A
|
import qualified Text.Blaze.Html5.Attributes as A
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
|
|
||||||
import Aggreact.User (NewUser (..), User)
|
|
||||||
import Database.Store (Entity (..))
|
|
||||||
|
|
||||||
container :: H.Html -> H.Html
|
container :: H.Html -> H.Html
|
||||||
container = H.div ! A.class_ "container"
|
container = H.div ! A.class_ "container"
|
||||||
|
|
||||||
|
@ -68,10 +64,6 @@ data LoginPage = LoginPage
|
||||||
instance H.ToMarkup LoginPage where
|
instance H.ToMarkup LoginPage where
|
||||||
toMarkup _ = boilerplate (return ()) loginPage
|
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 :: H.Markup -> H.Markup -> H.Html
|
||||||
boilerplate headerHtml innerHtml =
|
boilerplate headerHtml innerHtml =
|
||||||
H.html $ do
|
H.html $ do
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
@ -21,7 +22,6 @@
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
|
|
||||||
{- |
|
{- |
|
||||||
Module : Aggreact.User
|
Module : Aggreact.User
|
||||||
|
@ -42,9 +42,13 @@ where
|
||||||
|
|
||||||
import Protolude hiding (pass)
|
import Protolude hiding (pass)
|
||||||
|
|
||||||
|
import Aggreact.Html (boilerplate, cvt, urlEncode)
|
||||||
|
|
||||||
|
|
||||||
import qualified Crypto.Scrypt as Crypt
|
import qualified Crypto.Scrypt as Crypt
|
||||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||||
import Data.Data (Data (..))
|
import Data.Data (Data (..))
|
||||||
|
import qualified Data.UUID as UUID
|
||||||
import Database.SQLite.Simple (NamedParam (..),
|
import Database.SQLite.Simple (NamedParam (..),
|
||||||
SQLData (..))
|
SQLData (..))
|
||||||
import Database.SQLite.Simple.FromField (FromField (..),
|
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 Database.Store.Search as Search
|
||||||
import qualified Generics.SOP as SOP
|
import qualified Generics.SOP as SOP
|
||||||
import Servant
|
import Servant
|
||||||
|
import Servant.Auth.Server (AuthResult (..),
|
||||||
|
FromJWT (..), ToJWT (..))
|
||||||
import Servant.Errors as Err
|
import Servant.Errors as Err
|
||||||
import Servant.HTML.Blaze (HTML)
|
import Servant.HTML.Blaze (HTML)
|
||||||
import Servant.Auth.Server (AuthResult(..),FromJWT(..),ToJWT(..))
|
import Text.Blaze.Html5 ((!))
|
||||||
|
import qualified Text.Blaze.Html5 as H
|
||||||
|
import qualified Text.Blaze.Html5.Attributes as A
|
||||||
|
|
||||||
-- NewUser
|
-- NewUser
|
||||||
data NewUser =
|
data NewUser =
|
||||||
|
@ -128,8 +136,8 @@ deriving anyclass instance ToJSON Role
|
||||||
|
|
||||||
instance FromField Role where
|
instance FromField Role where
|
||||||
fromField f = case fieldData f of
|
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"
|
_ -> returnError ConversionFailed f "need a text containing User or Admin"
|
||||||
instance ToField Role where toField = toField . (show :: Role -> Text)
|
instance ToField Role where toField = toField . (show :: Role -> Text)
|
||||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Role ': rest) where
|
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Role ': rest) where
|
||||||
|
@ -171,7 +179,7 @@ initDBUsers conf adminUser = do
|
||||||
(SR (SQL.Paginated admins _ _)) <- searchUsers' dbstore (Filter ["role" := Admin])
|
(SR (SQL.Paginated admins _ _)) <- searchUsers' dbstore (Filter ["role" := Admin])
|
||||||
case admins of
|
case admins of
|
||||||
[] -> void $ createUser' dbstore adminUser
|
[] -> void $ createUser' dbstore adminUser
|
||||||
_ -> return ()
|
_ -> pure ()
|
||||||
pure dbstore
|
pure dbstore
|
||||||
|
|
||||||
stopDBUsers' :: DBStore -> IO ()
|
stopDBUsers' :: DBStore -> IO ()
|
||||||
|
@ -229,15 +237,15 @@ checkUserLogin uh loginNick loginPass = do
|
||||||
(Crypt.Pass (toS loginPass))
|
(Crypt.Pass (toS loginPass))
|
||||||
(Crypt.EncryptedPass (toS (password (val user))))
|
(Crypt.EncryptedPass (toS (password (val user))))
|
||||||
if goodPassword
|
if goodPassword
|
||||||
then return (Just user)
|
then pure (Just user)
|
||||||
else return Nothing
|
else pure Nothing
|
||||||
_ -> return Nothing
|
_ -> pure Nothing
|
||||||
|
|
||||||
-- * User API
|
-- * User API
|
||||||
|
|
||||||
type UserAPI =
|
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" :> Get '[HTML,JSON] [User]
|
||||||
-- :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
-- :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
||||||
-- :> PostCreated '[HTML,JSON] User
|
-- :> PostCreated '[HTML,JSON] User
|
||||||
|
@ -250,23 +258,82 @@ userAPI userHandler authResult =
|
||||||
(Servant.Auth.Server.Authenticated user) -> Just user
|
(Servant.Auth.Server.Authenticated user) -> Just user
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
in
|
in
|
||||||
getUserById userHandler
|
getUserById muser userHandler
|
||||||
:<|> deleteUserById muser userHandler
|
:<|> deleteUserById muser userHandler
|
||||||
-- :<|> liftIO . searchUsers userHandler []
|
-- :<|> liftIO . searchUsers userHandler []
|
||||||
-- :<|> liftIO . createUser 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
|
mu <- liftIO $ readUser userHandler userId
|
||||||
case mu of
|
case mu of
|
||||||
Nothing -> Err.notFound "user not found"
|
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
|
deleteUserById :: Maybe User -- ^ Logged User
|
||||||
-> UserHandler
|
-> UserHandler
|
||||||
-> Id -- ^ User id to delete
|
-> Id -- ^ User id to delete
|
||||||
-> Handler Bool
|
-> Handler UserDeletedPage
|
||||||
deleteUserById Nothing _ _ = unauthorized "Only admins can delete users"
|
deleteUserById Nothing _ _ = unauthorized "Only admins can delete users"
|
||||||
deleteUserById (Just u) userHandler userId
|
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"
|
| 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))
|
||||||
|
|
Loading…
Reference in a new issue