servant 0.9.1.1 → 0.10
raw patch · 14 files changed
+707/−185 lines, 14 filesdep +aeson-compatdep +natural-transformationdep +semigroupsdep ~aesondep ~hspecdep ~mmorphbuild-type:Customsetup-changednew-uploader
Dependencies added: aeson-compat, natural-transformation, semigroups
Dependency ranges changed: aeson, hspec, mmorph
Files
- CHANGELOG.md +30/−0
- Setup.hs +0/−2
- Setup.lhs +165/−0
- servant.cabal +23/−5
- src/Servant/API.hs +1/−1
- src/Servant/API/Alternative.hs +4/−0
- src/Servant/API/ContentTypes.hs +56/−21
- src/Servant/API/TypeLevel.hs +264/−0
- src/Servant/Utils/Enter.hs +17/−22
- src/Servant/Utils/Links.hs +20/−74
- test/Doctests.hs +0/−40
- test/Servant/API/ContentTypesSpec.hs +52/−5
- test/Servant/Utils/LinksSpec.hs +16/−15
- test/doctests.hsc +59/−0
CHANGELOG.md view
@@ -1,3 +1,31 @@+0.10+------++### Breaking changes++* Use `NT` from `natural-transformation` for `Enter`+ ([#616](https://github.com/haskell-servant/servant/issues/616))++* Change to `MkLink (Verb ...) = Link` (previously `URI`). To consume `Link`+ use its `ToHttpApiData` instance or `linkURI`.+ ([#527](https://github.com/haskell-servant/servant/issues/527))++### Other changes++* Add `Servant.API.TypeLevel` module with type families to work with API types.+ ([#345](https://github.com/haskell-servant/servant/pull/345)+ , [#305](https://github.com/haskell-servant/servant/issues/305))++* Default JSON content type change to `application/json;charset=utf-8`.+ ([#263](https://github.com/haskell-servant/servant/issues/263))+ Related browser bugs:+ [Chromium](https://bugs.chromium.org/p/chromium/issues/detail?id=438464) and+ [Firefox](https://bugzilla.mozilla.org/show_bug.cgi?id=918742)++* `Accept` class may accept multiple content-types. `MimeUnrender` adopted as well.+ ([#613](https://github.com/haskell-servant/servant/pull/614)+ , [#615](https://github.com/haskell-servant/servant/pull/615))+ 0.9.1 ------ @@ -14,6 +42,8 @@ ---- * Add `CaptureAll` combinator. Captures all of the remaining segments in a URL.+* Add `Servant.API.TypeLevel` module, with frequently used type-level+functionaliy. 0.8 ---
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,165 @@+\begin{code}+{-# LANGUAGE CPP #-}+#ifndef MIN_VERSION_Cabal+#define MIN_VERSION_Cabal(x,y,z) 0+#endif+#ifndef MIN_VERSION_directory+#define MIN_VERSION_directory(x,y,z) 0+#endif+#if MIN_VERSION_Cabal(1,24,0)+#define InstalledPackageId UnitId+#endif+module Main (main) where++import Control.Monad ( when )+import Data.List ( nub )+import Distribution.Package ( InstalledPackageId )+import Distribution.Package ( PackageId, Package (..), packageVersion )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)+import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )+import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))+import Distribution.Text ( display , simpleParse )+import System.FilePath ( (</>) )++#if MIN_VERSION_Cabal(1,25,0)+import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )+#endif++#if MIN_VERSION_directory(1,2,2)+import System.Directory (makeAbsolute)+#else+import System.Directory (getCurrentDirectory)+import System.FilePath (isAbsolute)++makeAbsolute :: FilePath -> IO FilePath+makeAbsolute p | isAbsolute p = return p+ | otherwise = do+ cwd <- getCurrentDirectory+ return $ cwd </> p+#endif++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule flags pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ }++generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule flags pkg lbi = do+ let verbosity = fromFlag (buildVerbosity flags)+ let distPref = fromFlag (buildDistPref flags)++ -- Package DBs+ let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]+ let dbFlags = "-hide-all-packages" : packageDbArgs dbStack++ withLibLBI pkg lbi $ \lib libcfg -> do+ let libBI = libBuildInfo lib++ -- modules+ let modules = exposedModules lib ++ otherModules libBI+ -- it seems that doctest is happy to take in module names, not actual files!+ let module_sources = modules++ -- We need the directory with library's cabal_macros.h!+#if MIN_VERSION_Cabal(1,25,0)+ let libAutogenDir = autogenComponentModulesDir lbi libcfg+#else+ let libAutogenDir = autogenModulesDir lbi+#endif++ -- Lib sources and includes+ iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ "test" : libAutogenDir : hsSourceDirs libBI+ includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI++ -- CPP includes, i.e. include cabal_macros.h+ let cppFlags = map ("-optP"++) $+ [ "-include", libAutogenDir ++ "/cabal_macros.h" ]+ ++ cppOptions libBI++ -- Actually we need to check whether testName suite == "doctests"+ -- pending https://github.com/haskell/cabal/pull/4229 getting into GHC HEAD tree+ withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == "doctests") $ do++ -- get and create autogen dir+#if MIN_VERSION_Cabal(1,25,0)+ let testAutogenDir = autogenComponentModulesDir lbi suitecfg+#else+ let testAutogenDir = autogenModulesDir lbi+#endif+ createDirectoryIfMissingVerbose verbosity True testAutogenDir++ -- write autogen'd file+ rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines+ [ "module Build_doctests where"+ , ""+ -- -package-id etc. flags+ , "pkgs :: [String]"+ , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)+ , ""+ , "flags :: [String]"+ , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)+ , ""+ , "module_sources :: [String]"+ , "module_sources = " ++ show ("Servant.Utils.LinksSpec" : map display module_sources)+ ]+ where+ -- we do this check in Setup, as then doctests don't need to depend on Cabal+ isOldCompiler = maybe False id $ do+ a <- simpleParse $ showCompilerId $ compiler lbi+ b <- simpleParse "7.5"+ return $ packageVersion (a :: PackageId) < b++ formatDeps = map formatOne+ formatOne (installedPkgId, pkgId)+ -- The problem is how different cabal executables handle package databases+ -- when doctests depend on the library+ | packageId pkg == pkgId = "-package=" ++ display pkgId+ | otherwise = "-package-id=" ++ display installedPkgId++ -- From Distribution.Simple.Program.GHC+ packageDbArgs :: [PackageDB] -> [String]+ packageDbArgs | isOldCompiler = packageDbArgsConf+ | otherwise = packageDbArgsDb++ -- GHC <7.6 uses '-package-conf' instead of '-package-db'.+ packageDbArgsConf :: [PackageDB] -> [String]+ packageDbArgsConf dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+ (GlobalPackageDB:dbs) -> ("-no-user-package-conf")+ : concatMap specific dbs+ _ -> ierror+ where+ specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]+ specific _ = ierror+ ierror = error $ "internal error: unexpected package db stack: "+ ++ show dbstack++ -- GHC >= 7.6 uses the '-package-db' flag. See+ -- https://ghc.haskell.org/trac/ghc/ticket/5977.+ packageDbArgsDb :: [PackageDB] -> [String]+ -- special cases to make arguments prettier in common scenarios+ packageDbArgsDb dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs)+ | all isSpecific dbs -> concatMap single dbs+ (GlobalPackageDB:dbs)+ | all isSpecific dbs -> "-no-user-package-db"+ : concatMap single dbs+ dbs -> "-clear-package-db"+ : concatMap single dbs+ where+ single (SpecificPackageDB db) = [ "-package-db=" ++ db ]+ single GlobalPackageDB = [ "-global-package-db" ]+ single UserPackageDB = [ "-user-package-db" ]+ isSpecific (SpecificPackageDB _) = True+ isSpecific _ = False++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
servant.cabal view
@@ -1,5 +1,5 @@ name: servant-version: 0.9.1.1+version: 0.10 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them@@ -14,8 +14,8 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors-category: Web-build-type: Simple+category: Servant Web+build-type: Custom cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files:@@ -25,6 +25,10 @@ type: git location: http://github.com/haskell-servant/servant.git +custom-setup+ setup-depends:+ Cabal >=1.14, base, filepath, directory+ library exposed-modules: Servant.API@@ -43,6 +47,7 @@ Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Sub+ Servant.API.TypeLevel Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext@@ -51,19 +56,25 @@ build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9 && < 0.10- , aeson >= 0.7 && < 1.1+ , aeson >= 0.7 && < 1.2 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , http-api-data >= 0.3 && < 0.4 , http-media >= 0.4 && < 0.7 , http-types >= 0.8 && < 0.10+ , natural-transformation >= 0.4 && < 0.5 , mtl >= 2.0 && < 2.3 , mmorph >= 1 && < 1.1 , text >= 1 && < 1.3 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 && < 2.7 , vault >= 0.3 && < 0.4++ if !impl(ghc >= 8.0)+ build-depends:+ semigroups >= 0.16 && < 0.19+ hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP@@ -105,6 +116,7 @@ base == 4.* , base-compat , aeson+ , aeson-compat >=0.3.3 && <0.4 , attoparsec , bytestring , hspec == 2.*@@ -115,6 +127,10 @@ , text , url + if !impl(ghc >= 8.0)+ build-depends:+ semigroups >= 0.16 && < 0.19+ test-suite doctests build-depends: base , servant@@ -122,9 +138,11 @@ , filemanip , directory , filepath+ , hspec type: exitcode-stdio-1.0- main-is: test/Doctests.hs+ main-is: test/doctests.hs buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded+ build-tools: hsc2hs include-dirs: include
src/Servant/API.hs view
@@ -101,7 +101,7 @@ ReflectMethod (reflectMethod), Verb, StdMethod(..)) import Servant.API.WithNamedContext (WithNamedContext)-import Servant.Utils.Links (HasLink (..), IsElem, IsElem',+import Servant.Utils.Links (HasLink (..), Link, IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
src/Servant/API/Alternative.hs view
@@ -7,6 +7,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where +import Data.Semigroup (Semigroup (..)) import Data.Typeable (Typeable) import Prelude () import Prelude.Compat@@ -22,6 +23,9 @@ data a :<|> b = a :<|> b deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) infixr 8 :<|>++instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where+ (a :<|> b) <> (a' :<|> b') = (a <> a') :<|> (b <> b') instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty
src/Servant/API/ContentTypes.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -81,6 +82,7 @@ import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) import qualified Data.ByteString.Lazy.Char8 as BC+import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) import Data.String.Conversions (cs) import qualified Data.Text as TextS@@ -119,10 +121,18 @@ -- class Accept ctype where contentType :: Proxy ctype -> M.MediaType+ contentType = NE.head . contentTypes + contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType+ contentTypes = (NE.:| []) . contentType++ {-# MINIMAL contentType | contentTypes #-}+ -- | @application/json@ instance Accept JSON where- contentType _ = "application" M.// "json"+ contentTypes _ =+ "application" M.// "json" M./: ("charset", "utf-8") NE.:|+ [ "application" M.// "json" ] -- | @application/x-www-form-urlencoded@ instance Accept FormUrlEncoded where@@ -198,16 +208,32 @@ -- class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a+ mimeUnrender p = mimeUnrenderWithType p (contentType p) + -- | Variant which is given the actual 'M.MediaType' provided by the other party.+ --+ -- In the most cases you don't want to branch based on the 'M.MediaType'.+ -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.+ mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a+ mimeUnrenderWithType p _ = mimeUnrender p++ {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}+ class AllCTUnrender (list :: [*]) a where+ canHandleCTypeH+ :: Proxy list+ -> ByteString -- Content-Type header+ -> Maybe (ByteString -> Either String a)+ handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a)+ handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where- handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)- where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body+ canHandleCTypeH p ctypeH =+ M.mapContentMedia (allMimeUnrender p) (cs ctypeH) -------------------------------------------------------------------------- -- * Utils (Internal)@@ -219,9 +245,10 @@ allMime _ = [] instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where- allMime _ = (contentType pctyp):allMime pctyps- where pctyp = Proxy :: Proxy ctyp- pctyps = Proxy :: Proxy ctyps+ allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps+ where+ pctyp = Proxy :: Proxy ctyp+ pctyps = Proxy :: Proxy ctyps canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h@@ -235,25 +262,31 @@ -> [(M.MediaType, ByteString)] -- content-types/response pairs instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where- allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]- where pctyp = Proxy :: Proxy ctyp+ allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp+ where+ bs = mimeRender pctyp a+ pctyp = Proxy :: Proxy ctyp instance OVERLAPPABLE_ ( 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)+ allMimeRender _ a =+ (map (, bs) $ NE.toList $ contentTypes pctyp)+ ++ allMimeRender pctyps a+ where+ bs = mimeRender pctyp a+ pctyp = Proxy :: Proxy ctyp+ pctyps = Proxy :: Proxy (ctyp' ': ctyps) -- Ideally we would like to declare a 'MimeRender a NoContent' instance, and -- then this would be taken care of. However there is no more specific instance -- between that and 'MimeRender JSON a', so we do this instead instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where- allMimeRender _ _ = [(contentType pctyp, "")]- where pctyp = Proxy :: Proxy ctyp+ allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp+ where+ pctyp = Proxy :: Proxy ctyp instance OVERLAPPING_ ( AllMime (ctyp ': ctyp' ': ctyps)@@ -265,19 +298,21 @@ -------------------------------------------------------------------------- class (AllMime list) => AllMimeUnrender (list :: [*]) a where allMimeUnrender :: Proxy list- -> ByteString- -> [(M.MediaType, Either String a)]+ -> [(M.MediaType, ByteString -> Either String a)] instance AllMimeUnrender '[] a where- allMimeUnrender _ _ = []+ 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+ allMimeUnrender _ =+ (map mk $ NE.toList $ contentTypes pctyp)+ ++ allMimeUnrender pctyps+ where+ mk ct = (ct, \bs -> mimeUnrenderWithType pctyp ct bs)+ pctyp = Proxy :: Proxy ctyp+ pctyps = Proxy :: Proxy ctyps -------------------------------------------------------------------------- -- * MimeRender Instances
+ src/Servant/API/TypeLevel.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+This module collects utilities for manipulating @servant@ API types. The+functionality in this module is for advanced usage.++The code samples in this module use the following type synonym:++> type SampleAPI = "hello" :> Get '[JSON] Int+> :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool++-}+module Servant.API.TypeLevel (+ -- $setup+ -- * API predicates+ Endpoints,+ -- ** Lax inclusion+ IsElem',+ IsElem,+ IsSubAPI,+ AllIsElem,+ -- ** Strict inclusion+ IsIn,+ IsStrictSubAPI,+ AllIsIn,+ -- * Helpers+ -- ** Lists+ MapSub,+ AppendList,+ IsSubList,+ Elem,+ ElemGo,+ -- ** Logic+ Or,+ And,+ -- * Custom type errors+ -- | Before @base-4.9.0.0@ we use non-exported 'ElemNotFoundIn' class,+ -- which cannot be instantiated.+ ) where+++import GHC.Exts (Constraint)+import Servant.API.Alternative (type (:<|>))+import Servant.API.Capture (Capture, CaptureAll)+import Servant.API.Header (Header)+import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams)+import Servant.API.ReqBody (ReqBody)+import Servant.API.Sub (type (:>))+import Servant.API.Verbs (Verb)+#if MIN_VERSION_base(4,9,0)+import GHC.TypeLits (TypeError, ErrorMessage(..))+#endif++++-- * API predicates++-- | Flatten API into a list of endpoints.+--+-- >>> Refl :: Endpoints SampleAPI :~: '["hello" :> Verb 'GET 200 '[JSON] Int, "bye" :> (Capture "name" String :> Verb 'POST 200 '[JSON, PlainText] Bool)]+-- Refl+type family Endpoints api where+ Endpoints (a :<|> b) = AppendList (Endpoints a) (Endpoints b)+ Endpoints (e :> a) = MapSub e (Endpoints a)+ Endpoints a = '[a]++-- ** Lax inclusion++-- | 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@.+-- Uses @'IsElem''@ if it exhausts all other options.+--+-- >>> ok (Proxy :: Proxy (IsElem ("hello" :> Get '[JSON] Int) SampleAPI))+-- OK+--+-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))+-- ...+-- ... Could not deduce...+-- ...+--+-- An endpoint is considered within an api even if it is missing combinators+-- that don't affect the URL:+--+-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))+-- OK+--+-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (ReqBody '[JSON] Bool :> Get '[JSON] Int)))+-- OK+--+-- *N.B.:* @IsElem a b@ can be seen as capturing the notion of whether the URL+-- represented by @a@ would match the URL represented by @b@, *not* whether a+-- request represented by @a@ matches the endpoints serving @b@ (for the+-- latter, use 'IsIn').+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 sym x :> sb) = IsElem sa sb+ IsElem sa (ReqBody y x :> sb) = IsElem sa sb+ IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)+ = IsElem sa sb+ IsElem (Capture z y :> 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 (Verb m s ct typ) (Verb m s ct' typ)+ = IsSubList ct ct'+ IsElem e e = ()+ IsElem e a = IsElem' e a++-- | Check whether @sub@ is a sub-API of @api@.+--+-- >>> ok (Proxy :: Proxy (IsSubAPI SampleAPI (SampleAPI :<|> Get '[JSON] Int)))+-- OK+--+-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))+-- ...+-- ... Could not deduce...+-- ...+--+-- This uses @IsElem@ for checking; thus the note there applies here.+type family IsSubAPI sub api :: Constraint where+ IsSubAPI sub api = AllIsElem (Endpoints sub) api++-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsElem'@).+type family AllIsElem xs api :: Constraint where+ AllIsElem '[] api = ()+ AllIsElem (x ': xs) api = (IsElem x api, AllIsElem xs api)++-- ** Strict inclusion++-- | Closed type family, check if @endpoint@ is exactly within @api@.+--+-- >>> ok (Proxy :: Proxy (IsIn ("hello" :> Get '[JSON] Int) SampleAPI))+-- OK+--+-- Unlike 'IsElem', this requires an *exact* match.+--+-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))+-- ...+-- ... Could not deduce...+-- ...+type family IsIn (endpoint :: *) (api :: *) :: Constraint where+ IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)+ IsIn (e :> sa) (e :> sb) = IsIn sa sb+ IsIn e e = ()++-- | Check whether @sub@ is a sub API of @api@.+--+-- Like 'IsSubAPI', but uses 'IsIn' rather than 'IsElem'.+type family IsStrictSubAPI sub api :: Constraint where+ IsStrictSubAPI sub api = AllIsIn (Endpoints sub) api++-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@).+--+-- ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI))+-- OK+type family AllIsIn xs api :: Constraint where+ AllIsIn '[] api = ()+ AllIsIn (x ': xs) api = (IsIn x api, AllIsIn xs api)++-- * Helpers++-- ** Lists++-- | Apply @(e :>)@ to every API in @xs@.+type family MapSub e xs where+ MapSub e '[] = '[]+ MapSub e (x ': xs) = (e :> x) ': MapSub e xs++-- | Append two type-level lists.+type family AppendList xs ys where+ AppendList '[] ys = ys+ AppendList (x ': xs) ys = x ': AppendList xs ys++type family IsSubList a b :: Constraint where+ IsSubList '[] b = ()+ IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y++-- | Check that a value is an element of a list:+--+-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))+-- OK+--+-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool]))+-- ...+-- ... [Char]...'[Int, Bool...+-- ...+type Elem e es = ElemGo e es es++-- 'orig' is used to store original list for better error messages+type family ElemGo e es orig :: Constraint where+ ElemGo x (x ': xs) orig = ()+ ElemGo y (x ': xs) orig = ElemGo y xs orig+#if MIN_VERSION_base(4,9,0)+ -- Note [Custom Errors]+ ElemGo x '[] orig = TypeError ('ShowType x+ ':<>: 'Text " expected in list "+ ':<>: 'ShowType orig)+#else+ ElemGo x '[] orig = ElemNotFoundIn x orig+#endif++-- ** Logic++-- | If either a or b produce an empty constraint, produce an empty constraint.+type family Or (a :: Constraint) (b :: Constraint) :: Constraint where+ -- This works because of:+ -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap+ 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 () () = ()++-- * Custom type errors++#if !MIN_VERSION_base(4,9,0)+class ElemNotFoundIn val list+#endif++{- Note [Custom Errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We might try to factor these our more cleanly, but the type synonyms and type+families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).+-}+++-- $setup+--+-- The doctests in this module are run with following preamble:+--+-- >>> :set -XPolyKinds+-- >>> :set -XGADTs+-- >>> import Data.Proxy+-- >>> import Data.Type.Equality+-- >>> import Servant.API+-- >>> data OK ctx where OK :: ctx => OK ctx+-- >>> instance Show (OK ctx) where show _ = "OK"+-- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK+-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool+-- >>> let sampleAPI = Proxy :: Proxy SampleAPI
src/Servant/Utils/Enter.hs view
@@ -8,9 +8,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-module Servant.Utils.Enter where+module Servant.Utils.Enter (+ module Servant.Utils.Enter,+ -- * natural-transformation re-exports+ (:~>)(..),+ ) where -import qualified Control.Category as C+import Control.Natural import Control.Monad.Identity import Control.Monad.Morph import Control.Monad.Reader@@ -18,7 +22,6 @@ import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter-import Data.Typeable import Prelude () import Prelude.Compat @@ -38,57 +41,49 @@ -- ** Useful instances --- | A natural transformation from @m@ to @n@. Used to `enter` particular--- datatypes.-newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable--instance C.Category (:~>) where- id = Nat id- Nat f . Nat g = Nat (f . g)- instance Enter (m a) (m :~> n) (n a) where- enter (Nat f) = f+ enter (NT f) = f -- | Like `lift`. liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m-liftNat = Nat Control.Monad.Morph.lift+liftNat = NT Control.Monad.Morph.lift runReaderTNat :: r -> (ReaderT r m :~> m)-runReaderTNat a = Nat (`runReaderT` a)+runReaderTNat a = NT (`runReaderT` a) evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)-evalStateTLNat a = Nat (`LState.evalStateT` a)+evalStateTLNat a = NT (`LState.evalStateT` a) evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)-evalStateTSNat a = Nat (`SState.evalStateT` a)+evalStateTSNat a = NT (`SState.evalStateT` a) -- | Log the contents of `SWriter.WriterT` with the function provided as the -- first argument, and return the value of the @WriterT@ computation logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)-logWriterTSNat logger = Nat $ \x -> do+logWriterTSNat logger = NT $ \x -> do (a, w) <- SWriter.runWriterT x liftIO $ logger w return a -- | Like `logWriterTSNat`, but for strict @WriterT@. logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)-logWriterTLNat logger = Nat $ \x -> do+logWriterTLNat logger = NT $ \x -> do (a, w) <- LWriter.runWriterT x liftIO $ logger w return a -- | Like @mmorph@'s `hoist`. hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)-hoistNat (Nat n) = Nat $ hoist n+hoistNat (NT n) = NT $ hoist n -- | Like @mmorph@'s `embed`. embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)-embedNat (Nat n) = Nat $ embed n+embedNat (NT n) = NT $ embed n -- | Like @mmorph@'s `squash`. squashNat :: (Monad m, MMonad t) => t (t m) :~> t m-squashNat = Nat squash+squashNat = NT squash -- | Like @mmorph@'s `generalize`. generalizeNat :: Applicative m => Identity :~> m-generalizeNat = Nat (pure . runIdentity)+generalizeNat = NT (pure . runIdentity)
src/Servant/Utils/Links.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Type safe generation of internal links.@@ -30,7 +29,7 @@ -- 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+-- type of the endpoint. If everything lines up you will get a 'Link' out the -- other end. -- -- You may omit 'QueryParam's and the like should you not want to provide them,@@ -41,19 +40,19 @@ -- with an example. Here, a link is generated with no parameters: -- -- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)--- >>> print (safeLink api hello :: URI)--- hello+-- >>> toUrlPiece (safeLink api hello :: Link)+-- "hello" -- -- If the API has an endpoint with parameters then we can generate links with -- or without those: -- -- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)--- >>> print $ safeLink api with (Just "Hubert")--- bye?name=Hubert+-- >>> toUrlPiece $ safeLink api with (Just "Hubert")+-- "bye?name=Hubert" -- -- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)--- >>> print $ safeLink api without--- bye+-- >>> toUrlPiece $ safeLink api without+-- "bye" -- -- 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@@ -79,27 +78,24 @@ -- bad_link under api after trying the open (but empty) type family -- `IsElem'` as a last resort. module Servant.Utils.Links (+ module Servant.API.TypeLevel,+ -- * Building and using safe links --- -- | Note that 'URI' is Network.URI.URI from the network-uri package.+ -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. safeLink , URI(..) -- * Adding custom types , HasLink(..) , linkURI , Link- , IsElem'- -- * Illustrative exports- , IsElem- , Or ) where -import qualified Data.ByteString.Char8 as BSC import Data.List import Data.Monoid.Compat ( (<>) ) import Data.Proxy ( Proxy(..) ) import qualified Data.Text as Text-import GHC.Exts (Constraint)+import qualified Data.Text.Encoding as TE import GHC.TypeLits ( KnownSymbol, symbolVal ) import Network.URI ( URI(..), escapeURIString, isUnreserved ) import Prelude ()@@ -115,7 +111,7 @@ import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw )-import Servant.API.Alternative ( type (:<|>) )+import Servant.API.TypeLevel -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any@@ -126,60 +122,10 @@ } deriving Show instance ToHttpApiData Link where- toUrlPiece = Text.pack . show- toHeader = BSC.pack . show---- | If either a or b produce an empty constraint, produce an empty constraint.-type family Or (a :: Constraint) (b :: Constraint) :: Constraint where- -- This works because of:- -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap- 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--- 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 sym x :> sb) = IsElem sa sb- IsElem sa (ReqBody y x :> sb) = IsElem sa sb- IsElem (Capture z y :> sa) (Capture x y :> sb)- = IsElem sa sb- IsElem (CaptureAll z y :> sa) (CaptureAll 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 (Verb m s ct typ) (Verb m s ct' typ)- = IsSubList ct ct'- IsElem e e = ()- IsElem e a = IsElem' e a--type family IsSubList a b :: Constraint where- IsSubList '[] b = ()- IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y--type family Elem e es :: Constraint where- Elem x (x ': xs) = ()- Elem y (x ': xs) = Elem y xs+ toHeader = TE.encodeUtf8 . toUrlPiece+ toUrlPiece l =+ let uri = linkURI l+ in Text.pack $ uriPath uri ++ uriQuery uri -- Phantom types for Param data Query@@ -307,9 +253,9 @@ -- Verb (terminal) instances instance HasLink (Verb m s ct a) where- type MkLink (Verb m s ct a) = URI- toLink _ = linkURI+ type MkLink (Verb m s ct a) = Link+ toLink _ = id instance HasLink Raw where- type MkLink Raw = URI- toLink _ = linkURI+ type MkLink Raw = Link+ toLink _ = id
− test/Doctests.hs
@@ -1,40 +0,0 @@-module Main where--import Data.List (isPrefixOf)-import System.Directory-import System.FilePath-import System.FilePath.Find-import Test.DocTest--main :: IO ()-main = do- files <- find always (extension ==? ".hs") "src"- tfiles <- find always (extension ==? ".hs") "test/Servant"- mCabalMacrosFile <- getCabalMacrosFile- doctest $ "-isrc" : "-Iinclude" :- (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++- "-XOverloadedStrings" :- "-XFlexibleInstances" :- "-XMultiParamTypeClasses" :- (files ++ tfiles)--getCabalMacrosFile :: IO (Maybe FilePath)-getCabalMacrosFile = do- exists <- doesDirectoryExist "dist"- if exists- then do- contents <- getDirectoryContents "dist"- let rest = "build" </> "autogen" </> "cabal_macros.h"- whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of- [x] -> "dist" </> x </> rest- [] -> "dist" </> rest- xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"- ++ show xs ++ "\nTry cabal clean"- else return Nothing- where- whenExists :: FilePath -> IO (Maybe FilePath)- whenExists file = do- exists <- doesFileExist file- return $ if exists- then Just file- else Nothing
test/Servant/API/ContentTypesSpec.hs view
@@ -11,21 +11,25 @@ import Prelude () import Prelude.Compat -import Data.Aeson+import Data.Aeson.Compat import Data.ByteString.Char8 (ByteString, append, pack) import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Either import Data.Function (on) import Data.List (maximumBy)+import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust, isJust, isNothing) import Data.Proxy import Data.String (IsString (..)) import Data.String.Conversions (cs) import qualified Data.Text as TextS+import qualified Data.Text.Encoding as TextSE import qualified Data.Text.Lazy as TextL import GHC.Generics import Test.Hspec import Test.QuickCheck+import Text.Read (readMaybe) import "quickcheck-instances" Test.QuickCheck.Instances () import Servant.API.ContentTypes@@ -101,23 +105,31 @@ "application/octet-stream" ("content" :: ByteString) `shouldSatisfy` isJust + it "returns Just if the 'Accept' header matches, with multiple mime types" $ do+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "application/json" (3 :: Int)+ `shouldSatisfy` isJust+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "text/plain" (3 :: Int)+ `shouldSatisfy` isJust+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "image/jpeg" (3 :: Int)+ `shouldBe` Nothing+ it "returns the Content-Type as the first element of the tuple" $ do handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)- `shouldSatisfy` ((== "application/json") . fst . fromJust)+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int)- `shouldSatisfy` ((== "application/json") . fst . fromJust)+ `shouldSatisfy` ((== "application/json;charset=utf-8") . 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)+ == Just ("application/json;charset=utf-8", 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)+ , ("application/json;charset=utf-8", b) , ("text/plain;charset=utf-8", c) ] let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $@@ -158,6 +170,24 @@ (encode val) `shouldBe` Just (Right val) + it "returns Just (Right val) if the decoding succeeds for either of multiple mime-types" $ do+ let val = 42 :: Int+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"+ "42" `shouldBe` Just (Right val)+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"+ "42" `shouldBe` Just (Right val)+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"+ "42" `shouldBe` (Nothing :: Maybe (Either String Int))++ it "passes content-type to mimeUnrenderWithType" $ do+ let val = "foobar" :: TextS.Text+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"+ "\"foobar\"" `shouldBe` Just (Right val)+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"+ "foobar" `shouldBe` Just (Right val)+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"+ "foobar" `shouldBe` (Nothing :: Maybe (Either String Int))+ #if MIN_VERSION_aeson(0,9,0) -- aeson >= 0.9 decodes top-level strings describe "eitherDecodeLenient" $ do@@ -200,6 +230,23 @@ instance IsString AcceptHeader where fromString = AcceptHeader . fromString++-- To test multiple content types+data JSONorText++instance Accept JSONorText where+ contentTypes _ = "text/plain" NE.:| [ "application/json" ]++instance MimeRender JSONorText Int where+ mimeRender _ = cs . show++instance MimeUnrender JSONorText Int where+ mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack++instance MimeUnrender JSONorText TextS.Text where+ mimeUnrenderWithType _ mt+ | mt == "application/json" = maybe (Left "") Right . decode+ | otherwise = Right . TextSE.decodeUtf8 . BSL.toStrict addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)
test/Servant/Utils/LinksSpec.hs view
@@ -7,6 +7,7 @@ import Data.Proxy (Proxy (..)) import Test.Hspec (Expectation, Spec, describe, it, shouldBe)+import Data.String (fromString) import Servant.API @@ -32,38 +33,38 @@ -- | Convert a link to a URI and ensure that this maps to the given string -- given string-shouldBeURI :: URI -> String -> Expectation-shouldBeURI link expected =- show link `shouldBe` expected+shouldBeLink :: Link -> String -> Expectation+shouldBeLink link expected =+ toUrlPiece link `shouldBe` fromString expected spec :: Spec spec = describe "Servant.Utils.Links" $ do it "generates correct links for capture query params" $ do let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)- apiLink l1 "hi" `shouldBeURI` "hello/hi"+ apiLink l1 "hi" `shouldBeLink` "hello/hi" let l2 = Proxy :: Proxy ("hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent)- apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"+ apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true" it "generates correct links for CaptureAll" $ do apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent)) ["roads", "lead", "to", "rome"]- `shouldBeURI` "all/roads/lead/to/rome"+ `shouldBeLink` "all/roads/lead/to/rome" it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent)- apiLink l1 True True `shouldBeURI` "balls?bouncy&fast"- apiLink l1 False True `shouldBeURI` "balls?fast"+ apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"+ apiLink l1 False True `shouldBeLink` "balls?fast" it "generates correct links for all of the verbs" $ do- apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeURI` "get"- apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeURI` "put"- apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeURI` "post"- apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeURI` "delete"- apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"+ apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"+ apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"+ apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post"+ apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete"+ apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw" -- |@@ -96,8 +97,8 @@ -- ... -- -- sanity check--- >>> apiLink (Proxy :: Proxy AllGood)--- get+-- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood)+-- "get" type WrongPath = "getTypo" :> Get '[JSON] NoContent type WrongReturnType = "get" :> Get '[JSON] Bool type WrongContentType = "get" :> Get '[OctetStream] NoContent
+ test/doctests.hsc view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module : Main (doctests)+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+ cp <- c_GetConsoleCP+ (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ do+ traverse_ putStrLn args+ doctest args+ where+ args = + "-XOverloadedStrings" :+ "-XFlexibleInstances" :+ "-XMultiParamTypeClasses" :+ flags ++ pkgs ++ module_sources