Merge pull request #36 from alpmestan/some_refactorings

Client instance for Raw, API documentation serving, some refactoring.

example/greet.hs

@@ -46,9 +46,7 @@ instance ToParam (QueryParam "capital" Bool) where
                   Normal
 
 instance ToSample Greet where
-  toSample Proxy = Just (encode g)
-
-    where g = Greet "Hello, haskeller!"
+  toSample = Just $ Greet "Hello, haskeller!"
 
 -- API specification
 type TestApi =
@@ -104,4 +102,4 @@ main = do
   print =<< runEitherT (deleteGreet "blah" uri)
   killThread tid
   putStrLn "\n---------\n"
-  printMarkdown docsGreet
+  putStrLn $ markdown docsGreet

servant.cabal

@@ -80,7 +80,7 @@ executable greet
 test-suite spec
   type: exitcode-stdio-1.0
   ghc-options:
-    -Wall -Werror -fno-warn-name-shadowing -fno-warn-missing-signatures
+    -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
   default-language: Haskell2010
   hs-source-dirs: test
   main-is: Spec.hs

src/Servant/API/Delete.hs

@@ -39,7 +39,7 @@ instance HasClient Delete where
   type Client Delete = BaseUrl -> EitherT String IO ()
 
   clientWithRoute Proxy req host =
-    performRequest methodDelete req 204 host
+    performRequestJSON methodDelete req 204 host
 
 instance HasDocs Delete where
   docsFor Proxy (endpoint, action) =

src/Servant/API/Get.hs

@@ -39,12 +39,12 @@ instance ToJSON result => HasServer (Get result) where
 instance FromJSON result => HasClient (Get result) where
   type Client (Get result) = BaseUrl -> EitherT String IO result
   clientWithRoute Proxy req host =
-    performRequest methodGet req 200 host
+    performRequestJSON methodGet req 200 host
 
 instance ToSample a => HasDocs (Get a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
 
     where endpoint' = endpoint & method .~ DocGET
-          action' = action & response.respBody .~ toSample p
+          action' = action & response.respBody .~ sampleByteString p
           p = Proxy :: Proxy a

src/Servant/API/Post.hs

@@ -42,7 +42,7 @@ instance FromJSON a => HasClient (Post a) where
   type Client (Post a) = BaseUrl -> EitherT String IO a
 
   clientWithRoute Proxy req uri =
-    performRequest methodPost req 201 uri
+    performRequestJSON methodPost req 201 uri
 
 instance ToSample a => HasDocs (Post a) where
   docsFor Proxy (endpoint, action) =
@@ -50,7 +50,7 @@ instance ToSample a => HasDocs (Post a) where
 
     where endpoint' = endpoint & method .~ DocPOST
 
-          action' = action & response.respBody .~ toSample p
+          action' = action & response.respBody .~ sampleByteString p
                            & response.respStatus .~ 201
 
           p = Proxy :: Proxy a

src/Servant/API/Put.hs

@@ -41,7 +41,7 @@ instance FromJSON a => HasClient (Put a) where
   type Client (Put a) = BaseUrl -> EitherT String IO a
 
   clientWithRoute Proxy req host =
-    performRequest methodPut req 200 host
+    performRequestJSON methodPut req 200 host
 
 instance ToSample a => HasDocs (Put a) where
   docsFor Proxy (endpoint, action) =
@@ -49,7 +49,7 @@ instance ToSample a => HasDocs (Put a) where
 
     where endpoint' = endpoint & method .~ DocPUT
 
-          action' = action & response.respBody .~ toSample p
+          action' = action & response.respBody .~ sampleByteString p
                            & response.respStatus .~ 200
 
           p = Proxy :: Proxy a

src/Servant/API/Raw.hs

@@ -1,10 +1,17 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
 module Servant.API.Raw where
 
+import Control.Monad.Trans.Either
+import Data.ByteString.Lazy
 import Data.Proxy
+import Network.HTTP.Types
 import Network.Wai
-import Servant.Docs
+import Servant.Client
+import Servant.Common.BaseUrl
+import Servant.Common.Req
+import Servant.Docs hiding (Method)
 import Servant.Server
 
 -- | Endpoint for plugging in your own Wai 'Application's.
@@ -18,6 +25,14 @@ instance HasServer Raw where
   route Proxy rawApplication request respond =
     rawApplication request (respond . succeedWith)
 
+instance HasClient Raw where
+  type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)
+
+  clientWithRoute :: Proxy Raw -> Req -> Client Raw
+  clientWithRoute Proxy req method host =
+    performRequest method req (const True) host
+
+
 instance HasDocs Raw where
   docsFor _proxy (endpoint, action) =
     single endpoint action

