Exception Control Flow - Haskell

Continuations.hs

module Continuations where

import Project

getUser :: Request -> (User -> IO Response) -> IO Response
getUser (Request _ _ _ header) cont =
  case lookup "Authorization" header of
    Nothing -> return noToken
    Just token ->
      if is_malformed_token then return (malformedToken token) else
      if is_user_not_found then return (noUser token) else
      cont the_user

getResource :: Request -> (IO Resource -> IO Response) -> IO Response
getResource (Request path _ _ _) cont =
  is_resource_not_found_io >>= \notFound ->
  if notFound then return (noResource path) else
  cont the_resource_io

execute :: String -> User -> Resource -> (() -> IO Response) -> IO Response
execute body usr src@(Resource path) cont =
  is_permitted_io >>= \permitted ->
  if not permitted then return (notPermitted path) else
  is_executed_io >>= \executed ->
  if not executed then return badConnection else
  cont ()

handlePost :: Request -> IO Response
handlePost req@(Request path method body _) =
  if method /= "POST" then return (notAllowed method) else
  if null body then return noBody else
  getUser req (\usr ->
  getResource req (\ioSrc -> ioSrc >>= \src ->
  execute body usr src (\_ ->
  return (success path body))))

Eithers.hs

module Eithers where

import Project
import Control.Monad (join)

failure `implies` fallback = if failure then Left fallback else Right ()
failures `implies'` fallback = (`implies` fallback) <$> failures

getUser :: Request -> Either Response User
getUser (Request _ _ _ header) = do
  token <- maybe (Left noToken) Right $ lookup "Authorization" header
  is_malformed_token `implies` malformedToken token
  is_user_not_found `implies` noUser token
  return the_user

getResource :: () -> Request -> IO (Either Response Resource)
getResource method (Request path _ _ _) = do
  let doResource = (\_ -> the_resource_io) :: () -> IO Resource
  notFound <- is_resource_not_found_io `implies'` noResource path
  doResource `traverse` notFound

execute :: () -> String -> User -> Resource -> IO (Either Response ())
execute method body usr (Resource path) = do
  let doExecuted = (\_ -> is_executed_io) :: () -> IO Bool
  permitted <- (not <$> is_permitted_io) `implies'` notPermitted path
  executed <- doExecuted `traverse` permitted
  return ((not <$> executed) >>= (`implies` badConnection))

handlePost :: Request -> IO Response
handlePost req@(Request path method body _) = either id id <$> result
  where
    tunnel eitherIoEither = join <$> sequenceA eitherIoEither
    chkMth = (method /= "POST") `implies` notAllowed method
    errBdy = null body `implies` noBody >> return body
    errUsr = getUser req
    precon = chkMth >> errBdy >> errUsr >> return ()
    result = do
      errSrc <- tunnel (getResource <$> precon <*> pure req)
      errExe <- tunnel (execute <$> precon <*> errBdy <*> errUsr <*> errSrc)
      return (errExe >> return (success path body))

Project.hs

module Project (module Spec, module Undefined) where

import Spec
import Undefined

Spec.hs

module Spec where

newtype User = User { getToken :: String }
newtype Resource = Resource { getPath :: String }

data Request = Request
  { path :: String
  , method :: String
  , body :: String
  , header :: [(String, String)]
  }

data Response = Response { code :: Int, content :: String } deriving Show

success path body = Response 200 $
  "Successfully posted " ++ body ++ " to " ++ path

noBody = Response 400 $
  "You must provide a non-empty request body"

noToken = Response 401 $
  "You must provide an authorization header field"

malformedToken token = Response 401 $
  "Provided token is malformed: " ++ token

noUser token = Response 401 $
  "No user found for token: " ++ token

notPermitted path = Response 403 $
  "You do not have permission to post on " ++ path

noResource path = Response 404 $
  "No resource found for path: " ++ path

notAllowed method = Response 405 $
  "Method not allowed: " ++ method

badConnection = Response 503
  "Connection error, please try again later"

Test.hs

module Test where

import Project
import qualified Continuations as C
import qualified Eithers as E
import qualified Transformers as T

request1 = Request "path" "POST" "" [("Authorization", "hunter2")]
request2 = Request "path" "POST" "body" [("Nope", "nada")]
request3 = Request "path" "FOO" "body" [("Authorization", "hunter2")]

main :: IO ()
main = do

  putStrLn ""

  putStrLn "Testing Continuations:"
  cResponse1 <- C.handlePost request1
  putStrLn $ "    " ++ show cResponse1
  cResponse2 <- C.handlePost request2
  putStrLn $ "    " ++ show cResponse2
  cResponse3 <- C.handlePost request3
  putStrLn $ "    " ++ show cResponse3
  putStrLn "Passed."

  putStrLn ""

  putStrLn "Testing Eithers:"
  eResponse1 <- E.handlePost request1
  putStrLn $ "    " ++ show eResponse1
  eResponse2 <- E.handlePost request2
  putStrLn $ "    " ++ show eResponse2
  cResponse3 <- E.handlePost request3
  putStrLn $ "    " ++ show cResponse3
  putStrLn "Passed."

  putStrLn ""

  putStrLn "Testing Transformers:"
  tResponse1 <- T.handlePost request1
  putStrLn $ "    " ++ show tResponse1
  tResponse2 <- T.handlePost request2
  putStrLn $ "    " ++ show tResponse2
  cResponse3 <- T.handlePost request3
  putStrLn $ "    " ++ show cResponse3
  putStrLn "Passed."

  putStrLn ""

Transformers.hs

{-# LANGUAGE FlexibleContexts #-}

module Transformers where

import Project
import Control.Monad.Except (MonadError, throwError, runExceptT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Functor.Identity (runIdentity)

failure `implies` fallback = if failure then throwError fallback else return ()

getUser :: MonadError Response m => Request -> m User
getUser (Request _ _ _ header) = do
  token <- maybe (throwError noToken) return $ lookup "Authorization" header
  is_malformed_token `implies` malformedToken token
  is_user_not_found `implies` noUser token
  return the_user

getResource :: (MonadError Response m, MonadIO m) => Request -> m Resource
getResource (Request path _ _ _) = do
  liftIO is_resource_not_found_io >>= (`implies` noResource path)
  liftIO the_resource_io

execute :: (MonadError Response m, MonadIO m)
        => String -> User -> Resource -> m ()
execute body usr (Resource path) = do
  liftIO (not <$> is_permitted_io) >>= (`implies` notPermitted path)
  liftIO (not <$> is_executed_io) >>= (`implies` badConnection)

handlePost :: Request -> IO Response
handlePost req = (either id id <$>) . runExceptT $ do
  (method req /= "POST") `implies` notAllowed (method req)
  (null $ body req) `implies` noBody
  usr <- getUser req
  src <- getResource req
  execute (body req) usr src
  return $ success (path req) (body req)

Undefined.hs

module Undefined where

import Spec

is_malformed_token = undefined :: Bool
is_user_not_found = undefined :: Bool
the_user = undefined :: User
is_resource_not_found_io = undefined :: IO Bool
the_resource_io = undefined :: IO Resource
is_permitted_io = undefined :: IO Bool
is_executed_io = undefined :: IO Bool