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

Remove 'default' status code from HttpMethod type

Browse source 
Instead we use a type family to set this, where it's needed (for
backwards compatibility).
This commit is contained in:
George Pollard 2015-08-14 07:56:11 +12:00
parent 1342052a4f
commit 46bff31239
8 changed files with 36 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
servant-server/src/Servant/Server/Internal.hs
View file

@ -43,7 +43,7 @@ import Network.Wai (Application, lazyRequestBody,
requestMethod, responseLBS, remoteHost,
isSecure, vault, httpVersion, Response,
Request)
import Servant.API ((:<|>) (..), (:>), Capture,
import Servant.API ((:<|>) (..), (:>), Capture, DefaultStatusCode,
Header, HttpMethod, IsSecure(..),
MatrixFlag, MatrixParam, MatrixParams,
QueryFlag, QueryParam, QueryParams,
@ -236,25 +236,24 @@ instance
#endif
( AllCTRender ctypes a
, KnownSymbol method
, KnownNat status
) => HasServer (HttpMethod method status ctypes a) where
, KnownNat (DefaultStatusCode method)
) => HasServer (HttpMethod method ctypes a) where
type ServerT (HttpMethod method status ctypes a) m = m a
type ServerT (HttpMethod method ctypes a) m = m a
route Proxy = methodRouter method (Proxy :: Proxy ctypes) status
where
method = B8.pack $ symbolVal (Proxy :: Proxy method)
status = toEnum $ fromInteger $ natVal (Proxy :: Proxy status)
status = toEnum $ fromInteger $ natVal (Proxy :: Proxy (DefaultStatusCode method))
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( KnownSymbol method
, KnownNat status
) => HasServer (HttpMethod method status ctypes ()) where
) => HasServer (HttpMethod method ctypes ()) where
type ServerT (HttpMethod method status ctypes ()) m = m ()
type ServerT (HttpMethod method ctypes ()) m = m ()
route Proxy = methodRouterEmpty method
where
@ -269,15 +268,15 @@ instance
( GetHeaders (Headers h v)
, AllCTRender ctypes v
, KnownSymbol method
, KnownNat status
) => HasServer (HttpMethod method status ctypes (Headers h v)) where
, KnownNat (DefaultStatusCode method)
) => HasServer (HttpMethod method ctypes (Headers h v)) where
type ServerT (HttpMethod method status ctypes (Headers h v)) m = m (Headers h v)
type ServerT (HttpMethod method ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where
method = B8.pack $ symbolVal (Proxy :: Proxy method)
status = toEnum $ fromInteger $ natVal (Proxy :: Proxy status)
status = toEnum $ fromInteger $ natVal (Proxy :: Proxy (DefaultStatusCode method))
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

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

@ -75,7 +75,7 @@ import Servant.API.HttpVersion (HttpVersion (..))
import Servant.API.IsSecure (IsSecure (..))
import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
MatrixParams)
import Servant.API.Methods (HttpMethod)
import Servant.API.Methods (DefaultStatusCode, HttpMethod)
import Servant.API.Patch (Patch)
import Servant.API.Post (Post)
import Servant.API.Put (Put)

5
servant/src/Servant/API/Delete.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Delete (Delete) where
@ -12,7 +13,9 @@ import Servant.API.Methods
--
-- >>> -- DELETE /books/:isbn
-- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[JSON] ()
type Delete (contentTypes :: [*]) a = HttpMethod "DELETE" 200 contentTypes a
type Delete (contentTypes :: [*]) a = HttpMethod "DELETE" contentTypes a
type instance DefaultStatusCode "DELETE" = 200
-- $setup
-- >>> import Servant.API

5
servant/src/Servant/API/Get.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Get (Get) where
@ -11,7 +12,9 @@ import Servant.API.Methods
-- Example:
--
-- >>> type MyApi = "books" :> Get '[JSON] [Book]
type Get (contentTypes :: [*]) a = HttpMethod "GET" 200 contentTypes a
type Get (contentTypes :: [*]) a = HttpMethod "GET" contentTypes a
type instance DefaultStatusCode "GET" = 200
-- $setup
-- >>> import Servant.API

5
servant/src/Servant/API/Methods.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Methods where
@ -8,5 +9,7 @@ module Servant.API.Methods where
import Data.Typeable (Typeable)
import GHC.TypeLits (Nat, Symbol)
data HttpMethod (m :: Symbol) (s :: Nat) (contentTypes :: [*]) a
data HttpMethod (m :: Symbol) (contentTypes :: [*]) a
deriving Typeable
type family DefaultStatusCode (m :: Symbol) :: Nat

5
servant/src/Servant/API/Patch.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Patch (Patch) where
@ -18,7 +19,9 @@ import Servant.API.Methods
-- >>> -- with a JSON encoded Book as the request body
-- >>> -- returning the just-created Book
-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book
type Patch (contentTypes :: [*]) a = HttpMethod "PATCH" 200 contentTypes a
type Patch (contentTypes :: [*]) a = HttpMethod "PATCH" contentTypes a
type instance DefaultStatusCode "PATCH" = 200
-- $setup
-- >>> import Servant.API

5
servant/src/Servant/API/Post.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Post (Post) where
@ -16,7 +17,9 @@ import Servant.API.Methods
-- >>> -- with a JSON encoded Book as the request body
-- >>> -- returning the just-created Book
-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
type Post (contentTypes :: [*]) a = HttpMethod "POST" 201 contentTypes a
type Post (contentTypes :: [*]) a = HttpMethod "POST" contentTypes a
type instance DefaultStatusCode "POST" = 201
-- $setup
-- >>> import Servant.API

5
servant/src/Servant/API/Put.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Put (Put) where
@ -14,7 +15,9 @@ import Servant.API.Methods
-- >>> -- PUT /books/:isbn
-- >>> -- with a Book as request body, returning the updated Book
-- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book
type Put (contentTypes :: [*]) a = HttpMethod "PUT" 200 contentTypes a
type Put (contentTypes :: [*]) a = HttpMethod "PUT" contentTypes a
type instance DefaultStatusCode "PUT" = 200
-- $setup
-- >>> import Servant.API