src/Servant/API/ReqBody.hs

@@ -48,5 +48,5 @@ instance (ToSample a, HasDocs sublayout)
 
     where sublayoutP = Proxy :: Proxy sublayout
 
-          action' = action & rqbody .~ toSample p
+          action' = action & rqbody .~ sampleByteString p
           p = Proxy :: Proxy a

src/Servant/Common/Req.hs

@@ -77,12 +77,17 @@ __withGlobalManager action = modifyMVar __manager $ \ manager -> do
   result <- action manager
   return (manager, result)
 
-performRequest :: FromJSON result =>
-  Method -> Req -> Int -> BaseUrl -> EitherT String IO result
-performRequest method req wantedStatus host = do
+
+displayHttpRequest :: Method -> String
+displayHttpRequest method = "HTTP " ++ cs method ++ " request"
+
+
+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)
+performRequest method req isWantedStatus host = do
   partialRequest <- liftIO $ reqToRequest req host
 
   let request = partialRequest { Client.method = method
+                               , checkStatus = \ _status _headers _cookies -> Nothing
                                }
 
   eResponse <- liftIO $ __withGlobalManager $ \ manager ->
@@ -90,22 +95,28 @@ performRequest method req wantedStatus host = do
     Client.httpLbs request manager
   case eResponse of
     Left status ->
-      left (requestString ++ " failed with status: " ++ showStatus status)
+      left (displayHttpRequest method ++ " failed with status: " ++ showStatus status)
 
     Right response -> do
       let status = Client.responseStatus response
-      when (statusCode status /= wantedStatus) $
-        left (requestString ++ " failed with status: " ++ showStatus status)
-      result <- either
-        (\ message -> left (requestString ++ " returned invalid json: " ++ message))
-        return
-        (decodeLenient (Client.responseBody response))
-      return result
+      unless (isWantedStatus (statusCode status)) $
+        left (displayHttpRequest method ++ " failed with status: " ++ showStatus status)
+      return $ (statusCode status, Client.responseBody response)
   where
-    requestString = "HTTP " ++ cs method ++ " request"
     showStatus (Status code message) =
       show code ++ " - " ++ cs message
 
+
+performRequestJSON :: FromJSON result =>
+  Method -> Req -> Int -> BaseUrl -> EitherT String IO result
+performRequestJSON method req wantedStatus host = do
+  (_status, responseBody) <- performRequest method req (== wantedStatus) host
+  either
+    (\ message -> left (displayHttpRequest method ++ " returned invalid json: " ++ message))
+    return
+    (decodeLenient responseBody)
+
+
 catchStatusCodeException :: IO a -> IO (Either Status a)
 catchStatusCodeException action = catch (Right <$> action) $
   \ e -> case e of

src/Servant/Docs.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 -------------------------------------------------------------------------------
@@ -15,13 +16,13 @@
 --
 -- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@
 --
--- You can then call 'printMarkdown' on it:
+-- You can then call 'markdown' on it:
 --
--- @printMarkdown :: 'API' -> IO ()@
+-- @printMarkdown :: 'API' -> String@
 --
 -- or define a custom pretty printer:
 --
--- @yourPrettyDocs :: 'API' -> IO () -- or blaze-html's HTML, or ...@
+-- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@
 --
 -- The only thing you'll need to do will be to implement some classes
 -- for your captures, get parameters and request or response bodies.
@@ -69,7 +70,7 @@
 -- >   toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
 -- >
 -- > -- API specification
--- > type TestApi = 
+-- > type TestApi =
 -- >        "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
 -- >   :<|> "greet" :> RQBody Greet :> Post Greet
 -- >   :<|> "delete" :> Capture "greetid" Text :> Delete
@@ -82,13 +83,16 @@
 -- > greetDocs = docs testApi
 -- >
 -- > main :: IO ()
