diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,27 +11,60 @@ ``` haskell module Main where -import qualified Data.Text as T import qualified Network.Wai.Handler.Warp as W +import qualified Network.Wai as W +import Network.HTTP.Types (status500) + import UnliftIO (liftIO) import qualified UnliftIO.Exception as E +import Relude hiding (get, put) +import Relude.Print (putTextLn) +import qualified Data.Text as T + import Webby +-- An example exception handler web-applications can install with webby +appExceptionHandler :: T.Text -> (E.SomeException -> WebbyM appEnv ()) +appExceptionHandler appName = \(exception :: E.SomeException) -> do + setStatus status500 + let msg = appName <> " failed with " <> show exception + putTextLn msg + text msg + main :: IO () main = do - let routes = [ get "/api/a" (text "a") - , get "/api/b" (text "b") - , post "/api/capture/:id" (do idVal :: Int <- getCapture "id" - text $ T.pack $ show idVal - ) + -- Define the API routes handled by your web-application + let routes = [ get "/api/a" (text "a\n") + , get "/api/b" (text "b\n") + , post "/api/capture/:id" + (do idVal :: Int <- getCapture "id" + text $ (T.pack (show idVal) `T.append` "\n") + ) + , get "/api/isOdd/:val" + (do val :: Integer <- getCapture "val" + -- if val is odd return the number else we short-circuit the handler + unless (odd val) finish + text $ show val + ) , get "/api/showEnv" (do env <- getAppEnv - json env + text env ) , get "/aaah" (liftIO $ E.throwString "oops!") ] - webbyApp <- mkWebbyApp (3::Int) routes + -- Set the routes definition and exception handler for your + -- web-application + webbyConfig = setExceptionHandler (appExceptionHandler "MyApp") $ + setRoutes routes $ + defaultWebbyServerConfig + + -- Application environment in this example is a simple Text literal. + -- Usually, application environment would contain database connections + -- etc. + appEnv = "MyEnv" :: T.Text + + webbyApp <- mkWebbyApp appEnv webbyConfig putStrLn "Starting webserver..." W.runEnv 7000 webbyApp ``` @@ -55,9 +88,9 @@ $ curl http://localhost:7000/api/showEnv MyEnv $ curl http://localhost:7000/aaah -Control.Exception.Safe.throwString called with: +MyApp failed with Control.Exception.Safe.throwString called with: oops! Called from: - throwString (examples/Basic.hs:32:42 in main:Main) + throwString (examples/Basic.hs:55:42 in main:Main) ``` diff --git a/src/Webby.hs b/src/Webby.hs --- a/src/Webby.hs +++ b/src/Webby.hs @@ -46,6 +46,12 @@ , getAppEnv , runAppEnv + -- * Webby server configuration + , WebbyServerConfig + , defaultWebbyServerConfig + , setRoutes + , setExceptionHandler + -- * Handler flow control , finish diff --git a/src/Webby/Server.hs b/src/Webby/Server.hs --- a/src/Webby/Server.hs +++ b/src/Webby/Server.hs @@ -1,7 +1,6 @@ module Webby.Server where -import qualified Control.Monad.Logger as Log import qualified Data.Aeson as A import qualified Data.Binary.Builder as Bu import qualified Data.ByteString.Lazy as LB @@ -10,8 +9,6 @@ import qualified Data.Text as T import Network.HTTP.Types.URI (queryToQueryText) import Network.Wai.Internal (getRequestBodyChunk) -import qualified System.Log.FastLogger as FLog -import System.Log.FastLogger.Date (newTimeCache) import qualified UnliftIO.Concurrent as Conc import qualified UnliftIO.Exception as E import Web.HttpApiData @@ -186,23 +183,28 @@ -- defined `appEnv` data type and a list of routes. Routes are matched in the -- given order. If none of the requests match a request, a default 404 response -- is returned. -mkWebbyApp :: appEnv -> [Route appEnv] -> IO Application -mkWebbyApp appEnv routes' = do - lset <- FLog.newStdoutLoggerSet FLog.defaultBufSize - return $ mkApp lset routes' +mkWebbyApp :: env -> WebbyServerConfig env -> IO Application +mkWebbyApp env wsc = + return $ mkApp where - - mkApp lset routes req respond = do - let defaultHandler = errorResponse404 - (cs, handler) = fromMaybe (H.empty, defaultHandler) $ - matchRequest req routes + shortCircuitHandler = + [ -- Handler for FinishThrown exception to guide + -- short-circuiting handlers to early completion + E.Handler (\(ex :: FinishThrown) -> E.throwIO ex) + ] + mkApp req respond = do + let defaultHandler = errorResponse404 + routes = wscRoutes wsc + exceptionHandlerMay = wscExceptionHandler wsc + (cs, handler) = fromMaybe (H.empty, defaultHandler) $ + matchRequest req routes - timeFn <- newTimeCache "%Y-%m-%dT%H:%M:%S " wEnv <- do v <- Conc.newMVar defaultWyResp - return $ WEnv v cs req appEnv lset timeFn - - (do runWebbyM wEnv handler + return $ WEnv v cs req env exceptionHandlerMay + (do runWebbyM wEnv $ handler `E.catches` + (shortCircuitHandler + <> fmap (\(WebbyExceptionHandler e) -> E.Handler e) (maybeToList exceptionHandlerMay)) webbyReply wEnv respond) `E.catches` [ -- Handles Webby' exceptions while parsing parameters -- and request body @@ -217,11 +219,6 @@ -- Handles Webby's finish statement , E.Handler (\(_ :: FinishThrown) -> webbyReply wEnv respond) - - -- Handles any other exception thrown in the handler - , E.Handler (\(ex :: E.SomeException) -> do - Log.runStdoutLoggingT $ Log.logInfoN (show ex) - respond $ responseLBS status500 [] (show ex)) ] webbyReply wEnv respond' = do diff --git a/src/Webby/Types.hs b/src/Webby/Types.hs --- a/src/Webby/Types.hs +++ b/src/Webby/Types.hs @@ -1,12 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} module Webby.Types where -import qualified Control.Monad.Logger as Log import qualified Data.Binary.Builder as Bu import qualified Data.HashMap.Strict as H import qualified Data.Text as T -import System.Log.FastLogger (FormattedTime) -import qualified System.Log.FastLogger as FLog import qualified UnliftIO as U import qualified UnliftIO.Concurrent as Conc @@ -23,15 +21,16 @@ defaultWyResp :: WyResp defaultWyResp = WyResp status200 [] (Right Bu.empty) False +data WebbyExceptionHandler env = forall e . Exception e => WebbyExceptionHandler (e -> (WebbyM env) ()) + -- | The reader environment used by the web framework. It is -- parameterized by the application's environment data type. -data WEnv appEnv = WEnv { weResp :: Conc.MVar WyResp - , weCaptures :: Captures - , weRequest :: Request - , weAppEnv :: appEnv - , weLoggerSet :: FLog.LoggerSet - , weLogTime :: IO FormattedTime - } +data WEnv env = WEnv { weResp :: Conc.MVar WyResp + , weCaptures :: Captures + , weRequest :: Request + , weAppEnv :: env + , weExceptionHandler :: Maybe (WebbyExceptionHandler env) + } -- | The main monad transformer stack used in the web-framework. -- @@ -39,10 +38,10 @@ -- `appEnv` parameter is used by the web application to store an -- (read-only) environment. For e.g. it can be used to store a -- database connection pool. -newtype WebbyM appEnv a = WebbyM - { unWebbyM :: ReaderT (WEnv appEnv) (ResourceT IO) a +newtype WebbyM env a = WebbyM + { unWebbyM :: ReaderT (WEnv env) (ResourceT IO) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadReader (WEnv appEnv)) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader (WEnv env)) instance U.MonadUnliftIO (WebbyM appData) where askUnliftIO = WebbyM $ ReaderT $ @@ -50,15 +49,6 @@ \u -> return $ U.UnliftIO (U.unliftIO u . flip runReaderT w . unWebbyM) -instance Log.MonadLogger (WebbyM env) where - monadLoggerLog loc src lvl msg = do - lset <- asks weLoggerSet - ltime <- asks weLogTime - tstr <- liftIO ltime - let logstr = Log.toLogStr tstr <> - (Log.defaultLogStr loc src lvl $ Log.toLogStr msg) - liftIO $ FLog.pushLogStr lset logstr - runWebbyM :: WEnv w -> WebbyM w a -> IO a runWebbyM env = runResourceT . flip runReaderT env . unWebbyM @@ -96,3 +86,29 @@ displayException (WebbyMissingCapture capName) = T.unpack $ sformat (st % " missing") capName + +data WebbyServerConfig env = WebbyServerConfig + { wscRoutes :: [Route env] + , wscExceptionHandler :: Maybe (WebbyExceptionHandler env) + } + +defaultWebbyServerConfig :: WebbyServerConfig env +defaultWebbyServerConfig = WebbyServerConfig + { wscRoutes = [] + , wscExceptionHandler = Nothing :: Maybe (WebbyExceptionHandler env) + } + +setRoutes :: [Route env] + -> WebbyServerConfig env + -> WebbyServerConfig env +setRoutes routes wsc = wsc { wscRoutes = routes + } + +setExceptionHandler :: Exception e + => (e -> WebbyM env ()) + -> WebbyServerConfig env + -> WebbyServerConfig env +setExceptionHandler exceptionHandler wsc = + WebbyServerConfig { wscRoutes = wscRoutes wsc + , wscExceptionHandler = Just $ WebbyExceptionHandler exceptionHandler + } diff --git a/webby.cabal b/webby.cabal --- a/webby.cabal +++ b/webby.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 65bbfd9f416a142a8a1486ee20e9bf0dc2bb5715c5086ae8f3587951a83de9b8 +-- hash: bfb0c373ed44cff2bdb24832b270b756c77829da9cdacc96529b25985b637c95 name: webby -version: 0.3.1 +version: 0.4.0 synopsis: A super-simple web server framework description: A super-simple, easy to use web server framework inspired by Scotty. The goals of the project are: (1) Be easy to use (2) Allow @@ -32,6 +32,13 @@ default: False library + exposed-modules: + Webby + other-modules: + Prelude + Webby.Server + Webby.Types + Paths_webby hs-source-dirs: src default-extensions: FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections @@ -41,11 +48,9 @@ , base-noprelude >=4.7 && <5 , binary >=0.8 && <0.9 , bytestring >=0.10 && <0.11 - , fast-logger >=2.4 && <2.5 , formatting >=6.3 && <6.4 , http-api-data >=0.3 && <0.5 , http-types >=0.12 && <0.13 - , monad-logger >=0.3 && <0.4 , relude , resourcet >=1.2 && <1.3 , text >=1.2 && <1.3 @@ -54,13 +59,6 @@ , wai >=3.2 && <3.3 if flag(dev) ghc-options: -Wall -Werror - exposed-modules: - Webby - Prelude - other-modules: - Webby.Server - Webby.Types - Paths_webby default-language: Haskell2010 test-suite webby-test @@ -82,11 +80,9 @@ , base-noprelude >=4.7 && <5 , binary >=0.8 && <0.9 , bytestring >=0.10 && <0.11 - , fast-logger >=2.4 && <2.5 , formatting >=6.3 && <6.4 , http-api-data >=0.3 && <0.5 , http-types >=0.12 && <0.13 - , monad-logger >=0.3 && <0.4 , relude , resourcet >=1.2 && <1.3 , tasty