user api first pass
This commit is contained in:
parent
bd60cea184
commit
a87f0e928b
3 changed files with 59 additions and 33 deletions
|
@ -67,6 +67,7 @@ type API auths =
|
||||||
type Authenticated =
|
type Authenticated =
|
||||||
HomepageAPI
|
HomepageAPI
|
||||||
:<|> CommentAPI
|
:<|> CommentAPI
|
||||||
|
:<|> UserAPI
|
||||||
|
|
||||||
serverAuthenticated :: Settings
|
serverAuthenticated :: Settings
|
||||||
-> AuthResult User
|
-> AuthResult User
|
||||||
|
@ -74,6 +75,7 @@ serverAuthenticated :: Settings
|
||||||
serverAuthenticated Settings{..} authresult =
|
serverAuthenticated Settings{..} authresult =
|
||||||
homepageAPI commentHandler authresult
|
homepageAPI commentHandler authresult
|
||||||
:<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler) authresult
|
:<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler) authresult
|
||||||
|
:<|> userAPI userHandler authresult
|
||||||
|
|
||||||
data Settings =
|
data Settings =
|
||||||
Settings { cookieSettings :: CookieSettings
|
Settings { cookieSettings :: CookieSettings
|
||||||
|
@ -92,27 +94,6 @@ mainServe conf = do
|
||||||
(Settings{..},app) <- initialize conf
|
(Settings{..},app) <- initialize conf
|
||||||
run (port conf) app
|
run (port conf) app
|
||||||
|
|
||||||
-- -- * User API
|
|
||||||
--
|
|
||||||
-- type UserAPI =
|
|
||||||
-- "users" :> Capture "userid" Id :> Get '[HTML,JSON] User
|
|
||||||
-- :<|> "users" :> Capture "userid" Id :> Delete '[HTML,JSON] User
|
|
||||||
-- :<|> "users" :> Get '[HTML,JSON] [User]
|
|
||||||
-- :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
|
||||||
-- :> PostCreated '[HTML,JSON] User
|
|
||||||
--
|
|
||||||
-- userAPI :: Settings -> Servant.Auth.Server.AuthResult User -> Server UserAPI
|
|
||||||
-- userAPI settings@Settings{..} authResult =
|
|
||||||
-- let muser = case authResult of
|
|
||||||
-- (Servant.Auth.Server.Authenticated user) -> Just user
|
|
||||||
-- _ -> Nothing
|
|
||||||
-- in
|
|
||||||
-- liftIO . readUser userHandler
|
|
||||||
-- :<|> liftIO . deleteUser userHandler
|
|
||||||
-- :<|> liftIO . searchUsers userHandler []
|
|
||||||
-- :<|> liftIO . createUser userHandler
|
|
||||||
|
|
||||||
|
|
||||||
-- * Init & Stop app
|
-- * Init & Stop app
|
||||||
|
|
||||||
initialize :: Conf -> IO (Settings,Application)
|
initialize :: Conf -> IO (Settings,Application)
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
@ -23,8 +24,8 @@
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
{- |
|
{- |
|
||||||
Module : Aggreact.Store
|
Module : Aggreact.User
|
||||||
Description : User Store
|
Description : User
|
||||||
Copyright : (c) 2018, Yann Esposito
|
Copyright : (c) 2018, Yann Esposito
|
||||||
License : ISC
|
License : ISC
|
||||||
Maintainer : yann.esposito@gmail.com
|
Maintainer : yann.esposito@gmail.com
|
||||||
|
@ -61,7 +62,10 @@ import qualified Database.Store.Backend.SQLite as SQL
|
||||||
import qualified Database.Store.CRUD as CRUD
|
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.Auth.Server (FromJWT, ToJWT)
|
import Servant
|
||||||
|
import Servant.Errors as Err
|
||||||
|
import Servant.HTML.Blaze (HTML)
|
||||||
|
import Servant.Auth.Server (AuthResult(..),FromJWT(..),ToJWT(..))
|
||||||
|
|
||||||
-- NewUser
|
-- NewUser
|
||||||
data NewUser =
|
data NewUser =
|
||||||
|
@ -228,3 +232,41 @@ checkUserLogin uh loginNick loginPass = do
|
||||||
then return (Just user)
|
then return (Just user)
|
||||||
else return Nothing
|
else return Nothing
|
||||||
_ -> return Nothing
|
_ -> return Nothing
|
||||||
|
|
||||||
|
-- * User API
|
||||||
|
|
||||||
|
type UserAPI =
|
||||||
|
"users" :> Capture "userid" Id :> Get '[JSON] User
|
||||||
|
:<|> "users" :> Capture "userid" Id :> Delete '[JSON] Bool
|
||||||
|
-- :<|> "users" :> Get '[HTML,JSON] [User]
|
||||||
|
-- :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
||||||
|
-- :> PostCreated '[HTML,JSON] User
|
||||||
|
|
||||||
|
userAPI :: UserHandler
|
||||||
|
-> AuthResult User
|
||||||
|
-> Server UserAPI
|
||||||
|
userAPI userHandler authResult =
|
||||||
|
let muser = case authResult of
|
||||||
|
(Servant.Auth.Server.Authenticated user) -> Just user
|
||||||
|
_ -> Nothing
|
||||||
|
in
|
||||||
|
getUserById userHandler
|
||||||
|
:<|> deleteUserById muser userHandler
|
||||||
|
-- :<|> liftIO . searchUsers userHandler []
|
||||||
|
-- :<|> liftIO . createUser userHandler
|
||||||
|
|
||||||
|
getUserById :: UserHandler -> Id -> Handler User
|
||||||
|
getUserById userHandler userId = do
|
||||||
|
mu <- liftIO $ readUser userHandler userId
|
||||||
|
case mu of
|
||||||
|
Nothing -> Err.notFound "user not found"
|
||||||
|
Just u -> return u
|
||||||
|
|
||||||
|
deleteUserById :: Maybe User -- ^ Logged User
|
||||||
|
-> UserHandler
|
||||||
|
-> Id -- ^ User id to delete
|
||||||
|
-> Handler Bool
|
||||||
|
deleteUserById Nothing _ _ = unauthorized "Only admins can delete users"
|
||||||
|
deleteUserById (Just u) userHandler userId
|
||||||
|
| role (val u) == Admin = liftIO $ deleteUser userHandler userId
|
||||||
|
| otherwise = forbidden "Only admins can delete users"
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
@ -59,14 +59,15 @@ import Protolude
|
||||||
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Data
|
import Data.Data
|
||||||
import Data.String (IsString (..))
|
import Data.String (IsString (..))
|
||||||
import Data.Time (UTCTime(..))
|
import Data.Time (UTCTime (..))
|
||||||
import Data.Time.Calendar (Day(..))
|
import Data.Time.Calendar (Day (..))
|
||||||
import Data.Time.Clock (secondsToDiffTime)
|
import Data.Time.Clock (secondsToDiffTime)
|
||||||
import Data.UUID (UUID)
|
import Data.UUID (UUID)
|
||||||
import qualified Data.UUID as UUID
|
import qualified Data.UUID as UUID
|
||||||
import qualified Generics.SOP as SOP
|
import qualified Generics.SOP as SOP
|
||||||
import Servant.Auth.Server (FromJWT,ToJWT)
|
import Servant.Auth.Server (FromJWT, ToJWT)
|
||||||
|
import qualified Web.HttpApiData as FormI
|
||||||
|
|
||||||
-- | This is the ID type, it is like @Text@.
|
-- | This is the ID type, it is like @Text@.
|
||||||
instance StringConv UUID [Char] where strConv l = strConv l . UUID.toString
|
instance StringConv UUID [Char] where strConv l = strConv l . UUID.toString
|
||||||
|
@ -81,6 +82,8 @@ newtype Id = Id UUID deriving (Eq,Ord,Show,Generic,Typeable,Data)
|
||||||
instance StringConv Id [Char] where strConv l (Id uuid) = strConv l uuid
|
instance StringConv Id [Char] where strConv l (Id uuid) = strConv l uuid
|
||||||
instance StringConv Id Text where strConv l (Id uuid) = strConv l uuid
|
instance StringConv Id Text where strConv l (Id uuid) = strConv l uuid
|
||||||
instance StringConv Id UUID where strConv l (Id uuid) = strConv l uuid
|
instance StringConv Id UUID where strConv l (Id uuid) = strConv l uuid
|
||||||
|
instance FormI.FromHttpApiData Id where
|
||||||
|
parseUrlPiece = fmap Id . FormI.parseUrlPiece
|
||||||
|
|
||||||
deriving newtype instance ToJSON Id
|
deriving newtype instance ToJSON Id
|
||||||
deriving newtype instance FromJSON Id
|
deriving newtype instance FromJSON Id
|
||||||
|
|
Loading…
Reference in a new issue