diff --git a/src/SimpleService/Handler.purs b/src/SimpleService/Handler.purs index 03fb3f4..4cf34d0 100644 --- a/src/SimpleService/Handler.purs +++ b/src/SimpleService/Handler.purs @@ -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 diff --git a/src/SimpleService/Validation.purs b/src/SimpleService/Validation.purs new file mode 100644 index 0000000..d008347 --- /dev/null +++ b/src/SimpleService/Validation.purs @@ -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