Merge pull request #9 from haskell-servant/jkarni/content-types
Jkarni/content types
This commit is contained in:
Julian Arni
commit
5f1e8c3607
15 changed files with 526 additions and 486 deletions
12
default.nix
Normal file
12
default.nix
Normal 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 = {};
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -40,17 +41,39 @@ library
|
|||
Servant.API.ReqBody
|
||||
Servant.API.Sub
|
||||
Servant.Common.Text
|
||||
Servant.QQ
|
||||
Servant.Utils.Links
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, text >= 1
|
||||
, template-haskell
|
||||
, aeson >= 0.7
|
||||
, bytestring == 0.10.*
|
||||
, http-media >= 0.4 && < 0.6
|
||||
, http-types == 0.8.*
|
||||
, text >= 1 && < 2
|
||||
, template-haskell >= 2.7 && < 2.10
|
||||
, parsec >= 3.1
|
||||
, string-conversions >= 0.3
|
||||
, string-conversions >= 0.3 && < 0.4
|
||||
, network-uri >= 2.6
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
other-extensions: ConstraintKinds
|
||||
, DataKinds
|
||||
, DeriveDataTypeable
|
||||
, FlexibleInstances
|
||||
, FunctionalDependencies
|
||||
, GADTs
|
||||
, KindSignatures
|
||||
, MultiParamTypeClasses
|
||||
, OverlappingInstances
|
||||
, OverloadedStrings
|
||||
, PolyKinds
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, TemplateHaskell
|
||||
, TypeFamilies
|
||||
, TypeOperators
|
||||
, TypeSynonymInstances
|
||||
, UndecidableInstances
|
||||
ghc-options: -Wall
|
||||
|
||||
test-suite spec
|
||||
|
|
@ -62,6 +85,8 @@ test-suite spec
|
|||
main-is: Spec.hs
|
||||
build-depends:
|
||||
base == 4.*
|
||||
, aeson
|
||||
, bytestring
|
||||
, hspec == 2.*
|
||||
, QuickCheck
|
||||
, parsec
|
||||
|
|
|
|||
|
|
@ -30,19 +30,22 @@ 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,
|
||||
|
||||
-- * Utilities
|
||||
-- | QuasiQuotes for endpoints
|
||||
module Servant.QQ,
|
||||
-- | Type-safe internal URIs
|
||||
module Servant.Utils.Links,
|
||||
) where
|
||||
|
||||
import Servant.API.Alternative ( (:<|>)(..) )
|
||||
import Servant.API.Capture ( Capture )
|
||||
import Servant.API.ContentTypes ( JSON , PlainText, OctetStream
|
||||
, MimeRender(..) , MimeUnrender(..))
|
||||
import Servant.API.Delete ( Delete )
|
||||
import Servant.API.Get ( Get )
|
||||
import Servant.API.Header ( Header )
|
||||
|
|
@ -54,5 +57,4 @@ import Servant.API.MatrixParam ( MatrixFlag, MatrixParams, MatrixParam )
|
|||
import Servant.API.Raw ( Raw )
|
||||
import Servant.API.ReqBody ( ReqBody )
|
||||
import Servant.API.Sub ( (:>)(..) )
|
||||
import Servant.QQ ( sitemap )
|
||||
import Servant.Utils.Links ( safeLink, URI(..), IsElem, IsElem', HasLink(..) )
|
||||
|
|
|
|||
220
src/Servant/API/ContentTypes.hs
Normal file
220
src/Servant/API/ContentTypes.hs
Normal file
|
|
@ -0,0 +1,220 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.API.ContentTypes where
|
||||
|
||||
import Control.Arrow (left)
|
||||
import Data.Aeson (FromJSON, ToJSON, eitherDecode,
|
||||
encode)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text.Lazy as TextL
|
||||
import qualified Data.Text.Lazy.Encoding as TextL
|
||||
import qualified Data.Text as TextS
|
||||
import qualified Data.Text.Encoding as TextS
|
||||
import Data.Typeable
|
||||
import GHC.Exts (Constraint)
|
||||
import qualified Network.HTTP.Media as M
|
||||
|
||||
-- * Provided content types
|
||||
data JSON deriving Typeable
|
||||
data PlainText deriving Typeable
|
||||
data OctetStream deriving Typeable
|
||||
|
||||
-- * Accept class
|
||||
|
||||
-- | Instances of 'Accept' represent mimetypes. They are used for matching
|
||||
-- against the @Accept@ HTTP header of the request, and for setting the
|
||||
-- @Content-Type@ header of the response
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > instance Accept HTML where
|
||||
-- > contentType _ = "text" // "html"
|
||||
--
|
||||
class Accept ctype where
|
||||
contentType :: Proxy ctype -> M.MediaType
|
||||
|
||||
-- | @application/json@
|
||||
instance Accept JSON where
|
||||
contentType _ = "application" M.// "json"
|
||||
|
||||
-- | @text/plain;charset=utf-8@
|
||||
instance Accept PlainText where
|
||||
contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
|
||||
|
||||
-- | @application/octet-stream@
|
||||
instance Accept OctetStream where
|
||||
contentType _ = "application" M.// "octet-stream"
|
||||
|
||||
newtype AcceptHeader = AcceptHeader BS.ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- * Render (serializing)
|
||||
|
||||
-- | Instantiate this class to register a way of serializing a type based
|
||||
-- on the @Accept@ header.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > data MyContentType
|
||||
-- >
|
||||
-- > instance Accept MyContentType where
|
||||
-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
|
||||
-- >
|
||||
-- > instance Show a => MimeRender MyContentType where
|
||||
-- > toByteString _ val = pack ("This is MINE! " ++ show val)
|
||||
-- >
|
||||
-- > type MyAPI = "path" :> Get '[MyContentType] Int
|
||||
--
|
||||
class Accept ctype => MimeRender ctype a where
|
||||
toByteString :: Proxy ctype -> a -> ByteString
|
||||
|
||||
class AllCTRender list a where
|
||||
-- If the Accept header can be matched, returns (Just) a tuple of the
|
||||
-- Content-Type and response (serialization of @a@ into the appropriate
|
||||
-- mimetype).
|
||||
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
|
||||
|
||||
instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
|
||||
) => AllCTRender ctyps a where
|
||||
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
|
||||
where pctyps = Proxy :: Proxy ctyps
|
||||
amrs = allMimeRender pctyps val
|
||||
lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * Unrender
|
||||
|
||||
-- | Instantiate this class to register a way of deserializing a type based
|
||||
-- on the request's @Content-Type@ header.
|
||||
--
|
||||
-- > data MyContentType = MyContentType String
|
||||
-- >
|
||||
-- > instance Accept MyContentType where
|
||||
-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
|
||||
-- >
|
||||
-- > instance Show a => MimeUnrender MyContentType where
|
||||
-- > fromByteString _ bs = MyContentType $ unpack bs
|
||||
-- >
|
||||
-- > type MyAPI = "path" :> ReqBody '[MyContentType] :> Get '[JSON] Int
|
||||
--
|
||||
class Accept ctype => MimeUnrender ctype a where
|
||||
fromByteString :: Proxy ctype -> ByteString -> Either String a
|
||||
|
||||
class (IsNonEmpty list) => AllCTUnrender list a where
|
||||
handleCTypeH :: Proxy list
|
||||
-> ByteString -- Content-Type header
|
||||
-> ByteString -- Request body
|
||||
-> Maybe (Either String a)
|
||||
|
||||
instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
|
||||
) => AllCTUnrender ctyps a where
|
||||
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
|
||||
where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * Utils (Internal)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Check that all elements of list are instances of MimeRender
|
||||
--------------------------------------------------------------------------
|
||||
class AllMimeRender ls a where
|
||||
allMimeRender :: Proxy ls
|
||||
-> a -- value to serialize
|
||||
-> [(M.MediaType, ByteString)] -- content-types/response pairs
|
||||
|
||||
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
|
||||
allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
|
||||
instance ( MimeRender ctyp a
|
||||
, AllMimeRender (ctyp' ': ctyps) a
|
||||
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
|
||||
allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
|
||||
:(allMimeRender pctyps a)
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
pctyps = Proxy :: Proxy (ctyp' ': ctyps)
|
||||
|
||||
|
||||
instance AllMimeRender '[] a where
|
||||
allMimeRender _ _ = []
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Check that all elements of list are instances of MimeUnrender
|
||||
--------------------------------------------------------------------------
|
||||
class AllMimeUnrender ls a where
|
||||
allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
|
||||
|
||||
instance AllMimeUnrender '[] a where
|
||||
allMimeUnrender _ _ = []
|
||||
|
||||
instance ( MimeUnrender ctyp a
|
||||
, AllMimeUnrender ctyps a
|
||||
) => AllMimeUnrender (ctyp ': ctyps) a where
|
||||
allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
|
||||
:(allMimeUnrender pctyps val)
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
pctyps = Proxy :: Proxy ctyps
|
||||
|
||||
type family IsNonEmpty (ls::[*]) :: Constraint where
|
||||
IsNonEmpty (x ': xs) = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * MimeRender Instances
|
||||
|
||||
-- | `encode`
|
||||
instance ToJSON a => MimeRender JSON a where
|
||||
toByteString _ = encode
|
||||
|
||||
-- | `TextL.encodeUtf8`
|
||||
instance MimeRender PlainText TextL.Text where
|
||||
toByteString _ = TextL.encodeUtf8
|
||||
|
||||
-- | `fromStrict . TextS.encodeUtf8`
|
||||
instance MimeRender PlainText TextS.Text where
|
||||
toByteString _ = fromStrict . TextS.encodeUtf8
|
||||
|
||||
-- | `id`
|
||||
instance MimeRender OctetStream ByteString where
|
||||
toByteString _ = id
|
||||
|
||||
-- | `toStrict`
|
||||
instance MimeRender OctetStream BS.ByteString where
|
||||
toByteString _ = fromStrict
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * MimeUnrender Instances
|
||||
|
||||
-- | `eitherDecode`
|
||||
instance FromJSON a => MimeUnrender JSON a where
|
||||
fromByteString _ = eitherDecode
|
||||
|
||||
-- | `left show . TextL.decodeUtf8'`
|
||||
instance MimeUnrender PlainText TextL.Text where
|
||||
fromByteString _ = left show . TextL.decodeUtf8'
|
||||
|
||||
-- | `left show . TextS.decodeUtf8' . toStrict`
|
||||
instance MimeUnrender PlainText TextS.Text where
|
||||
fromByteString _ = left show . TextS.decodeUtf8' . toStrict
|
||||
|
||||
-- | `Right . id`
|
||||
instance MimeUnrender OctetStream ByteString where
|
||||
fromByteString _ = Right . id
|
||||
|
||||
-- | `Right . toStrict`
|
||||
instance MimeUnrender OctetStream BS.ByteString where
|
||||
fromByteString _ = Right . toStrict
|
||||
|
|
@ -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 (contentTypes::[*]) a
|
||||
deriving Typeable
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
module Servant.API.Patch where
|
||||
|
||||
import Data.Typeable ( Typeable )
|
||||
|
|
@ -11,9 +13,9 @@ import Data.Typeable ( Typeable )
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- POST /books
|
||||
-- > -- PATCH /books
|
||||
-- > -- with a JSON encoded Book as the request body
|
||||
-- > -- returning the just-created Book
|
||||
-- > type MyApi = "books" :> ReqBody Book :> Post Book
|
||||
data Patch a
|
||||
-- > type MyApi = "books" :> ReqBody Book :> Patch '[JSON] Book
|
||||
data Patch (contentTypes::[*]) a
|
||||
deriving Typeable
|
||||
|
|
|
|||
|
|
@ -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 (contentTypes::[*]) a
|
||||
deriving Typeable
|
||||
|
|
|
|||
|
|
@ -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 (contentTypes::[*]) a
|
||||
deriving Typeable
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module Servant.API.Raw where
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
-- | Endpoint for plugging in your own Wai 'Application's.
|
||||
--
|
||||
-- The given 'Application' will get the request as received by the server, potentially with
|
||||
|
|
@ -9,4 +11,4 @@ module Servant.API.Raw where
|
|||
-- this can also be used with 'Servant.Utils.StaticFiles.serveDirectory' to serve
|
||||
-- static files stored in a particular directory on your filesystem, or to serve
|
||||
-- your API's documentation with 'Servant.Utils.StaticFiles.serveDocumentation'.
|
||||
data Raw
|
||||
data Raw deriving Typeable
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
module Servant.API.ReqBody where
|
||||
|
||||
|
|
@ -6,5 +7,5 @@ module Servant.API.ReqBody where
|
|||
-- Example:
|
||||
--
|
||||
-- > -- POST /books
|
||||
-- > type MyApi = "books" :> ReqBody Book :> Post Book
|
||||
data ReqBody a
|
||||
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post Book
|
||||
data ReqBody (contentTypes::[*]) a
|
||||
|
|
|
|||
|
|
@ -1,228 +0,0 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
|
||||
-- | QuasiQuoting utilities for API types.
|
||||
--
|
||||
-- 'sitemap' allows you to write your type in a very natural way:
|
||||
--
|
||||
-- @
|
||||
-- [sitemap|
|
||||
-- PUT hello String -> ()
|
||||
-- POST hello/p:Int String -> ()
|
||||
-- GET hello/?name:String Int
|
||||
-- |]
|
||||
-- @
|
||||
--
|
||||
-- Will generate:
|
||||
--
|
||||
-- @
|
||||
-- "hello" :> ReqBody String :> Put ()
|
||||
-- :\<|> "hello" :> Capture "p" Int :> ReqBody String :> Post ()
|
||||
-- :\<|> "hello" :> QueryParam "name" String :> Get Int
|
||||
-- @
|
||||
--
|
||||
-- Note the @/@ before a @QueryParam@!
|
||||
module Servant.QQ (sitemap) where
|
||||
|
||||
import Control.Monad ( void )
|
||||
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
|
||||
import Language.Haskell.TH
|
||||
( mkName, Type(AppT, ConT, LitT), TyLit(StrTyLit) )
|
||||
import Text.ParserCombinators.Parsec
|
||||
( try,
|
||||
Parser,
|
||||
manyTill,
|
||||
endBy,
|
||||
sepBy1,
|
||||
optional,
|
||||
optionMaybe,
|
||||
string,
|
||||
anyChar,
|
||||
char,
|
||||
spaces,
|
||||
noneOf,
|
||||
parse,
|
||||
skipMany,
|
||||
many,
|
||||
lookAhead,
|
||||
(<|>),
|
||||
(<?>) )
|
||||
import Servant.API.Capture ( Capture )
|
||||
import Servant.API.Get ( Get )
|
||||
import Servant.API.Post ( Post )
|
||||
import Servant.API.Put ( Put )
|
||||
import Servant.API.Delete ( Delete )
|
||||
import Servant.API.QueryParam ( QueryParam )
|
||||
import Servant.API.MatrixParam ( MatrixParam )
|
||||
import Servant.API.ReqBody ( ReqBody )
|
||||
import Servant.API.Sub ( (:>) )
|
||||
import Servant.API.Alternative ( (:<|>) )
|
||||
|
||||
-- | Finally-tagless encoding for our DSL.
|
||||
-- Keeping 'repr'' and 'repr' distinct when writing functions with an
|
||||
-- @ExpSYM@ context ensures certain invariants (for instance, that there is
|
||||
-- only one of 'get', 'post', 'put', and 'delete' in a value), but
|
||||
-- sometimes requires a little more work.
|
||||
class ExpSYM repr' repr | repr -> repr', repr' -> repr where
|
||||
lit :: String -> repr' -> repr
|
||||
capture :: String -> String -> repr -> repr
|
||||
reqBody :: String -> repr -> repr
|
||||
queryParam :: String -> String -> repr -> repr
|
||||
matrixParam :: String -> String -> repr -> repr
|
||||
conj :: repr' -> repr -> repr
|
||||
get :: String -> repr
|
||||
post :: String -> repr
|
||||
put :: String -> repr
|
||||
delete :: String -> repr
|
||||
|
||||
|
||||
infixr 6 >:
|
||||
|
||||
(>:) :: Type -> Type -> Type
|
||||
(>:) = conj
|
||||
|
||||
|
||||
instance ExpSYM Type Type where
|
||||
lit name r = LitT (StrTyLit name) >: r
|
||||
capture name typ r = AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
|
||||
(ConT $ mkName typ) >: r
|
||||
reqBody typ r = AppT (ConT ''ReqBody) (ConT $ mkName typ) >: r
|
||||
queryParam name typ r = AppT (AppT (ConT ''QueryParam) (LitT (StrTyLit name)))
|
||||
(ConT $ mkName typ) >: r
|
||||
matrixParam name typ r = AppT (AppT (ConT ''MatrixParam) (LitT (StrTyLit name)))
|
||||
(ConT $ mkName typ) >: r
|
||||
conj x = AppT (AppT (ConT ''(:>)) x)
|
||||
get typ = AppT (ConT ''Get) (ConT $ mkName typ)
|
||||
post typ = AppT (ConT ''Post) (ConT $ mkName typ)
|
||||
put typ = AppT (ConT ''Put) (ConT $ mkName typ)
|
||||
delete "()" = ConT ''Delete
|
||||
delete _ = error "Delete does not return a request body"
|
||||
|
||||
parseMethod :: ExpSYM repr' repr => Parser (String -> repr)
|
||||
parseMethod = try (string "GET" >> return get)
|
||||
<|> try (string "POST" >> return post)
|
||||
<|> try (string "PUT" >> return put)
|
||||
<|> try (string "DELETE" >> return delete)
|
||||
|
||||
parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr)
|
||||
parseUrlSegment = try parseCapture
|
||||
<|> try parseQueryParam
|
||||
<|> try parseLit
|
||||
where
|
||||
parseCapture = do
|
||||
cname <- many (noneOf " ?/:;")
|
||||
char ':'
|
||||
ctyp <- many (noneOf " ?/:;")
|
||||
mx <- many parseMatrixParam
|
||||
return $ capture cname ctyp . foldr (.) id mx
|
||||
parseQueryParam = do
|
||||
char '?'
|
||||
cname <- many (noneOf " ?/:;")
|
||||
char ':'
|
||||
ctyp <- many (noneOf " ?/:;")
|
||||
return $ queryParam cname ctyp
|
||||
parseLit = do
|
||||
lt <- many (noneOf " ?/:;")
|
||||
mx <- many parseMatrixParam
|
||||
return $ lit lt . foldr (.) id mx
|
||||
parseMatrixParam = do
|
||||
char ';'
|
||||
cname <- many (noneOf " ?/:;")
|
||||
char ':'
|
||||
ctyp <- many (noneOf " ?/:;")
|
||||
return $ matrixParam cname ctyp
|
||||
|
||||
parseUrl :: ExpSYM repr repr => Parser (repr -> repr)
|
||||
parseUrl = do
|
||||
optional $ char '/'
|
||||
url <- parseUrlSegment `sepBy1` char '/'
|
||||
return $ foldr1 (.) url
|
||||
|
||||
data Typ = Val String
|
||||
| ReqArgVal String String
|
||||
|
||||
parseTyp :: Parser Typ
|
||||
parseTyp = do
|
||||
f <- many (noneOf "-{\n\r")
|
||||
spaces
|
||||
s <- optionMaybe (try parseRet)
|
||||
try $ optional inlineComment
|
||||
try $ optional blockComment
|
||||
case s of
|
||||
Nothing -> return $ Val (stripTr f)
|
||||
Just s' -> return $ ReqArgVal (stripTr f) (stripTr s')
|
||||
where
|
||||
parseRet :: Parser String
|
||||
parseRet = do
|
||||
string "->"
|
||||
spaces
|
||||
many (noneOf "-{\n\r")
|
||||
stripTr = reverse . dropWhile (== ' ') . reverse
|
||||
|
||||
|
||||
parseEntry :: ExpSYM repr repr => Parser repr
|
||||
parseEntry = do
|
||||
met <- parseMethod
|
||||
spaces
|
||||
url <- parseUrl
|
||||
spaces
|
||||
typ <- parseTyp
|
||||
case typ of
|
||||
Val s -> return $ url (met s)
|
||||
ReqArgVal i o -> return $ url $ reqBody i (met o)
|
||||
|
||||
blockComment :: Parser ()
|
||||
blockComment = do
|
||||
string "{-"
|
||||
manyTill anyChar (try $ string "-}")
|
||||
return ()
|
||||
|
||||
inlineComment :: Parser ()
|
||||
inlineComment = do
|
||||
string "--"
|
||||
manyTill anyChar (try $ lookAhead eol)
|
||||
return ()
|
||||
|
||||
eol :: Parser String
|
||||
eol = try (string "\n\r")
|
||||
<|> try (string "\r\n")
|
||||
<|> string "\n"
|
||||
<|> string "\r"
|
||||
<?> "end of line"
|
||||
|
||||
eols :: Parser ()
|
||||
eols = skipMany $ void eol <|> blockComment <|> inlineComment
|
||||
|
||||
parseAll :: Parser Type
|
||||
parseAll = do
|
||||
eols
|
||||
entries <- parseEntry `endBy` eols
|
||||
return $ foldr1 union entries
|
||||
where union :: Type -> Type -> Type
|
||||
union a = AppT (AppT (ConT ''(:<|>)) a)
|
||||
|
||||
-- | The sitemap QuasiQuoter.
|
||||
--
|
||||
-- * @.../<var>:<type>/...@ becomes a capture
|
||||
-- * @.../?<var>:<type>@ becomes a query parameter
|
||||
-- * @<method> ... <typ>@ becomes a method returning @<typ>@
|
||||
-- * @<method> ... <typ1> -> <typ2>@ becomes a method with request
|
||||
-- body of @<typ1>@ and returning @<typ2>@
|
||||
--
|
||||
-- Comments are allowed, and have the standard Haskell format
|
||||
--
|
||||
-- * @--@ for inline
|
||||
-- * @{- ... -}@ for block
|
||||
--
|
||||
sitemap :: QuasiQuoter
|
||||
sitemap = QuasiQuoter { quoteExp = undefined
|
||||
, quotePat = undefined
|
||||
, quoteType = \x -> case parse parseAll "" x of
|
||||
Left err -> error $ show err
|
||||
Right st -> return st
|
||||
, quoteDec = undefined
|
||||
}
|
||||
|
|
@ -2,10 +2,11 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | Type safe generation of internal links.
|
||||
|
|
@ -19,7 +20,7 @@
|
|||
-- >>>
|
||||
-- >>>
|
||||
-- >>>
|
||||
-- >>> type Hello = "hello" :> Get Int
|
||||
-- >>> type Hello = "hello" :> Get '[JSON] Int
|
||||
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete
|
||||
-- >>> type API = Hello :<|> Bye
|
||||
-- >>> let api = Proxy :: Proxy API
|
||||
|
|
@ -39,7 +40,7 @@
|
|||
-- function that accepts that input and generates a link. This is best shown
|
||||
-- with an example. Here, a link is generated with no parameters:
|
||||
--
|
||||
-- >>> let hello = Proxy :: Proxy ("hello" :> Get Int)
|
||||
-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
|
||||
-- >>> print (safeLink api hello :: URI)
|
||||
-- hello
|
||||
--
|
||||
|
|
@ -73,7 +74,7 @@
|
|||
-- <BLANKLINE>
|
||||
-- <interactive>:64:1:
|
||||
-- Could not deduce (Or
|
||||
-- (IsElem' Delete (Get Int))
|
||||
-- (IsElem' Delete (Get '[JSON] Int))
|
||||
-- (IsElem'
|
||||
-- ("hello" :> Delete)
|
||||
-- ("bye" :> (QueryParam "name" String :> Delete))))
|
||||
|
|
@ -122,11 +123,23 @@ 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 = ()
|
||||
Or a () = ()
|
||||
|
||||
-- | If both a or b produce an empty constraint, produce an empty constraint.
|
||||
type family And (a :: Constraint) (b :: Constraint) :: Constraint where
|
||||
And () () = ()
|
||||
|
||||
-- | You may use this type family to tell the type checker that your custom type
|
||||
-- may be skipped as part of a link. This is useful for things like
|
||||
-- 'QueryParam' that are optional in a URI and do not affect them if they are
|
||||
|
|
@ -147,24 +160,26 @@ type family IsElem endpoint api :: Constraint where
|
|||
IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
|
||||
IsElem (e :> sa) (e :> sb) = IsElem sa sb
|
||||
IsElem sa (Header x :> sb) = IsElem sa sb
|
||||
IsElem sa (ReqBody x :> sb) = IsElem sa sb
|
||||
IsElem sa (ReqBody y x :> sb) = IsElem sa sb
|
||||
IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
|
||||
IsElem sa (QueryParam x y :> sb) = IsElem sa sb
|
||||
IsElem sa (QueryParams x y :> sb) = IsElem sa sb
|
||||
IsElem sa (QueryFlag x :> sb) = IsElem sa sb
|
||||
IsElem sa (MatrixParam x y :> sb) = IsElem sa sb
|
||||
IsElem sa (MatrixParams x y :> sb) = IsElem sa sb
|
||||
IsElem sa (MatrixFlag x :> sb) = IsElem sa sb
|
||||
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 = ()
|
||||
IsElem e a = IsElem' e a
|
||||
|
||||
-- | 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 :: Constraint where
|
||||
IsSubList '[] b = ()
|
||||
IsSubList '[x] (x ': xs) = ()
|
||||
IsSubList '[x] (y ': ys) = IsSubList '[x] ys
|
||||
IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y
|
||||
|
||||
-- Phantom types for Param
|
||||
data Matrix
|
||||
|
|
@ -317,16 +332,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
|
||||
instance HasLink (Post y r) where
|
||||
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
|
||||
|
|
|
|||
182
test/Servant/API/ContentTypesSpec.hs
Normal file
182
test/Servant/API/ContentTypesSpec.hs
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.API.ContentTypesSpec where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Aeson
|
||||
import Data.Function (on)
|
||||
import Data.Proxy
|
||||
|
||||
import Data.ByteString.Char8
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.List (maximumBy)
|
||||
import Data.Maybe (fromJust, isJust, isNothing)
|
||||
import Data.String (IsString (..))
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as TextS
|
||||
import qualified Data.Text.Lazy as TextL
|
||||
import GHC.Generics
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.API.ContentTypes
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Servant.API.ContentTypes" $ do
|
||||
|
||||
describe "The JSON Content-Type type" $ do
|
||||
|
||||
it "has fromByteString reverse toByteString for valid top-level json ([Int]) " $ do
|
||||
let p = Proxy :: Proxy JSON
|
||||
property $ \x -> fromByteString p (toByteString p x) == Right (x::[Int])
|
||||
|
||||
it "has fromByteString reverse toByteString for valid top-level json " $ do
|
||||
let p = Proxy :: Proxy JSON
|
||||
property $ \x -> fromByteString p (toByteString p x) == Right (x::SomeData)
|
||||
|
||||
describe "The PlainText Content-Type type" $ do
|
||||
|
||||
it "has fromByteString reverse toByteString (lazy Text)" $ do
|
||||
let p = Proxy :: Proxy PlainText
|
||||
property $ \x -> fromByteString p (toByteString p x) == Right (x::TextL.Text)
|
||||
|
||||
it "has fromByteString reverse toByteString (strict Text)" $ do
|
||||
let p = Proxy :: Proxy PlainText
|
||||
property $ \x -> fromByteString p (toByteString p x) == Right (x::TextS.Text)
|
||||
|
||||
describe "The OctetStream Content-Type type" $ do
|
||||
|
||||
it "is id (Lazy ByteString)" $ do
|
||||
let p = Proxy :: Proxy OctetStream
|
||||
property $ \x -> toByteString p x == (x :: BSL.ByteString)
|
||||
&& fromByteString p x == Right x
|
||||
|
||||
it "is fromStrict/toStrict (Strict ByteString)" $ do
|
||||
let p = Proxy :: Proxy OctetStream
|
||||
property $ \x -> toByteString p x == BSL.fromStrict (x :: ByteString)
|
||||
&& fromByteString p (BSL.fromStrict x) == Right x
|
||||
|
||||
describe "handleAcceptH" $ do
|
||||
|
||||
it "returns Nothing if the 'Accept' header doesn't match" $ do
|
||||
handleAcceptH (Proxy :: Proxy '[JSON]) "text/plain" (3 :: Int)
|
||||
`shouldSatisfy` isNothing
|
||||
|
||||
it "returns Just if the 'Accept' header matches" $ do
|
||||
handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
|
||||
`shouldSatisfy` isJust
|
||||
handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int)
|
||||
`shouldSatisfy` isJust
|
||||
handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream])
|
||||
"application/octet-stream" ("content" :: ByteString)
|
||||
`shouldSatisfy` isJust
|
||||
|
||||
it "returns the Content-Type as the first element of the tuple" $ do
|
||||
handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
|
||||
`shouldSatisfy` ((== "application/json") . fst . fromJust)
|
||||
handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int)
|
||||
`shouldSatisfy` ((== "application/json") . fst . fromJust)
|
||||
handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream])
|
||||
"application/octet-stream" ("content" :: ByteString)
|
||||
`shouldSatisfy` ((== "application/octet-stream") . fst . fromJust)
|
||||
|
||||
it "returns the appropriately serialized representation" $ do
|
||||
property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData)
|
||||
== Just ("application/json", encode x)
|
||||
|
||||
it "respects the Accept spec ordering" $ do
|
||||
let highest a b c = maximumBy (compare `on` snd)
|
||||
[ ("application/octet-stream", a)
|
||||
, ("application/json", b)
|
||||
, ("text/plain;charset=utf-8", c)
|
||||
]
|
||||
let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $
|
||||
addToAccept (Proxy :: Proxy JSON) b $
|
||||
addToAccept (Proxy :: Proxy PlainText ) c ""
|
||||
let val a b c i = handleAcceptH (Proxy :: Proxy '[OctetStream, JSON, PlainText])
|
||||
(acceptH a b c) (i :: Int)
|
||||
property $ \a b c i -> fst (fromJust $ val a b c i) == fst (highest a b c)
|
||||
|
||||
describe "handleCTypeH" $ do
|
||||
|
||||
it "returns Nothing if the 'Content-Type' header doesn't match" $ do
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 "
|
||||
`shouldBe` (Nothing :: Maybe (Either String Value))
|
||||
|
||||
context "the 'Content-Type' header matches" $ do
|
||||
it "returns Just if the parameter matches" $ do
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
|
||||
"𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 "
|
||||
`shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
|
||||
|
||||
it "returns Just if there is no parameter" $ do
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
|
||||
"𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 "
|
||||
`shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
|
||||
|
||||
it "returns Just Left if the decoding fails" $ do
|
||||
let isJustLeft :: Maybe (Either String Value) -> Bool
|
||||
isJustLeft (Just (Left _)) = True
|
||||
isJustLeft _ = False
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
|
||||
"𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- "
|
||||
`shouldSatisfy` isJustLeft
|
||||
|
||||
it "returns Just (Right val) if the decoding succeeds" $ do
|
||||
let val = SomeData "Of cabbages--and kings" 12
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
|
||||
(encode val)
|
||||
`shouldBe` Just (Right val)
|
||||
|
||||
|
||||
data SomeData = SomeData { record1 :: String, record2 :: Int }
|
||||
deriving (Generic, Eq, Show)
|
||||
|
||||
newtype ZeroToOne = ZeroToOne Float
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromJSON SomeData
|
||||
|
||||
instance ToJSON SomeData
|
||||
|
||||
instance Arbitrary SomeData where
|
||||
arbitrary = SomeData <$> arbitrary <*> arbitrary
|
||||
|
||||
instance Arbitrary TextL.Text where
|
||||
arbitrary = TextL.pack <$> arbitrary
|
||||
|
||||
instance Arbitrary TextS.Text where
|
||||
arbitrary = TextS.pack <$> arbitrary
|
||||
|
||||
instance Arbitrary ZeroToOne where
|
||||
arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]
|
||||
|
||||
instance MimeRender OctetStream Int where
|
||||
toByteString _ = cs . show
|
||||
|
||||
instance MimeRender PlainText Int where
|
||||
toByteString _ = cs . show
|
||||
|
||||
instance MimeRender PlainText ByteString where
|
||||
toByteString _ = cs
|
||||
|
||||
instance ToJSON ByteString where
|
||||
toJSON x = object [ "val" .= x ]
|
||||
|
||||
instance IsString AcceptHeader where
|
||||
fromString = AcceptHeader . fromString
|
||||
|
||||
instance Arbitrary BSL.ByteString where
|
||||
arbitrary = cs <$> (arbitrary :: Gen String)
|
||||
|
||||
instance Arbitrary ByteString where
|
||||
arbitrary = cs <$> (arbitrary :: Gen String)
|
||||
|
||||
addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader
|
||||
addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)
|
||||
where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)
|
||||
cont "" = new
|
||||
cont old = old `append` ", " `append` new
|
||||
|
|
@ -1,209 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.QQSpec where
|
||||
|
||||
import Test.Hspec ( Expectation, Spec, shouldBe, it, describe )
|
||||
|
||||
import Servant.API
|
||||
( (:<|>),
|
||||
ReqBody,
|
||||
QueryParam,
|
||||
MatrixParam,
|
||||
Put,
|
||||
Get,
|
||||
Post,
|
||||
Capture,
|
||||
(:>),
|
||||
sitemap )
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Types for testing
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
-- Methods ---------------------------------------------------------------
|
||||
type SimpleGet = [sitemap|
|
||||
GET hello ()
|
||||
|]
|
||||
type SimpleGet' = "hello" :> Get ()
|
||||
type SimpleGet'' = "hello" :> Get Bool
|
||||
|
||||
type SimpleGet2 = [sitemap|
|
||||
GET hello Bool
|
||||
|]
|
||||
type SimpleGet2' = "hello" :> Get Bool
|
||||
type SimpleGet2'' = "hello" :> Get Int
|
||||
|
||||
type SimplePost = [sitemap|
|
||||
POST hello ()
|
||||
|]
|
||||
type SimplePost' = "hello" :> Post ()
|
||||
type SimplePost'' = "hello" :> Post Bool
|
||||
|
||||
type SimplePost2 = [sitemap|
|
||||
POST hello Bool
|
||||
|]
|
||||
type SimplePost2' = "hello" :> Post Bool
|
||||
type SimplePost2'' = "hello" :> Post ()
|
||||
|
||||
type SimplePut = [sitemap|
|
||||
PUT hello ()
|
||||
|]
|
||||
type SimplePut' = "hello" :> Put ()
|
||||
type SimplePut'' = "hello" :> Put Bool
|
||||
|
||||
type SimplePut2 = [sitemap|
|
||||
PUT hello Bool
|
||||
|]
|
||||
type SimplePut2' = "hello" :> Put Bool
|
||||
type SimplePut2'' = "hello" :> Put ()
|
||||
|
||||
-- Parameters ------------------------------------------------------------
|
||||
|
||||
type SimpleReqBody = [sitemap|
|
||||
POST hello () -> Bool
|
||||
|]
|
||||
type SimpleReqBody' = "hello" :> ReqBody () :> Post Bool
|
||||
type SimpleReqBody'' = "hello" :> ReqBody Bool :> Post ()
|
||||
|
||||
type SimpleCapture = [sitemap|
|
||||
POST hello/p:Int Bool
|
||||
|]
|
||||
type SimpleCapture' = "hello" :> Capture "p" Int :> Post Bool
|
||||
type SimpleCapture'' = "hello" :> Capture "r" Int :> Post Bool
|
||||
type SimpleCapture''' = "hello" :> Capture "p" Bool :> Post Bool
|
||||
|
||||
type SimpleQueryParam = [sitemap|
|
||||
POST hello/?p:Int Bool
|
||||
|]
|
||||
type SimpleQueryParam' = "hello" :> QueryParam "p" Int :> Post Bool
|
||||
type SimpleQueryParam'' = "hello" :> QueryParam "r" Int :> Post Bool
|
||||
type SimpleQueryParam''' = "hello" :> QueryParam "p" Bool :> Post Bool
|
||||
|
||||
type SimpleMatrixParam = [sitemap|
|
||||
POST hello;p:Int Bool
|
||||
|]
|
||||
type SimpleMatrixParam' = "hello" :> MatrixParam "p" Int :> Post Bool
|
||||
type SimpleMatrixParam'' = "hello" :> MatrixParam "r" Int :> Post Bool
|
||||
type SimpleMatrixParam''' = "hello" :> MatrixParam "p" Bool :> Post Bool
|
||||
|
||||
type ComplexMatrixParam = [sitemap|
|
||||
POST hello;p:Int;q:String/world;r:Int Bool
|
||||
|]
|
||||
type ComplexMatrixParam' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "r" Int :> Post Bool
|
||||
type ComplexMatrixParam'' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "s" Int :> Post Bool
|
||||
type ComplexMatrixParam''' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "r" Bool :> Post Bool
|
||||
|
||||
-- Combinations ----------------------------------------------------------
|
||||
|
||||
type TwoPaths = [sitemap|
|
||||
POST hello Bool
|
||||
GET hello Bool
|
||||
|]
|
||||
type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get Bool)
|
||||
|
||||
type WithInlineComments = [sitemap|
|
||||
GET hello Bool -- This is a comment
|
||||
|]
|
||||
type WithInlineComments' = "hello" :> Get Bool
|
||||
|
||||
type WithInlineComments2 = [sitemap|
|
||||
GET hello Bool
|
||||
-- This is a comment
|
||||
|]
|
||||
type WithInlineComments2' = "hello" :> Get Bool
|
||||
|
||||
|
||||
type WithBlockComments = [sitemap|
|
||||
GET hello Bool {-
|
||||
POST hello Bool
|
||||
-}
|
||||
|]
|
||||
type WithBlockComments' = "hello" :> Get Bool
|
||||
|
||||
type WithBlockComments2 = [sitemap|
|
||||
GET hello Bool {-
|
||||
POST hello Bool
|
||||
-}
|
||||
POST hello Bool
|
||||
|]
|
||||
type WithBlockComments2' = ("hello" :> Get Bool) :<|> ("hello" :> Post Bool)
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Spec
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "'sitemap' QuasiQuoter" $ do
|
||||
it "Handles simple GET types" $ do
|
||||
(u::SimpleGet) ~= (u::SimpleGet' ) ~> True
|
||||
(u::SimpleGet) ~= (u::SimpleGet'' ) ~> False
|
||||
(u::SimpleGet2) ~= (u::SimpleGet2' ) ~> True
|
||||
(u::SimpleGet2) ~= (u::SimpleGet2'') ~> False
|
||||
it "Handles simple POST types" $ do
|
||||
(u::SimplePost) ~= (u::SimplePost' ) ~> True
|
||||
(u::SimplePost) ~= (u::SimplePost'' ) ~> False
|
||||
(u::SimplePost2) ~= (u::SimplePost2' ) ~> True
|
||||
(u::SimplePost2) ~= (u::SimplePost2'') ~> False
|
||||
it "Handles simple PUT types" $ do
|
||||
(u::SimplePut) ~= (u::SimplePut' ) ~> True
|
||||
(u::SimplePut) ~= (u::SimplePut'' ) ~> False
|
||||
(u::SimplePut2) ~= (u::SimplePut2' ) ~> True
|
||||
(u::SimplePut2) ~= (u::SimplePut2'') ~> False
|
||||
it "Handles simple request body types" $ do
|
||||
(u::SimpleReqBody) ~= (u::SimpleReqBody' ) ~> True
|
||||
(u::SimpleReqBody) ~= (u::SimpleReqBody'') ~> False
|
||||
it "Handles simple captures" $ do
|
||||
(u::SimpleCapture) ~= (u::SimpleCapture' ) ~> True
|
||||
(u::SimpleCapture) ~= (u::SimpleCapture'') ~> False
|
||||
(u::SimpleCapture) ~= (u::SimpleCapture''') ~> False
|
||||
it "Handles simple querystring parameters" $ do
|
||||
(u::SimpleQueryParam) ~= (u::SimpleQueryParam' ) ~> True
|
||||
(u::SimpleQueryParam) ~= (u::SimpleQueryParam'') ~> False
|
||||
(u::SimpleQueryParam) ~= (u::SimpleQueryParam''') ~> False
|
||||
it "Handles simple matrix parameters" $ do
|
||||
(u::SimpleMatrixParam) ~= (u::SimpleMatrixParam' ) ~> True
|
||||
(u::SimpleMatrixParam) ~= (u::SimpleMatrixParam'') ~> False
|
||||
(u::SimpleMatrixParam) ~= (u::SimpleMatrixParam''') ~> False
|
||||
it "Handles more complex matrix parameters" $ do
|
||||
(u::ComplexMatrixParam) ~= (u::ComplexMatrixParam' ) ~> True
|
||||
(u::ComplexMatrixParam) ~= (u::ComplexMatrixParam'') ~> False
|
||||
(u::ComplexMatrixParam) ~= (u::ComplexMatrixParam''') ~> False
|
||||
it "Handles multiples paths" $ do
|
||||
(u::TwoPaths) ~= (u::TwoPaths') ~> True
|
||||
it "Ignores inline comments" $ do
|
||||
(u::WithInlineComments) ~= (u::WithInlineComments') ~> True
|
||||
(u::WithInlineComments2) ~= (u::WithInlineComments2') ~> True
|
||||
it "Ignores inline comments" $ do
|
||||
(u::WithBlockComments) ~= (u::WithBlockComments') ~> True
|
||||
(u::WithBlockComments2) ~= (u::WithBlockComments2') ~> True
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Utilities
|
||||
--------------------------------------------------------------------------
|
||||
data HTrue
|
||||
data HFalse
|
||||
|
||||
-- Kiselyov's Type Equality predicate
|
||||
class TypeEq x y b | x y -> b where { areEq :: x -> y -> Bool }
|
||||
instance TypeEq x x HTrue where { areEq _ _ = True }
|
||||
instance b ~ HFalse => TypeEq x y b where { areEq _ _ = False}
|
||||
|
||||
infix 4 ~=
|
||||
(~=) :: TypeEq x y b => x -> y -> Bool
|
||||
(~=) = areEq
|
||||
|
||||
u :: a
|
||||
u = undefined
|
||||
|
||||
infix 3 ~>
|
||||
(~>) :: (Show a, Eq a) => a -> a -> Expectation
|
||||
(~>) = shouldBe
|
||||
|
|
@ -15,22 +15,32 @@ type TestApi =
|
|||
"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 '[JSON] '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 '[PlainText] Bool
|
||||
type TestLink3 = "parent" :> "child" :> Get '[JSON] String
|
||||
|
||||
type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool
|
||||
type BadTestLink2 = "greet" :> Get '[PlainText] Bool
|
||||
type BadTestLink3 = "parent" :> "child" :> MatrixFlag "male" :> Get '[JSON] String
|
||||
|
||||
type BadTestLink' = "hello" :> "hi" :> Get '[OctetStream] Bool
|
||||
type BadTestLink'2 = "greet" :> Get '[OctetStream] Bool
|
||||
|
||||
type NotALink = "hello" :> Capture "x" Bool :> Get '[JSON] Bool
|
||||
type NotALink2 = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool
|
||||
|
||||
apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
|
||||
=> Proxy endpoint -> MkLink endpoint
|
||||
|
|
@ -56,7 +66,7 @@ spec = describe "Servant.Utils.Links" $ do
|
|||
let l3 = Proxy :: Proxy ("parent" :> MatrixParams "name" String
|
||||
:> "child"
|
||||
:> MatrixParam "gender" String
|
||||
:> Get String)
|
||||
:> Get '[JSON] String)
|
||||
apiLink l3 ["Hubert?x=;&", "Cumberdale"] "Edward?"
|
||||
`shouldBeURI` "parent;name[]=Hubert%3Fx%3D%3B%26;\
|
||||
\name[]=Cumberdale/child;gender=Edward%3F"
|
||||
|
|
@ -73,8 +83,8 @@ spec = describe "Servant.Utils.Links" $ do
|
|||
apiLink l2 False True `shouldBeURI` "ducks;loud"
|
||||
|
||||
it "Generates correct links for all of the verbs" $ do
|
||||
apiLink (Proxy :: Proxy ("get" :> Get ())) `shouldBeURI` "get"
|
||||
apiLink (Proxy :: Proxy ("put" :> Put ())) `shouldBeURI` "put"
|
||||
apiLink (Proxy :: Proxy ("post" :> Post ())) `shouldBeURI` "post"
|
||||
apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get"
|
||||
apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put"
|
||||
apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post"
|
||||
apiLink (Proxy :: Proxy ("delete" :> Delete)) `shouldBeURI` "delete"
|
||||
apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"
|
||||
|
|
|
|||
Loading…
Reference in a new issue