Adds exceptT based handler validation
parent
9be24a1091
commit
dbf198fe6b
|
@ -3,83 +3,86 @@ module SimpleService.Handler where
|
|||
import Prelude
|
||||
|
||||
import Control.Monad.Aff.Class (liftAff)
|
||||
import Data.Either (Either(..))
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Bifunctor (lmap)
|
||||
import Data.Either (Either)
|
||||
import Data.Foldable (intercalate)
|
||||
import Data.Foreign (renderForeignError)
|
||||
import Data.Foreign (ForeignError, renderForeignError)
|
||||
import Data.Foreign.Class (encode)
|
||||
import Data.Foreign.NullOrUndefined (unNullOrUndefined)
|
||||
import Data.Int (fromString)
|
||||
import Data.List.NonEmpty (toList)
|
||||
import Data.List.Types (NonEmptyList)
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Database.PostgreSQL as PG
|
||||
import Node.Express.Handler (Handler)
|
||||
import Node.Express.Request (getBody, getRouteParam)
|
||||
import Node.Express.Response (end, sendJson, setStatus)
|
||||
import SimpleService.Persistence as P
|
||||
import SimpleService.Validation as V
|
||||
import SimpleService.Types
|
||||
|
||||
getUser :: forall eff. PG.Pool -> Handler (postgreSQL :: PG.POSTGRESQL | eff)
|
||||
getUser pool = getRouteParam "id" >>= case _ of
|
||||
Nothing -> respond 422 { error: "User ID is required" }
|
||||
Just sUserId -> case fromString sUserId of
|
||||
Nothing -> respond 422 { error: "User ID must be an integer: " <> sUserId }
|
||||
Just userId -> liftAff (PG.withConnection pool $ flip P.findUser userId) >>= case _ of
|
||||
Nothing -> respond 404 { error: "User not found with id: " <> sUserId }
|
||||
Just user -> respond 200 (encode user)
|
||||
getUser pool = V.withValidation getUserId \userId ->
|
||||
liftAff (PG.withConnection pool $ flip P.findUser userId) >>= case _ of
|
||||
Nothing -> respond 404 { error: "User not found with id: " <> show userId }
|
||||
Just user -> respond 200 (encode user)
|
||||
|
||||
deleteUser :: forall eff. PG.Pool -> Handler (postgreSQL :: PG.POSTGRESQL | eff)
|
||||
deleteUser pool = getRouteParam "id" >>= case _ of
|
||||
Nothing -> respond 422 { error: "User ID is required" }
|
||||
Just sUserId -> case fromString sUserId of
|
||||
Nothing -> respond 422 { error: "User ID must be an integer: " <> sUserId }
|
||||
Just userId -> do
|
||||
found <- liftAff $ PG.withConnection pool \conn -> PG.withTransaction conn do
|
||||
P.findUser conn userId >>= case _ of
|
||||
Nothing -> pure false
|
||||
Just _ -> do
|
||||
P.deleteUser conn userId
|
||||
pure true
|
||||
if found
|
||||
then respondNoContent 204
|
||||
else respond 404 { error: "User not found with id: " <> sUserId }
|
||||
deleteUser pool = V.withValidation getUserId \userId -> do
|
||||
found <- liftAff $ PG.withConnection pool \conn -> PG.withTransaction conn do
|
||||
P.findUser conn userId >>= case _ of
|
||||
Nothing -> pure false
|
||||
Just _ -> do
|
||||
P.deleteUser conn userId
|
||||
pure true
|
||||
if found
|
||||
then respondNoContent 204
|
||||
else respond 404 { error: "User not found with id: " <> show userId }
|
||||
|
||||
createUser :: forall eff. PG.Pool -> Handler (postgreSQL :: PG.POSTGRESQL | eff)
|
||||
createUser pool = getBody >>= case _ of
|
||||
Left errs -> respond 422 { error: intercalate ", " $ map renderForeignError errs}
|
||||
Right u@(User user) ->
|
||||
if user.id <= 0
|
||||
then respond 422 { error: "User ID must be positive: " <> show user.id}
|
||||
else if user.name == ""
|
||||
then respond 422 { error: "User name must not be empty" }
|
||||
else do
|
||||
liftAff (PG.withConnection pool $ flip P.insertUser u)
|
||||
respondNoContent 201
|
||||
createUser pool = V.withValidation getUser \user@(User _) -> do
|
||||
liftAff (PG.withConnection pool $ flip P.insertUser user)
|
||||
respondNoContent 201
|
||||
where
|
||||
getUser = lift getBody
|
||||
>>= V.except <<< renderForeignErrors
|
||||
>>= V.exceptCond "User ID must be positive" (\(User user) -> user.id > 0)
|
||||
>>= V.exceptCond "User name must not be empty" (\(User user) -> user.name /= "")
|
||||
|
||||
updateUser :: forall eff. PG.Pool -> Handler (postgreSQL :: PG.POSTGRESQL | eff)
|
||||
updateUser pool = getRouteParam "id" >>= case _ of
|
||||
Nothing -> respond 422 { error: "User ID is required" }
|
||||
Just sUserId -> case fromString sUserId of
|
||||
Nothing -> respond 422 { error: "User ID must be positive: " <> sUserId }
|
||||
Just userId -> getBody >>= case _ of
|
||||
Left errs -> respond 422 { error: intercalate ", " $ map renderForeignError errs}
|
||||
Right (UserPatch userPatch) -> case unNullOrUndefined userPatch.name of
|
||||
Nothing -> respondNoContent 204
|
||||
Just userName -> if userName == ""
|
||||
then respond 422 { error: "User name must not be empty" }
|
||||
else do
|
||||
savedUser <- liftAff $ PG.withConnection pool \conn -> PG.withTransaction conn do
|
||||
P.findUser conn userId >>= case _ of
|
||||
Nothing -> pure Nothing
|
||||
Just (User user) -> do
|
||||
let user' = User (user { name = userName })
|
||||
P.updateUser conn user'
|
||||
pure $ Just user'
|
||||
case savedUser of
|
||||
Nothing -> respond 404 { error: "User not found with id: " <> sUserId }
|
||||
Just user -> respond 200 (encode user)
|
||||
updateUser pool = V.withValidation (Tuple <$> getUserId <*> getUserPatch)
|
||||
\(Tuple userId (UserPatch userPatch)) ->
|
||||
case unNullOrUndefined userPatch.name of
|
||||
Nothing -> respondNoContent 204
|
||||
Just uName -> V.withValidation (getUserName uName) \userName -> do
|
||||
savedUser <- liftAff $ PG.withConnection pool \conn -> PG.withTransaction conn do
|
||||
P.findUser conn userId >>= case _ of
|
||||
Nothing -> pure Nothing
|
||||
Just (User user) -> do
|
||||
let user' = User (user { name = userName })
|
||||
P.updateUser conn user'
|
||||
pure $ Just user'
|
||||
case savedUser of
|
||||
Nothing -> respond 404 { error: "User not found with id: " <> show userId }
|
||||
Just user -> respond 200 (encode user)
|
||||
where
|
||||
getUserPatch = lift getBody >>= V.except <<< renderForeignErrors
|
||||
getUserName = V.exceptCond "User name must not be empty" (_ /= "")
|
||||
|
||||
listUsers :: forall eff. PG.Pool -> Handler (postgreSQL :: PG.POSTGRESQL | eff)
|
||||
listUsers pool = liftAff (PG.withConnection pool P.listUsers) >>= encode >>> respond 200
|
||||
|
||||
getUserId :: forall eff. V.Validation eff Int
|
||||
getUserId = lift (getRouteParam "id")
|
||||
>>= V.exceptMaybe "User ID is required"
|
||||
>>= fromString >>> V.exceptMaybe "User ID must be an integer"
|
||||
>>= V.exceptCond "User ID must be positive" (_ > 0)
|
||||
|
||||
renderForeignErrors :: forall a. Either (NonEmptyList ForeignError) a -> Either String a
|
||||
renderForeignErrors = lmap (toList >>> map renderForeignError >>> intercalate ", ")
|
||||
|
||||
respond :: forall eff a. Int -> a -> Handler eff
|
||||
respond status body = do
|
||||
setStatus status
|
||||
|
|
|
@ -0,0 +1,32 @@
|
|||
module SimpleService.Validation
|
||||
(module MoreExports, module SimpleService.Validation) where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Monad.Except (ExceptT, except, runExceptT)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Node.Express.Handler (HandlerM, Handler)
|
||||
import Node.Express.Response (sendJson, setStatus)
|
||||
import Node.Express.Types (EXPRESS)
|
||||
import Control.Monad.Except (except) as MoreExports
|
||||
|
||||
type Validation eff a = ExceptT String (HandlerM (express :: EXPRESS | eff)) a
|
||||
|
||||
exceptMaybe :: forall e m a. Applicative m => e -> Maybe a -> ExceptT e m a
|
||||
exceptMaybe e a = except $ case a of
|
||||
Just x -> Right x
|
||||
Nothing -> Left e
|
||||
|
||||
exceptCond :: forall e m a. Applicative m => e -> (a -> Boolean) -> a -> ExceptT e m a
|
||||
exceptCond e cond a = except $ if cond a then Right a else Left e
|
||||
|
||||
withValidation :: forall eff a.
|
||||
Validation eff a
|
||||
-> (a -> Handler eff)
|
||||
-> Handler eff
|
||||
withValidation action handler = runExceptT action >>= case _ of
|
||||
Left err -> do
|
||||
setStatus 422
|
||||
sendJson {error: err}
|
||||
Right x -> handler x
|
Loading…
Reference in New Issue