{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.Streaming.ClientSpec (spec) where

import           Control.Monad.Trans.Resource (ResourceT, runResourceT)
import qualified Data.ByteString              as BS
import qualified Data.ByteString.Char8        as BSC
import qualified Data.ByteString.Lazy.Char8   as BSCL
import           GHC.Stats
import           Network.HTTP.Client          (defaultManagerSettings,
                                               newManager)
import qualified Network.HTTP.Media           as M
import           Network.Wai.Handler.Warp
import           Servant                      ((:<|>) ((:<|>)), (:>), JSON,
                                               MimeRender (..),
                                               MimeUnrender (..), PlainText,
                                               Post, Proxy (..), Server, serve)
import           Servant.Client
import           Servant.Streaming.Client
import           Servant.Streaming.Server     ()
import           Streaming
import qualified Streaming.Prelude            as S
import           Test.Hspec

spec :: Spec
spec = do
  streamBodySpec
  {-streamResponseSpec-}

streamBodySpec :: Spec
streamBodySpec = describe "StreamBody instance" $ around withServer $ do

  it "streams the request body" $ \port' -> do
    runClient port' (lengthC ("application" M.// "json", S.each ["h","i"]))
      `shouldReturn` Right 2

  it "does not keep the request in memory" $ \port' -> do
    let bd = S.replicate 1000 (BSC.replicate megabyte 'a') -- 1000 MB total
    runClient port' (lengthC ("application" M.// "json", bd))
      `shouldReturn` Right (1000 * megabyte)
    bytes <- max_live_bytes <$> getRTSStats
    bytes < 100 * megabyte `shouldBe` True

------------------------------------------------------------------------------
-- API

type API
  =    "length" :> StreamBody '[JSON] :> Post '[JSON] Int
  :<|> "contentType" :> StreamBody '[JSON, PlainText] :> Post '[PlainText] M.MediaType
  :<|> "echo" :> StreamBody '[JSON] :> StreamResponsePost '[JSON]

api :: Proxy API
api = Proxy

server :: Server API
server = lengthH :<|> contentTypeH :<|> echoH
  where
    lengthH      (_contentType, stream')
      = liftIO . runResourceT $ S.sum_ $ S.subst (\x -> BS.length x :> ()) stream'
    contentTypeH (contentType, _stream')
      = return contentType
    echoH        (_contentType, stream')
      = return stream'

withServer :: (Port -> IO ()) -> IO ()
withServer = testWithApplicationSettings settings (return $ serve api server)
  where
    settings = setTimeout 1000 defaultSettings

lengthC
  :: (M.MediaType, Stream (Of BS.ByteString) (ResourceT IO) ())
  -> ClientM Int
_contentTypeC
  :: (M.MediaType, Stream (Of BS.ByteString) (ResourceT IO) ())
  -> ClientM M.MediaType
_echoC
  :: (M.MediaType, Stream (Of BS.ByteString) (ResourceT IO) ())
  -> ClientM (Stream (Of BS.ByteString) (ResourceT IO) ())
lengthC :<|> _contentTypeC :<|> _echoC
  = client api

------------------------------------------------------------------------------
-- Utils

runClient  :: Port -> ClientM a -> IO (Either ServantError a)
runClient p action = do
  mgr <- newManager defaultManagerSettings
  let env = ClientEnv
        { manager = mgr
        , baseUrl = BaseUrl Http "localhost" p ""
        , cookieJar = Nothing
        }
  runClientM action env

megabyte :: Num a => a
megabyte = 1000 ^ (2 :: Int)

------------------------------------------------------------------------------
-- Orphans

instance Show a => MimeRender PlainText a where
  mimeRender _ = BSCL.pack . show
instance Read a => MimeUnrender PlainText a where
  mimeUnrender _ = error . BSCL.unpack

instance Read M.MediaType where
  readsPrec _ x = case M.parseAccept (BSC.pack x) of
    Nothing -> error $ show x
    Just y -> [(y, "")]