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

Add Content Types. 

Still needs QQ.
This commit is contained in:
Julian K. Arni 2015-01-08 16:24:19 +01:00
parent 648dc2f2fb
commit 8930a45403
11 changed files with 158 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
default.nix Normal file
View File

@ -0,0 +1,12 @@
{ pkgs ? import <nixpkgs> { config.allowUnfree = true; }
, src ? builtins.filterSource (path: type:
type != "unknown" &&
baseNameOf path != ".git" &&
baseNameOf path != "result" &&
baseNameOf path != "dist") ./.
}:
pkgs.haskellPackages.buildLocalCabalWithArgs {
name = "servant";
inherit src;
args = {};
}

3
servant.cabal
View File

@ -28,6 +28,7 @@ library
Servant.API
Servant.API.Alternative
Servant.API.Capture
Servant.API.ContentTypes
Servant.API.Delete
Servant.API.Get
Servant.API.Header
@ -44,6 +45,8 @@ library
Servant.Utils.Links
build-depends:
base >=4.7 && <5
, bytestring == 0.10.*
, http-types == 0.8.*
, text >= 1
, template-haskell
, parsec >= 3.1

4
src/Servant/API.hs
View File

@ -30,6 +30,9 @@ module Servant.API (
-- | PATCH requests
module Servant.API.Patch,
-- * Content Types
module Servant.API.ContentTypes,
-- * Untyped endpoints
-- | Plugging in a wai 'Network.Wai.Application', serving directories
module Servant.API.Raw,
@ -43,6 +46,7 @@ module Servant.API (
import Servant.API.Alternative ( (:<|>)(..) )
import Servant.API.Capture ( Capture )
import Servant.API.ContentTypes ( Accept(..), MimeRender(..), HTML, XML, JSON )
import Servant.API.Delete ( Delete )
import Servant.API.Get ( Get )
import Servant.API.Header ( Header )

55
src/Servant/API/ContentTypes.hs Normal file
View File

@ -0,0 +1,55 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Servant.API.ContentTypes where
import Data.ByteString (ByteString)
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable)
data XML deriving Typeable
data HTML deriving Typeable
data JSON deriving Typeable
type ContentTypeBS = ByteString
class Accept ctype where
isContentType :: Proxy ctype -> ByteString -> Bool
contentType :: Proxy ctype -> ContentTypeBS
isContentType p bs = bs == contentType p
instance Accept HTML where
contentType _ = "text/html"
instance Accept JSON where
contentType _ = "application/json"
instance Accept XML where
contentType _ = "application/xml"
-- | Instantiate this class to register a way of serializing a type based
-- on the @Accept@ header.
class Accept ctype => MimeRender ctype a where
toByteString :: Proxy ctype -> a -> ByteString
class AllCTRender list a where
handleAcceptH :: Proxy list -> ContentTypeBS -> a -> (ByteString, ContentTypeBS)
instance MimeRender ctyp a => AllCTRender '[ctyp] a where
handleAcceptH _ accept val = (toByteString pctyp val, accept)
where pctyp = Proxy :: Proxy ctyp
instance ( MimeRender ctyp a
, AllCTRender ctyps a
) => AllCTRender (ctyp ': ctyps) a where
handleAcceptH _ accept val
| isContentType pctyp accept = (toByteString pctyp val, accept)
| otherwise = handleAcceptH pctyps accept val
where pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy ctyps

4
src/Servant/API/ContentTypes/HTML.hs Normal file
View File

@ -0,0 +1,4 @@
module Servant.API.ContentTypes.HTML where
data HTML
deriving Typeable

6
src/Servant/API/Get.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
module Servant.API.Get where
import Data.Typeable ( Typeable )
@ -7,6 +9,6 @@ import Data.Typeable ( Typeable )
--
-- Example:
--
-- > type MyApi = "books" :> Get [Book]
data Get a
-- > type MyApi = "books" :> Get '[JSON] [Book]
data Get (cts::[*]) a
deriving Typeable

6
src/Servant/API/Post.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
module Servant.API.Post where
import Data.Typeable ( Typeable )
@ -12,6 +14,6 @@ import Data.Typeable ( Typeable )
-- > -- POST /books
-- > -- with a JSON encoded Book as the request body
-- > -- returning the just-created Book
-- > type MyApi = "books" :> ReqBody Book :> Post Book
data Post a
-- > type MyApi = "books" :> ReqBody Book :> Post '[JSON] Book
data Post (cts::[*]) a
deriving Typeable

6
src/Servant/API/Put.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
module Servant.API.Put where
import Data.Typeable ( Typeable )
@ -10,6 +12,6 @@ import Data.Typeable ( Typeable )
--
-- > -- PUT /books/:isbn
-- > -- with a Book as request body, returning the updated Book
-- > type MyApi = "books" :> Capture "isbn" Text :> ReqBody Book :> Put Book
data Put a
-- > type MyApi = "books" :> Capture "isbn" Text :> ReqBody Book :> Put '[JSON] Book
data Put (cts::[*]) a
deriving Typeable

44
src/Servant/Utils/Links.hs
View File

@ -122,6 +122,14 @@ import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw )
import Servant.API.Alternative ( type (:<|>) )
-- | A safe link datatype.
-- The only way of constructing a 'Link' is using 'safeLink', which means any
-- 'Link' is guaranteed to be part of the mentioned API.
data Link = Link
{ _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"]
, _queryParams :: [Param Query]
} deriving Show
-- | If either a or b produce an empty constraint, produce an empty constraint.
type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
Or () b = ()
@ -156,14 +164,26 @@ type family IsElem endpoint api :: Constraint where
IsElem sa (MatrixFlag x :> sb) = IsElem sa sb
IsElem e e = ()
IsElem e a = IsElem' e a
IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'
IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'
IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'
IsElem e e = 'True
IsElem e a = 'False
-- | A safe link datatype.
-- The only way of constructing a 'Link' is using 'safeLink', which means any
-- 'Link' is guaranteed to be part of the mentioned API.
data Link = Link
{ _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"]
, _queryParams :: [Param Query]
} deriving Show
type family IsSubList a b where
IsSubList '[] b = 'True
IsSubList '[x] (x ': xs) = 'True
IsSubList '[x] (y ': ys) = IsSubList '[x] ys
IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y
IsSubList a b = 'False
type family IsLink'' l where
IsLink'' (e :> Get cts x) = IsLink' e
IsLink'' (e :> Post cts x) = IsLink' e
IsLink'' (e :> Put cts x) = IsLink' e
IsLink'' (e :> Delete) = IsLink' e
IsLink'' a = 'False
-- Phantom types for Param
@ -317,16 +337,16 @@ instance (ToText v, HasLink sub)
addSegment (escape . unpack $ toText v) l
-- Verb (terminal) instances
instance HasLink (Get r) where
type MkLink (Get r) = URI
instance HasLink (Get y r) where
type MkLink (Get y r) = URI
toLink _ = linkURI
instance HasLink (Post r) where
type MkLink (Post r) = URI
type MkLink (Post y r) = URI
toLink _ = linkURI
instance HasLink (Put r) where
type MkLink (Put r) = URI
instance HasLink (Put y r) where
type MkLink (Put y r) = URI
toLink _ = linkURI
instance HasLink Delete where

