Merge pull request #1262 from haskell-servant/rawQueryString

Refactor of #1249

Author: phadej

changelog.d/pr1249

@@ -0,0 +1,14 @@
+synopsis: use queryString to parse QueryParam, QueryParams and QueryFlag
+packages: servant-server
+prs: #1249
+description: {
+
+Some APIs need query parameters rewriting, e.g. in order to support
+ for multiple casing (camel, snake, etc) or something to that effect.
+
+This could be easily achieved by using WAI Middleware and modyfing
+request's `Query`. But QueryParam, QueryParams and QueryFlag use
+`rawQueryString`. By using `queryString` rather then `rawQueryString`
+we can enable such rewritings.
+
+}

servant-server/src/Servant/Server/Internal.hs

@@ -64,7 +64,7 @@ import           Network.Socket
                  (SockAddr)
 import           Network.Wai
                  (Application, Request, httpVersion, isSecure, lazyRequestBody,
-                 rawQueryString, remoteHost, requestBody, requestHeaders,
+                 queryString, remoteHost, requestBody, requestHeaders,
                  requestMethod, responseLBS, responseStream, vault)
 import           Prelude ()
 import           Prelude.Compat
@@ -452,7 +452,7 @@ instance
   hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
 
   route Proxy context subserver =
-    let querytext req = parseQueryText $ rawQueryString req
+    let querytext = queryToQueryText . queryString
         paramname = cs $ symbolVal (Proxy :: Proxy sym)
 
         parseParam :: Request -> DelayedIO (RequestArgument mods a)
@@ -519,8 +519,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
           params :: [T.Text]
           params = mapMaybe snd
                  . filter (looksLikeParam . fst)
-                 . parseQueryText
-                 . rawQueryString
+                 . queryToQueryText 
+                 . queryString                 
                  $ req
 
           looksLikeParam name = name == paramname || name == (paramname <> "[]")
@@ -546,7 +546,7 @@ instance (KnownSymbol sym, HasServer api context)
   hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
 
   route Proxy context subserver =
-    let querytext r = parseQueryText $ rawQueryString r
+    let querytext = queryToQueryText . queryString
         param r = case lookup paramname (querytext r) of
           Just Nothing  -> True  -- param is there, with no value
           Just (Just v) -> examine v -- param with a value

servant-server/test/Servant/ServerSpec.hs

@@ -25,6 +25,8 @@ import qualified Data.ByteString                   as BS
 import qualified Data.ByteString.Base64            as Base64
 import           Data.Char
                  (toUpper)
+import           Data.Maybe
+                 (fromMaybe)
 import           Data.Proxy
                  (Proxy (Proxy))
 import           Data.String
@@ -35,26 +37,26 @@ import qualified Data.Text                         as T
 import           GHC.Generics
                  (Generic)
 import           Network.HTTP.Types
-                 (Status (..), hAccept, hContentType, imATeapot418,
+                 (QueryItem, Status (..), hAccept, hContentType, imATeapot418,
                  methodDelete, methodGet, methodHead, methodPatch, methodPost,
                  methodPut, ok200, parseQuery)
 import           Network.Wai
-                 (Application, Request, pathInfo, queryString, rawQueryString,
-                 requestHeaders, responseLBS)
+                 (Application, Middleware, Request, pathInfo, queryString,
+                 rawQueryString, requestHeaders, responseLBS)
 import           Network.Wai.Test
                  (defaultRequest, request, runSession, simpleBody,
                  simpleHeaders, simpleStatus)
 import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
-                 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, Lenient, Strict, Delete,
-                 EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),
-                 JSON, NoContent (..), NoFraming, OctetStream, Patch,
-                 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
-                 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,
-                 NoContentVerb, addHeader)
+                 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
+                 Delete, EmptyAPI, Get, Header, Headers, HttpVersion,
+                 IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
+                 NoFraming, OctetStream, Patch, PlainText, Post, Put,
+                 QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,
+                 SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
-                 emptyServer, err400, err401, err403, err404, serve, serveWithContext)
+                 emptyServer, err401, err403, err404, serve, serveWithContext)
 import           Servant.Test.ComprehensiveAPI
 import qualified Servant.Types.SourceT             as S
 import           Test.Hspec
