diff --git a/servant.cabal b/servant.cabal --- a/servant.cabal +++ b/servant.cabal @@ -1,5 +1,5 @@ name: servant -version: 0.2.2 +version: 0.4.0 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them @@ -8,6 +8,8 @@ . 's a runnable example, with comments, that defines a dummy API and implements a webserver that serves this API, using the package. + . + homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 @@ -28,27 +30,55 @@ Servant.API Servant.API.Alternative Servant.API.Capture + Servant.API.ContentTypes Servant.API.Delete Servant.API.Get Servant.API.Header + Servant.API.Patch Servant.API.Post Servant.API.Put Servant.API.QueryParam Servant.API.MatrixParam Servant.API.Raw Servant.API.ReqBody + Servant.API.ResponseHeaders Servant.API.Sub Servant.Common.Text - Servant.QQ Servant.Utils.Links build-depends: base >=4.7 && <5 - , text >= 1 - , template-haskell - , parsec >= 3.1 - , string-conversions >= 0.3 + , aeson >= 0.7 + , attoparsec >= 0.12 + , bytestring == 0.10.* + , bytestring-conversion == 0.3.* + , case-insensitive >= 1.2 + , http-media >= 0.4 && < 0.7 + , http-types == 0.8.* + , text >= 1 && < 2 + , string-conversions >= 0.3 && < 0.4 + , network-uri >= 2.6 hs-source-dirs: src default-language: Haskell2010 + other-extensions: CPP + , 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 @@ -60,9 +90,25 @@ main-is: Spec.hs build-depends: base == 4.* + , aeson + , attoparsec + , bytestring , hspec == 2.* , QuickCheck + , quickcheck-instances , parsec , servant , string-conversions , text + , url + +test-suite doctests + build-depends: base + , servant + , doctest + , filemanip + type: exitcode-stdio-1.0 + main-is: test/Doctests.hs + buildable: True + default-language: Haskell2010 + ghc-options: -threaded diff --git a/src/Servant/API.hs b/src/Servant/API.hs --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -1,55 +1,85 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.API ( -- * Combinators - -- | Type-level combinator for expressing subrouting: @':>'@ module Servant.API.Sub, - -- | Type-level combinator for alternative endpoints: @':<|>'@ + -- | Type-level combinator for expressing subrouting: @':>'@ module Servant.API.Alternative, + -- | Type-level combinator for alternative endpoints: @':<|>'@ -- * Accessing information from the request - -- | Capturing parts of the url path as parsed values: @'Capture'@ module Servant.API.Capture, - -- | Retrieving specific headers from the request + -- | Capturing parts of the url path as parsed values: @'Capture'@ module Servant.API.Header, - -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ + -- | Retrieving specific headers from the request module Servant.API.QueryParam, - -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ + -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ module Servant.API.ReqBody, - -- | Retrieving matrix parameters from the 'URI' segment: @'MatrixParam'@ + -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ module Servant.API.MatrixParam, + -- | Retrieving matrix parameters from the 'URI' segment: @'MatrixParam'@ -- * Actual endpoints, distinguished by HTTP method - -- | GET requests module Servant.API.Get, - -- | POST requests + -- | @GET@ requests module Servant.API.Post, - -- | DELETE requests + -- | @POST@ requests module Servant.API.Delete, - -- | PUT requests + -- | @DELETE@ requests module Servant.API.Put, + -- | @PUT@ requests + module Servant.API.Patch, + -- | @PATCH@ requests + -- * Content Types + module Servant.API.ContentTypes, + -- | Serializing and deserializing types based on @Accept@ and + -- @Content-Type@ headers. + + -- * Response Headers + module Servant.API.ResponseHeaders, + -- * Untyped endpoints - -- | Plugging in a wai 'Network.Wai.Application', serving directories module Servant.API.Raw, + -- | Plugging in a wai 'Network.Wai.Application', serving directories + -- * FromText and ToText + module Servant.Common.Text, + -- | Classes and instances for types that can be converted to and from @Text@ + -- * Utilities - -- | QuasiQuotes for endpoints - module Servant.QQ, - -- | Type-safe internal URLs module Servant.Utils.Links, + -- | Type-safe internal URIs ) where -import Servant.API.Alternative ( (:<|>)(..) ) -import Servant.API.Capture ( Capture ) -import Servant.API.Delete ( Delete ) -import Servant.API.Get ( Get ) -import Servant.API.Header ( Header ) -import Servant.API.Post ( Post ) -import Servant.API.Put ( Put ) -import Servant.API.QueryParam ( QueryFlag, QueryParams, QueryParam ) -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 ( mkLink ) +import Servant.API.Alternative ((:<|>) (..)) +import Servant.API.Capture (Capture) +import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, + FromFormUrlEncoded (..), JSON, + MimeRender (..), + MimeUnrender (..), OctetStream, + PlainText, ToFormUrlEncoded (..)) +import Servant.API.Delete (Delete) +import Servant.API.Get (Get) +import Servant.API.Header (Header (..)) +import Servant.API.MatrixParam (MatrixFlag, MatrixParam, + MatrixParams) +import Servant.API.Patch (Patch) +import Servant.API.Post (Post) +import Servant.API.Put (Put) +import Servant.API.QueryParam (QueryFlag, QueryParam, + QueryParams) +import Servant.API.Raw (Raw) +import Servant.API.ReqBody (ReqBody) +import Servant.API.ResponseHeaders (AddHeader (addHeader), + BuildHeadersTo (buildHeadersTo), + GetHeaders (getHeaders), + HList (..), Headers (..), + getHeadersHList, getResponse) +import Servant.API.Sub ((:>)) +import Servant.Common.Text (FromText (..), ToText (..)) +import Servant.Utils.Links (HasLink (..), IsElem, IsElem', + URI (..), safeLink) + diff --git a/src/Servant/API/Alternative.hs b/src/Servant/API/Alternative.hs --- a/src/Servant/API/Alternative.hs +++ b/src/Servant/API/Alternative.hs @@ -1,11 +1,32 @@ -{-# LANGUAGE TypeOperators #-} -module Servant.API.Alternative where +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Alternative ((:<|>)(..)) where +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid (..)) +#endif +import Data.Typeable (Typeable) -- | Union of two APIs, first takes precedence in case of overlap. -- -- Example: -- --- > type MyApi = "books" :> Get [Book] -- GET /books --- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- >>> :{ +--type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books +-- :} data a :<|> b = a :<|> b + deriving (Typeable, Eq, Show) infixr 8 :<|> + +instance (Monoid a, Monoid b) => Monoid (a :<|> b) where + mempty = mempty :<|> mempty + (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b') + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Capture.hs b/src/Servant/API/Capture.hs --- a/src/Servant/API/Capture.hs +++ b/src/Servant/API/Capture.hs @@ -1,10 +1,22 @@ -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Capture (Capture) where +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) -- | Capture a value from the request path under a certain type @a@. -- -- Example: --- --- > -- GET /books/:isbn --- > type MyApi = "books" :> Capture "isbn" Text :> Get Book -data Capture sym a +-- >>> -- GET /books/:isbn +-- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book +data Capture (sym :: Symbol) a + deriving (Typeable) + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/ContentTypes.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | A collection of basic Content-Types (also known as Internet Media +-- Types, or MIME types). Additionally, this module provides classes that +-- encapsulate how to serialize or deserialize values to or from +-- a particular Content-Type. +-- +-- Content-Types are used in `ReqBody` and the method combinators: +-- +-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book +-- +-- Meaning the endpoint accepts requests of Content-Type @application/json@ +-- or @text/plain;charset-utf8@, and returns data in either one of those +-- formats (depending on the @Accept@ header). +-- +-- If you would like to support Content-Types beyond those provided here, +-- then: +-- +-- (1) Declare a new data type with no constructors (e.g. @data HTML@). +-- (2) Make an instance of it for `Accept`. +-- (3) If you want to be able to serialize data *into* that +-- Content-Type, make an instance of it for `MimeRender`. +-- (4) If you want to be able to deserialize data *from* that +-- Content-Type, make an instance of it for `MimeUnrender`. +-- +-- Note that roles are reversed in @servant-server@ and @servant-client@: +-- to be able to serve (or even typecheck) a @Get '[JSON, XML] MyData@, +-- you'll need to have the appropriate `MimeRender` instances in scope, +-- whereas to query that endpoint with @servant-client@, you'll need +-- a `MimeUnrender` instance in scope. +module Servant.API.ContentTypes + ( + -- * Provided Content-Types + JSON + , PlainText + , FormUrlEncoded + , OctetStream + + -- * Building your own Content-Type + , Accept(..) + , MimeRender(..) + , MimeUnrender(..) + + -- * Internal + , AcceptHeader(..) + , AllCTRender(..) + , AllCTUnrender(..) + , AllMimeRender(..) + , AllMimeUnrender(..) + , FromFormUrlEncoded(..) + , ToFormUrlEncoded(..) + , IsNonEmpty + , eitherDecodeLenient + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<*)) +#endif +import Control.Arrow (left) +import Control.Monad +import Data.Aeson (FromJSON, ToJSON, Value, + encode, parseJSON) +import Data.Aeson.Parser (value) +import Data.Aeson.Types (parseEither) +import Data.Attoparsec.ByteString (endOfInput, parseOnly) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) +import qualified Data.ByteString.Lazy as B +import Data.Monoid +import Data.String.Conversions (cs) +import qualified Data.Text as TextS +import qualified Data.Text.Encoding as TextS +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL +import Data.Typeable +import GHC.Exts (Constraint) +import qualified Network.HTTP.Media as M +import Network.URI (escapeURIString, isUnreserved, + unEscapeString) + +-- * Provided content types +data JSON deriving Typeable +data PlainText deriving Typeable +data FormUrlEncoded 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: +-- +-- >>> import Network.HTTP.Media ((//), (/:)) +-- >>> data HTML +-- >>> :{ +--instance Accept HTML where +-- contentType _ = "text" // "html" /: ("charset", "utf-8") +-- :} +-- +class Accept ctype where + contentType :: Proxy ctype -> M.MediaType + +-- | @application/json@ +instance Accept JSON where + contentType _ = "application" M.// "json" + +-- | @application/x-www-form-urlencoded@ +instance Accept FormUrlEncoded where + contentType _ = "application" M.// "x-www-form-urlencoded" + +-- | @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 +-- > mimeRender _ val = pack ("This is MINE! " ++ show val) +-- > +-- > type MyAPI = "path" :> Get '[MyContentType] Int +-- +class Accept ctype => MimeRender ctype a where + mimeRender :: 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. +-- +-- >>> import Network.HTTP.Media hiding (Accept) +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSC +-- >>> data MyContentType = MyContentType String +-- +-- >>> :{ +--instance Accept MyContentType where +-- contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") +-- :} +-- +-- >>> :{ +--instance Read a => MimeUnrender MyContentType a where +-- mimeUnrender _ bs = case BSC.take 12 bs of +-- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs +-- _ -> Left "didn't start with the magic incantation" +-- :} +-- +-- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int +-- +class Accept ctype => MimeUnrender ctype a where + mimeUnrender :: 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 (list :: [*]) a where + allMimeRender :: Proxy list + -> a -- value to serialize + -> [(M.MediaType, ByteString)] -- content-types/response pairs + +instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where + allMimeRender _ a = [(contentType pctyp, mimeRender 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, mimeRender 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 (list :: [*]) a where + allMimeUnrender :: Proxy list + -> 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, mimeUnrender pctyp val) + :(allMimeUnrender pctyps val) + where pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps + +type family IsNonEmpty (list :: [*]) :: Constraint where + IsNonEmpty (x ': xs) = () + + +-------------------------------------------------------------------------- +-- * MimeRender Instances + +-- | `encode` +instance ToJSON a => MimeRender JSON a where + mimeRender _ = encode + +-- | @encodeFormUrlEncoded . toFormUrlEncoded@ +-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only +-- holds if every element of x is non-null (i.e., not @("", "")@) +instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where + mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded + +-- | `TextL.encodeUtf8` +instance MimeRender PlainText TextL.Text where + mimeRender _ = TextL.encodeUtf8 + +-- | @fromStrict . TextS.encodeUtf8@ +instance MimeRender PlainText TextS.Text where + mimeRender _ = fromStrict . TextS.encodeUtf8 + +-- | @id@ +instance MimeRender OctetStream ByteString where + mimeRender _ = id + +-- | `fromStrict` +instance MimeRender OctetStream BS.ByteString where + mimeRender _ = fromStrict + + +-------------------------------------------------------------------------- +-- * MimeUnrender Instances + +-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just +-- objects and arrays. +eitherDecodeLenient :: FromJSON a => ByteString -> Either String a +eitherDecodeLenient input = do + v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input) + parseEither parseJSON v + +-- | `eitherDecode` +instance FromJSON a => MimeUnrender JSON a where + mimeUnrender _ = eitherDecodeLenient + +-- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@ +-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only +-- holds if every element of x is non-null (i.e., not @("", "")@) +instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where + mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded + +-- | @left show . TextL.decodeUtf8'@ +instance MimeUnrender PlainText TextL.Text where + mimeUnrender _ = left show . TextL.decodeUtf8' + +-- | @left show . TextS.decodeUtf8' . toStrict@ +instance MimeUnrender PlainText TextS.Text where + mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict + +-- | @Right . id@ +instance MimeUnrender OctetStream ByteString where + mimeUnrender _ = Right . id + +-- | @Right . toStrict@ +instance MimeUnrender OctetStream BS.ByteString where + mimeUnrender _ = Right . toStrict + + +-------------------------------------------------------------------------- +-- * FormUrlEncoded + +-- | A type that can be converted to @application/x-www-form-urlencoded@ +class ToFormUrlEncoded a where + toFormUrlEncoded :: a -> [(TextS.Text, TextS.Text)] + +instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where + toFormUrlEncoded = id + +-- | A type that can be converted from @application/x-www-form-urlencoded@, +-- with the possibility of failure. +class FromFormUrlEncoded a where + fromFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> Either String a + +instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where + fromFormUrlEncoded = return + +encodeFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> ByteString +encodeFormUrlEncoded xs = + let escape :: TextS.Text -> ByteString + escape = cs . escapeURIString isUnreserved . cs + encodePair :: (TextS.Text, TextS.Text) -> ByteString + encodePair (k, "") = escape k + encodePair (k, v) = escape k <> "=" <> escape v + in B.intercalate "&" $ map encodePair xs + +decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)] +decodeFormUrlEncoded "" = return [] +decodeFormUrlEncoded q = do + let xs :: [TextS.Text] + xs = TextS.splitOn "&" . cs $ q + parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text) + parsePair p = + case TextS.splitOn "=" p of + [k,v] -> return ( unescape k + , unescape v + ) + [k] -> return ( unescape k, "" ) + _ -> Left $ "not a valid pair: " <> cs p + unescape :: TextS.Text -> TextS.Text + unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+" + mapM parsePair xs + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs --- a/src/Servant/API/Delete.hs +++ b/src/Servant/API/Delete.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Servant.API.Delete where +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Delete (Delete) where import Data.Typeable ( Typeable ) @@ -7,7 +10,15 @@ -- -- Example: -- --- > -- DELETE /books/:isbn --- > type MyApi = "books" :> Capture "isbn" Text :> Delete -data Delete +-- >>> -- DELETE /books/:isbn +-- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete +data Delete (contentTypes :: [*]) a deriving Typeable + + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -1,12 +1,22 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Servant.API.Get where +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Get (Get) where -import Data.Typeable ( Typeable ) +import Data.Typeable (Typeable) -- | Endpoint for simple GET requests. Serves the result as JSON. -- -- Example: -- --- > type MyApi = "books" :> Get [Book] -data Get a +-- >>> type MyApi = "books" :> Get '[JSON] [Book] +data Get (contentTypes :: [*]) a deriving Typeable + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Header.hs b/src/Servant/API/Header.hs --- a/src/Servant/API/Header.hs +++ b/src/Servant/API/Header.hs @@ -1,13 +1,30 @@ -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Header where +import Data.ByteString (ByteString) +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) -- | Extract the given header's value as a value of type @a@. -- -- Example: -- --- > newtype Referer = Referer Text --- > deriving (Eq, Show, FromText, ToText) --- > --- > -- GET /view-my-referer --- > type MyApi = "view-my-referer" :> Header "from" Referer :> Get Referer -data Header sym a +-- >>> newtype Referer = Referer Text deriving (Eq, Show) +-- >>> +-- >>> -- GET /view-my-referer +-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer +data Header (sym :: Symbol) a = Header a + | MissingHeader + | UndecodableHeader ByteString + deriving (Typeable, Eq, Show, Functor) + +-- $setup +-- >>> import Servant.API +-- >>> import Servant.Common.Text +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/MatrixParam.hs b/src/Servant/API/MatrixParam.hs --- a/src/Servant/API/MatrixParam.hs +++ b/src/Servant/API/MatrixParam.hs @@ -1,14 +1,20 @@ -{-# LANGUAGE PolyKinds #-} -module Servant.API.MatrixParam where +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) -- | Lookup the value associated to the @sym@ matrix string parameter -- and try to extract it as a value of type @a@. -- -- Example: -- --- > -- /books;author= --- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book] -data MatrixParam sym a +-- >>> -- /books;author= +-- >>> type MyApi = "books" :> MatrixParam "author" Text :> Get '[JSON] [Book] +data MatrixParam (sym :: Symbol) a + deriving (Typeable) -- | Lookup the values associated to the @sym@ matrix string parameter -- and try to extract it as a value of type @[a]@. This is typically @@ -19,9 +25,10 @@ -- -- Example: -- --- > -- /books;authors[]=;authors[]=;... --- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book] -data MatrixParams sym a +-- >>> -- /books;authors[]=;authors[]=;... +-- >>> type MyApi = "books" :> MatrixParams "authors" Text :> Get '[JSON] [Book] +data MatrixParams (sym :: Symbol) a + deriving (Typeable) -- | Lookup a potentially value-less matrix string parameter -- with boolean semantics. If the param @sym@ is there without any value, @@ -30,6 +37,15 @@ -- -- Example: -- --- > -- /books;published --- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book] -data MatrixFlag sym +-- >>> -- /books;published +-- >>> type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book] +data MatrixFlag (sym :: Symbol) + deriving (Typeable) + + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Patch.hs b/src/Servant/API/Patch.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Patch.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Patch (Patch) where + +import Data.Typeable (Typeable) + +-- | Endpoint for PATCH requests. The type variable represents the type of the +-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for +-- that). +-- +-- If the HTTP response is empty, only () is supported. +-- +-- Example: +-- +-- >>> -- PATCH /books +-- >>> -- with a JSON encoded Book as the request body +-- >>> -- returning the just-created Book +-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book +data Patch (contentTypes :: [*]) a + deriving Typeable + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Servant.API.Post where +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Post (Post) where -import Data.Typeable ( Typeable ) +import Data.Typeable (Typeable) -- | Endpoint for POST requests. The type variable represents the type of the -- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for @@ -9,9 +12,16 @@ -- -- Example: -- --- > -- 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 +-- >>> -- POST /books +-- >>> -- with a JSON encoded Book as the request body +-- >>> -- returning the just-created Book +-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book +data Post (contentTypes :: [*]) a deriving Typeable + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Servant.API.Put where +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Put (Put) where import Data.Typeable ( Typeable ) @@ -8,8 +11,15 @@ -- -- Example: -- --- > -- 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 +-- >>> -- 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 +data Put (contentTypes :: [*]) a deriving Typeable + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/QueryParam.hs b/src/Servant/API/QueryParam.hs --- a/src/Servant/API/QueryParam.hs +++ b/src/Servant/API/QueryParam.hs @@ -1,14 +1,21 @@ -{-# LANGUAGE PolyKinds #-} -module Servant.API.QueryParam where +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) -- | Lookup the value associated to the @sym@ query string parameter -- and try to extract it as a value of type @a@. -- -- Example: -- --- > -- /books?author= --- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] -data QueryParam sym a +-- >>> -- /books?author= +-- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] +data QueryParam (sym :: Symbol) a + deriving Typeable -- | Lookup the values associated to the @sym@ query string parameter -- and try to extract it as a value of type @[a]@. This is typically @@ -19,9 +26,10 @@ -- -- Example: -- --- > -- /books?authors[]=&authors[]=&... --- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] -data QueryParams sym a +-- >>> -- /books?authors[]=&authors[]=&... +-- >>> type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] +data QueryParams (sym :: Symbol) a + deriving Typeable -- | Lookup a potentially value-less query string parameter -- with boolean semantics. If the param @sym@ is there without any value, @@ -30,6 +38,13 @@ -- -- Example: -- --- > -- /books?published --- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] -data QueryFlag sym +-- >>> -- /books?published +-- >>> type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] +data QueryFlag (sym :: Symbol) + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK not-home #-} 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 @@ -7,6 +10,5 @@ -- -- In addition to just letting you plug in your existing WAI 'Application's, -- 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 +-- static files stored in a particular directory on your filesystem +data Raw deriving Typeable diff --git a/src/Servant/API/ReqBody.hs b/src/Servant/API/ReqBody.hs --- a/src/Servant/API/ReqBody.hs +++ b/src/Servant/API/ReqBody.hs @@ -1,10 +1,23 @@ -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.ReqBody where +import Data.Typeable (Typeable) -- | Extract the request body as a value of type @a@. -- -- Example: -- --- > -- POST /books --- > type MyApi = "books" :> ReqBody Book :> Post Book -data ReqBody a +-- >>> -- POST /books +-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book +data ReqBody (contentTypes :: [*]) a + deriving (Typeable) + +-- $setup +-- >>> import Servant.API +-- >>> import Servant.Common.Text +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/ResponseHeaders.hs b/src/Servant/API/ResponseHeaders.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/ResponseHeaders.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif +{-# OPTIONS_HADDOCK not-home #-} + +-- | This module provides facilities for adding headers to a response. +-- +-- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int +-- +-- The value is added to the header specified by the type (@Location@ in the +-- example above). +module Servant.API.ResponseHeaders + ( Headers(..) + , AddHeader(addHeader) + , BuildHeadersTo(buildHeadersTo) + , GetHeaders(getHeaders) + , HeaderValMap + , HList(..) + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Data.ByteString.Char8 as BS (pack, unlines, init) +import Data.ByteString.Conversion (ToByteString, toByteString', + FromByteString, fromByteString) +import qualified Data.CaseInsensitive as CI +import Data.Proxy +import GHC.TypeLits (KnownSymbol, symbolVal) +import qualified Network.HTTP.Types.Header as HTTP + +import Servant.API.Header (Header (..)) + +-- | Response Header objects. You should never need to construct one directly. +-- Instead, use 'addHeader'. +data Headers ls a = Headers { getResponse :: a + -- ^ The underlying value of a 'Headers' + , getHeadersHList :: HList ls + -- ^ HList of headers. + } deriving (Functor) + +data HList a where + HNil :: HList '[] + HCons :: Header h x -> HList xs -> HList (Header h x ': xs) + +type family HeaderValMap (f :: * -> *) (xs :: [*]) where + HeaderValMap f '[] = '[] + HeaderValMap f (Header h x ': xs) = Header h (f x) ': (HeaderValMap f xs) + + +class BuildHeadersTo hs where + buildHeadersTo :: [HTTP.Header] -> HList hs + -- ^ Note: if there are multiple occurences of a header in the argument, + -- the values are interspersed with commas before deserialization (see + -- ) + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + BuildHeadersTo '[] where + buildHeadersTo _ = HNil + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False + ) => BuildHeadersTo ((Header h v) ': xs) where + buildHeadersTo headers = + let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) + matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers + in case matching of + [] -> MissingHeader `HCons` buildHeadersTo headers + xs -> case fromByteString (BS.init $ BS.unlines xs) of + Nothing -> UndecodableHeader (BS.init $ BS.unlines xs) + `HCons` buildHeadersTo headers + Just h -> Header h `HCons` buildHeadersTo headers + +-- * Getting + +class GetHeaders ls where + getHeaders :: ls -> [HTTP.Header] + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + GetHeaders (HList '[]) where + getHeaders _ = [] + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) + ) => GetHeaders (HList (Header h x ': xs)) where + getHeaders hdrs = case hdrs of + Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest + UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest + MissingHeader `HCons` rest -> getHeaders rest + where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + GetHeaders (Headers '[] a) where + getHeaders _ = [] + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ( KnownSymbol h, GetHeaders (HList rest), ToByteString v + ) => GetHeaders (Headers (Header h v ': rest) a) where + getHeaders hs = getHeaders $ getHeadersHList hs + +-- * Adding + +-- We need all these fundeps to save type inference +class AddHeader h v orig new + | h v orig -> new, new -> h, new -> v, new -> orig where + addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times + + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False + ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where + addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ( KnownSymbol h, ToByteString v + , new ~ (Headers '[Header h v] a) + ) => AddHeader h v a new where + addHeader a resp = Headers resp (HCons (Header a) HNil) + +type family Contains x xs where + Contains x ((Header x a) ': xs) = 'True + Contains x ((Header y a) ': xs) = Contains x xs + Contains x '[] = 'False + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/Sub.hs b/src/Servant/API/Sub.hs --- a/src/Servant/API/Sub.hs +++ b/src/Servant/API/Sub.hs @@ -1,16 +1,27 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -module Servant.API.Sub where +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Sub ((:>)) where -import Data.Proxy ( Proxy ) +import Data.Typeable (Typeable) -- | The contained API (second argument) can be found under @("/" ++ path)@ -- (path being the first argument). -- -- Example: -- --- > -- GET /hello/world --- > -- returning a JSON encoded World value --- > type MyApi = "hello" :> "world" :> Get World -data (path :: k) :> a = Proxy path :> a +-- >>> -- GET /hello/world +-- >>> -- returning a JSON encoded World value +-- >>> type MyApi = "hello" :> "world" :> Get '[JSON] World +data (path :: k) :> a + deriving (Typeable) infixr 9 :> + +-- $setup +-- >>> import Servant.API +-- >>> import Servant.Common.Text +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data World +-- >>> instance ToJSON World where { toJSON = undefined } diff --git a/src/Servant/Common/Text.hs b/src/Servant/Common/Text.hs --- a/src/Servant/Common/Text.hs +++ b/src/Servant/Common/Text.hs @@ -1,22 +1,34 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} module Servant.Common.Text ( FromText(..) , ToText(..) ) where -import Data.String.Conversions ( cs ) -import Data.Int ( Int8, Int16, Int32, Int64 ) -import Data.Text ( Text ) -import Data.Text.Read ( rational, signed, decimal, Reader ) -import Data.Word ( Word, Word8, Word16, Word32, Word64 ) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Data.Int (Int16, Int32, Int64, Int8) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Text.Read (Reader, decimal, rational, signed) +import Data.Word (Word16, Word32, Word64, Word8 +#if !MIN_VERSION_base(4,8,0) + , Word +#endif + ) -- | For getting values from url captures and query string parameters +-- Instances should obey: +-- > fromText (toText a) == Just a class FromText a where fromText :: Text -> Maybe a -- | For putting values in paths and query string parameters +-- Instances should obey: +-- > fromText (toText a) == Just a class ToText a where toText :: a -> Text @@ -33,17 +45,22 @@ toText = cs -- | --- > fromText "true" = Just True --- > fromText "false" = Just False --- > fromText _ = Nothing +-- >>> fromText ("true"::Text) :: Maybe Bool +-- Just True +-- >>> fromText ("false"::Text) :: Maybe Bool +-- Just False +-- >>> fromText ("anything else"::Text) :: Maybe Bool +-- Nothing instance FromText Bool where fromText "true" = Just True fromText "false" = Just False fromText _ = Nothing -- | --- > toText True = "true" --- > toText False = "false" +-- >>> toText True +-- "true" +-- >>> toText False +-- "false" instance ToText Bool where toText True = "true" toText False = "false" @@ -109,19 +126,21 @@ toText = cs . show instance FromText Integer where - fromText = runReader decimal + fromText = runReader (signed decimal) instance ToText Integer where toText = cs . show instance FromText Double where - fromText = runReader rational + fromText x = fromRational <$> runReader rational x instance ToText Double where toText = cs . show instance FromText Float where - fromText = runReader rational + -- Double is more practically accurate due to weird rounding when using + -- rational. We convert to double and then convert to Float. + fromText x = fromRational <$> runReader rational x instance ToText Float where toText = cs . show diff --git a/src/Servant/QQ.hs b/src/Servant/QQ.hs deleted file mode 100644 --- a/src/Servant/QQ.hs +++ /dev/null @@ -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. --- --- * @.../:/...@ becomes a capture --- * @.../?:@ becomes a query parameter --- * @ ... @ becomes a method returning @@ --- * @ ... -> @ becomes a method with request --- body of @@ and returning @@ --- --- 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 - } diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs --- a/src/Servant/Utils/Links.hs +++ b/src/Servant/Utils/Links.hs @@ -1,131 +1,359 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} --- | Type safe internal links. +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Type safe generation of internal links. -- --- Provides the function 'mkLink': +-- Given an API with a few endpoints: -- --- @ --- type API = Proxy ("hello" :> Get Int --- :<|> "bye" :> QueryParam "name" String :> Post Bool) +-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators +-- >>> import Servant.API +-- >>> import Servant.Utils.Links +-- >>> import Data.Proxy +-- >>> +-- >>> +-- >>> +-- >>> type Hello = "hello" :> Get '[JSON] Int +-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] () +-- >>> type API = Hello :<|> Bye +-- >>> let api = Proxy :: Proxy API -- --- api :: API --- api = proxy +-- It is possible to generate links that are guaranteed to be within 'API' with +-- 'safeLink'. The first argument to 'safeLink' is a type representing the API +-- you would like to restrict links to. The second argument is the destination +-- endpoint you would like the link to point to, this will need to end with a +-- verb like GET or POST. Further arguments may be required depending on the +-- type of the endpoint. If everything lines up you will get a 'URI' out the +-- other end. -- --- link1 :: Proxy ("hello" :> Get Int) --- link1 = proxy +-- You may omit 'QueryParam's and the like should you not want to provide them, +-- but types which form part of the URL path like 'Capture' must be included. +-- The reason you may want to omit 'QueryParam's is that safeLink is a bit +-- magical: if parameters are included that could take input it will return a +-- function that accepts that input and generates a link. This is best shown +-- with an example. Here, a link is generated with no parameters: -- --- link2 :: Proxy ("hello" :> Delete) --- link2 = proxy +-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int) +-- >>> print (safeLink api hello :: URI) +-- hello -- --- mkLink link1 API -- typechecks, returns 'Link "/hello"' +-- If the API has an endpoint with parameters then we can generate links with +-- or without those: -- --- mkLink link2 API -- doesn't typecheck --- @ +-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] ()) +-- >>> print $ safeLink api with "Hubert" +-- bye?name=Hubert -- --- That is, 'mkLink' takes two arguments, a link proxy and a sitemap, and --- returns a 'Link', but only typechecks if the link proxy is a valid link, --- and part of the sitemap. +-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] ()) +-- >>> print $ safeLink api without +-- bye -- --- __N.B.:__ 'mkLink' assumes a capture matches any string (without slashes). +-- If you would like create a helper for generating links only within that API, +-- you can partially apply safeLink if you specify a correct type signature +-- like so: +-- +-- >>> :set -XConstraintKinds +-- >>> :{ +-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) +-- >>> => Proxy endpoint -> MkLink endpoint +-- >>> apiLink = safeLink api +-- >>> :} +-- +-- Attempting to construct a link to an endpoint that does not exist in api +-- will result in a type error like this: +-- +-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ()) +-- >>> safeLink api bad_link +-- +-- :64:1: +-- Could not deduce (Or +-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int)) +-- (IsElem' +-- ("hello" :> Delete '[JSON] ()) +-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) +-- arising from a use of ‘safeLink’ +-- In the expression: safeLink api bad_link +-- In an equation for ‘it’: it = safeLink api bad_link +-- +-- This error is essentially saying that the type family couldn't find +-- bad_link under api after trying the open (but empty) type family +-- `IsElem'` as a last resort. module Servant.Utils.Links ( - -- * Link and mkLink - -- | The only end-user utilities - mkLink - , Link - -- * Internal - -- | These functions will likely only be of interest if you are writing - -- more API combinators and would like to extend the behavior of - -- 'mkLink' - , ValidLinkIn() - , VLinkHelper(..) - , IsElem - , IsLink - )where + -- * Building and using safe links + -- + -- | Note that 'URI' is Network.URI.URI from the network-uri package. + safeLink + , URI(..) + -- * Adding custom types + , HasLink(..) + , linkURI + , Link + , IsElem' + -- * Illustrative exports + , IsElem + , Or +) where +import Data.List import Data.Proxy ( Proxy(..) ) -import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) +import Data.Text (Text, unpack) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid ( Monoid(..), (<>) ) +#else +import Data.Monoid ( (<>) ) +#endif +import Network.URI ( URI(..), escapeURIString, isUnreserved ) +import GHC.TypeLits ( KnownSymbol, symbolVal ) +import GHC.Exts(Constraint) +import Servant.Common.Text import Servant.API.Capture ( Capture ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.MatrixParam ( MatrixParam, MatrixParams, MatrixFlag ) +import Servant.API.Header ( Header ) import Servant.API.Get ( Get ) import Servant.API.Post ( Post ) import Servant.API.Put ( Put ) import Servant.API.Delete ( Delete ) 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 -type family Or a b where - Or 'False 'False = 'False - Or 'True b = 'True - Or a 'True = 'True +-- | 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 () = () -type family And a b where - And 'True 'True = 'True - And a 'False = 'False - And 'False b = 'False +-- | If both a or b produce an empty constraint, produce an empty constraint. +type family And (a :: Constraint) (b :: Constraint) :: Constraint where + And () () = () -type family IsElem a s where +-- | 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 +-- omitted. +-- +-- >>> data CustomThing +-- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s +-- +-- Note that 'IsElem' is called, which will mutually recurse back to `IsElem'` +-- if it exhausts all other options again. +-- +-- Once you have written a HasLink instance for CustomThing you are ready to +-- go. +type family IsElem' a s :: Constraint + +-- | Closed type family, check if endpoint is within api +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 y x :> sb) = IsElem sa sb IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb - IsElem sa (ReqBody x :> 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 e e = 'True - IsElem e a = 'False + 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 (Delete ct typ) (Delete ct' typ) = IsSubList ct ct' + IsElem e e = () + IsElem e a = IsElem' e a -type family IsLink'' l where - IsLink'' (e :> Get x) = IsLink' e - IsLink'' (e :> Post x) = IsLink' e - IsLink'' (e :> Put x) = IsLink' e - IsLink'' (e :> Delete) = IsLink' e - IsLink'' a = 'False -type family IsLink' e where - IsLink' (f :: Symbol) = 'True +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 -type family IsLink e where - IsLink (a :> b) = Or (And (IsLink' a) (IsLink'' b)) - (IsLink'' (a :> b)) +-- Phantom types for Param +data Matrix +data Query +-- | Query/Matrix param +data Param a + = SingleParam String Text + | ArrayElemParam String Text + | FlagParam String + deriving Show --- | The 'ValidLinkIn f s' constraint holds when 's' is an API that --- contains 'f', and 'f' is a link. -class ValidLinkIn f s where - mkLink :: f -> s -> Link -- ^ This function will only typecheck if `f` - -- is an URI within `s` +addSegment :: String -> Link -> Link +addSegment seg l = l { _segments = _segments l <> [seg] } -instance ( IsElem f s ~ 'True - , IsLink f ~ 'True - , VLinkHelper f) => ValidLinkIn f s where - mkLink _ _ = Link (vlh (Proxy :: Proxy f)) +addQueryParam :: Param Query -> Link -> Link +addQueryParam qp l = + l { _queryParams = _queryParams l <> [qp] } --- | A safe link datatype. --- The only way of constructing a 'Link' is using 'mkLink', which means any --- 'Link' is guaranteed to be part of the mentioned API. -data Link = Link String deriving Show +-- Not particularly efficient for many updates. Something to optimise if it's +-- a problem. +addMatrixParam :: Param Matrix -> Link -> Link +addMatrixParam param l = l { _segments = f (_segments l) } + where + f [] = [] + f xs = init xs <> [g (last xs)] + -- Modify the segment at the "top" of the stack + g :: String -> String + g seg = + case param of + SingleParam k v -> seg <> ";" <> k <> "=" <> escape (unpack v) + ArrayElemParam k v -> seg <> ";" <> k <> "[]=" <> escape (unpack v) + FlagParam k -> seg <> ";" <> k -class VLinkHelper f where - vlh :: forall proxy. proxy f -> String +linkURI :: Link -> URI +linkURI (Link segments q_params) = + URI mempty -- No scheme (relative) + Nothing -- Or authority (relative) + (intercalate "/" segments) + (makeQueries q_params) mempty + where + makeQueries :: [Param Query] -> String + makeQueries [] = "" + makeQueries xs = + "?" <> intercalate "&" (fmap makeQuery xs) -instance (KnownSymbol s, VLinkHelper e) => VLinkHelper (s :> e) where - vlh _ = "/" ++ symbolVal (Proxy :: Proxy s) ++ vlh (Proxy :: Proxy e) + makeQuery :: Param Query -> String + makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (unpack v) + makeQuery (SingleParam k v) = escape k <> "=" <> escape (unpack v) + makeQuery (FlagParam k) = escape k -instance VLinkHelper (Get x) where - vlh _ = "" +escape :: String -> String +escape = escapeURIString isUnreserved -instance VLinkHelper (Post x) where - vlh _ = "" +-- | Create a valid (by construction) relative URI with query params. +-- +-- This function will only typecheck if `endpoint` is part of the API `api` +safeLink + :: forall endpoint api. (IsElem endpoint api, HasLink endpoint) + => Proxy api -- ^ The whole API that this endpoint is a part of + -> Proxy endpoint -- ^ The API endpoint you would like to point to + -> MkLink endpoint +safeLink _ endpoint = toLink endpoint (Link mempty mempty) + +-- | Construct a toLink for an endpoint. +class HasLink endpoint where + type MkLink endpoint + toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to + -> Link + -> MkLink endpoint + +-- Naked symbol instance +instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where + type MkLink (sym :> sub) = MkLink sub + toLink _ = + toLink (Proxy :: Proxy sub) . addSegment seg + where + seg = symbolVal (Proxy :: Proxy sym) + + +-- QueryParam instances +instance (KnownSymbol sym, ToText v, HasLink sub) + => HasLink (QueryParam sym v :> sub) where + type MkLink (QueryParam sym v :> sub) = v -> MkLink sub + toLink _ l v = + toLink (Proxy :: Proxy sub) + (addQueryParam (SingleParam k (toText v)) l) + where + k :: String + k = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, ToText v, HasLink sub) + => HasLink (QueryParams sym v :> sub) where + type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub + toLink _ l = + toLink (Proxy :: Proxy sub) . + foldl' (\l' v -> addQueryParam (ArrayElemParam k (toText v)) l') l + where + k = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, HasLink sub) + => HasLink (QueryFlag sym :> sub) where + type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub + toLink _ l False = + toLink (Proxy :: Proxy sub) l + toLink _ l True = + toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l + where + k = symbolVal (Proxy :: Proxy sym) + +-- MatrixParam instances +instance (KnownSymbol sym, ToText v, HasLink sub) + => HasLink (MatrixParam sym v :> sub) where + type MkLink (MatrixParam sym v :> sub) = v -> MkLink sub + toLink _ l v = + toLink (Proxy :: Proxy sub) $ + addMatrixParam (SingleParam k (toText v)) l + where + k = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, ToText v, HasLink sub) + => HasLink (MatrixParams sym v :> sub) where + type MkLink (MatrixParams sym v :> sub) = [v] -> MkLink sub + toLink _ l = + toLink (Proxy :: Proxy sub) . + foldl' (\l' v -> addMatrixParam (ArrayElemParam k (toText v)) l') l + where + k = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, HasLink sub) + => HasLink (MatrixFlag sym :> sub) where + type MkLink (MatrixFlag sym :> sub) = Bool -> MkLink sub + toLink _ l False = + toLink (Proxy :: Proxy sub) l + toLink _ l True = + toLink (Proxy :: Proxy sub) $ addMatrixParam (FlagParam k) l + where + k = symbolVal (Proxy :: Proxy sym) + +-- Misc instances +instance HasLink sub => HasLink (ReqBody ct a :> sub) where + type MkLink (ReqBody ct a :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) + +instance (ToText v, HasLink sub) + => HasLink (Capture sym v :> sub) where + type MkLink (Capture sym v :> sub) = v -> MkLink sub + toLink _ l v = + toLink (Proxy :: Proxy sub) $ + addSegment (escape . unpack $ toText v) l + +-- Verb (terminal) instances +instance HasLink (Get y r) where + type MkLink (Get y r) = URI + toLink _ = linkURI + +instance HasLink (Post y r) where + type MkLink (Post y r) = URI + toLink _ = linkURI + +instance HasLink (Put y r) where + type MkLink (Put y r) = URI + toLink _ = linkURI + +instance HasLink (Delete y r) where + type MkLink (Delete y r) = URI + toLink _ = linkURI + +instance HasLink Raw where + type MkLink Raw = URI + toLink _ = linkURI diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 --- /dev/null +++ b/test/Doctests.hs @@ -0,0 +1,16 @@ +module Main where + +import System.FilePath.Find +import Test.DocTest + +main :: IO () +main = do + files <- find always (extension ==? ".hs") "src" + doctest $ [ "-isrc" + , "-optP-include" + , "-optPdist/build/autogen/cabal_macros.h" + , "-XOverloadedStrings" + , "-XFlexibleInstances" + , "-XMultiParamTypeClasses" + ] ++ files +