diff --git a/.travis.yml b/.travis.yml index 461daaf7c..12a235760 100644 --- a/.travis.yml +++ b/.travis.yml @@ -33,9 +33,9 @@ before_cache: matrix: include: - - compiler: "ghc-8.4.2" + - compiler: "ghc-8.4.3" # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,ghc-8.4.2], sources: [hvr-ghc]}} + addons: {apt: {packages: [ghc-ppa-tools,ghc-8.4.3], sources: [hvr-ghc]}} - compiler: "ghc-8.2.2" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,ghc-8.2.2], sources: [hvr-ghc]}} @@ -83,9 +83,9 @@ install: - rm -fv cabal.project cabal.project.local - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi" - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/basic-auth\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/https\" \"doc/cookbook/pagination\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\"\\n' > cabal.project" + - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/basic-auth\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/https\" \"doc/cookbook/pagination\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\"\\n' > cabal.project" - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project" - - "echo 'allow-newer: servant-js:servant,servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet,servant-multipart:servant,servant-multipart:servant-server,servant-auth-server:servant-server, http-media:base' >> cabal.project" + - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, http-media:base' >> cabal.project" - cat cabal.project - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); @@ -117,9 +117,6 @@ install: - if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then (cd "doc/cookbook/db-sqlite-simple" && autoreconf -i); fi - - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then - (cd "doc/cookbook/file-upload" && autoreconf -i); - fi - if [ -f "doc/cookbook/https/configure.ac" ]; then (cd "doc/cookbook/https" && autoreconf -i); fi @@ -133,7 +130,7 @@ install: (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi - rm -f cabal.project.freeze - - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/https"/dist "doc/cookbook/pagination"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist + - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/https"/dist "doc/cookbook/pagination"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Here starts the actual work to be performed for the package under test; @@ -151,19 +148,18 @@ script: - (cd "doc/cookbook/basic-auth" && cabal sdist) - (cd "doc/cookbook/db-postgres-pool" && cabal sdist) - (cd "doc/cookbook/db-sqlite-simple" && cabal sdist) - - (cd "doc/cookbook/file-upload" && cabal sdist) - (cd "doc/cookbook/https" && cabal sdist) - (cd "doc/cookbook/pagination" && cabal sdist) - (cd "doc/cookbook/structuring-apis" && cabal sdist) - (cd "doc/cookbook/using-custom-monad" && cabal sdist) - echo -en 'travis_fold:end:sdist\\r' - echo Unpacking... && echo -en 'travis_fold:start:unpack\\r' - - mv "servant"/dist/servant-*.tar.gz "servant-client"/dist/servant-client-*.tar.gz "servant-client-core"/dist/servant-client-core-*.tar.gz "servant-docs"/dist/servant-docs-*.tar.gz "servant-foreign"/dist/servant-foreign-*.tar.gz "servant-server"/dist/servant-server-*.tar.gz "doc/tutorial"/dist/tutorial-*.tar.gz "doc/cookbook/basic-auth"/dist/cookbook-basic-auth-*.tar.gz "doc/cookbook/db-postgres-pool"/dist/cookbook-db-postgres-pool-*.tar.gz "doc/cookbook/db-sqlite-simple"/dist/cookbook-db-sqlite-simple-*.tar.gz "doc/cookbook/file-upload"/dist/cookbook-file-upload-*.tar.gz "doc/cookbook/https"/dist/cookbook-https-*.tar.gz "doc/cookbook/pagination"/dist/cookbook-pagination-*.tar.gz "doc/cookbook/structuring-apis"/dist/cookbook-structuring-apis-*.tar.gz "doc/cookbook/using-custom-monad"/dist/cookbook-using-custom-monad-*.tar.gz ${DISTDIR}/ + - mv "servant"/dist/servant-*.tar.gz "servant-client"/dist/servant-client-*.tar.gz "servant-client-core"/dist/servant-client-core-*.tar.gz "servant-docs"/dist/servant-docs-*.tar.gz "servant-foreign"/dist/servant-foreign-*.tar.gz "servant-server"/dist/servant-server-*.tar.gz "doc/tutorial"/dist/tutorial-*.tar.gz "doc/cookbook/basic-auth"/dist/cookbook-basic-auth-*.tar.gz "doc/cookbook/db-postgres-pool"/dist/cookbook-db-postgres-pool-*.tar.gz "doc/cookbook/db-sqlite-simple"/dist/cookbook-db-sqlite-simple-*.tar.gz "doc/cookbook/https"/dist/cookbook-https-*.tar.gz "doc/cookbook/pagination"/dist/cookbook-pagination-*.tar.gz "doc/cookbook/structuring-apis"/dist/cookbook-structuring-apis-*.tar.gz "doc/cookbook/using-custom-monad"/dist/cookbook-using-custom-monad-*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-https-*/*.cabal cookbook-pagination-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal\\n' > cabal.project" + - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-https-*/*.cabal cookbook-pagination-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal\\n' > cabal.project" - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project" - - "echo 'allow-newer: servant-js:servant,servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet,servant-multipart:servant,servant-multipart:servant-server,servant-auth-server:servant-server, http-media:base' >> cabal.project" + - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, http-media:base' >> cabal.project" - cat cabal.project - echo -en 'travis_fold:end:unpack\\r' diff --git a/cabal.project b/cabal.project index 2b41bbf57..9a6c9e1c4 100644 --- a/cabal.project +++ b/cabal.project @@ -11,8 +11,10 @@ packages: servant/ doc/cookbook/basic-auth doc/cookbook/db-postgres-pool doc/cookbook/db-sqlite-simple - doc/cookbook/file-upload + -- MkLink changed + -- doc/cookbook/file-upload doc/cookbook/https + -- servant-auth-* doesn't support GHC-8.4 -- doc/cookbook/jwt-and-basic-auth doc/cookbook/pagination doc/cookbook/structuring-apis diff --git a/doc/cookbook/basic-auth/basic-auth.cabal b/doc/cookbook/basic-auth/basic-auth.cabal index e2006578a..ea9bfb09a 100644 --- a/doc/cookbook/basic-auth/basic-auth.cabal +++ b/doc/cookbook/basic-auth/basic-auth.cabal @@ -8,7 +8,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-basic-auth main-is: BasicAuth.lhs diff --git a/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal b/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal index cebcee7e2..6e2da06ba 100644 --- a/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal +++ b/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal @@ -8,7 +8,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-db-postgres-pool main-is: PostgresPool.lhs diff --git a/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal b/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal index 760d3929b..a6736adce 100644 --- a/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal +++ b/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal @@ -8,7 +8,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-db-sqlite-simple main-is: DBConnection.lhs diff --git a/doc/cookbook/file-upload/file-upload.cabal b/doc/cookbook/file-upload/file-upload.cabal index 55722b3af..f422e59eb 100644 --- a/doc/cookbook/file-upload/file-upload.cabal +++ b/doc/cookbook/file-upload/file-upload.cabal @@ -8,7 +8,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-file-upload main-is: FileUpload.lhs diff --git a/doc/cookbook/https/https.cabal b/doc/cookbook/https/https.cabal index 98df6c50a..790acaef1 100644 --- a/doc/cookbook/https/https.cabal +++ b/doc/cookbook/https/https.cabal @@ -8,7 +8,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-https main-is: Https.lhs diff --git a/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal b/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal index 15d8d22ba..4ff5e6f1f 100644 --- a/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal +++ b/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal @@ -11,7 +11,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com category: Servant build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-jwt-and-basic-auth if !impl(ghc >= 7.10) diff --git a/doc/cookbook/pagination/pagination.cabal b/doc/cookbook/pagination/pagination.cabal index db177efb0..91382df43 100644 --- a/doc/cookbook/pagination/pagination.cabal +++ b/doc/cookbook/pagination/pagination.cabal @@ -11,7 +11,7 @@ cabal-version: >=1.10 extra-source-files: Pagination.lhs dummy/Pagination.lhs -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-pagination main-is: Pagination.lhs diff --git a/doc/cookbook/structuring-apis/structuring-apis.cabal b/doc/cookbook/structuring-apis/structuring-apis.cabal index 9b85de19c..de50bf43b 100644 --- a/doc/cookbook/structuring-apis/structuring-apis.cabal +++ b/doc/cookbook/structuring-apis/structuring-apis.cabal @@ -8,7 +8,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-structuring-apis main-is: StructuringApis.lhs diff --git a/doc/cookbook/using-custom-monad/using-custom-monad.cabal b/doc/cookbook/using-custom-monad/using-custom-monad.cabal index 22fb44503..d5945b019 100644 --- a/doc/cookbook/using-custom-monad/using-custom-monad.cabal +++ b/doc/cookbook/using-custom-monad/using-custom-monad.cabal @@ -8,7 +8,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-using-custom-monad main-is: UsingCustomMonad.lhs diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 9b8cab59f..9c928c119 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -17,7 +17,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 - GHC==8.4.2 + GHC==8.4.3 extra-source-files: static/index.html static/ui.js diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 6c116b784..7888f0085 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -23,7 +23,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 - GHC==8.4.2 + GHC==8.4.3 source-repository head type: git diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index e5d25ae11..394ba3f28 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -21,7 +21,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 - GHC==8.4.2 + GHC==8.4.3 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 6ee8277d0..fc3624c9e 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -21,7 +21,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 - GHC==8.4.2 + GHC==8.4.3 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 2b0fbd6c3..a8af2ec17 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -27,7 +27,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 - GHC==8.4.2 + GHC==8.4.3 source-repository head type: git diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 3da71e13d..4ac5e101b 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -26,7 +26,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 - GHC==8.4.2 + GHC==8.4.3 extra-source-files: include/*.h CHANGELOG.md diff --git a/servant/servant.cabal b/servant/servant.cabal index 0dd30bd59..8a9589ed3 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -22,7 +22,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 - GHC==8.4.2 + GHC==8.4.3 extra-source-files: include/*.h CHANGELOG.md diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 6ae8bb37b..5002bcca4 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -19,8 +19,6 @@ -- >>> import Servant.Utils.Links -- >>> import Data.Proxy -- >>> --- >>> --- >>> -- >>> type Hello = "hello" :> Get '[JSON] Int -- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent -- >>> type API = Hello :<|> Bye @@ -63,10 +61,24 @@ -- >>> :set -XConstraintKinds -- >>> :{ -- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) --- >>> => Proxy endpoint -> MkLink endpoint +-- >>> => Proxy endpoint -> MkLink endpoint Link -- >>> apiLink = safeLink api -- >>> :} -- +-- `safeLink'` allows to make specialise the output: +-- +-- >>> safeLink' toUrlPiece api without +-- "bye" +-- +-- >>> :{ +-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint) +-- >>> => Proxy endpoint -> MkLink endpoint Text +-- >>> apiTextLink = safeLink' toUrlPiece api +-- >>> :} +-- +-- >>> apiTextLink without +-- "bye" +-- -- Attempting to construct a link to an endpoint that does not exist in api -- will result in a type error like this: -- @@ -86,7 +98,9 @@ module Servant.Utils.Links ( -- -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. safeLink + , safeLink' , allLinks + , allLinks' , URI(..) -- * Adding custom types , HasLink(..) @@ -109,8 +123,6 @@ import Data.Singletons.Bool (SBool (..), SBoolI (..)) import qualified Data.Text as Text import qualified Data.Text.Encoding as TE -import Data.Type.Bool - (If) import Data.Type.Bool (If) import GHC.TypeLits @@ -278,8 +290,18 @@ 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) + -> MkLink endpoint Link +safeLink = safeLink' id + +-- | More general 'safeLink'. +-- +safeLink' + :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint) + => (Link -> a) + -> 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 a +safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty) -- | Create all links in an API. -- @@ -295,37 +317,47 @@ safeLink _ endpoint = toLink endpoint (Link mempty mempty) -- -- Note: nested APIs don't work well with this approach -- --- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) --- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) :: * +-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link +-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: * -- = Char -> (Int -> Link) :<|> (Double -> Link) --- allLinks :: forall api. HasLink api => Proxy api - -> MkLink api -allLinks api = toLink api (Link mempty mempty) + -> MkLink api Link +allLinks = allLinks' id + +-- | More general 'allLinks'. See `safeLink'`. +allLinks' + :: forall api a. HasLink api + => (Link -> a) + -> Proxy api + -> MkLink api a +allLinks' toA api = toLink toA api (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 + type MkLink endpoint (a :: *) + toLink + :: (Link -> a) + -> Proxy endpoint -- ^ The API endpoint you would like to point to + -> Link + -> MkLink endpoint a -- Naked symbol instance instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where - type MkLink (sym :> sub) = MkLink sub - toLink _ = - toLink (Proxy :: Proxy sub) . addSegment (escaped seg) + type MkLink (sym :> sub) a = MkLink sub a + toLink toA _ = + toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg) where seg = symbolVal (Proxy :: Proxy sym) -- QueryParam instances instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods)) - => HasLink (QueryParam' mods sym v :> sub) where - type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub - toLink _ l mv = - toLink (Proxy :: Proxy sub) $ + => HasLink (QueryParam' mods sym v :> sub) + where + type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a + toLink toA _ l mv = + toLink toA (Proxy :: Proxy sub) $ case sbool :: SBool (FoldRequired mods) of STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l @@ -334,105 +366,121 @@ instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mo k = symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) - => HasLink (QueryParams sym v :> sub) where - type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub - toLink _ l = - toLink (Proxy :: Proxy sub) . + => HasLink (QueryParams sym v :> sub) + where + type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a + toLink toA _ l = + toLink toA (Proxy :: Proxy sub) . foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam 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 + => HasLink (QueryFlag sym :> sub) + where + type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a + toLink toA _ l False = + toLink toA (Proxy :: Proxy sub) l + toLink toA _ l True = + toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l where k = symbolVal (Proxy :: Proxy sym) -- :<|> instance - Generate all links at once instance (HasLink a, HasLink b) => HasLink (a :<|> b) where - type MkLink (a :<|> b) = MkLink a :<|> MkLink b - toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l + type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r + toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l -- Misc instances instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where - type MkLink (ReqBody' mods ct a :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r + toLink toA _ = toLink toA (Proxy :: Proxy sub) instance (ToHttpApiData v, HasLink sub) - => HasLink (Capture' mods sym v :> sub) where - type MkLink (Capture' mods sym v :> sub) = v -> MkLink sub - toLink _ l v = - toLink (Proxy :: Proxy sub) $ + => HasLink (Capture' mods sym v :> sub) + where + type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a + toLink toA _ l v = + toLink toA (Proxy :: Proxy sub) $ addSegment (escaped . Text.unpack $ toUrlPiece v) l instance (ToHttpApiData v, HasLink sub) - => HasLink (CaptureAll sym v :> sub) where - type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub - toLink _ l vs = - toLink (Proxy :: Proxy sub) $ - foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs + => HasLink (CaptureAll sym v :> sub) + where + type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a + toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $ + foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs -instance HasLink sub => HasLink (Header' mods sym a :> sub) where - type MkLink (Header' mods sym a :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) +instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where + type MkLink (Header' mods sym a :> sub) r = MkLink sub r + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (Vault :> sub) where - type MkLink (Vault :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (Vault :> sub) a = MkLink sub a + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (Description s :> sub) where - type MkLink (Description s :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (Description s :> sub) a = MkLink sub a + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (Summary s :> sub) where - type MkLink (Summary s :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (Summary s :> sub) a = MkLink sub a + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (HttpVersion :> sub) where - type MkLink (HttpVersion:> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (HttpVersion:> sub) a = MkLink sub a + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (IsSecure :> sub) where - type MkLink (IsSecure :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (IsSecure :> sub) a = MkLink sub a + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (WithNamedContext name context sub) where - type MkLink (WithNamedContext name context sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (WithNamedContext name context sub) a = MkLink sub a + toLink toA _ = toLink toA (Proxy :: Proxy sub) instance HasLink sub => HasLink (RemoteHost :> sub) where - type MkLink (RemoteHost :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (RemoteHost :> sub) a = MkLink sub a + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (BasicAuth realm a :> sub) where - type MkLink (BasicAuth realm a :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (BasicAuth realm a :> sub) r = MkLink sub r + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink EmptyAPI where - type MkLink EmptyAPI = EmptyAPI - toLink _ _ = EmptyAPI + type MkLink EmptyAPI a = EmptyAPI + toLink _ _ _ = EmptyAPI -- Verb (terminal) instances instance HasLink (Verb m s ct a) where - type MkLink (Verb m s ct a) = Link - toLink _ = id + type MkLink (Verb m s ct a) r = r + toLink toA _ = toA instance HasLink Raw where - type MkLink Raw = Link - toLink _ = id + type MkLink Raw a = a + toLink toA _ = toA instance HasLink (Stream m fr ct a) where - type MkLink (Stream m fr ct a) = Link - toLink _ = id + type MkLink (Stream m fr ct a) r = r + toLink toA _ = toA -- AuthProtext instances instance HasLink sub => HasLink (AuthProtect tag :> sub) where - type MkLink (AuthProtect tag :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (AuthProtect tag :> sub) a = MkLink sub a + toLink = simpleToLink (Proxy :: Proxy sub) + +-- | Helper for implemneting 'toLink' for combinators not affecting link +-- structure. +simpleToLink + :: forall sub a combinator. + (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a) + => Proxy sub + -> (Link -> a) + -> Proxy (combinator :> sub) + -> Link + -> MkLink (combinator :> sub) a +simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub) + -- $setup -- >>> import Servant.API diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 1d30d578a..1ebb0fc64 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -41,7 +41,7 @@ type LinkableApi = apiLink :: (IsElem endpoint TestApi, HasLink endpoint) - => Proxy endpoint -> MkLink endpoint + => Proxy endpoint -> MkLink endpoint Link apiLink = safeLink (Proxy :: Proxy TestApi) -- | Convert a link to a URI and ensure that this maps to the given string