@@ -218,7 +220,7 @@ captureServer = getLegs :<|> getEars :<|> getEyes
           _ -> throwError err404
 
         getEars :: Either String Integer -> Handler Animal
-        getEars (Left e) = return chimera -- ignore integer parse error, return weird animal
+        getEars (Left _) = return chimera -- ignore integer parse error, return weird animal
         getEars (Right 2) = return jerry
         getEars (Right _) = throwError err404
 
@@ -339,117 +341,123 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAge
         queryParamServer (Just name_) = return alice{name = name_}
         queryParamServer Nothing = return alice
 
+
+
 queryParamSpec :: Spec
 queryParamSpec = do
+  let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
+        { rawQueryString = params
+        , queryString    = parseQuery params
+        , pathInfo       = pinfo
+        }
+
   describe "Servant.API.QueryParam" $ do
       it "allows retrieving simple GET parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
-          let params1 = "?name=bob"
-          response1 <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params1,
-            queryString = parseQuery params1
-           }
-          liftIO $ do
-            decode' (simpleBody response1) `shouldBe` Just alice{
-              name = "bob"
-             }
+        flip runSession (serve queryParamApi qpServer) $ do
+          response1 <- mkRequest "?name=bob" []
+          liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
+            { name = "bob"
+            }
 
       it "allows retrieving lists in GET parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
-          let params2 = "?names[]=bob&names[]=john"
-          response2 <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params2,
-            queryString = parseQuery params2,
-            pathInfo = ["a"]
-           }
-          liftIO $
-            decode' (simpleBody response2) `shouldBe` Just alice{
-              name = "john"
-             }
+        flip runSession (serve queryParamApi qpServer) $ do
+          response2 <- mkRequest "?names[]=bob&names[]=john" ["a"]
+          liftIO $ decode' (simpleBody response2) `shouldBe` Just alice
+            { name = "john"
+            }
 
       it "parses a query parameter" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
-        let params = "?age=55"
-        response <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params,
-            queryString = parseQuery params,
-            pathInfo = ["param"]
-           }
-        liftIO $
-            decode' (simpleBody response) `shouldBe` Just alice{
-              age = 55
-            }
+        flip runSession (serve queryParamApi qpServer) $ do
+        response <- mkRequest "?age=55" ["param"]
+        liftIO $ decode' (simpleBody response) `shouldBe` Just alice
+          { age = 55
+          }
 
       it "generates an error on query parameter parse failure" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
-        let params = "?age=foo"
-        response <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params,
-            queryString = parseQuery params,
-            pathInfo = ["param"]
-           }
+        flip runSession (serve queryParamApi qpServer) $ do
+        response <- mkRequest "?age=foo" ["param"]
         liftIO $ statusCode (simpleStatus response) `shouldBe` 400
         return ()
 
       it "parses multiple query parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
-        let params = "?ages=10&ages=22"
-        response <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params,
-            queryString = parseQuery params,
-            pathInfo = ["multiparam"]
-           }
-        liftIO $
-            decode' (simpleBody response) `shouldBe` Just alice{
-              age = 32
-            }
+        flip runSession (serve queryParamApi qpServer) $ do
+        response <- mkRequest "?ages=10&ages=22" ["multiparam"]
+        liftIO $ decode' (simpleBody response) `shouldBe` Just alice
+          { age = 32
+          }
 
       it "generates an error on parse failures of multiple parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
-        let params = "?ages=2&ages=foo"
-        response <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params,
-            queryString = parseQuery params,
-            pathInfo = ["multiparam"]
-           }
+        flip runSession (serve queryParamApi qpServer) $ do
+        response <- mkRequest "?ages=2&ages=foo" ["multiparam"]
         liftIO $ statusCode (simpleStatus response) `shouldBe` 400
         return ()
 
