webby 0.1.3 → 0.2.0
raw patch · 7 files changed
+76/−206 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Webby: type Routes appEnv = [(RoutePattern, WebbyM appEnv ())]
- Webby: mkWebbyApp :: appEnv -> Routes appEnv -> IO Application
+ Webby: mkWebbyApp :: appEnv -> [(RoutePattern, WebbyM appEnv ())] -> IO Application
Files
- src/Webby.hs +0/−1
- src/Webby/Route.hs +0/−88
- src/Webby/Server.hs +26/−27
- src/Webby/Types.hs +1/−9
- test/Spec.hs +39/−19
- test/Webby/RouteTest.hs +0/−55
- webby.cabal +10/−7
src/Webby.hs view
@@ -3,7 +3,6 @@ -- * Routing and handler functions , RoutePattern- , Routes , mkRoute , post , get
− src/Webby/Route.hs
@@ -1,88 +0,0 @@-{-# 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
@@ -18,7 +18,6 @@ import WebbyPrelude -import Webby.Route import Webby.Types -- | Retrieve the app environment given to the application at@@ -160,14 +159,22 @@ 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+matchRequest :: Request -> [(RoutePattern, a)] -> Maybe (Captures, a)+matchRequest _ [] = Nothing+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)+ 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 errorResponse404 :: WebbyM appEnv () errorResponse404 = setStatus status404@@ -179,19 +186,17 @@ -- 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+mkWebbyApp :: appEnv -> [(RoutePattern, WebbyM appEnv ())] -> IO Application+mkWebbyApp appEnv routes' = do lset <- FLog.newStdoutLoggerSet FLog.defaultBufSize- routeTrie <- maybe (E.throwString invalidRoutesErr) return $- mkRoutesHashTrie routes- return $ mkApp lset routeTrie+ return $ mkApp lset routes' where - mkApp lset trie req respond = do+ mkApp lset routes req respond = do let defaultHandler = errorResponse404 (cs, handler) = fromMaybe (H.empty, defaultHandler) $- matchRequest req trie+ matchRequest req routes timeFn <- newTimeCache "%Y-%m-%dT%H:%M:%S " wEnv <- do v <- Conc.newMVar defaultWyResp@@ -229,21 +234,15 @@ 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)+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) -- | Create a route for a POST request method, given the path pattern -- and handler.
src/Webby/Types.hs view
@@ -64,19 +64,11 @@ -- A route pattern specifies a HTTP method and a list of path segments -- that must match.-data RoutePattern = RoutePattern Method [PathSegment]+data RoutePattern = RoutePattern Method [Text] 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.
test/Spec.hs view
@@ -1,37 +1,57 @@ 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 Network.Wai.Internal+import qualified Data.HashMap.Strict as H+ import Webby.Server import Webby.Types import WebbyPrelude -import Webby.RouteTest- main :: IO () main = defaultMain tests tests :: TestTree-tests = testGroup "Webby Tests" [text2PathSegmentsTest, testHashTrie]+tests = testGroup "Webby Tests" [matchRequestTests] -text2PathSegmentsTest :: TestTree-text2PathSegmentsTest = testGroup "text2PathSegments" [text2PathSegmentsUT]+matchRequestTests :: TestTree+matchRequestTests = testGroup "matchRequest" [unitTests] where- text2PathSegmentsUT :: TestTree- text2PathSegmentsUT = HUnit.testCase "Unit tests" $ do- text2PathSegments "" @?= []-- text2PathSegments "/" @?= []-- text2PathSegments "/ab" @?= [Literal "ab"]-- text2PathSegments "ab" @?= [Literal "ab"]+ 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+ } - text2PathSegments "/ab/bc" @?= [Literal "ab", Literal "bc"]+ unitTests :: TestTree+ unitTests = HUnit.testCase "Unit tests" $ do+ let cases = [ (methodGet, ["api"], routes1, Nothing) - text2PathSegments ":ab/bc" @?= [Capture "ab", Literal "bc"]+ , (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)) - text2PathSegments "/:ab/bc" @?= [Capture "ab", Literal "bc"]+ , (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) - text2PathSegments "/ab/:bc/cd" @?= [Literal "ab", Capture "bc", Literal "cd"]+ , (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
− test/Webby/RouteTest.hs
@@ -1,55 +0,0 @@-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
@@ -4,16 +4,18 @@ -- -- see: https://github.com/sol/hpack ----- hash: f31e358f56cab247d8a40116ed142502fdcb0bb62c0f18ce5552dd680f8cbda4+-- hash: 8328c4d0d2c281b35a9d68f0bf6dd439945809c585fed2b86789a8f70cd00ffd name: webby-version: 0.1.3+version: 0.2.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+homepage: https://github.com/donatello/webby+bug-reports: https://github.com/donatello/webby/issues maintainer: aditya.mmy@gmail.com license: Apache-2.0 license-file: LICENSE@@ -21,6 +23,10 @@ extra-source-files: README.md +source-repository head+ type: git+ location: https://github.com/donatello/webby+ flag dev manual: True default: False@@ -28,7 +34,7 @@ library hs-source-dirs: src- default-extensions: FlexibleInstances MultiParamTypeClasses NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections+ default-extensions: FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections ghc-options: -Wall build-depends: aeson >=1.2 && <1.5@@ -51,7 +57,6 @@ exposed-modules: Webby other-modules:- Webby.Route Webby.Server Webby.Types WebbyPrelude@@ -63,16 +68,14 @@ 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+ default-extensions: FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=1.2 && <1.5