diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 4386817..1aa4090 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -67,6 +67,7 @@ type API auths = type Authenticated = HomepageAPI :<|> CommentAPI + :<|> UserAPI serverAuthenticated :: Settings -> AuthResult User @@ -74,6 +75,7 @@ serverAuthenticated :: Settings serverAuthenticated Settings{..} authresult = homepageAPI commentHandler authresult :<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler) authresult + :<|> userAPI userHandler authresult data Settings = Settings { cookieSettings :: CookieSettings @@ -92,27 +94,6 @@ mainServe conf = do (Settings{..},app) <- initialize conf 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 initialize :: Conf -> IO (Settings,Application) diff --git a/src/Aggreact/User.hs b/src/Aggreact/User.hs index e842536..00f44a5 100644 --- a/src/Aggreact/User.hs +++ b/src/Aggreact/User.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -23,8 +24,8 @@ {-# LANGUAGE TupleSections #-} {- | -Module : Aggreact.Store -Description : User Store +Module : Aggreact.User +Description : User Copyright : (c) 2018, Yann Esposito License : ISC 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.Search as Search 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 data NewUser = @@ -228,3 +232,41 @@ checkUserLogin uh loginNick loginPass = do then return (Just user) else 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" diff --git a/src/Database/Store.hs b/src/Database/Store.hs index 3a94efa..4b033a7 100644 --- a/src/Database/Store.hs +++ b/src/Database/Store.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE AllowAmbiguousTypes #-} @@ -59,14 +59,15 @@ import Protolude import Data.Aeson import Data.Data -import Data.String (IsString (..)) -import Data.Time (UTCTime(..)) -import Data.Time.Calendar (Day(..)) -import Data.Time.Clock (secondsToDiffTime) -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import qualified Generics.SOP as SOP -import Servant.Auth.Server (FromJWT,ToJWT) +import Data.String (IsString (..)) +import Data.Time (UTCTime (..)) +import Data.Time.Calendar (Day (..)) +import Data.Time.Clock (secondsToDiffTime) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Generics.SOP as SOP +import Servant.Auth.Server (FromJWT, ToJWT) +import qualified Web.HttpApiData as FormI -- | This is the ID type, it is like @Text@. 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 Text 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 FromJSON Id