servant-combinators 0.0.1 → 0.0.2
raw patch · 8 files changed
+235/−43 lines, 8 files
Files
- lib/Servant/API/PathInfo.hs +56/−0
- lib/Servant/API/RawPathInfo.hs +55/−0
- servant-combinators.cabal +5/−33
- src/LiveTest.hs +0/−3
- tests/Main.hs +8/−0
- tests/TestLib.hs +6/−7
- tests/TestPathInfo.hs +53/−0
- tests/TestRawPathInfo.hs +52/−0
+ lib/Servant/API/PathInfo.hs view
@@ -0,0 +1,56 @@+{- |Description: Combinator for Servant to allow Handlers access to+ the raw path from the WAI request.+-}+module Servant.API.PathInfo where++import Data.Text (Text)+import Network.HTTP.Types (decodePathSegments)+import Network.Wai+import Servant+import Servant.Server.Internal.Delayed (passToServer)++{- |+ @PathInfo@ provides handlers access to the path segments from the+ request, without the domain name or query parameters. We re-generate+ this from the rawPathInfo via+ @Network.HTTP.Types.decodePathSegments@ because Servant removes all+ fields from the @pathInfo@ field of a request as part of routing the+ request to the appropriate handler.++ Example:++@+import Data.ByteString (ByteString)+import Control.Monad.IO.Class (liftIO)+import Servant+import ServantExtras.RawPathInfo++type MyAPI = "merlin" :> "my-path-info-endpoint"+ :> PathInfo+ :> Get '[JSON] NoContent++myServer :: Server MyAPI+myServer = pathInfoEndpointHandler+ where+ pathInfoEndpointHandler :: [Text] -> Handler NoContent+ pathInfoEndpointHandler pInfo = do+ case (elem "merlin" pInfo) of+ False -> do+ liftIO $ print "This example has a bug!"+ throwError err400 { errBody = "Patches accepted!" }+ True -> do+ liftIO $ print "Hopefully this demonstrates how path info works."+ pure NoContent+@+-}+data PathInfo++instance HasServer api ctx => HasServer (PathInfo :> api) ctx where+ type ServerT (PathInfo :> api) m = [Text] -> ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt . server+ route _ ctx server =+ route (Proxy @api) ctx $+ server `passToServer` \req ->+ decodePathSegments $ rawPathInfo req
+ lib/Servant/API/RawPathInfo.hs view
@@ -0,0 +1,55 @@+{- |Description: Combinator for Servant to allow Handlers access to+ the raw path from the WAI request.+-}+module Servant.API.RawPathInfo where++import Data.ByteString (ByteString)+import Network.Wai+import Servant+import Servant.Server.Internal.Delayed (passToServer)++{- |+ @RawPathInfo@ provides handlers access to the raw, unparsed path+ information the WAI request.++ If you wish to get the path segments, you can either use the+ @PathInfo@ combinator in @Servant.API.PathInfo@ or parse it yourself+ with @Network.HTTP.Types.decodePathSegments@++ Example:++@+import Data.ByteString (ByteString)+import Control.Monad.IO.Class (liftIO)+import Servant+import ServantExtras.RawPathInfo++type MyAPI = "my-path-info-endpoint"+ :> RawPathInfo+ :> Get '[JSON] NoContent++myServer :: Server MyAPI+myServer = queryEndpointHandler+ where+ queryEndpointHandler :: ByteString -> Handler NoContent+ queryEndpointHandler rawPath = do+ case rawPath of+ "/my-path-info-endpoint" -> do+ liftIO $ print "Servant routed us to the right place!"+ pure NoContent+ _ -> do+ liftIO $ print "My example has a bug!"+ throwError err400 { errBody = "Patches accepted!" }+@+-}+data RawPathInfo++instance HasServer api ctx => HasServer (RawPathInfo :> api) ctx where+ type ServerT (RawPathInfo :> api) m = ByteString -> ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt . server+ route _ ctx server =+ route (Proxy @api) ctx $+ server `passToServer` \req ->+ rawPathInfo req
servant-combinators.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: servant-combinators-version: 0.0.1+version: 0.0.2 synopsis: Extra servant combinators for full WAI functionality. description: Servant covers most of the data in a raw WAI request, but misses a few fields. This library aims to let handler authors get all the information about a request they need. category: web@@ -28,7 +28,9 @@ exposed-modules: Servant.API.Cookies Servant.API.HeaderList+ Servant.API.PathInfo Servant.API.QueryString+ Servant.API.RawPathInfo Servant.API.RawQueryString Servant.API.RawRequest other-modules:@@ -63,38 +65,6 @@ , wai default-language: Haskell2010 -executable live-test- main-is: LiveTest.hs- hs-source-dirs:- src- default-extensions:- DataKinds- FlexibleInstances- MultiParamTypeClasses- OverloadedStrings- ScopedTypeVariables- TypeApplications- TypeFamilies- TypeOperators- ghc-options: -Wall -Wwarn -fwarn-tabs -threaded- build-depends:- QuickCheck- , aeson- , base >=4.14 && <4.17- , bytestring- , clientsession- , containers- , cookie- , http-types- , servant- , servant-server- , tasty- , text- , time- , vault- , wai- default-language: Haskell2010- test-suite check type: exitcode-stdio-1.0 main-is: Main.hs@@ -102,7 +72,9 @@ TestCookies TestHeaders TestLib+ TestPathInfo TestQueryString+ TestRawPathInfo TestRawQueryString TestRawRequest hs-source-dirs:
− src/LiveTest.hs
@@ -1,3 +0,0 @@-main :: IO ()-main = do- putStrLn "Main!"
tests/Main.hs view
@@ -7,7 +7,9 @@ import TestCookies (CookieAPI, cookieProps, cookieServer) import TestHeaders (HeaderAPI, headerProps, headerServer) import TestLib (testFunctionGeneric)+import TestPathInfo (PathInfoAPI, pathInfoProps, pathInfoServer) import TestQueryString (QueryStrAPI, queryStrProps, queryStrServer)+import TestRawPathInfo (RawPathInfoAPI, rawPathInfoProps, rawPathInfoServer) import TestRawQueryString (RawQueryStrAPI, rawQueryStrProps, rawQueryStrServer) import TestRawRequest (RawRequestAPI, rawRequestProps, rawRequestServer) import Web.ClientSession@@ -20,6 +22,8 @@ :<|> QueryStrAPI :<|> RawQueryStrAPI :<|> RawRequestAPI+ :<|> PathInfoAPI+ :<|> RawPathInfoAPI topLevelServer :: Key -> Server TopLevelAPI topLevelServer encKey =@@ -28,6 +32,8 @@ :<|> queryStrServer :<|> rawQueryStrServer :<|> rawRequestServer+ :<|> pathInfoServer+ :<|> rawPathInfoServer topLevelProps :: Key -> Int -> TestTree topLevelProps key port =@@ -38,6 +44,8 @@ , queryStrProps port , rawQueryStrProps port , rawRequestProps port+ , pathInfoProps port+ , rawPathInfoProps port ] mkTestApplication :: Key -> IO Application
tests/TestLib.hs view
@@ -16,13 +16,12 @@ defaultMain $ tests port cancel serverAsync +returnsWith :: Int -> S.Response ByteString -> PropertyM IO Bool+returnsWith expectedResponse resp = do+ pure $ expectedResponse == S.getResponseStatusCode resp+ success :: S.Response ByteString -> PropertyM IO Bool-success resp = do- let respCode = S.getResponseStatusCode resp- respBool = (respCode <= 200) && 299 >= respCode- pure respBool+success resp = returnsWith 200 resp returns400 :: S.Response ByteString -> PropertyM IO Bool-returns400 resp = do- let respCode = S.getResponseStatusCode resp- pure $ respCode == 400+returns400 resp = returnsWith 400 resp
+ tests/TestPathInfo.hs view
@@ -0,0 +1,53 @@+module TestPathInfo where++import Data.Text (Text)+import Data.ByteString (ByteString)+import Network.HTTP.Client (method)+import Servant+import Servant.API.PathInfo+import Test.QuickCheck.Monadic (PropertyM (..), assert, monadicIO)+import Test.Tasty+import TestLib (returns400, success)++import qualified Network.HTTP.Simple as S+import qualified Test.Tasty.QuickCheck as QC++type PathInfoAPI =+ "merlin" :> "check-path-info" :> PathInfo :> Get '[JSON] NoContent+ :<|> "check-path-info" :> PathInfo :> Get '[JSON] NoContent++pathInfoServer :: Server PathInfoAPI+pathInfoServer = pathInfo :<|> pathInfo+ where+ pathInfo :: [Text] -> Handler NoContent+ pathInfo pInfo = do+ case elem "merlin" pInfo of+ False -> throwError err400 {errBody = "Merlin was not found in the path info list."}+ True -> pure NoContent++pathInfoProps :: Int -> TestTree+pathInfoProps port =+ testGroup+ "PathInfo"+ [ QC.testProperty "Requests to the merlin/check-path-info should succeed with a 200" $+ monadicIO $ do+ result <- (fetchEndpoint port "/merlin") >>= success+ assert $ result == True+ , QC.testProperty "Requests to just /check-path-info should fail with a 400" $+ monadicIO $ do+ result <- (fetchEndpoint port "") >>= returns400+ assert $ result == True+ ]+ where+ fetchEndpoint :: Int -> String -> PropertyM IO (S.Response ByteString)+ fetchEndpoint port' urlPrefix = do+ let initReq =+ S.parseRequest_ $+ "http://localhost:"+ <> (show port')+ <> urlPrefix+ <> "/check-path-info"+ req = initReq {method = "GET"}+ in do+ resp <- S.httpBS req+ pure resp
+ tests/TestRawPathInfo.hs view
@@ -0,0 +1,52 @@+module TestRawPathInfo where++import Data.ByteString (ByteString)+import Network.HTTP.Client (method)+import Servant+import Servant.API.RawPathInfo+import Test.QuickCheck.Monadic (PropertyM (..), assert, monadicIO)+import Test.Tasty+import TestLib (returns400, success)++import qualified Network.HTTP.Simple as S+import qualified Test.Tasty.QuickCheck as QC++type RawPathInfoAPI =+ "merlin" :> "check-raw-path-info" :> RawPathInfo :> Get '[JSON] NoContent+ :<|> "check-raw-path-info" :> RawPathInfo :> Get '[JSON] NoContent++rawPathInfoServer :: Server RawPathInfoAPI+rawPathInfoServer = pathInfo :<|> pathInfo+ where+ pathInfo :: ByteString -> Handler NoContent+ pathInfo rPathInfo = do+ case rPathInfo of+ "/merlin/check-raw-path-info" -> pure NoContent+ _ -> throwError err400 {errBody = "Merlin was not found in the path info list."}++rawPathInfoProps :: Int -> TestTree+rawPathInfoProps port =+ testGroup+ "RawPathInfo"+ [ QC.testProperty "Requests to the merlin/check-raw-path-info should succeed with a 200" $+ monadicIO $ do+ result <- (fetchEndpoint port "/merlin") >>= success+ assert $ result == True+ , QC.testProperty "Requests to just /check-raw-path-info should fail with a 400" $+ monadicIO $ do+ result <- (fetchEndpoint port "") >>= returns400+ assert $ result == True+ ]+ where+ fetchEndpoint :: Int -> String -> PropertyM IO (S.Response ByteString)+ fetchEndpoint port' urlPrefix = do+ let initReq =+ S.parseRequest_ $+ "http://localhost:"+ <> (show port')+ <> urlPrefix+ <> "/check-raw-path-info"+ req = initReq {method = "GET"}+ in do+ resp <- S.httpBS req+ pure resp