Merge pull request #968 from phadej/issue-952-safelink-prime
Add safeLink'
This commit is contained in:
Oleg Grenrus
GitHub
commit
e1b848f67c
20
.travis.yml
20
.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'
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user