diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/src/Network/Waitra.hs b/src/Network/Waitra.hs --- a/src/Network/Waitra.hs +++ b/src/Network/Waitra.hs @@ -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 -- 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/waitra.cabal b/waitra.cabal --- a/waitra.cabal +++ b/waitra.cabal @@ -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