--- > main = printMarkdown greetDocs
+-- > main = putStrLn $ markdown greetDocs
 module Servant.Docs
   ( -- * 'HasDocs' class and key functions
-    HasDocs(..), docs, markdown, printMarkdown
+    HasDocs(..), docs, markdown
 
   , -- * Classes you need to implement for your types
-    ToSample(..), ToParam(..), ToCapture(..)
+    ToSample(..)
+  , sampleByteString
+  , ToParam(..)
+  , ToCapture(..)
 
   , -- * ADTs to represent an 'API'
     Method(..)
@@ -320,7 +324,13 @@ class HasDocs layout where
 -- >
 -- >     where g = Greet "Hello, haskeller!"
 class ToJSON a => ToSample a where
-  toSample :: Proxy a -> Maybe ByteString
+  toSample :: Maybe a
+
+instance ToSample () where
+  toSample = Just ()
+
+sampleByteString :: forall a . ToSample a => Proxy a -> Maybe ByteString
+sampleByteString Proxy = fmap encode (toSample :: Maybe a)
 
 -- | The class that helps us automatically get documentation
 --   for GET parameters.
@@ -345,11 +355,8 @@ class ToParam t where
 class ToCapture c where
   toCapture :: Proxy c -> DocCapture
 
--- | Print documentation in Markdown format for
---   the given 'API', on standard output.
-printMarkdown :: API -> IO ()
-printMarkdown = print . markdown
-
+-- | Generate documentation in Markdown format for
+--   the given 'API'.
 markdown :: API -> String
 markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList
 

src/Servant/Utils/StaticFiles.hs

@@ -26,8 +26,8 @@ toHtml :: String -> String
 toHtml markdown =
   "<html>" ++
   "<body>" ++
-  "<verbatim>" ++
+  "<pre>" ++
   markdown ++
-  "</verbatim>" ++
+  "</pre>" ++
   "</body>" ++
   "</html>"

test/Servant/ClientSpec.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Servant.ClientSpec where
@@ -8,10 +9,12 @@ module Servant.ClientSpec where
 import Control.Concurrent
 import Control.Exception
 import Control.Monad.Trans.Either
+import Data.ByteString.Lazy (ByteString)
 import Data.Char
 import Data.Foldable (forM_)
 import Data.Proxy
 import Data.Typeable
+import Network.HTTP.Types
 import Network.Socket
 import Network.Wai
 import Network.Wai.Handler.Warp
@@ -33,6 +36,8 @@ type Api =
   :<|> "param" :> QueryParam "name" String :> Get Person
   :<|> "params" :> QueryParams "names" String :> Get [Person]
   :<|> "flag" :> QueryFlag "flag" :> Get Bool
+  :<|> "rawSuccess" :> Raw
+  :<|> "rawFailure" :> Raw
   :<|> "multiple" :>
             Capture "first" String :>
             QueryParam "second" Int :>
@@ -53,6 +58,8 @@ server = serve api (
                    Nothing -> left (400, "missing parameter"))
   :<|> (\ names -> return (zipWith Person names [0..]))
   :<|> return
+  :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
+  :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
   :<|> \ a b c d -> return (a, b, c, d)
  )
 
@@ -65,6 +72,8 @@ getBody :: Person -> BaseUrl -> EitherT String IO Person
 getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person
 getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]
 getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool
+getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
+getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
 getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
   -> BaseUrl
   -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])
@@ -74,6 +83,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
  :<|> getQueryParam
  :<|> getQueryParams
  :<|> getQueryFlag
+ :<|> getRawSuccess
+ :<|> getRawFailure
  :<|> getMultiple)
     = client api
 
@@ -104,6 +115,12 @@ spec = do
     it (show flag) $ withServer $ \ host -> do
       runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
 
+  it "Servant.API.Raw on success" $ withServer $ \ host -> do
+    runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess")
+
+  it "Servant.API.Raw on failure" $ withServer $ \ host -> do
+    runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure")
+
   modifyMaxSuccess (const 20) $ do
     it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
       property $ forAllShrink pathGen shrink $ \ a -> \ b c d ->

test/Servant/ServerSpec.hs

@@ -44,7 +44,7 @@ data Person = Person {
 instance ToJSON Person
 instance FromJSON Person
 instance ToSample Person where
-  toSample _proxy = Just $ encode alice
+  toSample = Just alice
 
 alice :: Person
 alice = Person "Alice" 42