diff --git a/src/Webby.hs b/src/Webby.hs --- a/src/Webby.hs +++ b/src/Webby.hs @@ -3,7 +3,6 @@ -- * Routing and handler functions , RoutePattern - , Routes , mkRoute , post , get diff --git a/src/Webby/Route.hs b/src/Webby/Route.hs deleted file mode 100644 --- a/src/Webby/Route.hs +++ /dev/null @@ -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 diff --git a/src/Webby/Server.hs b/src/Webby/Server.hs --- a/src/Webby/Server.hs +++ b/src/Webby/Server.hs @@ -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. diff --git a/src/Webby/Types.hs b/src/Webby/Types.hs --- a/src/Webby/Types.hs +++ b/src/Webby/Types.hs @@ -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. diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Webby/RouteTest.hs b/test/Webby/RouteTest.hs deleted file mode 100644 --- a/test/Webby/RouteTest.hs +++ /dev/null @@ -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 diff --git a/webby.cabal b/webby.cabal --- a/webby.cabal +++ b/webby.cabal @@ -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