diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/src/Prelude.hs b/src/Prelude.hs --- a/src/Prelude.hs +++ b/src/Prelude.hs @@ -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 diff --git a/src/Webby.hs b/src/Webby.hs --- a/src/Webby.hs +++ b/src/Webby.hs @@ -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 diff --git a/src/Webby/Server.hs b/src/Webby/Server.hs --- a/src/Webby/Server.hs +++ b/src/Webby/Server.hs @@ -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 diff --git a/src/Webby/Types.hs b/src/Webby/Types.hs --- a/src/Webby/Types.hs +++ b/src/Webby/Types.hs @@ -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 + } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/webby.cabal b/webby.cabal --- a/webby.cabal +++ b/webby.cabal @@ -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