webby 0.4.0 → 1.0.0
raw patch · 7 files changed
+429/−353 lines, 7 filesdep +basedep +unliftio-coredep −base-nopreludedep ~aesondep ~formattingdep ~http-api-datasetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: base, unliftio-core
Dependencies removed: base-noprelude
Dependency ranges changed: aeson, formatting, http-api-data, unliftio
API changes (from Hackage documentation)
- Webby: data WEnv env
- Webby: getAppEnv :: WebbyM appEnv appEnv
- Webby: runAppEnv :: ReaderT appEnv (WebbyM appEnv) a -> WebbyM appEnv a
- Webby: data WebbyM env a
+ Webby: data WebbyM appEnv a
Files
- Setup.hs +1/−0
- src/Prelude.hs +18/−21
- src/Webby.hs +55/−55
- src/Webby/Server.hs +204/−150
- src/Webby/Types.hs +83/−69
- test/Spec.hs +44/−43
- webby.cabal +24/−15
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
src/Prelude.hs view
@@ -1,31 +1,28 @@ module Prelude- ( module Exports-+ ( module Exports, -- | Custom prelude functions- , parseInt- , headMay- ) where--import Control.Monad.Trans.Resource as Exports (ResourceT,- liftResourceT,- runResourceT)-import Network.HTTP.Types as Exports-import Network.Wai as Exports-import Relude as Exports hiding (get, put)---- import Data.Text.Encoding (decodeUtf8With)--- import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Text.Read as TR--import UnliftIO.Exception as Exports (throwIO)+ parseInt,+ headMay,+ )+where +import Control.Monad.Trans.Resource as Exports+ ( ResourceT,+ liftResourceT,+ runResourceT,+ )+import qualified Data.Text.Read as TR -- Text formatting-import Formatting as Exports (format, sformat, (%))-import Formatting.ShortFormatters as Exports (d, sh, st, t)+import Formatting as Exports ((%), format, sformat)+import Formatting.ShortFormatters as Exports (d, sh, st, t)+import Network.HTTP.Types as Exports+import Network.Wai as Exports+import Relude as Exports hiding (get, put)+import UnliftIO.Exception as Exports (throwIO) parseInt :: Integral a => Text -> Maybe a parseInt t' = either (const Nothing) Just $ fmap fst $ TR.decimal t' headMay :: [a] -> Maybe a headMay [] = Nothing-headMay (a:_) = Just a+headMay (a : _) = Just a
src/Webby.hs view
@@ -1,65 +1,65 @@+-- |+-- Module : Webby+-- Description : An easy to use Haskell web-server inspired by Scotty.+-- License : Apache License 2.0+-- Maintainer : aditya.mmy@gmail.com module Webby- ( WebbyM-- -- * Routing and handler functions- , RoutePattern- , Route- , mkRoute- , post- , get- , put- , delete-- -- * Captures- , Captures- , captures- , getCapture+ ( WebbyM, - -- * Request parsing- , flag- , header- , headers- , jsonData- , param- , param_- , params- , request- , requestBodyLBS- , requestBodyLength- , getRequestBodyChunkAction+ -- * Routing and handler functions+ RoutePattern,+ Route,+ mkRoute,+ post,+ get,+ put,+ delete, - -- * Response modification- , setStatus- , addHeader- , setHeader- , blob- , json- , text- , stream+ -- * Captures+ Captures,+ captures,+ getCapture, - -- * Application- , mkWebbyApp- , Application+ -- * Request parsing+ flag,+ header,+ headers,+ jsonData,+ param,+ param_,+ params,+ request,+ requestBodyLBS,+ requestBodyLength,+ getRequestBodyChunkAction, - -- * Application context- , WEnv- , getAppEnv- , runAppEnv+ -- * Response modification+ setStatus,+ addHeader,+ setHeader,+ blob,+ json,+ text,+ stream, - -- * Webby server configuration- , WebbyServerConfig- , defaultWebbyServerConfig- , setRoutes- , setExceptionHandler+ -- * Application+ mkWebbyApp,+ Application, - -- * Handler flow control- , finish+ -- * Webby server configuration+ WebbyServerConfig,+ defaultWebbyServerConfig,+ setRoutes,+ setExceptionHandler, - -- * Exceptions thrown- , WebbyError(..)- ) where+ -- * Handler flow control+ finish, -import Webby.Server-import Webby.Types+ -- * Exceptions thrown+ WebbyError (..),+ )+where -import Network.Wai (Application)+import Network.Wai (Application)+import Webby.Server+import Webby.Types
src/Webby/Server.hs view
@@ -1,177 +1,214 @@ module Webby.Server where --import qualified Data.Aeson as A-import qualified Data.Binary.Builder as Bu-import qualified Data.ByteString.Lazy as LB-import qualified Data.HashMap.Strict as H-import qualified Data.List as L-import qualified Data.Text as T-import Network.HTTP.Types.URI (queryToQueryText)-import Network.Wai.Internal (getRequestBodyChunk)-import qualified UnliftIO.Concurrent as Conc-import qualified UnliftIO.Exception as E-import Web.HttpApiData--import Prelude--import Webby.Types---- | Retrieve the app environment given to the application at--- initialization.-getAppEnv :: WebbyM appEnv appEnv-getAppEnv = asks weAppEnv+import qualified Data.Aeson as A+import qualified Data.Binary.Builder as Bu+import qualified Data.ByteString.Lazy as LB+import qualified Data.HashMap.Strict as H+import qualified Data.List as L+import qualified Data.Text as T+import qualified UnliftIO.Concurrent as Conc+import qualified UnliftIO.Exception as E+import Web.HttpApiData+import Webby.Types+import Prelude -runAppEnv :: ReaderT appEnv (WebbyM appEnv) a -> WebbyM appEnv a-runAppEnv appFn = do- env <- getAppEnv- runReaderT appFn env+asksWEnv :: (WEnv appEnv -> a) -> WebbyM appEnv a+asksWEnv getter = WebbyM $ lift $ asks getter -- | Retrieve all path captures captures :: WebbyM appEnv Captures-captures = asks weCaptures+captures = asksWEnv weCaptures --- | Retrieve a particular capture (TODO: extend?)+-- | Retrieve a particular capture getCapture :: (FromHttpApiData a) => Text -> WebbyM appEnv a getCapture capName = do- cs <- captures- case H.lookup capName cs of- Nothing -> throwIO $ WebbyMissingCapture capName- Just cap -> either (throwIO . WebbyParamParseError capName . show)- return $- parseUrlPiece cap+ cs <- captures+ case H.lookup capName cs of+ Nothing -> throwIO $ WebbyMissingCapture capName+ Just cap ->+ either+ (throwIO . WebbyParamParseError capName . show)+ return+ $ parseUrlPiece cap +-- | Set response status setStatus :: Status -> WebbyM appEnv () setStatus sts = do- wVar <- asks weResp- Conc.modifyMVar_ wVar $ \wr -> return $ wr { wrStatus = sts}+ wVar <- asksWEnv weResp+ Conc.modifyMVar_ wVar $ \wr -> return $ wr {wrStatus = sts} +-- | Append given header to the response headers addHeader :: Header -> WebbyM appEnv () addHeader h = do- wVar <- asks weResp- Conc.modifyMVar_ wVar $- \wr -> do let hs = wrHeaders wr- return $ wr { wrHeaders = hs ++ [h] }+ wVar <- asksWEnv weResp+ Conc.modifyMVar_ wVar $+ \wr -> do+ let hs = wrHeaders wr+ return $ wr {wrHeaders = hs ++ [h]} --- similar to addHeader but replaces a header+-- | Similar to 'addHeader' but replaces a header setHeader :: Header -> WebbyM appEnv () setHeader (k, v) = do- wVar <- asks weResp- Conc.modifyMVar_ wVar $- \wr -> do let hs = wrHeaders wr- ohs = filter ((/= k) . fst) hs- return $ wr { wrHeaders = ohs ++ [(k, v)] }+ wVar <- asksWEnv weResp+ Conc.modifyMVar_ wVar $+ \wr -> do+ let hs = wrHeaders wr+ ohs = filter ((/= k) . fst) hs+ return $ wr {wrHeaders = ohs ++ [(k, v)]} resp400 :: Text -> WebbyM appEnv a resp400 msg = do- setStatus status400- json $ A.object [ "error" A..= A.String msg ]- finish+ setStatus status400+ json $ A.object ["error" A..= A.String msg]+ finish +-- | Get all request query params as a list of key-value pairs params :: WebbyM appEnv [(Text, Text)] params = do- qparams <- (queryToQueryText . queryString) <$> request- return $ fmap (\(q, mv) -> (,) q $ fromMaybe "" mv) qparams+ qparams <- (queryToQueryText . queryString) <$> request+ return $ fmap (\(q, mv) -> (,) q $ fromMaybe "" mv) qparams +-- | Checks if the request contains the given query param flag :: Text -> WebbyM appEnv Bool flag name = (isJust . L.lookup name) <$> params +-- | Gets the given query param's value param :: (FromHttpApiData a) => Text -> WebbyM appEnv (Maybe a)-param p = do ps <- params- case L.lookup p ps of- Nothing -> return Nothing- Just myParam -> either (throwIO . WebbyParamParseError p . show)- (return . Just) $- parseQueryParam myParam+param p = do+ ps <- params+ case L.lookup p ps of+ Nothing -> return Nothing+ Just myParam ->+ either+ (throwIO . WebbyParamParseError p . show)+ (return . Just)+ $ parseQueryParam myParam +-- | Similar to 'param' except that it returns the handler with a '400+-- BadRequest' if the query param is missing. param_ :: (FromHttpApiData a) => Text -> WebbyM appEnv a-param_ p = do myParam <- param p- maybe (resp400 $ T.concat [p, " missing in params"])- return myParam+param_ p = do+ myParam <- param p+ maybe+ (resp400 $ T.concat [p, " missing in params"])+ return+ myParam +-- | Get the given header value header :: HeaderName -> WebbyM appEnv (Maybe Text) header n = do- hs <- requestHeaders <$> request- return $ headMay $ map (decodeUtf8 . snd) $ filter ((n == ) . fst) hs+ hs <- requestHeaders <$> request+ return $ headMay $ map (decodeUtf8 . snd) $ filter ((n ==) . fst) hs +-- | Get the 'Network.Wai.Request' of the handler request :: WebbyM appEnv Request-request = asks weRequest+request = asksWEnv weRequest -- | Returns an action that returns successive chunks of the rquest -- body. It returns an empty bytestring after the request body is -- consumed. getRequestBodyChunkAction :: WebbyM appEnv (WebbyM appEnv ByteString)-getRequestBodyChunkAction = (liftIO . getRequestBodyChunk) <$> asks weRequest+getRequestBodyChunkAction = (liftIO . getRequestBodyChunk) <$> asksWEnv weRequest +-- | Get all the request headers headers :: WebbyM appEnv [Header] headers = requestHeaders <$> request +-- | Returns request body size in bytes requestBodyLength :: WebbyM appEnv (Maybe Int64) requestBodyLength = do- hMay <- header hContentLength- return $ do val <- hMay- parseInt val+ hMay <- header hContentLength+ return $ do+ val <- hMay+ parseInt val +-- | Used to return early from an API handler finish :: WebbyM appEnv a finish = E.throwIO FinishThrown +-- | Send a binary stream in the response body. Also+-- sets @Content-Type@ header to @application/octet-stream@ blob :: ByteString -> WebbyM appEnv () blob bs = do- setHeader (hContentType, "application/octet-stream")- wVar <- asks weResp- Conc.modifyMVar_ wVar $- \wr -> return $ wr { wrRespData = Right $ Bu.fromByteString bs }+ setHeader (hContentType, "application/octet-stream")+ wVar <- asksWEnv weResp+ Conc.modifyMVar_ wVar $+ \wr -> return $ wr {wrRespData = Right $ Bu.fromByteString bs} +-- | Send plain-text in the response body. Also+-- sets @Content-Type@ header to @text/plain; charset=utf-8@ text :: Text -> WebbyM appEnv () text txt = do- setHeader (hContentType, "text/plain; charset=utf-8")- wVar <- asks weResp- Conc.modifyMVar_ wVar $- \wr -> return $ wr { wrRespData = Right $ Bu.fromByteString $- encodeUtf8 txt }+ setHeader (hContentType, "text/plain; charset=utf-8")+ wVar <- asksWEnv weResp+ Conc.modifyMVar_ wVar $+ \wr ->+ return $+ wr+ { wrRespData =+ Right $+ Bu.fromByteString $+ encodeUtf8 txt+ } -- | Return the raw request body as a lazy bytestring requestBodyLBS :: WebbyM appEnv LByteString requestBodyLBS = do- req <- request- liftIO $ lazyRequestBody req+ req <- request+ liftIO $ lazyRequestBody req +-- | Parse the request body as a JSON object and return it. Raises+-- 'WebbyJSONParseError' exception if parsing is unsuccessful. jsonData :: A.FromJSON a => WebbyM appEnv a jsonData = do- req <- request- body <- liftIO $ lazyRequestBody req- either (throwIO . WebbyJSONParseError . T.pack) return $ A.eitherDecode body+ req <- request+ body <- liftIO $ lazyRequestBody req+ either (throwIO . WebbyJSONParseError . T.pack) return $ A.eitherDecode body +-- | Set the body of the response to the JSON encoding of the given value. Also+-- sets @Content-Type@ header to @application/json; charset=utf-8@ json :: A.ToJSON b => b -> WebbyM appEnv () json j = do- setHeader (hContentType, "application/json; charset=utf-8")- wVar <- asks weResp- Conc.modifyMVar_ wVar $- \wr -> return $ wr { wrRespData = Right $ Bu.fromLazyByteString $- A.encode j }+ setHeader (hContentType, "application/json; charset=utf-8")+ wVar <- asksWEnv weResp+ Conc.modifyMVar_ wVar $+ \wr ->+ return $+ wr+ { wrRespData =+ Right $+ Bu.fromLazyByteString $+ A.encode j+ } +-- | Set the body of the response to a StreamingBody. Doesn't set the+-- @Content-Type@ header, so you probably want to do that on your own with+-- 'setHeader'. stream :: StreamingBody -> WebbyM appEnv () stream s = do- wVar <- asks weResp- Conc.modifyMVar_ wVar $- \wr -> return $ wr { wrRespData = Left s }+ wVar <- asksWEnv weResp+ Conc.modifyMVar_ wVar $+ \wr -> return $ wr {wrRespData = Left s} matchRequest :: Request -> [(RoutePattern, a)] -> Maybe (Captures, a) matchRequest _ [] = Nothing-matchRequest req ((RoutePattern method pathSegs, handler):rs) =- if requestMethod req == method+matchRequest req ((RoutePattern method pathSegs, handler) : rs) =+ if requestMethod req == method then case go (pathInfo req) pathSegs H.empty of- Nothing -> matchRequest req rs- Just cs -> return (cs, handler)+ Nothing -> matchRequest req rs+ Just cs -> return (cs, handler) else matchRequest req rs where- go [] p h | mconcat p == "" = Just h- | otherwise = Nothing- go p [] h | mconcat p == "" = Just h- | otherwise = Nothing- go (p:ps) (l:pat) h | T.head l == ':' = go ps pat $ H.insert (T.drop 1 l) p h- | p == l = go ps pat h- | otherwise = Nothing+ go [] p h+ | mconcat p == "" = Just h+ | otherwise = Nothing+ go p [] h+ | mconcat p == "" = Just h+ | otherwise = Nothing+ go (p : ps) (l : pat) h+ | T.head l == ':' = go ps pat $ H.insert (T.drop 1 l) p h+ | p == l = go ps pat h+ | otherwise = Nothing errorResponse404 :: WebbyM appEnv () errorResponse404 = setStatus status404@@ -179,83 +216,100 @@ invalidRoutesErr :: [Char] invalidRoutesErr = "Invalid route specification: contains duplicate routes or routes with overlapping capture patterns." --- | Use this function, to create a WAI application. It takes a user/application--- defined `appEnv` data type and a list of routes. Routes are matched in the+-- | Use this function to create a WAI application. It takes a user/application+-- 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 :: env -> WebbyServerConfig env -> IO Application mkWebbyApp env wsc =- return $ mkApp+ return $ mkApp where shortCircuitHandler =- [ -- Handler for FinishThrown exception to guide- -- short-circuiting handlers to early completion- E.Handler (\(ex :: FinishThrown) -> E.throwIO ex)- ]+ [ -- 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+ let defaultHandler = errorResponse404+ routes = wscRoutes wsc+ exceptionHandlerMay = wscExceptionHandler wsc+ (cs, handler) =+ fromMaybe (H.empty, defaultHandler) $+ matchRequest req routes - wEnv <- do v <- Conc.newMVar defaultWyResp- 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- E.Handler (\(ex :: WebbyError) -> case ex of+ wEnv <- do+ v <- Conc.newMVar defaultWyResp+ 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+ E.Handler+ ( \(ex :: WebbyError) -> case ex of wmc@(WebbyMissingCapture _) ->- respond $ responseLBS status404 [] $- encodeUtf8 $ displayException wmc-- _ -> respond $ responseLBS status400 [] $- encodeUtf8 $ displayException ex- )-- -- Handles Webby's finish statement- , E.Handler (\(_ :: FinishThrown) -> webbyReply wEnv respond)- ]-+ respond $+ responseLBS status404 [] $+ encodeUtf8 $+ displayException wmc+ _ ->+ respond $+ responseLBS status400 [] $+ encodeUtf8 $+ displayException ex+ ),+ -- Handles Webby's finish statement+ E.Handler (\(_ :: FinishThrown) -> webbyReply wEnv respond)+ ] webbyReply wEnv respond' = do- let wVar = weResp wEnv- wr <- Conc.takeMVar wVar- case wrRespData wr of- Left s -> respond' $ responseStream (wrStatus wr) (wrHeaders wr) s- Right b -> do- let clen = LB.length $ Bu.toLazyByteString b- respond' $ responseBuilder (wrStatus wr)- (wrHeaders wr ++ [(hContentLength, show clen)]) b+ let wVar = weResp wEnv+ wr <- Conc.takeMVar wVar+ case wrRespData wr of+ Left s -> respond' $ responseStream (wrStatus wr) (wrHeaders wr) s+ Right b -> do+ let clen = LB.length $ Bu.toLazyByteString b+ respond' $+ responseBuilder+ (wrStatus wr)+ (wrHeaders wr ++ [(hContentLength, show clen)])+ b -- | Create a route for a user-provided HTTP request method, pattern -- and handler function.-mkRoute :: Method -> Text -> WebbyM appEnv ()- -> (RoutePattern, WebbyM appEnv ())+mkRoute ::+ Method ->+ Text ->+ WebbyM appEnv () ->+ (RoutePattern, WebbyM appEnv ()) mkRoute m p h =- let p' = if | T.null p -> "/"- | T.head p /= '/' -> "/" <> p- | otherwise -> p- in (RoutePattern m (drop 1 $ T.splitOn "/" p'), h)+ let p' =+ if+ | T.null p -> "/"+ | T.head p /= '/' -> "/" <> p+ | otherwise -> p+ in (RoutePattern m (drop 1 $ T.splitOn "/" p'), h) --- | Create a route for a POST request method, given the path pattern+-- | Create a route for a @POST@ request method, given the path pattern -- and handler. post :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ()) post = mkRoute methodPost --- | Create a route for a GET request method, given the path pattern+-- | Create a route for a @GET@ request method, given the path pattern -- and handler. get :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ()) get = mkRoute methodGet --- | Create a route for a PUT request method, given the path pattern+-- | Create a route for a @PUT@ request method, given the path pattern -- and handler. put :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ()) put = mkRoute methodPut --- | Create a route for a DELETE request method, given path pattern and handler.+-- | Create a route for a @DELETE@ request method, given path pattern and handler. delete :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ()) delete = mkRoute methodDelete
src/Webby/Types.hs view
@@ -1,60 +1,62 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-}-module Webby.Types where+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -import qualified Data.Binary.Builder as Bu-import qualified Data.HashMap.Strict as H-import qualified Data.Text as T-import qualified UnliftIO as U-import qualified UnliftIO.Concurrent as Conc+module Webby.Types where -import Prelude+-- We directly depend on unliftio-core's Control.Monad.IO.Unlift, so we can+-- deriving MonadUnliftIO via GeneralizedNewtypeDeriving. If we depend on the+-- exported class from unliftio's UnliftIO module, we have problem building with+-- stack and LTS 16.0. FIXME: fix this unliftio has the right dep.+import qualified Control.Monad.IO.Unlift as Un+import qualified Data.Binary.Builder as Bu+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified UnliftIO as U+import qualified UnliftIO.Concurrent as Conc+import Prelude -- | A data type to represent parts of the response constructed in the -- handler when servicing a request.-data WyResp = WyResp { wrStatus :: Status- , wrHeaders :: ResponseHeaders- , wrRespData :: Either StreamingBody Bu.Builder- , wrResponded :: Bool- }+data WyResp = WyResp+ { wrStatus :: Status,+ wrHeaders :: ResponseHeaders,+ wrRespData :: Either StreamingBody Bu.Builder,+ wrResponded :: Bool+ } defaultWyResp :: WyResp defaultWyResp = WyResp status200 [] (Right Bu.empty) False -data WebbyExceptionHandler env = forall e . Exception e => WebbyExceptionHandler (e -> (WebbyM env) ())+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 env = WEnv { weResp :: Conc.MVar WyResp- , weCaptures :: Captures- , weRequest :: Request- , weAppEnv :: env- , weExceptionHandler :: Maybe (WebbyExceptionHandler env)- }+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. ----- The type of a handler for a request is `WebbyM appEnv ()`. The--- `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 env a = WebbyM- { unWebbyM :: ReaderT (WEnv env) (ResourceT IO) a- }- deriving (Functor, Applicative, Monad, MonadIO, MonadReader (WEnv env))--instance U.MonadUnliftIO (WebbyM appData) where- askUnliftIO = WebbyM $ ReaderT $- \(w :: WEnv appData) -> U.withUnliftIO $- \u -> return $- U.UnliftIO (U.unliftIO u . flip runReaderT w . unWebbyM)+-- The type of a handler for a request is @WebbyM appEnv ()@. The @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 appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a+ }+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader appEnv, Un.MonadUnliftIO) runWebbyM :: WEnv w -> WebbyM w a -> IO a-runWebbyM env = runResourceT . flip runReaderT env . unWebbyM+runWebbyM env = runResourceT . flip runReaderT env . flip runReaderT appEnv . unWebbyM+ where+ appEnv = weAppEnv env -- | A route pattern represents logic to match a request to a handler. data RoutePattern = RoutePattern Method [Text]- deriving (Eq, Show)+ deriving (Eq, Show) -- | A route is a pair of a route pattern and a handler. type Route env = (RoutePattern, WebbyM env ())@@ -65,50 +67,62 @@ -- | Internal type used to terminate handler processing by throwing and -- catching an exception. data FinishThrown = FinishThrown- deriving (Show)+ deriving (Show) instance U.Exception FinishThrown -- | Various kinds of errors thrown by this library - these can be -- caught by handler code.-data WebbyError = WebbyJSONParseError Text- | WebbyParamParseError { wppeParamName :: Text- , wppeErrMsg :: Text- }- | WebbyMissingCapture Text- deriving Show+data WebbyError+ = WebbyJSONParseError Text+ | WebbyParamParseError+ { wppeParamName :: Text,+ wppeErrMsg :: Text+ }+ | WebbyMissingCapture Text+ deriving (Show) instance U.Exception WebbyError where- displayException (WebbyParamParseError pName msg) =- T.unpack $ sformat ("Param parse error: " % st % " " % st) pName msg-- displayException (WebbyJSONParseError _) = "Invalid JSON body"-- displayException (WebbyMissingCapture capName) =- T.unpack $ sformat (st % " missing") capName+ displayException (WebbyParamParseError pName msg) =+ T.unpack $ sformat ("Param parse error: " % st % " " % st) pName msg+ displayException (WebbyJSONParseError _) = "Invalid JSON body"+ displayException (WebbyMissingCapture capName) =+ T.unpack $ sformat (st % " missing") capName +-- | Holds web server configuration like API routes, handlers and an optional+-- exception handler data WebbyServerConfig env = WebbyServerConfig- { wscRoutes :: [Route env]- , wscExceptionHandler :: Maybe (WebbyExceptionHandler env)- }+ { wscRoutes :: [Route env],+ wscExceptionHandler :: Maybe (WebbyExceptionHandler env)+ } +-- | Default @WebbyServerConfig@ typically used in conjunction with 'setRoutes'+-- and 'setExceptionHandler' defaultWebbyServerConfig :: WebbyServerConfig env-defaultWebbyServerConfig = WebbyServerConfig- { wscRoutes = []- , wscExceptionHandler = Nothing :: Maybe (WebbyExceptionHandler env)- }+defaultWebbyServerConfig =+ WebbyServerConfig+ { wscRoutes = [],+ wscExceptionHandler = Nothing :: Maybe (WebbyExceptionHandler env)+ } -setRoutes :: [Route env]- -> WebbyServerConfig env- -> WebbyServerConfig env-setRoutes routes wsc = wsc { wscRoutes = routes- }+-- | Sets API routes and their handlers of a 'WebbyServerConfig'+setRoutes ::+ [Route env] ->+ WebbyServerConfig env ->+ WebbyServerConfig env+setRoutes routes wsc =+ wsc+ { wscRoutes = routes+ } -setExceptionHandler :: Exception e- => (e -> WebbyM env ())- -> WebbyServerConfig env- -> WebbyServerConfig env+-- | Sets the exception handler of a 'WebbyServerConfig'+setExceptionHandler ::+ Exception e =>+ (e -> WebbyM env ()) ->+ WebbyServerConfig env ->+ WebbyServerConfig env setExceptionHandler exceptionHandler wsc =- WebbyServerConfig { wscRoutes = wscRoutes wsc- , wscExceptionHandler = Just $ WebbyExceptionHandler exceptionHandler- }+ WebbyServerConfig+ { wscRoutes = wscRoutes wsc,+ wscExceptionHandler = Just $ WebbyExceptionHandler exceptionHandler+ }
test/Spec.hs view
@@ -1,13 +1,11 @@-import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.HUnit ((@?=))-import qualified Test.Tasty.HUnit as HUnit--import Network.Wai.Internal import qualified Data.HashMap.Strict as H--import Webby.Server-import Webby.Types-import Prelude+import Network.Wai.Internal+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit ((@?=))+import qualified Test.Tasty.HUnit as HUnit+import Webby.Server+import Webby.Types+import Prelude main :: IO () main = defaultMain tests@@ -19,39 +17,42 @@ matchRequestTests = testGroup "matchRequest" [unitTests] where routes1 = []- routes2 = [ (RoutePattern methodGet ["api"], 1::Int)- , (RoutePattern methodPut ["api"], 2)- , (RoutePattern methodGet ["api", "v1"], 3)- ]- routes3 = [ (RoutePattern methodGet ["api", "vX"], 1)- , (RoutePattern methodGet ["api", ":version"], 2)- , (RoutePattern methodGet ["api", "vX", "aaa"], 3)- ]- routes4 = [ (RoutePattern methodGet ["api", ":version"], 1)- , (RoutePattern methodGet [":api", "version"], 2)]- r mthd path = defaultRequest { pathInfo = path- , requestMethod = mthd- }-+ routes2 =+ [ (RoutePattern methodGet ["api"], 1 :: Int),+ (RoutePattern methodPut ["api"], 2),+ (RoutePattern methodGet ["api", "v1"], 3)+ ]+ routes3 =+ [ (RoutePattern methodGet ["api", "vX"], 1),+ (RoutePattern methodGet ["api", ":version"], 2),+ (RoutePattern methodGet ["api", "vX", "aaa"], 3)+ ]+ routes4 =+ [ (RoutePattern methodGet ["api", ":version"], 1),+ (RoutePattern methodGet [":api", "version"], 2)+ ]+ r mthd path =+ defaultRequest+ { pathInfo = path,+ requestMethod = mthd+ } unitTests :: TestTree unitTests = HUnit.testCase "Unit tests" $ do- let cases = [ (methodGet, ["api"], routes1, Nothing)-- , (methodGet, ["api"], routes2, Just (H.empty, 1))- , (methodPut, ["api"], routes2, Just (H.empty, 2))- , (methodPost, ["api"], routes2, Nothing)- , (methodGet, ["api", "v1"], routes2, Just (H.empty, 3))- , (methodPut, ["api", "ab"], routes2, Nothing)- , (methodPut, ["api", ""], routes2, Just (H.empty, 2))-- , (methodGet, ["api"], routes3, Nothing)- , (methodGet, ["api", "vX"], routes3, Just (H.empty, 1))- , (methodGet, ["api", "v1"], routes3, Just (H.fromList [("version", "v1")], 2))- , (methodGet, ["api", "vX", "aaa"], routes3, Just (H.empty, 3))- , (methodGet, ["api", "vX", "aaa1"], routes3, Nothing)- , (methodGet, ["api", "vX", "aaa", "b"], routes3, Nothing)-- , (methodGet, ["api", "version"], routes4, Just (H.fromList [("version", "version")], 1))- , (methodGet, ["api1", "version"], routes4, Just (H.fromList [("api", "api1")], 2))- ]- in mapM_ (\(m, path, rs, res) -> matchRequest (r m path) rs @?= res) cases+ let cases =+ [ (methodGet, ["api"], routes1, Nothing),+ (methodGet, ["api"], routes2, Just (H.empty, 1)),+ (methodPut, ["api"], routes2, Just (H.empty, 2)),+ (methodPost, ["api"], routes2, Nothing),+ (methodGet, ["api", "v1"], routes2, Just (H.empty, 3)),+ (methodPut, ["api", "ab"], routes2, Nothing),+ (methodPut, ["api", ""], routes2, Just (H.empty, 2)),+ (methodGet, ["api"], routes3, Nothing),+ (methodGet, ["api", "vX"], routes3, Just (H.empty, 1)),+ (methodGet, ["api", "v1"], routes3, Just (H.fromList [("version", "v1")], 2)),+ (methodGet, ["api", "vX", "aaa"], routes3, Just (H.empty, 3)),+ (methodGet, ["api", "vX", "aaa1"], routes3, Nothing),+ (methodGet, ["api", "vX", "aaa", "b"], routes3, Nothing),+ (methodGet, ["api", "version"], routes4, Just (H.fromList [("version", "version")], 1)),+ (methodGet, ["api1", "version"], routes4, Just (H.fromList [("api", "api1")], 2))+ ]+ in mapM_ (\(m, path, rs, res) -> matchRequest (r m path) rs @?= res) cases
webby.cabal view
@@ -1,13 +1,13 @@-cabal-version: 1.12+cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: bfb0c373ed44cff2bdb24832b270b756c77829da9cdacc96529b25985b637c95+-- hash: b211693d69ab4d3d938e226148afca6d0405b20971fcfc052c1c9196af8a9b4b name: webby-version: 0.4.0+version: 1.0.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@@ -16,7 +16,8 @@ category: Web homepage: https://github.com/donatello/webby bug-reports: https://github.com/donatello/webby/issues-maintainer: aditya.mmy@gmail.com+maintainer: aditya.mmy@gmail.com,+ krishnan.parthasarathi@gmail.com license: Apache-2.0 license-file: LICENSE build-type: Simple@@ -39,24 +40,29 @@ Webby.Server Webby.Types Paths_webby+ autogen-modules:+ Paths_webby hs-source-dirs: src default-extensions: FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections ghc-options: -Wall build-depends:- aeson >=1.2 && <1.5- , base-noprelude >=4.7 && <5+ aeson >=1.4 && <1.5+ , base >=4.7 && <5 , binary >=0.8 && <0.9 , bytestring >=0.10 && <0.11- , formatting >=6.3 && <6.4- , http-api-data >=0.3 && <0.5+ , formatting >=6.3.7 && <6.4+ , http-api-data >=0.4 && <0.5 , http-types >=0.12 && <0.13 , relude , resourcet >=1.2 && <1.3 , text >=1.2 && <1.3- , unliftio >=0.2.7 && <0.3+ , unliftio >=0.2.13 && <0.3+ , unliftio-core >=0.2 && <0.3 , unordered-containers >=0.2.9 && <0.3 , wai >=3.2 && <3.3+ mixins:+ base hiding (Prelude) if flag(dev) ghc-options: -Wall -Werror default-language: Haskell2010@@ -76,12 +82,12 @@ default-extensions: FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends:- aeson >=1.2 && <1.5- , base-noprelude >=4.7 && <5+ aeson >=1.4 && <1.5+ , base >=4.7 && <5 , binary >=0.8 && <0.9 , bytestring >=0.10 && <0.11- , formatting >=6.3 && <6.4- , http-api-data >=0.3 && <0.5+ , formatting >=6.3.7 && <6.4+ , http-api-data >=0.4 && <0.5 , http-types >=0.12 && <0.13 , relude , resourcet >=1.2 && <1.3@@ -89,10 +95,13 @@ , tasty-hunit , tasty-quickcheck , text >=1.2 && <1.3- , unliftio >=0.2.7 && <0.3+ , unliftio >=0.2.13 && <0.3+ , unliftio-core >=0.2 && <0.3 , unordered-containers >=0.2.9 && <0.3 , wai >=3.2 && <3.3 , webby+ mixins:+ base hiding (Prelude) if flag(dev) ghc-options: -Wall -Werror default-language: Haskell2010