webby (empty) → 0.1.0.0
raw patch · 11 files changed
+990/−0 lines, 11 filesdep +aesondep +basedep +binarysetup-changed
Dependencies added: aeson, base, binary, bytestring, fast-logger, formatting, http-api-data, http-types, monad-logger, mtl, protolude, resourcet, tasty, tasty-hunit, tasty-quickcheck, text, unliftio, unordered-containers, wai, wai-extra, warp, webby
Files
- LICENSE +202/−0
- README.md +63/−0
- Setup.hs +2/−0
- src/Webby.hs +53/−0
- src/Webby/Route.hs +88/−0
- src/Webby/Server.hs +248/−0
- src/Webby/Types.hs +104/−0
- src/WebbyPrelude.hs +33/−0
- test/Spec.hs +37/−0
- test/Webby/RouteTest.hs +55/−0
- webby.cabal +105/−0
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,63 @@+# Webby++An easy to use Haskell web-server inspired by Scotty.++# Build++Clone the repo and run `stack build`++# Example++``` haskell+module Main where++import qualified Data.Text as T+import qualified Network.Wai.Handler.Warp as W+import UnliftIO (liftIO)+import qualified UnliftIO.Exception as E++import Webby++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+ )+ , get "/api/showEnv" (do env <- getAppEnv+ json env+ )+ , get "/aaah" (liftIO $ E.throwString "oops!")+ ]++ webbyApp <- mkWebbyApp (3::Int) routes+ putStrLn "Starting webserver..."+ W.runEnv 7000 webbyApp+```++You can try the example above, by cloning the repo and running the+example:++``` shell+$ examples/Basic.hs+```++In another shell, let's `curl` the server:++``` shell+$ curl http://localhost:7000/api/a+a+$ curl http://localhost:7000/api/b+b+$ curl -XPOST http://localhost:7000/api/capture/32+32+$ curl http://localhost:7000/api/showEnv+MyEnv+$ curl http://localhost:7000/aaah+Control.Exception.Safe.throwString called with:++oops!+Called from:+ throwString (examples/Basic.hs:32:42 in main:Main)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Webby.hs view
@@ -0,0 +1,53 @@+module Webby+ ( WebbyM++ -- * Routing and handler functions+ , RoutePattern+ , Routes+ , mkRoute+ , post+ , get+ , put++ -- * Captures+ , Captures+ , captures+ , getCapture++ -- * Request parsing+ , flag+ , header+ , headers+ , jsonData+ , param+ , param_+ , params+ , request+ , requestBodyLength++ -- * Response modification+ , setStatus+ , addHeader+ , setHeader+ , blob+ , json+ , text+ , stream++ -- * Application+ , mkWebbyApp++ -- * Application context+ , WEnv+ , getAppEnv+ , runAppEnv++ -- * Handler flow control+ , finish++ -- * Exceptions thrown+ , WebbyError(..)+ ) where++import Webby.Server+import Webby.Types
+ src/Webby/Route.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE BangPatterns #-}+module Webby.Route where++-- This modules contains the data structure and utilities to process+-- route patterns and lookup request paths internally in Webby.++import qualified Data.HashMap.Strict as H++import Webby.Types+import WebbyPrelude+++data HashTrie a = HashTrie { handlerMay :: Maybe a+ , litSubtree :: H.HashMap Text (HashTrie a)+ , capMay :: Maybe (Text, HashTrie a)+ }+ deriving (Eq, Show)++emptyHashTrie :: HashTrie a+emptyHashTrie = HashTrie Nothing H.empty Nothing++-- | addItem adds a route to the HashTrie, only if the route does not+-- already exist, and the route does not have overlapping captures.+--+-- An overlapping capture happens when there are two routes with+-- captures at the same position, for example:+-- @/person/:name@+-- @/person/:id@+--+-- Note that @/person/:name@ and @/address/:name@ are not overlapping+-- captures as they have different leading components.+addItem :: ([PathSegment], a) -> HashTrie a -> Maybe (HashTrie a)+addItem ([], !handler) !trie =+ -- If there are no path segments remaining, set handler at the+ -- current node of the HashTrie+ case handlerMay trie of+ Nothing -> Just $ trie { handlerMay = Just handler }+ Just _ -> Nothing+addItem (b:bs, !handler) !trie =+ case b of+ -- For a literal path segment, lookup and insert in the+ -- litSubtree.+ Literal p ->+ let ltrie = litSubtree trie+ child = H.lookupDefault emptyHashTrie p ltrie+ in do nchild <- addItem (bs, handler) child+ let nltrie = H.insert p nchild ltrie+ return $ trie { litSubtree = nltrie }++ -- For a capture path segment, insert into the capture child of+ -- the current node (if it doesn't exist).+ Capture p ->+ case capMay trie of+ Nothing -> do ntrie <- addItem (bs, handler) emptyHashTrie+ return $ trie { capMay = Just (p, ntrie) }+ Just _ -> Nothing++-- | lookupItem lookup the path segments in the tree and returns a+-- handler if a match is found along with a map of captures found.+lookupItem :: [Text] -> HashTrie a+ -> Maybe (Captures, a)+lookupItem !bs' !trie' = lookupItemWithCaptures bs' trie' H.empty+ where+ lookupItemWithCaptures [] !trie !h = do hdlr <- handlerMay trie+ return (h, hdlr)+ lookupItemWithCaptures (b:bs) !trie !h =+ let litChildMay = H.lookup b $ litSubtree trie+ captureLookup = do (capKey, childTrie) <- capMay trie+ lookupItemWithCaptures bs childTrie $+ H.insert capKey b h+ in -- At lookup we always prefer a literal match over a+ -- capture if both are present at node.+ maybe captureLookup+ (\childTrie -> lookupItemWithCaptures bs childTrie h)+ litChildMay++routePattern2PathSegments :: RoutePattern -> [PathSegment]+routePattern2PathSegments (RoutePattern mthd ps) =+ (Literal $ decodeUtf8Lenient mthd) : ps++mkRoutesHashTrie :: Routes a -> Maybe (HashTrie (WebbyM a ()))+mkRoutesHashTrie rs = foldl combine (Just emptyHashTrie) rs+ where++ combine Nothing _ = Nothing+ combine (Just h) (rpat, handler) =+ let pathSegments = routePattern2PathSegments rpat+ in addItem (pathSegments, handler) h
+ src/Webby/Server.hs view
@@ -0,0 +1,248 @@+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+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 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++import WebbyPrelude++import Webby.Route+import Webby.Types++-- | Retrieve the app environment given to the application at+-- initialization.+getAppEnv :: WebbyM appEnv appEnv+getAppEnv = asks weAppEnv++runAppEnv :: ReaderT appEnv (WebbyM appEnv) a -> WebbyM appEnv a+runAppEnv appFn = do+ env <- getAppEnv+ runReaderT appFn env++-- | Retrieve all path captures+captures :: WebbyM appEnv Captures+captures = asks weCaptures++-- | Retrieve a particular capture (TODO: extend?)+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++setStatus :: Status -> WebbyM appEnv ()+setStatus sts = do+ wVar <- asks weResp+ Conc.modifyMVar_ wVar $ \wr -> return $ wr { wrStatus = sts}++addHeader :: Header -> WebbyM appEnv ()+addHeader h = do+ wVar <- asks weResp+ Conc.modifyMVar_ wVar $+ \wr -> do let hs = wrHeaders wr+ return $ wr { wrHeaders = hs ++ [h] }++-- 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)] }++resp400 :: Text -> WebbyM appEnv a+resp400 msg = do+ setStatus status400+ json $ A.object [ "error" A..= A.String msg ]+ finish++params :: WebbyM appEnv [(Text, Text)]+params = do+ qparams <- (queryToQueryText . queryString) <$> request+ return $ fmap (\(q, mv) -> (,) q $ fromMaybe "" mv) qparams++flag :: Text -> WebbyM appEnv Bool+flag name = (isJust . L.lookup name) <$> params++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_ :: (FromHttpApiData a) => Text -> WebbyM appEnv a+param_ p = do myParam <- param p+ maybe (resp400 $ T.concat [p, " missing in params"])+ return myParam++header :: HeaderName -> WebbyM appEnv (Maybe Text)+header n = do+ hs <- requestHeaders <$> request+ return $ headMay $ map (decodeUtf8Lenient . snd) $ filter ((n == ) . fst) hs++request :: WebbyM appEnv Request+request = asks weRequest++headers :: WebbyM appEnv [Header]+headers = requestHeaders <$> request++requestBodyLength :: WebbyM appEnv (Maybe Int64)+requestBodyLength = do+ hMay <- header hContentLength+ return $ do val <- toS <$> hMay+ parseInt val++finish :: WebbyM appEnv a+finish = E.throwIO FinishThrown++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 }++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 }++jsonData :: A.FromJSON a => WebbyM appEnv a+jsonData = do+ req <- request+ body <- liftIO $ lazyRequestBody req+ either (throwIO . WebbyJSONParseError . T.pack) return $ A.eitherDecode body++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 }++stream :: StreamingBody -> WebbyM appEnv ()+stream s = do+ wVar <- asks weResp+ Conc.modifyMVar_ wVar $+ \wr -> return $ wr { wrRespData = Left s }++-- | matchRequest uses a looks up a data structure built from the+-- configured routes.+matchRequest :: Request -> HashTrie a -> Maybe (Captures, a)+matchRequest req trie =+ let mthd = requestMethod req+ path = pathInfo req+ lookupPath = decodeUtf8Lenient mthd : path+ in lookupItem lookupPath trie++errorResponse404 :: WebbyM appEnv ()+errorResponse404 = setStatus status404++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. If none of the requests match a request, a default 404+-- response is returned.+mkWebbyApp :: appEnv -> Routes appEnv -> IO Application+mkWebbyApp appEnv routes = do+ lset <- FLog.newStdoutLoggerSet FLog.defaultBufSize+ routeTrie <- maybe (E.throwString invalidRoutesErr) return $+ mkRoutesHashTrie routes+ return $ mkApp lset routeTrie++ where++ mkApp lset trie req respond = do+ let defaultHandler = errorResponse404+ (cs, handler) = fromMaybe (H.empty, defaultHandler) $+ matchRequest req trie++ 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+ 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 [] $+ toS $ displayException wmc++ _ -> respond $ responseLBS status400 [] $+ toS $ displayException ex+ )++ -- 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+ 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+++text2PathSegments :: Text -> [PathSegment]+text2PathSegments path =+ let toSegment s = maybe (Literal s) Capture $+ ":" `T.stripPrefix` s++ path' = maybe path identity $ T.stripPrefix "/" path++ in map toSegment $ bool (T.splitOn "/" path') [] $ path' == ""++-- | Create a route for a user-provided HTTP request method, pattern+-- and handler function.+mkRoute :: Method -> Text -> WebbyM appEnv ()+ -> (RoutePattern, WebbyM appEnv ())+mkRoute m p h = (RoutePattern m (text2PathSegments p), h)++-- | 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+-- and handler.+get :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())+get = mkRoute methodGet++-- | Create a route for a PUT request method, given the path pattern+-- and handler.+put :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())+put = mkRoute methodPut
+ src/Webby/Types.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+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++import WebbyPrelude++-- | 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+ }++defaultWyResp :: WyResp+defaultWyResp = WyResp status200 [] (Right Bu.empty) False++-- | 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+ }++-- | 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 appEnv a = WebbyM+ { unWebbyM :: ReaderT (WEnv appEnv) (ResourceT IO) a+ }+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader (WEnv appEnv))++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)++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++-- A route pattern specifies a HTTP method and a list of path segments+-- that must match.+data RoutePattern = RoutePattern Method [PathSegment]+ deriving (Eq, Show)++-- | The Routes of a web-application are a list of mappings from a+-- `RoutePattern` to a handler function.+type Routes appEnv = [(RoutePattern, WebbyM appEnv ())]++-- | Captures are simply extracted path elements in a HashMap+type Captures = H.HashMap Text Text++data PathSegment = Literal Text+ | Capture Text+ deriving (Eq, Show)++-- | Internal type used to terminate handler processing by throwing and+-- catching an exception.+data FinishThrown = FinishThrown+ 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++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
+ src/WebbyPrelude.hs view
@@ -0,0 +1,33 @@+module WebbyPrelude+ ( module Exports++ -- | Custom prelude functions+ , decodeUtf8Lenient+ , parseInt+ ) where++import Control.Monad.Trans.Resource as Exports (ResourceT,+ liftResourceT,+ runResourceT)+import Network.HTTP.Types as Exports+import Network.Wai as Exports+import Protolude as Exports hiding (get, put, (%))++import Data.Text.Encoding as Exports (encodeUtf8)++-- Imports for custom functionality coded in this module.+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Text.Read as TR++-- Text formatting+import Formatting as Exports (format, sformat, (%))+import Formatting.ShortFormatters as Exports (d, sh, st, t)++-- Decode UTF8 leniently (by replacing an invalid input byte with the+-- Unicode replacement character U+FFFD).+decodeUtf8Lenient :: ByteString -> Text+decodeUtf8Lenient = decodeUtf8With lenientDecode++parseInt :: Integral a => Text -> Maybe a+parseInt t' = hush $ fmap fst $ TR.decimal t'
+ test/Spec.hs view
@@ -0,0 +1,37 @@+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit ((@?=))+import qualified Test.Tasty.HUnit as HUnit+-- import qualified Test.Tasty.QuickCheck as QC++import Webby.Server+import Webby.Types+import WebbyPrelude++import Webby.RouteTest++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Webby Tests" [text2PathSegmentsTest, testHashTrie]++text2PathSegmentsTest :: TestTree+text2PathSegmentsTest = testGroup "text2PathSegments" [text2PathSegmentsUT]+ where+ text2PathSegmentsUT :: TestTree+ text2PathSegmentsUT = HUnit.testCase "Unit tests" $ do+ text2PathSegments "" @?= []++ text2PathSegments "/" @?= []++ text2PathSegments "/ab" @?= [Literal "ab"]++ text2PathSegments "ab" @?= [Literal "ab"]++ text2PathSegments "/ab/bc" @?= [Literal "ab", Literal "bc"]++ text2PathSegments ":ab/bc" @?= [Capture "ab", Literal "bc"]++ text2PathSegments "/:ab/bc" @?= [Capture "ab", Literal "bc"]++ text2PathSegments "/ab/:bc/cd" @?= [Literal "ab", Capture "bc", Literal "cd"]
+ test/Webby/RouteTest.hs view
@@ -0,0 +1,55 @@+module Webby.RouteTest where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=))+import qualified Test.Tasty.HUnit as HUnit++import qualified Data.HashMap.Strict as H++import Webby.Route+import Webby.Types+import WebbyPrelude++testHashTrie :: TestTree+testHashTrie = testGroup "HashTrie tests" [htAddItem, htLookupItem]++htAddItem :: TestTree+htAddItem = HUnit.testCase "Unit Test - Add Item" $ do+ let n = 1 :: Int+ leaf = HashTrie (Just n) H.empty Nothing+ addItem ([], n) emptyHashTrie @?=+ Just leaf++ addItem ([Literal "ab"], n) emptyHashTrie @?=+ Just (HashTrie Nothing (H.fromList [("ab", leaf)]) Nothing)++ let tnode = HashTrie Nothing (H.fromList [("cd", leaf)]) Nothing+ addItem ([Literal "ab", Literal "cd"], n) emptyHashTrie @?=+ Just (HashTrie Nothing (H.fromList [("ab", tnode)]) Nothing)++ -- capture test!+ addItem ([Capture "ab", Literal "cd"], n) emptyHashTrie @?=+ Just (HashTrie Nothing H.empty (Just ("ab", tnode)))++ -- TODO: capture test with overlapping capture and literal pattern++htLookupItem :: TestTree+htLookupItem = HUnit.testCase "Unit Test - Lookup Item" $ do+ lookupItem [] emptyHashTrie @?= (Nothing :: Maybe (Captures, Int))++ let n = 1 :: Int+ leaf = HashTrie (Just n) H.empty Nothing+ lookupItem [] leaf @?= Just (H.empty, n)++ let trie1 = HashTrie Nothing (H.fromList [("ab", leaf)]) Nothing+ lookupItem ["a"] trie1 @?= Nothing+ lookupItem ["ab"] trie1 @?= Just (H.empty, n)++ -- capture test!+ let tnode = HashTrie Nothing (H.fromList [("cd", leaf)]) Nothing+ trie2 = HashTrie Nothing H.empty (Just ("ab", tnode))+ lookupItem ["abc"] trie2 @?= Nothing+ lookupItem ["captureValue", "cd"] trie2 @?=+ Just (H.fromList [("ab", "captureValue")], n)++ -- TODO: capture test with overlapping capture and literal pattern
+ webby.cabal view
@@ -0,0 +1,105 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4f81f8a7502f5cce8bbeea48a56ceb91bc52428d3b45594d74a22c035108c56c++name: webby+version: 0.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+ graceful exception handling (3) Parse request parameters easily and+ in a typed manner.+category: Web+maintainer: aditya.mmy@gmail.com+license: Apache-2.0+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md++flag dev+ manual: True+ default: False++library+ hs-source-dirs:+ src+ default-extensions: FlexibleInstances MultiParamTypeClasses NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections+ ghc-options: -Wall+ build-depends:+ aeson+ , base >=4.7 && <5+ , binary+ , bytestring+ , fast-logger+ , formatting+ , http-api-data+ , http-types+ , monad-logger+ , mtl+ , protolude+ , resourcet+ , text+ , unliftio+ , unordered-containers+ , wai+ , wai-extra+ , warp+ if flag(dev)+ ghc-options: -Werror+ exposed-modules:+ Webby+ other-modules:+ Webby.Route+ Webby.Server+ Webby.Types+ WebbyPrelude+ Paths_webby+ default-language: Haskell2010++test-suite webby-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Webby+ Webby.Route+ Webby.Server+ Webby.Types+ WebbyPrelude+ Webby.RouteTest+ Paths_webby+ hs-source-dirs:+ src+ test+ default-extensions: FlexibleInstances MultiParamTypeClasses NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , base >=4.7 && <5+ , binary+ , bytestring+ , fast-logger+ , formatting+ , http-api-data+ , http-types+ , monad-logger+ , mtl+ , protolude+ , resourcet+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , text+ , unliftio+ , unordered-containers+ , wai+ , wai-extra+ , warp+ , webby+ if flag(dev)+ ghc-options: -Werror+ default-language: Haskell2010