7.10 CPP
Including some annoying hacks to work around CPP comments.
This commit is contained in:
parent
f82ca76f7d
commit
7cb2ca05c4
2 changed files with 22 additions and 13 deletions
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
@ -10,7 +11,9 @@
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
module Servant.ClientSpec where
|
module Servant.ClientSpec where
|
||||||
|
|
||||||
import Control.Applicative
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
|
import Control.Applicative ((<$>))
|
||||||
|
#endif
|
||||||
import qualified Control.Arrow as Arrow
|
import qualified Control.Arrow as Arrow
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
|
|
|
@ -10,16 +10,19 @@
|
||||||
#if !MIN_VERSION_base(4,8,0)
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
{-# LANGUAGE OverlappingInstances #-}
|
{-# LANGUAGE OverlappingInstances #-}
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
module Servant.Server.Internal where
|
module Servant.Server.Internal where
|
||||||
|
|
||||||
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
|
import Data.Monoid (Monoid, mappend, mempty)
|
||||||
|
#endif
|
||||||
import Control.Monad.Trans.Either (EitherT, runEitherT)
|
import Control.Monad.Trans.Either (EitherT, runEitherT)
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||||
import Data.List (unfoldr)
|
import Data.List (unfoldr)
|
||||||
import Data.Maybe (catMaybes, fromMaybe)
|
import Data.Maybe (catMaybes, fromMaybe)
|
||||||
import Data.Monoid (Monoid, mappend, mempty)
|
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
import Data.String.Conversions (cs, (<>))
|
import Data.String.Conversions (cs, (<>))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
@ -281,7 +284,7 @@ instance HasServer Delete where
|
||||||
-- If successfully returning a value, we use the type-level list, combined
|
-- If successfully returning a value, we use the type-level list, combined
|
||||||
-- with the request's @Accept@ header, to encode the value for you
|
-- with the request's @Accept@ header, to encode the value for you
|
||||||
-- (returning a status code of 200). If there was no @Accept@ header or it
|
-- (returning a status code of 200). If there was no @Accept@ header or it
|
||||||
-- was @*/*@, we return encode using the first @Content-Type@ type on the
|
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
|
||||||
-- list.
|
-- list.
|
||||||
instance
|
instance
|
||||||
#if MIN_VERSION_base(4,8,0)
|
#if MIN_VERSION_base(4,8,0)
|
||||||
|
@ -296,7 +299,7 @@ instance
|
||||||
e <- runEitherT action
|
e <- runEitherT action
|
||||||
respond $ case e of
|
respond $ case e of
|
||||||
Right output -> do
|
Right output -> do
|
||||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
||||||
Nothing -> failWith UnsupportedMediaType
|
Nothing -> failWith UnsupportedMediaType
|
||||||
Just (contentT, body) -> succeedWith $
|
Just (contentT, body) -> succeedWith $
|
||||||
|
@ -341,7 +344,7 @@ instance
|
||||||
e <- runEitherT action
|
e <- runEitherT action
|
||||||
respond $ case e of
|
respond $ case e of
|
||||||
Right output -> do
|
Right output -> do
|
||||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
headers = getHeaders output
|
headers = getHeaders output
|
||||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
||||||
Nothing -> failWith UnsupportedMediaType
|
Nothing -> failWith UnsupportedMediaType
|
||||||
|
@ -396,7 +399,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
||||||
-- If successfully returning a value, we use the type-level list, combined
|
-- If successfully returning a value, we use the type-level list, combined
|
||||||
-- with the request's @Accept@ header, to encode the value for you
|
-- with the request's @Accept@ header, to encode the value for you
|
||||||
-- (returning a status code of 201). If there was no @Accept@ header or it
|
-- (returning a status code of 201). If there was no @Accept@ header or it
|
||||||
-- was @*/*@, we return encode using the first @Content-Type@ type on the
|
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
|
||||||
-- list.
|
-- list.
|
||||||
instance
|
instance
|
||||||
#if MIN_VERSION_base(4,8,0)
|
#if MIN_VERSION_base(4,8,0)
|
||||||
|
@ -412,7 +415,7 @@ instance
|
||||||
e <- runEitherT action
|
e <- runEitherT action
|
||||||
respond $ case e of
|
respond $ case e of
|
||||||
Right output -> do
|
Right output -> do
|
||||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
||||||
Nothing -> failWith UnsupportedMediaType
|
Nothing -> failWith UnsupportedMediaType
|
||||||
Just (contentT, body) -> succeedWith $
|
Just (contentT, body) -> succeedWith $
|
||||||
|
@ -456,7 +459,7 @@ instance
|
||||||
e <- runEitherT action
|
e <- runEitherT action
|
||||||
respond $ case e of
|
respond $ case e of
|
||||||
Right output -> do
|
Right output -> do
|
||||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
headers = getHeaders output
|
headers = getHeaders output
|
||||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
||||||
Nothing -> failWith UnsupportedMediaType
|
Nothing -> failWith UnsupportedMediaType
|
||||||
|
@ -479,7 +482,7 @@ instance
|
||||||
-- If successfully returning a value, we use the type-level list, combined
|
-- If successfully returning a value, we use the type-level list, combined
|
||||||
-- with the request's @Accept@ header, to encode the value for you
|
-- with the request's @Accept@ header, to encode the value for you
|
||||||
-- (returning a status code of 200). If there was no @Accept@ header or it
|
-- (returning a status code of 200). If there was no @Accept@ header or it
|
||||||
-- was @*/*@, we return encode using the first @Content-Type@ type on the
|
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
|
||||||
-- list.
|
-- list.
|
||||||
instance
|
instance
|
||||||
#if MIN_VERSION_base(4,8,0)
|
#if MIN_VERSION_base(4,8,0)
|
||||||
|
@ -494,7 +497,7 @@ instance
|
||||||
e <- runEitherT action
|
e <- runEitherT action
|
||||||
respond $ case e of
|
respond $ case e of
|
||||||
Right output -> do
|
Right output -> do
|
||||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
||||||
Nothing -> failWith UnsupportedMediaType
|
Nothing -> failWith UnsupportedMediaType
|
||||||
Just (contentT, body) -> succeedWith $
|
Just (contentT, body) -> succeedWith $
|
||||||
|
@ -538,7 +541,7 @@ instance
|
||||||
e <- runEitherT action
|
e <- runEitherT action
|
||||||
respond $ case e of
|
respond $ case e of
|
||||||
Right output -> do
|
Right output -> do
|
||||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
headers = getHeaders output
|
headers = getHeaders output
|
||||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
||||||
Nothing -> failWith UnsupportedMediaType
|
Nothing -> failWith UnsupportedMediaType
|
||||||
|
@ -574,7 +577,7 @@ instance
|
||||||
e <- runEitherT action
|
e <- runEitherT action
|
||||||
respond $ case e of
|
respond $ case e of
|
||||||
Right output -> do
|
Right output -> do
|
||||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
||||||
Nothing -> failWith UnsupportedMediaType
|
Nothing -> failWith UnsupportedMediaType
|
||||||
Just (contentT, body) -> succeedWith $
|
Just (contentT, body) -> succeedWith $
|
||||||
|
@ -618,7 +621,7 @@ instance
|
||||||
e <- runEitherT action
|
e <- runEitherT action
|
||||||
respond $ case e of
|
respond $ case e of
|
||||||
Right outpatch -> do
|
Right outpatch -> do
|
||||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
headers = getHeaders outpatch
|
headers = getHeaders outpatch
|
||||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
|
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
|
||||||
Nothing -> failWith UnsupportedMediaType
|
Nothing -> failWith UnsupportedMediaType
|
||||||
|
@ -929,3 +932,6 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
|
||||||
_ -> respond $ failWith NotFound
|
_ -> respond $ failWith NotFound
|
||||||
|
|
||||||
where proxyPath = Proxy :: Proxy path
|
where proxyPath = Proxy :: Proxy path
|
||||||
|
|
||||||
|
ct_wildcard :: B.ByteString
|
||||||
|
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
|
||||||
|
|
Loading…
Reference in a new issue