waitra 0.0.1.0 → 0.0.2.0
raw patch · 4 files changed
+133/−28 lines, 4 filesdep +aesondep +tastydep +tasty-hunitdep ~http-typesdep ~regex-applicativedep ~wai
Dependencies added: aeson, tasty, tasty-hunit, wai-extra, waitra
Dependency ranges changed: http-types, regex-applicative, wai
Files
- README.md +6/−2
- src/Network/Waitra.hs +27/−20
- test/Main.hs +70/−0
- waitra.cabal +30/−6
README.md view
@@ -10,9 +10,13 @@ ```hs echoRoute :: Route-echoRoute = routeGet (string "/api/echo/" *> many anySym) echoApp+echoRoute = routeGet (echoApp <$ string "/api/echo/" <*> many anySym) where echoApp msg _req respond = respond $ responseLBS status200 [] (fromString msg) app :: Application-app = compile [echoRoute] fallbackApp+app = waitraMiddleware [echoRoute] fallbackApp ```++## Documentation++Documentation is available at [hackage](http://hackage.haskell.org/package/waitra).
src/Network/Waitra.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Network.Waitra@@ -8,7 +5,6 @@ -- License : MIT (see the file LICENSE) -- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi> -- Stability : experimental--- Portability : GADTs and RankNTypes -- -- @Network.Waitra@ is a very simple router. -- It's useful for writing simple API web-services,@@ -30,24 +26,27 @@ , routePost , routePut , routeDelete+ -- * JSON helper+ , jsonApp -- * Compilation- , compile- , compileRoute+ , routeMiddleware+ , waitraMiddleware ) where +import Data.Aeson import qualified Data.Text as T import qualified Network.HTTP.Types as H import Network.Wai import Text.Regex.Applicative+import Data.String (fromString) -- | We use strings, as - unluckily - `Text.Regex.Applicative` doesn't work with `Text` directly. type Path = String -data Route where- Route :: forall a. H.Method -> RE Char a -> (a -> Application) -> Route+data Route = Route H.Method (RE Char Application) simpleRoute :: H.Method -> Path -> Application -> Route-simpleRoute method r app = Route method (string r) (const app)+simpleRoute method r app = Route method (const app <$> string r) simpleGet :: Path -> Application -> Route simpleGet = simpleRoute H.methodGet@@ -61,27 +60,35 @@ simpleDelete :: Path -> Application -> Route simpleDelete = simpleRoute H.methodDelete -routeGet :: RE Char a -> (a -> Application) -> Route+routeGet :: RE Char Application -> Route routeGet = Route H.methodGet -routePost :: RE Char a -> (a -> Application) -> Route+routePost :: RE Char Application -> Route routePost = Route H.methodPost -routeDelete :: RE Char a -> (a -> Application) -> Route+routeDelete :: RE Char Application -> Route routeDelete = Route H.methodDelete -routePut :: RE Char a -> (a -> Application) -> Route+routePut :: RE Char Application -> Route routePut = Route H.methodPut path :: Request -> Path-path req = T.unpack . T.intercalate "/" $ "" : pathInfo req+path req = T.unpack . T.intercalate (T.pack "/") $ T.pack "" : pathInfo req -compileRoute :: Route -> Middleware-compileRoute (Route method re routeApp) app req =+routeMiddleware :: Route -> Middleware+routeMiddleware (Route method re) app req = case (requestMethod req == method, path req =~ re) of- (True, Just m') -> routeApp m' req- _ -> app req+ (True, Just routeApp) -> routeApp req+ _ -> app req -- | Turn the list of routes into `Middleware`-compile :: [Route] -> Middleware-compile = foldr (.) id . map compileRoute+waitraMiddleware :: [Route] -> Middleware+waitraMiddleware = foldr ((.) . routeMiddleware) id++jsonApp :: (FromJSON a, ToJSON b) => (a -> IO (H.Status, H.ResponseHeaders, b)) -> Application+jsonApp f req respond = do+ body <- strictRequestBody req+ case eitherDecode body of+ Left err -> respond $ responseLBS H.status400 [] $ fromString err+ Right x -> do (status, headers, y) <- f x+ respond $ responseLBS status ((H.hContentType, fromString "application/json") : headers) $ encode y
+ test/Main.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Data.Aeson+import Data.String (fromString)+import qualified Network.HTTP.Types as H+import Network.Wai+import Network.Wai.Test+import Network.Waitra+import Test.Tasty+import Test.Tasty.HUnit+import Text.Regex.Applicative++echoRoute :: Route+echoRoute = routeGet (echoApp <$ string "/api/echo/" <*> many anySym)+ where echoApp msg _req respond = respond $ responseLBS H.status200 [] (fromString msg)++jsonRoute :: Route+jsonRoute = simpleGet "/api/json" $ jsonApp (return . f)+ where f (Object _) = (H.status200, [], "object" :: String)+ f (Array _) = (H.status200, [], "array")+ f v = (H.status404, [], show v)++emptyApp :: Application+emptyApp _ respond = respond $ responseLBS H.status404 [] (fromString "Fallback: Not found")++app :: Application+app = waitraMiddleware [echoRoute, jsonRoute] emptyApp++runApp :: Session a -> IO a+runApp s = runSession s app++echoCase1 :: IO ()+echoCase1 = runApp $ do+ let req = setPath defaultRequest "/api/echo/foobar"+ res <- request req+ assertStatus 200 res+ assertBody "foobar" res+ +echoCase2 :: IO ()+echoCase2 = runApp $ do+ let req = setPath defaultRequest "/not-found"+ res <- request req+ assertStatus 404 res++jsonCase1 :: IO ()+jsonCase1 = runApp $ do+ let req = setPath defaultRequest "/api/json"+ res <- srequest $ SRequest req "{}"+ assertStatus 200 res+ assertHeader H.hContentType "application/json" res+ assertBody "\"object\"" res++-- Cannot parse number as json+jsonCase2 :: IO ()+jsonCase2 = runApp $ do+ let req = setPath defaultRequest "/api/json"+ res <- srequest $ SRequest req "42"+ assertStatus 400 res++tests :: TestTree+tests = testGroup "Unit tests"+ [ testCase "echo case 1" echoCase1+ , testCase "echo case 2" echoCase2+ , testCase "json case 1" jsonCase1+ , testCase "json case 2" jsonCase2+ ]++main :: IO ()+main = defaultMain tests
waitra.cabal view
@@ -1,10 +1,17 @@ name: waitra-version: 0.0.1.0+version: 0.0.2.0 synopsis: A very simple Wai router description: Waitra is a very simple router. It's useful for writing simple API web-services, when you don't want to use the whole Yesod stack.+ .+ > echoRoute :: Route+ > echoRoute = routeGet (echoApp <$ string "/api/echo/" <*> many anySym)+ > where echoApp msg _req respond = respond $ responseLBS status200 [] (fromString msg)+ >+ > app :: Application+ > app = waitraMiddleware [echoRoute] fallbackApp homepage: https://github.com/futurice/waitra license: MIT license-file: LICENSE@@ -18,13 +25,30 @@ library exposed-modules: Network.Waitra- other-extensions: RankNTypes, GADTs, OverloadedStrings- build-depends: base >=4.6 && <4.9,- http-types >=0.8.6,+ build-depends: base >=4.6 && <4.9,+ aeson >=0.8.0.2,+ http-types >=0.8.6, regex-applicative >=0.3.1,- text >=1.1.0.0,- wai >=3.0.2.3+ text >=1.1.0.0,+ wai >=3.0.2.3 hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010++test-suite test+ main-is: Main.hs+ type: exitcode-stdio-1.0++ build-depends: base >= 4.6 && < 4.9,+ aeson,+ http-types,+ regex-applicative,+ tasty,+ tasty-hunit,+ wai,+ wai-extra >= 3.0.4.5,+ waitra+ hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010