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

Merge pull request #968 from phadej/issue-952-safelink-prime

Browse source 
Add safeLink'
This commit is contained in:
Oleg Grenrus 2018-06-01 16:47:33 +03:00 committed by GitHub
commit e1b848f67c
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
20 changed files with 151 additions and 105 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
.travis.yml
View file

@ -33,9 +33,9 @@ before_cache:
matrix: matrix:
include: include:
- compiler: "ghc-8.4.2" - compiler: "ghc-8.4.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks # 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" - compiler: "ghc-8.2.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks # env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,ghc-8.2.2], sources: [hvr-ghc]}} 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 - 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" - "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*$' - 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 '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 - cat cabal.project
- if [ -f "servant/configure.ac" ]; then - if [ -f "servant/configure.ac" ]; then
(cd "servant" && autoreconf -i); (cd "servant" && autoreconf -i);
@ -117,9 +117,6 @@ install:
- if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then - if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then
(cd "doc/cookbook/db-sqlite-simple" && autoreconf -i); (cd "doc/cookbook/db-sqlite-simple" && autoreconf -i);
fi 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 - if [ -f "doc/cookbook/https/configure.ac" ]; then
(cd "doc/cookbook/https" && autoreconf -i); (cd "doc/cookbook/https" && autoreconf -i);
fi fi
@ -133,7 +130,7 @@ install:
(cd "doc/cookbook/using-custom-monad" && autoreconf -i); (cd "doc/cookbook/using-custom-monad" && autoreconf -i);
fi fi
- rm -f cabal.project.freeze - 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) - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
# Here starts the actual work to be performed for the package under test; # 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/basic-auth" && cabal sdist)
- (cd "doc/cookbook/db-postgres-pool" && cabal sdist) - (cd "doc/cookbook/db-postgres-pool" && cabal sdist)
- (cd "doc/cookbook/db-sqlite-simple" && 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/https" && cabal sdist)
- (cd "doc/cookbook/pagination" && cabal sdist) - (cd "doc/cookbook/pagination" && cabal sdist)
- (cd "doc/cookbook/structuring-apis" && cabal sdist) - (cd "doc/cookbook/structuring-apis" && cabal sdist)
- (cd "doc/cookbook/using-custom-monad" && cabal sdist) - (cd "doc/cookbook/using-custom-monad" && cabal sdist)
- echo -en 'travis_fold:end:sdist\\r' - echo -en 'travis_fold:end:sdist\\r'
- echo Unpacking... && echo -en 'travis_fold:start:unpack\\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 - cd ${DISTDIR} || false
- find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - 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 '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 - cat cabal.project
- echo -en 'travis_fold:end:unpack\\r' - echo -en 'travis_fold:end:unpack\\r'

4
cabal.project
View file

@ -11,8 +11,10 @@ packages: servant/
doc/cookbook/basic-auth doc/cookbook/basic-auth
doc/cookbook/db-postgres-pool doc/cookbook/db-postgres-pool
doc/cookbook/db-sqlite-simple doc/cookbook/db-sqlite-simple
doc/cookbook/file-upload -- MkLink changed
-- doc/cookbook/file-upload
doc/cookbook/https doc/cookbook/https
-- servant-auth-* doesn't support GHC-8.4
-- doc/cookbook/jwt-and-basic-auth -- doc/cookbook/jwt-and-basic-auth
doc/cookbook/pagination doc/cookbook/pagination
doc/cookbook/structuring-apis doc/cookbook/structuring-apis

2
doc/cookbook/basic-auth/basic-auth.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 executable cookbook-basic-auth
main-is: BasicAuth.lhs main-is: BasicAuth.lhs

2
doc/cookbook/db-postgres-pool/db-postgres-pool.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 executable cookbook-db-postgres-pool
main-is: PostgresPool.lhs main-is: PostgresPool.lhs

2
doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 executable cookbook-db-sqlite-simple
main-is: DBConnection.lhs main-is: DBConnection.lhs

2
doc/cookbook/file-upload/file-upload.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 executable cookbook-file-upload
main-is: FileUpload.lhs main-is: FileUpload.lhs

2
doc/cookbook/https/https.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 executable cookbook-https
main-is: Https.lhs main-is: Https.lhs

2
doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal
View file

@ -11,7 +11,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com
category: Servant category: Servant
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 executable cookbook-jwt-and-basic-auth
if !impl(ghc >= 7.10) if !impl(ghc >= 7.10)

2
doc/cookbook/pagination/pagination.cabal
View file

@ -11,7 +11,7 @@ cabal-version: >=1.10
extra-source-files: extra-source-files:
Pagination.lhs Pagination.lhs
dummy/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 executable cookbook-pagination
main-is: Pagination.lhs main-is: Pagination.lhs

2
doc/cookbook/structuring-apis/structuring-apis.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 executable cookbook-structuring-apis
main-is: StructuringApis.lhs main-is: StructuringApis.lhs

2
doc/cookbook/using-custom-monad/using-custom-monad.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 executable cookbook-using-custom-monad
main-is: UsingCustomMonad.lhs main-is: UsingCustomMonad.lhs

2
doc/tutorial/tutorial.cabal
View file

@ -17,7 +17,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.2 GHC==8.4.3
extra-source-files: extra-source-files:
static/index.html static/index.html
static/ui.js static/ui.js

2
servant-client-core/servant-client-core.cabal
View file

@ -23,7 +23,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.2 GHC==8.4.3
source-repository head source-repository head
type: git type: git

2
servant-client/servant-client.cabal
View file

@ -21,7 +21,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.2 GHC==8.4.3
homepage: http://haskell-servant.readthedocs.org/ homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files: extra-source-files:

2
servant-docs/servant-docs.cabal
View file

@ -21,7 +21,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.2 GHC==8.4.3
homepage: http://haskell-servant.readthedocs.org/ homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files: extra-source-files:

2
servant-foreign/servant-foreign.cabal
View file

@ -27,7 +27,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.2 GHC==8.4.3
source-repository head source-repository head
type: git type: git

2
servant-server/servant-server.cabal
View file

@ -26,7 +26,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.2 GHC==8.4.3
extra-source-files: extra-source-files:
include/*.h include/*.h
CHANGELOG.md CHANGELOG.md

2
servant/servant.cabal
View file

@ -22,7 +22,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.2 GHC==8.4.3
extra-source-files: extra-source-files:
include/*.h include/*.h
CHANGELOG.md CHANGELOG.md

194
servant/src/Servant/Utils/Links.hs
View file

@ -19,8 +19,6 @@
-- >>> import Servant.Utils.Links -- >>> import Servant.Utils.Links
-- >>> import Data.Proxy -- >>> import Data.Proxy
-- >>> -- >>>
-- >>>
-- >>>
-- >>> type Hello = "hello" :> Get '[JSON] Int -- >>> type Hello = "hello" :> Get '[JSON] Int
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent -- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
-- >>> type API = Hello :<|> Bye -- >>> type API = Hello :<|> Bye
@ -63,10 +61,24 @@
-- >>> :set -XConstraintKinds -- >>> :set -XConstraintKinds
-- >>> :{ -- >>> :{
-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) -- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
-- >>> => Proxy endpoint -> MkLink endpoint -- >>> => Proxy endpoint -> MkLink endpoint Link
-- >>> apiLink = safeLink api -- >>> 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 -- Attempting to construct a link to an endpoint that does not exist in api
-- will result in a type error like this: -- 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. -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
safeLink safeLink
, safeLink'
, allLinks , allLinks
, allLinks'
, URI(..) , URI(..)
-- * Adding custom types -- * Adding custom types
, HasLink(..) , HasLink(..)
@ -109,8 +123,6 @@ import Data.Singletons.Bool
(SBool (..), SBoolI (..)) (SBool (..), SBoolI (..))
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import Data.Type.Bool
(If)
import Data.Type.Bool import Data.Type.Bool
(If) (If)
import GHC.TypeLits import GHC.TypeLits
@ -278,8 +290,18 @@ safeLink
:: forall endpoint api. (IsElem endpoint api, HasLink endpoint) :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
=> Proxy api -- ^ The whole API that this endpoint is a part of => Proxy api -- ^ The whole API that this endpoint is a part of
-> Proxy endpoint -- ^ The API endpoint you would like to point to -> Proxy endpoint -- ^ The API endpoint you would like to point to
-> MkLink endpoint -> MkLink endpoint Link
safeLink _ endpoint = toLink endpoint (Link mempty mempty) 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. -- | 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 -- 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)) -- >>> :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)) :: * -- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
-- = Char -> (Int -> Link) :<|> (Double -> Link) -- = Char -> (Int -> Link) :<|> (Double -> Link)
--
allLinks allLinks
:: forall api. HasLink api :: forall api. HasLink api
=> Proxy api => Proxy api
-> MkLink api -> MkLink api Link
allLinks api = toLink api (Link mempty mempty) 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. -- | Construct a toLink for an endpoint.
class HasLink endpoint where class HasLink endpoint where
type MkLink endpoint type MkLink endpoint (a :: *)
toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to toLink
:: (Link -> a)
-> Proxy endpoint -- ^ The API endpoint you would like to point to
-> Link -> Link
-> MkLink endpoint -> MkLink endpoint a
-- Naked symbol instance -- Naked symbol instance
instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
type MkLink (sym :> sub) = MkLink sub type MkLink (sym :> sub) a = MkLink sub a
toLink _ = toLink toA _ =
toLink (Proxy :: Proxy sub) . addSegment (escaped seg) toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
where where
seg = symbolVal (Proxy :: Proxy sym) seg = symbolVal (Proxy :: Proxy sym)
-- QueryParam instances -- QueryParam instances
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods)) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
=> HasLink (QueryParam' mods sym v :> sub) where => HasLink (QueryParam' mods sym v :> sub)
type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub where
toLink _ l mv = type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l mv =
toLink toA (Proxy :: Proxy sub) $
case sbool :: SBool (FoldRequired mods) of case sbool :: SBool (FoldRequired mods) of
STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
SFalse -> maybe id (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) k = symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
=> HasLink (QueryParams sym v :> sub) where => HasLink (QueryParams sym v :> sub)
type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub where
toLink _ l = type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
toLink (Proxy :: Proxy sub) . toLink toA _ l =
toLink toA (Proxy :: Proxy sub) .
foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
where where
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, HasLink sub) instance (KnownSymbol sym, HasLink sub)
=> HasLink (QueryFlag sym :> sub) where => HasLink (QueryFlag sym :> sub)
type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub where
toLink _ l False = type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
toLink (Proxy :: Proxy sub) l toLink toA _ l False =
toLink _ l True = toLink toA (Proxy :: Proxy sub) l
toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l toLink toA _ l True =
toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
where where
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
-- :<|> instance - Generate all links at once -- :<|> instance - Generate all links at once
instance (HasLink a, HasLink b) => HasLink (a :<|> b) where instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
type MkLink (a :<|> b) = MkLink a :<|> MkLink b type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
-- Misc instances -- Misc instances
instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
type MkLink (ReqBody' mods ct a :> sub) = MkLink sub type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink toA _ = toLink toA (Proxy :: Proxy sub)
instance (ToHttpApiData v, HasLink sub) instance (ToHttpApiData v, HasLink sub)
=> HasLink (Capture' mods sym v :> sub) where => HasLink (Capture' mods sym v :> sub)
type MkLink (Capture' mods sym v :> sub) = v -> MkLink sub where
toLink _ l v = type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l v =
toLink toA (Proxy :: Proxy sub) $
addSegment (escaped . Text.unpack $ toUrlPiece v) l addSegment (escaped . Text.unpack $ toUrlPiece v) l
instance (ToHttpApiData v, HasLink sub) instance (ToHttpApiData v, HasLink sub)
=> HasLink (CaptureAll sym v :> sub) where => HasLink (CaptureAll sym v :> sub)
type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub where
toLink _ l vs = type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
instance HasLink sub => HasLink (Header' mods sym a :> sub) where instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
type MkLink (Header' mods sym a :> sub) = MkLink sub type MkLink (Header' mods sym a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Vault :> sub) where instance HasLink sub => HasLink (Vault :> sub) where
type MkLink (Vault :> sub) = MkLink sub type MkLink (Vault :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Description s :> sub) where instance HasLink sub => HasLink (Description s :> sub) where
type MkLink (Description s :> sub) = MkLink sub type MkLink (Description s :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Summary s :> sub) where instance HasLink sub => HasLink (Summary s :> sub) where
type MkLink (Summary s :> sub) = MkLink sub type MkLink (Summary s :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (HttpVersion :> sub) where instance HasLink sub => HasLink (HttpVersion :> sub) where
type MkLink (HttpVersion:> sub) = MkLink sub type MkLink (HttpVersion:> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (IsSecure :> sub) where instance HasLink sub => HasLink (IsSecure :> sub) where
type MkLink (IsSecure :> sub) = MkLink sub type MkLink (IsSecure :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (WithNamedContext name context sub) where instance HasLink sub => HasLink (WithNamedContext name context sub) where
type MkLink (WithNamedContext name context sub) = MkLink sub type MkLink (WithNamedContext name context sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink toA _ = toLink toA (Proxy :: Proxy sub)
instance HasLink sub => HasLink (RemoteHost :> sub) where instance HasLink sub => HasLink (RemoteHost :> sub) where
type MkLink (RemoteHost :> sub) = MkLink sub type MkLink (RemoteHost :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
type MkLink (BasicAuth realm a :> sub) = MkLink sub type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink EmptyAPI where instance HasLink EmptyAPI where
type MkLink EmptyAPI = EmptyAPI type MkLink EmptyAPI a = EmptyAPI
toLink _ _ = EmptyAPI toLink _ _ _ = EmptyAPI
-- Verb (terminal) instances -- Verb (terminal) instances
instance HasLink (Verb m s ct a) where instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = Link type MkLink (Verb m s ct a) r = r
toLink _ = id toLink toA _ = toA
instance HasLink Raw where instance HasLink Raw where
type MkLink Raw = Link type MkLink Raw a = a
toLink _ = id toLink toA _ = toA
instance HasLink (Stream m fr ct a) where instance HasLink (Stream m fr ct a) where
type MkLink (Stream m fr ct a) = Link type MkLink (Stream m fr ct a) r = r
toLink _ = id toLink toA _ = toA
-- AuthProtext instances -- AuthProtext instances
instance HasLink sub => HasLink (AuthProtect tag :> sub) where instance HasLink sub => HasLink (AuthProtect tag :> sub) where
type MkLink (AuthProtect tag :> sub) = MkLink sub type MkLink (AuthProtect tag :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) 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 -- $setup
-- >>> import Servant.API -- >>> import Servant.API

2
servant/test/Servant/Utils/LinksSpec.hs
View file

@ -41,7 +41,7 @@ type LinkableApi =
apiLink :: (IsElem endpoint TestApi, HasLink endpoint) apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
=> Proxy endpoint -> MkLink endpoint => Proxy endpoint -> MkLink endpoint Link
apiLink = safeLink (Proxy :: Proxy TestApi) apiLink = safeLink (Proxy :: Proxy TestApi)
-- | Convert a link to a URI and ensure that this maps to the given string -- | Convert a link to a URI and ensure that this maps to the given string