24
test/Servant/QQSpec.hs
View File

@ -9,8 +9,10 @@
{-# LANGUAGE UndecidableInstances #-}
module Servant.QQSpec where
import Test.Hspec ( Expectation, Spec, shouldBe, it, describe )
import Test.Hspec ( Expectation, Spec, shouldBe, it, describe, pendingWith )
spec = describe "this" $ it "is" $ pendingWith "playing around"
{-
import Servant.API
( (:<|>),
ReqBody,
@ -21,6 +23,7 @@ import Servant.API
Post,
Capture,
(:>),
JSON,
sitemap )
--------------------------------------------------------------------------
@ -31,14 +34,14 @@ import Servant.API
type SimpleGet = [sitemap|
GET hello ()
|]
type SimpleGet' = "hello" :> Get ()
type SimpleGet'' = "hello" :> Get Bool
type SimpleGet' = "hello" :> Get '[JSON] ()
type SimpleGet'' = "hello" :> Get '[JSON] Bool
type SimpleGet2 = [sitemap|
GET hello Bool
|]
type SimpleGet2' = "hello" :> Get Bool
type SimpleGet2'' = "hello" :> Get Int
type SimpleGet2' = "hello" :> Get '[JSON] Bool
type SimpleGet2'' = "hello" :> Get '[JSON] Int
type SimplePost = [sitemap|
POST hello ()
@ -106,18 +109,18 @@ type TwoPaths = [sitemap|
POST hello Bool
GET hello Bool
|]
type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get Bool)
type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get '[JSON] Bool)
type WithInlineComments = [sitemap|
GET hello Bool -- This is a comment
|]
type WithInlineComments' = "hello" :> Get Bool
type WithInlineComments' = "hello" :> Get '[JSON] Bool
type WithInlineComments2 = [sitemap|
GET hello Bool
-- This is a comment
|]
type WithInlineComments2' = "hello" :> Get Bool
type WithInlineComments2' = "hello" :> Get '[JSON] Bool
type WithBlockComments = [sitemap|
@ -125,7 +128,7 @@ GET hello Bool {-
POST hello Bool
-}
|]
type WithBlockComments' = "hello" :> Get Bool
type WithBlockComments' = "hello" :> Get '[JSON] Bool
type WithBlockComments2 = [sitemap|
GET hello Bool {-
@ -133,7 +136,7 @@ POST hello Bool
-}
POST hello Bool
|]
type WithBlockComments2' = ("hello" :> Get Bool) :<|> ("hello" :> Post Bool)
type WithBlockComments2' = ("hello" :> Get '[JSON] Bool) :<|> ("hello" :> Post Bool)
--------------------------------------------------------------------------
-- Spec
@ -185,6 +188,7 @@ spec = do
(u::WithBlockComments) ~= (u::WithBlockComments') ~> True
(u::WithBlockComments2) ~= (u::WithBlockComments2') ~> True
-}
--------------------------------------------------------------------------
-- Utilities

30
test/Servant/Utils/LinksSpec.hs
View File

@ -8,29 +8,43 @@ module Servant.Utils.LinksSpec where
import Test.Hspec ( Spec, it, describe, shouldBe, Expectation )
import Data.Proxy ( Proxy(..) )
import Servant.API
import Servant.API ( type (:<|>), ReqBody, QueryParam, MatrixParam, MatrixParams
, MatrixFlag, Get, Post, Capture, type (:>) , HTML , JSON, XML )
import Servant.QQSpec ( (~>) )
import Servant.Utils.Links ( IsElem, IsLink )
<<<<<<< HEAD
type TestApi =
-- Capture and query/matrix params
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete
:<|> "parent" :> MatrixParams "name" String :> "child"
:> MatrixParam "gender" String :> Get String
:> MatrixParam "gender" String :> Get '[JSON] String
-- Flags
:<|> "ducks" :> MatrixFlag "yellow" :> MatrixFlag "loud" :> Delete
:<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete
-- All of the verbs
:<|> "get" :> Get ()
:<|> "put" :> Put ()
:<|> "post" :> ReqBody 'True :> Post ()
:<|> "get" :> Get '[JSON] ()
:<|> "put" :> Put '[JSON] ()
:<|> "post" :> ReqBody 'True :> Post '[JSON] ()
:<|> "delete" :> Header "ponies" :> Delete
:<|> "raw" :> Raw
type TestLink = "hello" :> "hi" :> Get Bool
type TestLink2 = "greet" :> Post Bool
type TestLink3 = "parent" :> "child" :> Get String
type TestLink = "hello" :> "hi" :> Get '[JSON] Bool
type TestLink2 = "greet" :> Post '[XML] Bool
type TestLink3 = "parent" :> "child" :> Get '[JSON] String
type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool
type BadTestLink2 = "greet" :> Get '[XML] Bool
type BadTestLink3 = "parent" :> "child" :> MatrixFlag "male" :> Get '[JSON] String
type BadTestLink' = "hello" :> "hi" :> Get '[HTML] Bool
type BadTestLink'2 = "greet" :> Get '[HTML] Bool
type NotALink = "hello" :> Capture "x" Bool :> Get '[JSON] Bool
type NotALink2 = "hello" :> ReqBody 'True :> Get '[JSON] Bool
apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
=> Proxy endpoint -> MkLink endpoint