Allow for custom exception types, rather than just Text

Web/Scotty.hs

@@ -22,7 +22,7 @@ module Web.Scotty
       -- definition, as they completely replace the current 'Response' body.
     , text, html, file, json, source, raw
       -- ** Exceptions
-    , raise, rescue, next
+    , raise, rescue, next, defaultHandler
       -- * Parsing Parameters
     , Param, Trans.Parsable(..), Trans.readEither
       -- * Types
@@ -45,8 +45,8 @@ import Network.Wai.Handler.Warp (Port)
 
 import Web.Scotty.Types (ScottyT, ActionT, Param, RoutePattern, Options, File)
 
-type ScottyM = ScottyT IO
-type ActionM = ActionT () IO -- TODO: something besides () for default error type?
+type ScottyM = ScottyT Text IO
+type ActionM = ActionT Text IO 
 
 -- | Run a scotty application using the warp server.
 scotty :: Port -> ScottyM () -> IO ()
@@ -61,6 +61,10 @@ scottyOpts opts = Trans.scottyOptsT opts id id
 scottyApp :: ScottyM () -> IO Application
 scottyApp = Trans.scottyAppT id id
 
+-- | Global handler for uncaught exceptions. 
+defaultHandler :: (Text -> ActionM ()) -> ScottyM ()
+defaultHandler = Trans.defaultHandler
+
 -- | Use given middleware. Middleware is nested such that the first declared
 -- is the outermost middleware (it has first dibs on the request and last action
 -- on the response). Every middleware is run on each request.

Web/Scotty/Action.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, RankNTypes #-}
 module Web.Scotty.Action
     ( addHeader
     , body
@@ -39,10 +39,10 @@ import qualified Data.ByteString.Lazy.Char8 as BL
 import qualified Data.CaseInsensitive as CI
 import Data.Conduit (Flush, Source)
 import Data.Default (def)
-import Data.Monoid (mconcat, (<>))
+import Data.Monoid (mconcat)
 import qualified Data.Text as ST
 import qualified Data.Text.Lazy as T
-import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
+import Data.Text.Lazy.Encoding (encodeUtf8)
 
 import Network.HTTP.Types
 import Network.Wai
@@ -52,32 +52,30 @@ import Web.Scotty.Util
 
 -- Nothing indicates route failed (due to Next) and pattern matching should continue.
 -- Just indicates a successful response.
-runAction :: Monad m => ActionEnv -> ActionT e m () -> m (Maybe Response)
-runAction env action = do
+runAction :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionEnv -> ActionT e m () -> m (Maybe Response)
+runAction h env action = do
     (e,r) <- flip MS.runStateT def
            $ flip runReaderT env
            $ runErrorT
            $ runAM
-           $ action `catchError` defaultHandler
+           $ action `catchError` (defH h)
     return $ either (const Nothing) (const $ Just $ mkResponse r) e
 
-defaultHandler :: Monad m => ActionError e -> ActionT e m ()
-defaultHandler (Redirect url) = do
+-- | Default error handler for all actions.
+defH :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionError e -> ActionT e m ()
+defH _          (Redirect url)    = do
     status status302
     setHeader "Location" url
-defaultHandler (StringError msg) = do
+defH Nothing    (ActionError e)   = do
     status status500
-    html $ mconcat ["<h1>500 Internal Server Error</h1>", msg]
-defaultHandler Next = next
-defaultHandler (ActionError _) = do
-    status status500
-    html $ mconcat ["<h1>500 Internal Server Error</h1>"
-                   ,"<br/>Uncaught Custom Exception"]
+    html $ mconcat ["<h1>500 Internal Server Error</h1>", showError e]
+defH h@(Just f) (ActionError e)   = f e `catchError` (defH h) -- so handlers can throw exceptions themselves
+defH _          Next              = next
 
 -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions
 -- turn into HTTP 500 responses.
-raise :: Monad m => T.Text -> ActionT e m a
-raise = throwError . StringError
+raise :: (ScottyError e, Monad m) => e -> ActionT e m a
+raise = throwError . ActionError
 
 -- | Abort execution of this action and continue pattern matching routes.
 -- Like an exception, any code after 'next' is not executed.
@@ -93,16 +91,16 @@ raise = throwError . StringError
 -- > get "/foo/:bar" $ do
 -- >   bar <- param "bar"
 -- >   text "not a number"
-next :: Monad m => ActionT e m a
+next :: (ScottyError e, Monad m) => ActionT e m a
 next = throwError Next
 
 -- | Catch an exception thrown by 'raise'.
 --
 -- > raise "just kidding" `rescue` (\msg -> text msg)
-rescue :: Monad m => ActionT e m a -> (T.Text -> ActionT e m a) -> ActionT e m a
-rescue action handler = catchError action $ \e -> case e of
-    StringError msg -> handler msg      -- handle errors
-    other           -> throwError other -- rethrow redirects and nexts
+rescue :: (ScottyError e, Monad m) => ActionT e m a -> (e -> ActionT e m a) -> ActionT e m a
+rescue action h = catchError action $ \e -> case e of
+    ActionError err -> h err            -- handle errors
+    other           -> throwError other -- rethrow internal error types
 
 -- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect
 -- will not be run.
@@ -112,32 +110,32 @@ rescue action handler = catchError action $ \e -> case e of
 -- OR
 --
 -- > redirect "/foo/bar"
-redirect :: Monad m => T.Text -> ActionT e m a
+redirect :: (ScottyError e, Monad m) => T.Text -> ActionT e m a
 redirect = throwError . Redirect
 
 -- | Get the 'Request' object.
-request :: Monad m => ActionT e m Request
+request :: (ScottyError e, Monad m) => ActionT e m Request
 request = ActionT $ liftM getReq ask
 
 -- | Get list of uploaded files.
-files :: Monad m => ActionT e m [File]
+files :: (ScottyError e, Monad m) => ActionT e m [File]
 files = ActionT $ liftM getFiles ask
 
 -- | Get a request header. Header name is case-insensitive.
-reqHeader :: Monad m => T.Text -> ActionT e m (Maybe T.Text)
+reqHeader :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text)
 reqHeader k = do
     hs <- liftM requestHeaders request
     return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs
 
 -- | Get the request body.
