Adds exceptT based handler validation

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
+getUser pool = V.withValidation getUserId \userId ->
-  Nothing -> respond 422 { error: "User ID is required" }
+  liftAff (PG.withConnection pool $ flip P.findUser userId) >>= case _ of
-  Just sUserId -> case fromString sUserId of
+    Nothing -> respond 404 { error: "User not found with id: " <> show userId }
-    Nothing -> respond 422 { error: "User ID must be an integer: " <> sUserId }
+    Just user -> respond 200 (encode user)
-    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)
 
 deleteUser :: forall eff. PG.Pool -> Handler (postgreSQL :: PG.POSTGRESQL | eff)
-deleteUser pool = getRouteParam "id" >>= case _ of
+deleteUser pool = V.withValidation getUserId \userId -> do
-  Nothing -> respond 422 { error: "User ID is required" }
+  found <- liftAff $ PG.withConnection pool \conn -> PG.withTransaction conn do
-  Just sUserId -> case fromString sUserId of
+    P.findUser conn userId >>= case _ of
-    Nothing -> respond 422 { error: "User ID must be an integer: " <> sUserId }
+      Nothing -> pure false
-    Just userId -> do
+      Just _  -> do
-      found <- liftAff $ PG.withConnection pool \conn -> PG.withTransaction conn do
+        P.deleteUser conn userId
-        P.findUser conn userId >>= case _ of
+        pure true
-          Nothing -> pure false
+  if found
-          Just _  -> do
+    then respondNoContent 204
-            P.deleteUser conn userId
+    else respond 404 { error: "User not found with id: " <> show userId }
-            pure true
-      if found
-        then respondNoContent 204
-        else respond 404 { error: "User not found with id: " <> sUserId }
 
 createUser :: forall eff. PG.Pool -> Handler (postgreSQL :: PG.POSTGRESQL | eff)
-createUser pool = getBody >>= case _ of
+createUser pool = V.withValidation getUser \user@(User _) -> do
-  Left errs -> respond 422 { error: intercalate ", " $ map renderForeignError errs}
+  liftAff (PG.withConnection pool $ flip P.insertUser user)
-  Right u@(User user) ->
+  respondNoContent 201
-    if user.id <= 0
+  where
-      then respond 422 { error: "User ID must be positive: " <> show user.id}
+    getUser = lift getBody
-      else if user.name == ""
+      >>= V.except <<< renderForeignErrors
-        then respond 422 { error: "User name must not be empty" }
+      >>= V.exceptCond "User ID must be positive" (\(User user) -> user.id > 0)
-        else do
+      >>= V.exceptCond "User name must not be empty" (\(User user) -> user.name /= "")
-          liftAff (PG.withConnection pool $ flip P.insertUser u)
-          respondNoContent 201
 
 updateUser :: forall eff. PG.Pool -> Handler (postgreSQL :: PG.POSTGRESQL | eff)
-updateUser pool = getRouteParam "id" >>= case _ of
+updateUser pool = V.withValidation (Tuple <$> getUserId <*> getUserPatch)
-  Nothing -> respond 422 { error: "User ID is required" }
+                                   \(Tuple userId (UserPatch userPatch)) ->
-  Just sUserId -> case fromString sUserId of
+    case unNullOrUndefined userPatch.name of
-    Nothing -> respond 422 { error: "User ID must be positive: " <> sUserId }
+      Nothing -> respondNoContent 204
-    Just userId -> getBody >>= case _ of
+      Just uName -> V.withValidation (getUserName uName) \userName -> do
-      Left errs -> respond 422 { error: intercalate ", " $ map renderForeignError errs}
+        savedUser <- liftAff $ PG.withConnection pool \conn -> PG.withTransaction conn do
-      Right (UserPatch userPatch) -> case unNullOrUndefined userPatch.name of
+          P.findUser conn userId >>= case _ of
-        Nothing -> respondNoContent 204
+            Nothing -> pure Nothing
-        Just userName -> if userName == ""
+            Just (User user) -> do
-          then respond 422 { error: "User name must not be empty" }
+              let user' = User (user { name = userName })
-          else do
+              P.updateUser conn user'
-            savedUser <- liftAff $ PG.withConnection pool \conn -> PG.withTransaction conn do
+              pure $ Just user'
-              P.findUser conn userId >>= case _ of
+        case savedUser of
-                Nothing -> pure Nothing
+          Nothing -> respond 404 { error: "User not found with id: " <> show userId }
-                Just (User user) -> do
+          Just user -> respond 200 (encode user)
-                  let user' = User (user { name = userName })
+  where
-                  P.updateUser conn user'
+    getUserPatch = lift getBody >>= V.except <<< renderForeignErrors
-                  pure $ Just user'
+    getUserName = V.exceptCond "User name must not be empty" (_ /= "")
-            case savedUser of
-              Nothing -> respond 404 { error: "User not found with id: " <> sUserId }
-              Just user -> respond 200 (encode user)
 
 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

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