packages feed

servant-matrix-param 0.3 → 0.3.1

raw patch · 8 files changed

+289/−19 lines, 8 filesdep +http-clientdep +servant-clientdep +warpPVP ok

version bump matches the API change (PVP)

Dependencies added: http-client, servant-client, warp

API changes (from Hackage documentation)

+ Servant.MatrixParam: data MatrixFlag (key :: Symbol)

Files

servant-matrix-param.cabal view
@@ -1,5 +1,5 @@ name:           servant-matrix-param-version:        0.3+version:        0.3.1 synopsis:       Matrix parameter combinator for servant description:    Matrix parameter combinator for servant category:       Web@@ -24,6 +24,11 @@   manual: True   default: False +flag with-servant-client+  description: support for servant-server+  manual: True+  default: False+ library   default-language: Haskell2010   ghc-options: -Wall@@ -34,11 +39,13 @@     , servant >= 0.7 && < 0.10   exposed-modules:       Servant.MatrixParam+   if flag(with-servant-aeson-specs)     build-depends:         servant-aeson-specs > 0.2 && < 0.6     exposed-modules:         Servant.MatrixParam.AesonSpecs+   if flag(with-servant-server)     build-depends:       servant-server >= 0.7 && < 0.10,@@ -51,6 +58,14 @@       Servant.MatrixParam.Server.Internal       Servant.MatrixParam.Server.Internal.ArgList +  if flag(with-servant-client)+    build-depends:+      servant-client,+      text+    exposed-modules:+      Servant.MatrixParam.Client+      Servant.MatrixParam.Client.Internal+ test-suite spec   default-language: Haskell2010   ghc-options: -Wall@@ -65,17 +80,21 @@     , servant-aeson-specs     , servant-matrix-param     , servant-server+    , servant-client     , wai+    , warp     , containers     , text     , wai-extra     , http-types+    , http-client     , bytestring     , transformers     , aeson   other-modules:       Servant.MatrixParam.AesonSpecsSpec       Servant.MatrixParam.ServerSpec+      Servant.MatrixParam.ClientSpec       Servant.MatrixParamSpec  test-suite doctest
src/Servant/MatrixParam.hs view
@@ -6,6 +6,7 @@ module Servant.MatrixParam (   WithMatrixParams,   MatrixParam,+  MatrixFlag, ) where  import           Data.Typeable (Typeable)@@ -24,4 +25,20 @@ -- >>> -- >>> type MyApi = "books" :> MatrixParam "author" String :> Get '[JSON] [String] data MatrixParam (key :: Symbol) a+    deriving (Typeable)++-- | Lookup a potentially value-less matrix string parameter+-- with boolean semantics. If the param @sym@ is there without any value,+-- or if it's there with value "true" or "1", it's interpreted as 'True'.+-- Otherwise, it's interpreted as 'False'.+--+--+-- @/book;published@+--+-- would be represented as:+--+-- >>> import Servant+-- >>>+-- >>> type MyApi = "book" :> MatrixFlag "published" :> Get '[JSON] [String]+data MatrixFlag (key :: Symbol)     deriving (Typeable)
+ src/Servant/MatrixParam/Client.hs view
@@ -0,0 +1,3 @@+module Servant.MatrixParam.Client () where++import Servant.MatrixParam.Client.Internal ()
+ src/Servant/MatrixParam/Client/Internal.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.MatrixParam.Client.Internal where++import           Data.Proxy+import qualified Data.Text           as T+import           GHC.TypeLits+import           Servant.API+import           Servant.Client+import           Servant.Common.Req+import           Servant.MatrixParam++instance+  ( HasClient (WMP path mat :> api)+  , KnownSymbol path+  )+  => HasClient (WithMatrixParams path mat :> api) where++  type Client (WithMatrixParams path mat :> api)+    = Client (WMP path mat :> api)++  clientWithRoute Proxy req =+    clientWithRoute (Proxy :: Proxy (WMP path mat :> api))+                    req { reqPath = reqPath req ++ "/" ++ path }+    where+     path = symbolVal (Proxy :: Proxy path)++-- This is just a dummy used to keep track of whether we have already processed+-- the leading path. If we are in a WMP instance, we have already dealt with+-- the leading path, and can just proceed recursively over the matrix params.+-- If not, we deal with the leading path, and call the WMP instance. WMP itself+-- should not be exported.+data WMP (p :: Symbol) (x :: [*])++instance+  ( HasClient (WMP path rest :> api)+  , ToHttpApiData v+  , KnownSymbol k+  ) => HasClient (WMP path (MatrixParam k v ': rest) :> api) where++  type Client (WMP path (MatrixParam k v ': rest) :> api)+    = Maybe v -> Client (WMP path rest :> api)++  clientWithRoute Proxy req x = case x of+    Nothing -> clientWithRoute nextProxy req+    Just v  -> clientWithRoute nextProxy+      req { reqPath = reqPath req ++ ";" ++ key ++ "=" ++ T.unpack (toQueryParam v) }+    where+      nextProxy :: Proxy (WMP path rest :> api)+      nextProxy = Proxy++      key :: String+      key = symbolVal (Proxy :: Proxy k)++instance+  ( HasClient api+  ) => HasClient (WMP path '[] :> api) where++  type Client (WMP path '[] :> api) = Client api++  clientWithRoute Proxy req =+    clientWithRoute (Proxy :: Proxy api) req
src/Servant/MatrixParam/Server/Internal.hs view
@@ -7,7 +7,6 @@   parsePathSegment, ) where -import           Data.List (foldl') import           Data.Map.Strict import           Data.Maybe import           Data.Text@@ -16,11 +15,11 @@ data MatrixSegment   = MatrixSegment {     segmentPath :: Text,-    segmentParams :: Maybe (Map Text Text)+    segmentParams :: Maybe (Map Text (Maybe Text))   }   deriving (Show, Eq) -getSegmentParams :: MatrixSegment -> Map Text Text+getSegmentParams :: MatrixSegment -> Map Text (Maybe Text) getSegmentParams = fromMaybe mempty . segmentParams  parsePathSegment :: Text -> Maybe MatrixSegment@@ -30,16 +29,10 @@   [path, ""] -> return $ MatrixSegment path mempty   (path : pairs) ->     Just $ MatrixSegment path $-      fmap collectPairs $ mapM parsePair pairs+      fmap fromList $ mapM parsePair pairs  parsePair :: Text -> Maybe (Text, Maybe Text) parsePair pair = case splitOn "=" pair of   [key, value] -> Just (key, Just value)   [flag] -> Just (flag, Nothing)   _ -> Nothing--collectPairs :: forall a b . Ord a => [(a, Maybe b)] -> Map a b-collectPairs =-  Data.List.foldl'-    (\ acc (k, mv) -> maybe acc (\ v -> insert k v acc) mv)-    mempty
src/Servant/MatrixParam/Server/Internal/ArgList.hs view
@@ -2,27 +2,32 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} module Servant.MatrixParam.Server.Internal.ArgList where +import           Control.Monad       (join)+import           Data.Char import qualified Data.Map            as Map import           Data.Proxy import qualified Data.Text           as T import           GHC.TypeLits        (KnownSymbol, symbolVal) import           Servant.MatrixParam-import           Web.HttpApiData     (parseQueryParamMaybe, FromHttpApiData)+import           Web.HttpApiData     (FromHttpApiData, parseQueryParamMaybe)  -- An HList that stores the arguments to a function data ArgList a where   NoArgs :: ArgList '[]   (:.:)  :: Maybe a -> ArgList as -> ArgList (MatrixParam key a ': as)+  (:?:)  :: Bool -> ArgList as -> ArgList (MatrixFlag key ': as)  type family Unapped (params :: [*]) end where   Unapped '[] r = r   Unapped (MatrixParam key a ': rest) r = Maybe a -> Unapped rest r+  Unapped (MatrixFlag key ': rest) r = Bool -> Unapped rest r  class (Apped (Unapped argList fn) argList ~ fn) => App fn (argList :: [*]) where   type Apped fn argList@@ -31,7 +36,7 @@  class ParseArgs argList where   -- Gets the arguments from a map-  parseArgs :: Map.Map T.Text T.Text -> ArgList argList+  parseArgs :: Map.Map T.Text (Maybe T.Text) -> ArgList argList  instance (App r rest         , Apped (Unapped rest (Maybe a -> r)) rest ~ (Maybe a -> r)@@ -39,11 +44,27 @@   type Apped (Maybe a -> r) (MatrixParam key a ': rest) = Apped r rest   apply fn (a :.: rest) = apply (fn a) rest +instance (App r rest+        , Apped (Unapped rest (Bool -> r)) rest ~ (Bool -> r)+        ) => App (Bool -> r) (MatrixFlag key ': rest) where+  type Apped (Bool -> r) (MatrixFlag key ': rest) = Apped r rest+  apply fn (a :?: rest) = apply (fn a) rest+ instance (FromHttpApiData a, KnownSymbol key, ParseArgs rest) => ParseArgs (MatrixParam key a ': rest) where   parseArgs m = val :.: (parseArgs m :: ArgList rest)     where       key = T.pack $ symbolVal (Proxy :: Proxy key)-      val = Map.lookup key m >>= parseQueryParamMaybe+      val = join $ Map.lookup key m >>= fmap parseQueryParamMaybe++instance (KnownSymbol key, ParseArgs rest) => ParseArgs (MatrixFlag key ': rest) where+  parseArgs m = val :?: (parseArgs m :: ArgList rest)+    where+      key = T.pack $ symbolVal (Proxy :: Proxy key)+      val = case Map.lookup key m of+        Nothing -> False+        Just Nothing -> True+                          -- Mimicking prior behaviour+        Just (Just x) -> T.map toLower x == "true" || x == "1"  instance App r '[] where   type Apped r '[] = r
+ test/Servant/MatrixParam/ClientSpec.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+module Servant.MatrixParam.ClientSpec (spec) where++import Control.Exception+import Control.Monad+import Data.ByteString     (ByteString)+import Data.IORef+import Data.Proxy+import Network.HTTP.Client (Manager, Request, defaultManagerSettings,+                            managerModifyRequest, managerResponseTimeout,+                            newManager, path)+import Servant+import Servant.Client+import System.IO.Unsafe+import Test.Hspec++#if MIN_VERSION_http_client(0,5,0)+import Network.HTTP.Client (responseTimeoutMicro)+#endif+#if MIN_VERSION_servant_client(0,9,0)+import Network.Wai.Handler.Warp (testWithApplication)+import Data.Maybe          (fromMaybe)+#else+import Control.Monad.Trans.Except (runExceptT)+#endif+++import Servant.MatrixParam+import Servant.MatrixParam.Client ()+import Servant.MatrixParam.Server ()++spec :: Spec+spec = do++  describe "Servant.API.MatrixParam" $ do++    it "generates correct paths when arguments are not Nothing" $ do+      cliA (Just "alice") `hasRequestPath` "/a;name=alice"+      cliB (Just 3) (Just 2) `hasRequestPath` "/b;foo=3;bar=2"++    it "generates correct paths when arguments are Nothing" $ do+      cliA Nothing `hasRequestPath` "/a"+      cliB Nothing Nothing `hasRequestPath` "/b"++#if MIN_VERSION_servant_client(0,9,0)+    it "generates paths that servant-server understands" $ do+      testWithApplication (return $ serve api server) $ \port -> do+        let res = (,) <$> cliA (Just "There is a there there")+                      <*> cliB (Just 1) (Just 2)+            url = BaseUrl Http "localhost" port ""+        mgr' <- newManager defaultManagerSettings+        runClientM res (ClientEnv mgr' url)+          `shouldReturn` Right ("There is a there there", "3")+#endif+------------------------------------------------------------------------------+-- API+------------------------------------------------------------------------------++type Api =+       WithMatrixParams "a" '[MatrixParam "name" String] :> Get '[JSON] String+  :<|> WithMatrixParams "b" '[MatrixParam "foo" Int, MatrixParam "bar" Int]+         :> Get '[JSON] String++api :: Proxy Api+api = Proxy+++#if MIN_VERSION_servant_client(0,9,0)+server :: Server Api+server = e1 :<|> e2+  where+    e1 name = return $ fromMaybe "" name+    e2 foo bar = return . show $ fromMaybe 0 foo + fromMaybe 0 bar+#endif++------------------------------------------------------------------------------+-- Utils+------------------------------------------------------------------------------++#if MIN_VERSION_servant_client(0,9,0)+hasRequestPath :: ClientM any -> ByteString -> IO ()+#else+hasRequestPath :: (Manager -> BaseUrl -> ClientM any) -> ByteString -> IO ()+#endif+hasRequestPath c expectedPath = do+  let anyBurl = BaseUrl Http "localhost" 6660 ""+#if MIN_VERSION_servant_client(0,9,0)+  _ <- void (runClientM c $ ClientEnv mgr anyBurl)+    `catch` \(_ :: SomeException) -> return ()+#else+  _ <- void (runExceptT $ c mgr anyBurl)+    `catch` \(_ :: SomeException) -> return ()+#endif+  Just r <- readIORef lastRequest+  path r `shouldBe` expectedPath+++lastRequest :: IORef (Maybe Network.HTTP.Client.Request)+lastRequest = unsafePerformIO $ newIORef Nothing+{-# NOINLINE lastRequest #-}+++mgr :: Manager+mgr = unsafePerformIO . newManager $ defaultManagerSettings+  { managerModifyRequest = \req -> writeIORef lastRequest (Just req) >> return req+#if MIN_VERSION_http_client(0,5,0)+  , managerResponseTimeout = responseTimeoutMicro 1+#else+  , managerResponseTimeout = Just 1+#endif+  }+{-# NOINLINE mgr #-}+++++#if MIN_VERSION_servant_client(0,9,0)+cliA :: Maybe String -> ClientM String+cliB :: Maybe Int -> Maybe Int -> ClientM String+#else+cliA :: Maybe String -> Manager -> BaseUrl -> ClientM String+cliB :: Maybe Int -> Maybe Int -> Manager -> BaseUrl -> ClientM String+#endif+cliA :<|> cliB = client api
test/Servant/MatrixParam/ServerSpec.hs view
@@ -24,12 +24,14 @@        WithMatrixParams "a" '[MatrixParam "name" String] :> Get '[PlainText] String   :<|> WithMatrixParams "b" '[MatrixParam "foo" Int, MatrixParam "bar" Int]          :> Get '[PlainText] String+  :<|> WithMatrixParams "c" '[MatrixParam "foo" Int, MatrixFlag "baz", MatrixParam "bar" Int]+         :> Get '[PlainText] String  api :: Proxy Api api = Proxy  server :: Server Api-server = a :<|> b+server = a :<|> b :<|> c   where     a :: Maybe String -> Handler String     a p = return $ show p@@ -37,6 +39,10 @@     b :: Maybe Int -> Maybe Int -> Handler String     b foo bar = return $ show (foo, bar) +    c :: Maybe Int -> Bool -> Maybe Int -> Handler String+    c foo baz bar | baz = return $ show (foo, bar)+                  | otherwise = return ""+ testWithPath :: [Text] -> ByteString -> IO () testWithPath segments expected = do   (flip runSession) (serve api server) $ do@@ -53,6 +59,19 @@     it "allows to retrieve simple matrix parameters" $ do       testWithPath ["a;name=bob"] "Just \"bob\"" +    it "retrieves matrix flags" $ do+      testWithPath ["c;baz"] "(Nothing,Nothing)"+      testWithPath ["c;foo=1;baz"] "(Just 1,Nothing)"+      testWithPath ["c;bar=1;baz"] "(Nothing,Just 1)"+      testWithPath ["c;bar=1;baz;foo=2"] "(Just 2,Just 1)"+      testWithPath ["c;foo=1"] ""++    it "treats 'true' as a flag that's present" $ do+      testWithPath ["c;baz=true"] "(Nothing,Nothing)"++    it "treats '1' as a flag that's present" $ do+      testWithPath ["c;baz=1"] "(Nothing,Nothing)"+     it "allows to omit matrix parameters" $ do       testWithPath ["a"] "Nothing" @@ -62,10 +81,11 @@     it "allows to overwrite matrix params" $ do       testWithPath ["a;name=alice;name=bob"] "Just \"bob\"" +   describe "parsePathSegment" $ do     it "parses a path segment with a matrix param" $ do       parsePathSegment "foo;bar=baz" `shouldBe`-        Just (MatrixSegment "foo" (Just (fromList [("bar", "baz")])))+        Just (MatrixSegment "foo" (Just (fromList [("bar", Just "baz")])))      it "parses a bare segment" $ do       parsePathSegment "foo" `shouldBe`@@ -73,11 +93,12 @@      it "parses a segment with multiple matrix params" $ do       parsePathSegment "foo;bar=baz;huhu=baba" `shouldBe`-        Just (MatrixSegment "foo" (Just (fromList [("bar", "baz"), ("huhu", "baba")])))+        Just (MatrixSegment "foo" (Just (fromList [("bar", Just "baz"),+                                                   ("huhu", Just "baba")])))      it "parses a segment with multiple values for the same matrix param" $ do       parsePathSegment "foo;bar=baz;bar=huhu" `shouldBe`-        Just (MatrixSegment "foo" (Just (fromList [("bar", "huhu")])))+        Just (MatrixSegment "foo" (Just (fromList [("bar", Just "huhu")])))      it "parses a segment with semicolon but without params" $ do       parsePathSegment "foo;" `shouldBe`@@ -89,4 +110,4 @@      it "can parse the empty string as value" $ do       parsePathSegment "foo;bar=" `shouldBe`-        Just (MatrixSegment "foo" (Just (fromList [("bar", "")])))+        Just (MatrixSegment "foo" (Just (fromList [("bar", Just "")])))