-body :: Monad m => ActionT e m BL.ByteString
+body :: (ScottyError e, Monad m) => ActionT e m BL.ByteString
 body = ActionT $ liftM getBody ask
 
 -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful.
-jsonData :: (A.FromJSON a, Monad m) => ActionT e m a
+jsonData :: (A.FromJSON a, ScottyError e, Monad m) => ActionT e m a
 jsonData = do
     b <- body
-    maybe (raise $ "jsonData - no parse: " <> decodeUtf8 b) return $ A.decode b
+    maybe (raise $ stringError $ "jsonData - no parse: " ++ BL.unpack b) return $ A.decode b
 
 -- | Get a parameter. First looks in captures, then form data, then query parameters.
 --
@@ -146,15 +144,15 @@ jsonData = do
 -- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called.
 --   This means captures are somewhat typed, in that a route won't match if a correctly typed
 --   capture cannot be parsed.
-param :: (Parsable a, Monad m) => T.Text -> ActionT e m a
+param :: (Parsable a, ScottyError e, Monad m) => T.Text -> ActionT e m a
 param k = do
     val <- ActionT $ liftM (lookup k . getParams) ask
     case val of
-        Nothing -> raise $ mconcat ["Param: ", k, " not found!"]
+        Nothing -> raise $ stringError $ "Param: " ++ T.unpack k ++ " not found!"
         Just v  -> either (const next) return $ parseParam v
 
 -- | Get all parameters from capture, form and query (in that order).
-params :: Monad m => ActionT e m [Param]
+params :: (ScottyError e, Monad m) => ActionT e m [Param]
 params = ActionT $ liftM getParams ask
 
 -- | Minimum implemention: 'parseParam'
