user api first pass

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)

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"

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