-
       it "allows retrieving value-less GET parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
-          let params3 = "?capitalize"
-          response3 <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params3,
-            queryString = parseQuery params3,
-            pathInfo = ["b"]
-           }
-          liftIO $
-            decode' (simpleBody response3) `shouldBe` Just alice{
-              name = "ALICE"
-             }
-
-          let params3' = "?capitalize="
-          response3' <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params3',
-            queryString = parseQuery params3',
-            pathInfo = ["b"]
-           }
-          liftIO $
-            decode' (simpleBody response3') `shouldBe` Just alice{
-              name = "ALICE"
-             }
-
-          let params3'' = "?unknown="
-          response3'' <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params3'',
-            queryString = parseQuery params3'',
-            pathInfo = ["b"]
-           }
-          liftIO $
-            decode' (simpleBody response3'') `shouldBe` Just alice{
-              name = "Alice"
-             }
+        flip runSession (serve queryParamApi qpServer) $ do
+          response3 <- mkRequest "?capitalize" ["b"]
+          liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
+            { name = "ALICE"
+            }
+
+          response3' <- mkRequest "?capitalize=" ["b"]
+          liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
+            { name = "ALICE"
+            }
+
+          response3'' <- mkRequest "?unknown=" ["b"]
+          liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
+            { name = "Alice"
+            }
+
+      describe "Uses queryString instead of rawQueryString" $ do
+        -- test query parameters rewriter
+        let queryRewriter :: Middleware
+            queryRewriter app req = app req
+                { queryString = fmap rewrite $ queryString req
+                }
+              where
+                rewrite :: QueryItem -> QueryItem
+                rewrite (k, v) = (fromMaybe k (BS.stripPrefix "person_" k), v)
+
+        let app = queryRewriter $ serve queryParamApi qpServer
+
+        it "allows rewriting for simple GET/query parameters" $
+          flip runSession app $ do
+            response1 <- mkRequest "?person_name=bob" []
+            liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
+              { name = "bob"
+              }
+
+        it "allows rewriting for lists in GET parameters" $
+          flip runSession app $ do
+            response2 <- mkRequest "?person_names[]=bob&person_names[]=john" ["a"]
+            liftIO $ decode' (simpleBody response2) `shouldBe` Just alice
+              { name = "john"
+              }
+
+        it "allows rewriting when parsing multiple query parameters" $
+          flip runSession app $ do
+            response <- mkRequest "?person_ages=10&person_ages=22" ["multiparam"]
+            liftIO $ decode' (simpleBody response) `shouldBe` Just alice
+              { age = 32
+              }
+
+        it "allows retrieving value-less GET parameters" $
+          flip runSession app $ do
+            response3 <- mkRequest "?person_capitalize" ["b"]
+            liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
+              { name = "ALICE"
+              }
+
+            response3' <- mkRequest "?person_capitalize=" ["b"]
+            liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
+              { name = "ALICE"
+              }
+
+            response3'' <- mkRequest "?person_unknown=" ["b"]
+            liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
+              { name = "Alice"
+              }
 
 -- }}}
 ------------------------------------------------------------------------------
@@ -544,15 +552,15 @@ rawSpec :: Spec
 rawSpec = do
   describe "Servant.API.Raw" $ do
     it "runs applications" $ do
-      (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
+      flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
         response <- Network.Wai.Test.request defaultRequest{
           pathInfo = ["foo"]
          }
         liftIO $ do
           simpleBody response `shouldBe` "42"
 
     it "gets the pathInfo modified" $ do
-      (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
+      flip runSession (serve rawApi (rawApplication pathInfo)) $ do
         response <- Network.Wai.Test.request defaultRequest{
           pathInfo = ["foo", "bar"]
          }