@@ -201,52 +199,52 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of
                 _   -> Left "readEither: ambiguous parse"
 
 -- | Set the HTTP response status. Default is 200.
-status :: Monad m => Status -> ActionT e m ()
+status :: (ScottyError e, Monad m) => Status -> ActionT e m ()
 status = ActionT . MS.modify . setStatus
 
 -- | Add to the response headers. Header names are case-insensitive.
-addHeader :: Monad m => T.Text -> T.Text -> ActionT e m ()
+addHeader :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m ()
 addHeader k v = ActionT . MS.modify $ setHeaderWith $ add (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v)
 
 -- | Set one of the response headers. Will override any previously set value for that header.
 -- Header names are case-insensitive.
-setHeader :: Monad m => T.Text -> T.Text -> ActionT e m ()
+setHeader :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m ()
 setHeader k v = ActionT . MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v)
 
 -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
 -- header to \"text/plain\".
-text :: Monad m => T.Text -> ActionT e m ()
+text :: (ScottyError e, Monad m) => T.Text -> ActionT e m ()
 text t = do
     setHeader "Content-Type" "text/plain"
     raw $ encodeUtf8 t
 
 -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
 -- header to \"text/html\".
-html :: Monad m => T.Text -> ActionT e m ()
+html :: (ScottyError e, Monad m) => T.Text -> ActionT e m ()
 html t = do
     setHeader "Content-Type" "text/html"
     raw $ encodeUtf8 t
 
 -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably
 -- want to do that on your own with 'header'.
-file :: Monad m => FilePath -> ActionT e m ()
+file :: (ScottyError e, Monad m) => FilePath -> ActionT e m ()
 file = ActionT . MS.modify . setContent . ContentFile
 
 -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\"
 -- header to \"application/json\".
-json :: (A.ToJSON a, Monad m) => a -> ActionT e m ()
+json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m ()
 json v = do
     setHeader "Content-Type" "application/json"
     raw $ A.encode v
 
 -- | Set the body of the response to a Source. Doesn't set the
 -- \"Content-Type\" header, so you probably want to do that on your
 -- own with 'header'.
-source :: Monad m => Source IO (Flush Builder) -> ActionT e m ()
+source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m ()
 source = ActionT . MS.modify . setContent . ContentSource
 
 -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the
 -- \"Content-Type\" header, so you probably want to do that on your
 -- own with 'header'.
-raw :: Monad m => BL.ByteString -> ActionT e m ()
+raw :: (ScottyError e, Monad m) => BL.ByteString -> ActionT e m ()
 raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString

Web/Scotty/Helpers.hs

@@ -13,6 +13,7 @@ import qualified Network.Wai as Wai
 
 -- Note that we only import the monad transformer version, to force
 -- us to be generic in the underyling monad. MonadIO constraints are fine.
+import           Web.Scotty.Types
 import           Web.Scotty.Trans
 import           Web.Scotty.Util
 
@@ -21,5 +22,5 @@ import           Web.Scotty.Util
 --
 -- > redirect =<< addQueryString "/foo"
 --
-addQueryString :: Monad m => T.Text -> ActionT e m T.Text
+addQueryString :: (ScottyError e, Monad m) => T.Text -> ActionT e m T.Text
 addQueryString r = liftM ((r <>) . strictByteStringToLazyText . Wai.rawQueryString) request

Web/Scotty/Route.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, RankNTypes #-}
 module Web.Scotty.Route
     ( get, post, put, delete, patch, addroute, matchAny, notFound,
       capture, regex, function, literal
@@ -32,32 +32,32 @@ import Web.Scotty.Types
 import Web.Scotty.Util
 
 -- | get = 'addroute' 'GET'
-get :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m ()
+get :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
 get = addroute GET
 
 -- | post = 'addroute' 'POST'
-post :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m ()
+post :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
 post = addroute POST
 
 -- | put = 'addroute' 'PUT'
-put :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m ()
+put :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
 put = addroute PUT
 
 -- | delete = 'addroute' 'DELETE'
-delete :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m ()
+delete :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
 delete = addroute DELETE
 
 -- | patch = 'addroute' 'PATCH'
-patch :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m ()
+patch :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
 patch = addroute PATCH
 
 -- | Add a route that matches regardless of the HTTP verb.
-matchAny :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m ()
+matchAny :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
 matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound]
 
 -- | Specify an action to take if nothing else is found. Note: this _always_ matches,
 -- so should generally be the last route specified.
