eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

add tests, fix to make tests work

Browse source
This commit is contained in:
Gershom 2017-11-04 00:10:29 -04:00
parent 0c77a2b4b0
commit 38e87397e7
6 changed files with 143 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs
View file

@ -267,7 +267,7 @@ instance OVERLAPPABLE_
}
return . buildFromStream $ ResultStream $ \k ->
runStreamingResponse sresp $ \(status,_headers,_httpversion,reader) -> do
when (H.statusCode status /= 200) $ error "bad status" --fixme
when (H.statusCode status /= 200) $ error "bad status" -- TODO fixme
let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)
loop bs = do
res <- BL.fromStrict <$> reader
@ -283,9 +283,11 @@ instance OVERLAPPABLE_
res <- BL.fromStrict <$> reader
let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))
if BL.null res
then return . addIsEmptyInfo $ parseEOF frameParser res
then if BL.null bs
then return ("", (Right "", True))
else return . addIsEmptyInfo $ parseEOF frameParser bs
else let sofar = (bs <> res)
in case parseIncremental frameParser res of
in case parseIncremental frameParser sofar of
Just x -> return $ addIsEmptyInfo x
Nothing -> frameLoop sofar

1
servant-client/servant-client.cabal
View file

@ -66,6 +66,7 @@ test-suite spec
main-is: Spec.hs
other-modules:
Servant.ClientSpec
Servant.StreamSpec
build-depends:
base == 4.*
, aeson

2
servant-client/test/Servant/ClientSpec.hs
View file

@ -24,7 +24,7 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#include "overlapping-compat.h"
module Servant.ClientSpec (spec) where
module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
import Prelude ()
import Prelude.Compat

113
servant-client/test/Servant/StreamSpec.hs Normal file
View file

@ -0,0 +1,113 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
#else
{-# OPTIONS_GHC -fcontext-stack=100 #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#include "overlapping-compat.h"
module Servant.StreamSpec (spec) where
import Prelude ()
import Prelude.Compat
import Data.Proxy
import qualified Network.HTTP.Client as C
import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec
import Servant.API ((:<|>) ((:<|>)),
(:>),
EmptyAPI, JSON,
StreamGet,
NewlineFraming,
NetstringFraming,
ResultStream(..),
StreamGenerator(..))
import Servant.Client
import Servant.Server
import qualified Servant.ClientSpec as CS
import Servant.ClientSpec (Person(..))
spec :: Spec
spec = describe "Servant.Stream" $ do
streamSpec
type StreamApi f =
"streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)
:<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)
:<|> EmptyAPI
capi :: Proxy (StreamApi ResultStream)
capi = Proxy
sapi :: Proxy (StreamApi StreamGenerator)
sapi = Proxy
getGetNL :<|> getGetNS :<|> EmptyClient = client capi
getGetNL :: ClientM (ResultStream Person)
getGetNS :: ClientM (ResultStream Person)
alice :: Person
alice = Person "Alice" 42
bob :: Person
bob = Person "Bob" 25
server :: Application
server = serve sapi (
(return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
:: Handler (StreamGenerator Person))
:<|>
(return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
:: Handler (StreamGenerator Person))
:<|>
emptyServer)
{-# NOINLINE manager' #-}
manager' :: C.Manager
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')
runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a))
runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act
streamSpec :: Spec
streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
Right res <- runClient getGetNL baseUrl
let jra = Just (Right alice)
jrb = Just (Right bob)
runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
Right res <- runClient getGetNS baseUrl
let jra = Just (Right alice)
jrb = Just (Right bob)
runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)

6
servant/src/Servant/API.hs
View file

@ -83,13 +83,15 @@ import Servant.API.IsSecure (IsSecure (..))
import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams)
import Servant.API.Raw (Raw)
import Servant.API.Stream (Stream, StreamGenerator (..),
import Servant.API.Stream (Stream, StreamGet, StreamPost,
StreamGenerator (..),
ToStreamGenerator (..),
ResultStream(..), BuildFromStream (..),
ByteStringParser (..),
FramingRender (..), BoundaryStrategy (..),
FramingUnrender (..),
NewlineFraming)
NewlineFraming,
NetstringFraming)
import Servant.API.RemoteHost (RemoteHost)
import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,

24
servant/src/Servant/API/Stream.hs
View file

@ -14,9 +14,12 @@ module Servant.API.Stream where
import Data.ByteString.Lazy (ByteString, empty)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Monoid ((<>))
import Data.Proxy (Proxy)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Text.Read (readMaybe)
import Data.Bifunctor (first)
import Network.HTTP.Types.Method (StdMethod (..))
-- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Steam endpoints always return response code 200 on success. Type synonyms are provided for standard methods.
@ -93,15 +96,22 @@ data NetstringFraming
instance FramingRender NetstringFraming a where
header _ _ = empty
boundary _ _ = BoundaryStrategyBracket $ \b -> (LB.pack . show . LB.length $ b, "")
boundary _ _ = BoundaryStrategyBracket $ \b -> ((<> ":") . LB.pack . show . LB.length $ b, ",")
trailer _ _ = empty
{-
instance FramingUnrender NetstringFraming a where
unrenderFrames _ _ = (, \b -> let (i,r) = LB.break (==':') b
unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
where go = ByteStringParser
(\b -> let (i,r) = LB.break (==':') b
in case readMaybe (LB.unpack i) of
Just len -> first Right $ LB.splitAt len . LB.drop 1 $ r
Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r)
)
-}
Just len -> if LB.length r > len
then Just . first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r
else Nothing
Nothing -> Just (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))
(\b -> let (i,r) = LB.break (==':') b
in case readMaybe (LB.unpack i) of
Just len -> if LB.length r > len
then first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r
else (Right $ LB.take len r, LB.empty)
Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))