-notFound :: MonadIO m => ActionT e m () -> ScottyT m ()
+notFound :: (ScottyError e, MonadIO m) => ActionT e m () -> ScottyT e m ()
 notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> action)
 
 -- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec,
@@ -74,17 +74,17 @@ notFound action = matchAny (Function (\req -> Just [("path", path req)])) (statu
 --
 -- >>> curl http://localhost:3000/foo/something
 -- something
-addroute :: MonadIO m => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT m ()
-addroute method pat action = ScottyT $ MS.modify $ addRoute $ route method pat action
+addroute :: (ScottyError e, MonadIO m) => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT e m ()
+addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (handler s) method pat action) s
 
-route :: MonadIO m => StdMethod -> RoutePattern -> ActionT e m () -> Middleware m
-route method pat action app req =
+route :: (ScottyError e, MonadIO m) => ErrorHandler e m -> StdMethod -> RoutePattern -> ActionT e m () -> Middleware m
+route h method pat action app req =
     let tryNext = app req
     in if Right method == parseMethod (requestMethod req)
        then case matchRoute pat req of
             Just captures -> do
                 env <- mkEnv req captures
-                res <- runAction env action
+                res <- runAction h env action
                 maybe tryNext return res
             Nothing -> tryNext
        else tryNext

Web/Scotty/Trans.hs

@@ -26,7 +26,7 @@ module Web.Scotty.Trans
       -- definition, as they completely replace the current 'Response' body.
     , text, html, file, json, source, raw
       -- ** Exceptions
-    , raise, rescue, next
+    , raise, rescue, next, defaultHandler, ScottyError(..)
       -- * Parsing Parameters
     , Param, Parsable(..), readEither
       -- * Types
@@ -58,7 +58,7 @@ scottyT :: (Monad m, MonadIO n)
         => Port
         -> (forall a. m a -> n a)      -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level.
         -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.
-        -> ScottyT m ()
+        -> ScottyT e m ()
         -> n ()
 scottyT p = scottyOptsT $ def { settings = (settings def) { settingsPort = p } }
 
@@ -68,7 +68,7 @@ scottyOptsT :: (Monad m, MonadIO n)
             => Options
             -> (forall a. m a -> n a)      -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level.
             -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.
-            -> ScottyT m ()
+            -> ScottyT e m ()
             -> n ()
 scottyOptsT opts runM runActionToIO s = do
     when (verbose opts > 0) $
@@ -81,7 +81,7 @@ scottyOptsT opts runM runActionToIO s = do
 scottyAppT :: (Monad m, Monad n)
            => (forall a. m a -> n a)      -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level.
            -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.
-           -> ScottyT m ()
+           -> ScottyT e m ()
            -> n Application
 scottyAppT runM runActionToIO defs = do
     s <- runM $ execStateT (runS defs) def
@@ -92,8 +92,12 @@ notFoundApp :: Monad m => Scotty.Application m
 notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")]
                        $ fromByteString "<h1>404: File Not Found!</h1>"
 
+-- | Global handler for uncaught custom exceptions. 
+defaultHandler :: Monad m => (e -> ActionT e m ()) -> ScottyT e m ()
+defaultHandler f = ScottyT $ modify $ addHandler $ Just f
+
 -- | Use given middleware. Middleware is nested such that the first declared
 -- is the outermost middleware (it has first dibs on the request and last action
 -- on the response). Every middleware is run on each request.
-middleware :: Monad m => Middleware -> ScottyT m ()
+middleware :: Monad m => Middleware -> ScottyT e m ()
 middleware = ScottyT . modify . addMiddleware