git.iko.soy/servant
on master help sign in
Merge pull request #1003 from phadej/updates-and-generic
d5ed0feOleg Grenrus
cabal.project+1
compare with master
unifiedsplit
@@ -12,6 +12,7 @@ packages: servant/
12 doc/cookbook/db-postgres-pool
12 doc/cookbook/db-postgres-pool
13 doc/cookbook/db-sqlite-simple
13 doc/cookbook/db-sqlite-simple
14 doc/cookbook/file-upload
14 doc/cookbook/file-upload
15+ doc/cookbook/generic
15 doc/cookbook/https
16 doc/cookbook/https
16 doc/cookbook/jwt-and-basic-auth
17 doc/cookbook/jwt-and-basic-auth
17 doc/cookbook/pagination
18 doc/cookbook/pagination
doc/cookbook/generic/Generic.lhsnew file+106
@@ -0,0 +1,106 @@
1+# Using generics
2+
3+```haskell
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE DeriveGeneric #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE TypeOperators #-}
8+module Main (main, api, getLink, routesLinks, cliGet) where
9+
10+import Control.Exception (throwIO)
11+import Data.Proxy (Proxy (..))
12+import Network.Wai.Handler.Warp (run)
13+import System.Environment (getArgs)
14+
15+import Servant
16+import Servant.Client
17+
18+import Servant.API.Generic
19+import Servant.Client.Generic
20+import Servant.Server.Generic
21+```
22+
23+The usage is simple, if you only need a collection of routes.
24+First you define a record with field types prefixed by a parameter `route`:
25+
26+```haskell
27+data Routes route = Routes
28+ { _get :: route :- Capture "id" Int :> Get '[JSON] String
29+ , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
30+ }
31+ deriving (Generic)
32+```
33+
34+Then we'll use this data type to define API, links, server and client.
35+
36+## API
37+
38+You can get a `Proxy` of the API using `genericApi`:
39+
40+```haskell
41+api :: Proxy (ToServantApi Routes)
42+api = genericApi (Proxy :: Proxy Routes)
43+```
44+
45+It's recommented to use `genericApi` function, as then you'll get
46+better error message, for example if you forget to `derive Generic`.
47+
48+## Links
49+
50+The clear advantage of record-based generics approach, is that
51+we can get safe links very conviently. We don't need to define endpoint types,
52+as field accessors work as proxies:
53+
54+```haskell
55+getLink :: Int -> Link
56+getLink = fieldLink _get
57+```
58+
59+We can also get all links at once, as a record:
60+
61+```haskell
62+routesLinks :: Routes (AsLink Link)
63+routesLinks = allFieldLinks
64+```
65+
66+## Client
67+
68+Even more power starts to show when we generate a record of client functions.
69+Here we use `genericClientHoist` function, which let us simultaneously
70+hoist the monad, in this case from `ClientM` to `IO`.
71+
72+```haskell
73+cliRoutes :: Routes (AsClientT IO)
74+cliRoutes = genericClientHoist
75+ (\x -> runClientM x env >>= either throwIO return)
76+ where
77+ env = error "undefined environment"
78+
79+cliGet :: Int -> IO String
80+cliGet = _get cliRoutes
81+```
82+
83+## Server
84+
85+Finally, probably the most handy usage: we can convert record of handlers into
86+the server implementation:
87+
88+```haskell
89+record :: Routes AsServer
90+record = Routes
91+ { _get = return . show
92+ , _put = return . odd
93+ }
94+
95+app :: Application
96+app = genericServe record
97+
98+main :: IO ()
99+main = do
100+ args <- getArgs
101+ case args of
102+ ("run":_) -> do
103+ putStrLn "Starting cookbook-generic at http://localhost:8000"
104+ run 8000 app
105+ _ -> putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run"
106+```
doc/cookbook/generic/generic.cabalnew file+25
@@ -0,0 +1,25 @@
1+name: cookbook-generic
2+version: 0.1
3+synopsis: Using custom monad to pass a state between handlers
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
6+license-file: ../../../servant/LICENSE
7+author: Servant Contributors
8+maintainer: haskell-servant-maintainers@googlegroups.com
9+build-type: Simple
10+cabal-version: >=1.10
11+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
12+
13+executable cookbook-using-custom-monad
14+ main-is: Generic.lhs
15+ build-depends: base == 4.*
16+ , servant
17+ , servant-client
18+ , servant-client-core
19+ , servant-server
20+ , base-compat
21+ , warp >= 3.2
22+ , transformers >= 0.3
23+ default-language: Haskell2010
24+ ghc-options: -Wall -pgmL markdown-unlit
25+ build-tool-depends: markdown-unlit:markdown-unlit >= 0.4
doc/tutorial/tutorial.cabal+2−2
@@ -75,8 +75,8 @@ library
75 , time >= 1.4.2 && < 1.9
75 , time >= 1.4.2 && < 1.9
76
76
77 -- For legacy tools, we need to specify build-depends too
77 -- For legacy tools, we need to specify build-depends too
78− build-depends: markdown-unlit >= 0.4.1 && <0.5
78+ build-depends: markdown-unlit >= 0.5.0 && <0.6
79− build-tool-depends: markdown-unlit:markdown-unlit >= 0.4.1 && <0.5
79+ build-tool-depends: markdown-unlit:markdown-unlit >= 0.5.0 && <0.6
80
80
81test-suite spec
81test-suite spec
82 type: exitcode-stdio-1.0
82 type: exitcode-stdio-1.0
servant-client-core/CHANGELOG.md+8
@@ -1,6 +1,14 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4+0.14.1
5+------
6+
7+- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick))
8+ into `servant` (`Servant.API.Generic`),
9+ `servant-client-code` (`Servant.Client.Generic`)
10+ and `servant-server` (`Servant.Server.Generic`).
11+
40.14
120.14
5----
13----
6
14
servant-client-core/servant-client-core.cabal+3−2
@@ -1,5 +1,5 @@
1name: servant-client-core
1name: servant-client-core
2−version: 0.14
2+version: 0.14.1
3synopsis: Core functionality and class for client function generation for servant APIs
3synopsis: Core functionality and class for client function generation for servant APIs
4description:
4description:
5 This library provides backend-agnostic generation of client functions. For
5 This library provides backend-agnostic generation of client functions. For
@@ -33,6 +33,7 @@ library
33 exposed-modules:
33 exposed-modules:
34 Servant.Client.Core
34 Servant.Client.Core
35 Servant.Client.Free
35 Servant.Client.Free
36+ Servant.Client.Generic
36 Servant.Client.Core.Reexport
37 Servant.Client.Core.Reexport
37 Servant.Client.Core.Internal.Auth
38 Servant.Client.Core.Internal.Auth
38 Servant.Client.Core.Internal.BaseUrl
39 Servant.Client.Core.Internal.BaseUrl
@@ -59,7 +60,7 @@ library
59
60
60 -- Servant dependencies
61 -- Servant dependencies
61 build-depends:
62 build-depends:
62− servant == 0.14.*
63+ servant >= 0.14.1 && <0.15
63
64
64 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
65 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
65 -- Here can be exceptions if we really need features from the newer versions.
66 -- Here can be exceptions if we really need features from the newer versions.
servant-client-core/src/Servant/Client/Generic.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+module Servant.Client.Generic (
8+ AsClientT,
9+ genericClient,
10+ genericClientHoist,
11+ ) where
12+
13+import Data.Proxy
14+ (Proxy (..))
15+
16+import Servant.API.Generic
17+import Servant.Client.Core
18+
19+-- | A type that specifies that an API reocrd contains a client implementation.
20+data AsClientT (m :: * -> *)
21+instance GenericMode (AsClientT m) where
22+ type AsClientT m :- api = Client m api
23+
24+-- | Generate a record of client functions.
25+genericClient
26+ :: forall routes m.
27+ ( HasClient m (ToServantApi routes)
28+ , GenericServant routes (AsClientT m)
29+ , Client m (ToServantApi routes) ~ ToServant routes (AsClientT m)
30+ )
31+ => routes (AsClientT m)
32+genericClient
33+ = fromServant
34+ $ clientIn (Proxy :: Proxy (ToServantApi routes)) (Proxy :: Proxy m)
35+
36+-- | 'genericClient' but with 'hoistClientMonad' in between.
37+genericClientHoist
38+ :: forall routes m n.
39+ ( HasClient m (ToServantApi routes)
40+ , GenericServant routes (AsClientT n)
41+ , Client n (ToServantApi routes) ~ ToServant routes (AsClientT n)
42+ )
43+ => (forall x. m x -> n x) -- ^ natural transformation
44+ -> routes (AsClientT n)
45+genericClientHoist nt
46+ = fromServant
47+ $ hoistClientMonad m api nt
48+ $ clientIn api m
49+ where
50+ m = Proxy :: Proxy m
51+ api = Proxy :: Proxy (ToServantApi routes)
servant-client-ghcjs/servant-client-ghcjs.cabal+1−1
@@ -42,7 +42,7 @@ library
42 , http-types >= 0.12 && < 0.13
42 , http-types >= 0.12 && < 0.13
43 , monad-control >= 1.0.0.4 && < 1.1
43 , monad-control >= 1.0.0.4 && < 1.1
44 , mtl >= 2.1 && < 2.3
44 , mtl >= 2.1 && < 2.3
45− , semigroupoids >= 4.3 && < 5.3
45+ , semigroupoids >= 4.3 && < 5.4
46 , servant-client-core == 0.14.*
46 , servant-client-core == 0.14.*
47 , string-conversions >= 0.3 && < 0.5
47 , string-conversions >= 0.3 && < 0.5
48 , transformers >= 0.3 && < 0.6
48 , transformers >= 0.3 && < 0.6
servant-client/servant-client.cabal+1−1
@@ -66,7 +66,7 @@ library
66 , http-types >= 0.12.1 && < 0.13
66 , http-types >= 0.12.1 && < 0.13
67 , exceptions >= 0.10.0 && < 0.11
67 , exceptions >= 0.10.0 && < 0.11
68 , monad-control >= 1.0.2.3 && < 1.1
68 , monad-control >= 1.0.2.3 && < 1.1
69− , semigroupoids >= 5.2.2 && < 5.3
69+ , semigroupoids >= 5.2.2 && < 5.4
70 , stm >= 2.4.5.0 && < 2.5
70 , stm >= 2.4.5.0 && < 2.5
71 , transformers-base >= 0.4.5.2 && < 0.5
71 , transformers-base >= 0.4.5.2 && < 0.5
72 , transformers-compat >= 0.6.2 && < 0.7
72 , transformers-compat >= 0.6.2 && < 0.7
servant-client/test/Servant/StreamSpec.hs+2
@@ -130,6 +130,7 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
130 jrb = Just (Right bob)
130 jrb = Just (Right bob)
131 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
131 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
132
132
133+{-
133 it "streams in constant memory" $ \(_, baseUrl) -> do
134 it "streams in constant memory" $ \(_, baseUrl) -> do
134 Right (ResultStream res) <- runClient getGetALot baseUrl
135 Right (ResultStream res) <- runClient getGetALot baseUrl
135 let consumeNChunks n = replicateM_ n (res void)
136 let consumeNChunks n = replicateM_ n (res void)
@@ -140,6 +141,7 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
140 memUsed <- currentBytesUsed <$> getGCStats
141 memUsed <- currentBytesUsed <$> getGCStats
141#endif
142#endif
142 memUsed `shouldSatisfy` (< megabytes 22)
143 memUsed `shouldSatisfy` (< megabytes 22)
144+-}
143
145
144megabytes :: Num a => a -> a
146megabytes :: Num a => a -> a
145megabytes n = n * (1000 ^ (2 :: Int))
147megabytes n = n * (1000 ^ (2 :: Int))
servant-server/CHANGELOG.md+10
@@ -1,6 +1,16 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4+0.14.1
5+------
6+
7+- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick))
8+ into `servant` (`Servant.API.Generic`),
9+ `servant-client-code` (`Servant.Client.Generic`)
10+ and `servant-server` (`Servant.Server.Generic`).
11+
12+- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`.
13+
40.14
140.14
5----
15----
6
16
servant-server/servant-server.cabal+9−4
@@ -1,5 +1,5 @@
1name: servant-server
1name: servant-server
2−version: 0.14
2+version: 0.14.1
3synopsis: A family of combinators for defining webservices APIs and serving them
3synopsis: A family of combinators for defining webservices APIs and serving them
4description:
4description:
5 A family of combinators for defining webservices APIs and serving them
5 A family of combinators for defining webservices APIs and serving them
@@ -47,6 +47,7 @@ library
47 Servant
47 Servant
48 Servant.Server
48 Servant.Server
49 Servant.Server.Experimental.Auth
49 Servant.Server.Experimental.Auth
50+ Servant.Server.Generic
50 Servant.Server.Internal
51 Servant.Server.Internal
51 Servant.Server.Internal.BasicAuth
52 Servant.Server.Internal.BasicAuth
52 Servant.Server.Internal.Context
53 Servant.Server.Internal.Context
@@ -54,6 +55,10 @@ library
54 Servant.Server.Internal.Router
55 Servant.Server.Internal.Router
55 Servant.Server.Internal.RoutingApplication
56 Servant.Server.Internal.RoutingApplication
56 Servant.Server.Internal.ServantErr
57 Servant.Server.Internal.ServantErr
58+ Servant.Server.StaticFiles
59+
60+ -- deprecated
61+ exposed-modules:
57 Servant.Utils.StaticFiles
62 Servant.Utils.StaticFiles
58
63
59 -- Bundled with GHC: Lower bound to not force re-installs
64 -- Bundled with GHC: Lower bound to not force re-installs
@@ -75,7 +80,7 @@ library
75
80
76 -- Servant dependencies
81 -- Servant dependencies
77 build-depends:
82 build-depends:
78− servant == 0.14.*
83+ servant >= 0.14.1 && <0.15
79
84
80 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
85 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
81 -- Here can be exceptions if we really need features from the newer versions.
86 -- Here can be exceptions if we really need features from the newer versions.
@@ -133,12 +138,12 @@ test-suite spec
133 Servant.Server.Internal.ContextSpec
138 Servant.Server.Internal.ContextSpec
134 Servant.Server.Internal.RoutingApplicationSpec
139 Servant.Server.Internal.RoutingApplicationSpec
135 Servant.Server.RouterSpec
140 Servant.Server.RouterSpec
141+ Servant.Server.StaticFilesSpec
136 Servant.Server.StreamingSpec
142 Servant.Server.StreamingSpec
137 Servant.Server.UsingContextSpec
143 Servant.Server.UsingContextSpec
138 Servant.Server.UsingContextSpec.TestCombinators
144 Servant.Server.UsingContextSpec.TestCombinators
139 Servant.HoistSpec
145 Servant.HoistSpec
140 Servant.ServerSpec
146 Servant.ServerSpec
141− Servant.Utils.StaticFilesSpec
142
147
143 -- Dependencies inherited from the library. No need to specify bounds.
148 -- Dependencies inherited from the library. No need to specify bounds.
144 build-depends:
149 build-depends:
@@ -176,7 +181,7 @@ test-suite doctests
176 build-depends:
181 build-depends:
177 base
182 base
178 , servant-server
183 , servant-server
179− , doctest >= 0.15.0 && <0.16
184+ , doctest >= 0.15.0 && <0.17
180 type: exitcode-stdio-1.0
185 type: exitcode-stdio-1.0
181 main-is: test/doctests.hs
186 main-is: test/doctests.hs
182 buildable: True
187 buildable: True
servant-server/src/Servant.hs+2−2
@@ -6,7 +6,7 @@ module Servant (
6 -- | For implementing servers for servant APIs.
6 -- | For implementing servers for servant APIs.
7 module Servant.Server,
7 module Servant.Server,
8 -- | Utilities on top of the servant core
8 -- | Utilities on top of the servant core
9− module Servant.Utils.Links,
9+ module Servant.Links,
10 module Servant.Utils.StaticFiles,
10 module Servant.Utils.StaticFiles,
11 -- | Useful re-exports
11 -- | Useful re-exports
12 Proxy(..),
12 Proxy(..),
@@ -17,5 +17,5 @@ import Control.Monad.Error.Class (throwError)
17import Data.Proxy
17import Data.Proxy
18import Servant.API
18import Servant.API
19import Servant.Server
19import Servant.Server
20−import Servant.Utils.Links
20+import Servant.Links
21import Servant.Utils.StaticFiles
21import Servant.Utils.StaticFiles
servant-server/src/Servant/Server/Generic.hsnew file+52
@@ -0,0 +1,52 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+-- | @since 0.14.1
10+module Servant.Server.Generic (
11+ AsServerT,
12+ AsServer,
13+ genericServe,
14+ genericServer,
15+ genericServerT,
16+ ) where
17+
18+import Data.Proxy
19+ (Proxy (..))
20+
21+import Servant.API.Generic
22+import Servant.Server
23+
24+-- | A type that specifies that an API record contains a server implementation.
25+data AsServerT (m :: * -> *)
26+instance GenericMode (AsServerT m) where
27+ type AsServerT m :- api = ServerT api m
28+
29+type AsServer = AsServerT Handler
30+
31+-- | Transform record of routes into a WAI 'Application'.
32+genericServe
33+ :: forall routes.
34+ ( HasServer (ToServantApi routes) '[]
35+ , GenericServant routes AsServer
36+ , Server (ToServantApi routes) ~ ToServant routes AsServer
37+ )
38+ => routes AsServer -> Application
39+genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer
40+
41+-- | Transform record of endpoints into a 'Server'.
42+genericServer
43+ :: GenericServant routes AsServer
44+ => routes AsServer
45+ -> ToServant routes AsServer
46+genericServer = toServant
47+
48+genericServerT
49+ :: GenericServant routes (AsServerT m)
50+ => routes (AsServerT m)
51+ -> ToServant routes (AsServerT m)
52+genericServerT = toServant
servant-server/src/Servant/Server/Internal/Context.hs+1−1
@@ -18,7 +18,7 @@ import GHC.TypeLits
18-- | 'Context's are used to pass values to combinators. (They are __not__ meant
18-- | 'Context's are used to pass values to combinators. (They are __not__ meant
19-- to be used to pass parameters to your handlers, i.e. they should not replace
19-- to be used to pass parameters to your handlers, i.e. they should not replace
20-- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using
20-- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using
21−-- with 'Servant.Utils.Enter'.) If you don't use combinators that
21+-- with 'hoistServer'.) If you don't use combinators that
22-- require any context entries, you can just use 'Servant.Server.serve' as always.
22-- require any context entries, you can just use 'Servant.Server.serve' as always.
23--
23--
24-- If you are using combinators that require a non-empty 'Context' you have to
24-- If you are using combinators that require a non-empty 'Context' you have to
servant-server/src/Servant/Server/StaticFiles.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# LANGUAGE CPP #-}
2+-- | This module defines server-side handlers that lets you serve static files.
3+--
4+-- The most common needs for a web application are covered by
5+-- 'serveDirectoryWebApp`, but the other variants allow you to use
6+-- different `StaticSettings` and 'serveDirectoryWith' even allows you
7+-- to specify arbitrary 'StaticSettings' to be used for serving static files.
8+module Servant.Server.StaticFiles
9+ ( serveDirectoryWebApp
10+ , serveDirectoryWebAppLookup
11+ , serveDirectoryFileServer
12+ , serveDirectoryEmbedded
13+ , serveDirectoryWith
14+ , -- * Deprecated
15+ serveDirectory
16+ ) where
17+
18+import Data.ByteString
19+ (ByteString)
20+import Network.Wai.Application.Static
21+import Servant.API.Raw
22+ (Raw)
23+import Servant.Server
24+ (ServerT, Tagged (..))
25+import System.FilePath
26+ (addTrailingPathSeparator)
27+#if !MIN_VERSION_wai_app_static(3,1,0)
28+import Filesystem.Path.CurrentOS
29+ (decodeString)
30+#endif
31+import WaiAppStatic.Storage.Filesystem
32+ (ETagLookup)
33+
34+-- | Serve anything under the specified directory as a 'Raw' endpoint.
35+--
36+-- @
37+-- type MyApi = "static" :> Raw
38+--
39+-- server :: Server MyApi
40+-- server = serveDirectoryWebApp "\/var\/www"
41+-- @
42+--
43+-- would capture any request to @\/static\/\<something>@ and look for
44+-- @\<something>@ under @\/var\/www@.
45+--
46+-- It will do its best to guess the MIME type for that file, based on the extension,
47+-- and send an appropriate /Content-Type/ header if possible.
48+--
49+-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API
50+-- as a webapp backend, you will most likely not want the static files to be hidden
51+-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp'
52+-- handler in the last position, because /servant/ will try to match the handlers
53+-- in order.
54+--
55+-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.
56+serveDirectoryWebApp :: FilePath -> ServerT Raw m
57+serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath
58+
59+-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.
60+serveDirectoryFileServer :: FilePath -> ServerT Raw m
61+serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath
62+
63+-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.
64+serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m
65+serveDirectoryWebAppLookup etag =
66+ serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath
67+
68+-- | Uses 'embeddedSettings'.
69+serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m
70+serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)
71+
72+-- | Alias for 'staticApp'. Lets you serve a directory
73+-- with arbitrary 'StaticSettings'. Useful when you want
74+-- particular settings not covered by the four other
75+-- variants. This is the most flexible method.
76+serveDirectoryWith :: StaticSettings -> ServerT Raw m
77+serveDirectoryWith = Tagged . staticApp
78+
79+-- | Same as 'serveDirectoryFileServer'. It used to be the only
80+-- file serving function in servant pre-0.10 and will be kept
81+-- around for a few versions, but is deprecated.
82+serveDirectory :: FilePath -> ServerT Raw m
83+serveDirectory = serveDirectoryFileServer
84+{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-}
85+
86+fixPath :: FilePath -> FilePath
87+fixPath =
88+#if MIN_VERSION_wai_app_static(3,1,0)
89+ addTrailingPathSeparator
90+#else
91+ decodeString . addTrailingPathSeparator
92+#endif
servant-server/src/Servant/Utils/StaticFiles.hs+4−84
@@ -1,86 +1,6 @@
1−{-# LANGUAGE CPP #-}
2−-- | This module defines server-side handlers that lets you serve static files.
3−--
4−-- The most common needs for a web application are covered by
5−-- 'serveDirectoryWebApp`, but the other variants allow you to use
6−-- different `StaticSettings` and 'serveDirectoryWith' even allows you
7−-- to specify arbitrary 'StaticSettings' to be used for serving static files.
8module Servant.Utils.StaticFiles
1module Servant.Utils.StaticFiles
9− ( serveDirectoryWebApp
2+ {-# DEPRECATED "Use Servant.ServerStaticFiles." #-}
10− , serveDirectoryWebAppLookup
3+ ( module Servant.Server.StaticFiles )
11− , serveDirectoryFileServer
12− , serveDirectoryEmbedded
13− , serveDirectoryWith
14− , -- * Deprecated
15− serveDirectory
16− ) where
4+ where
17
5
18−import Data.ByteString (ByteString)
19−import Network.Wai.Application.Static
20−import Servant.API.Raw (Raw)
21−import Servant.Server (ServerT, Tagged (..))
6+import Servant.Server.StaticFiles
22−import System.FilePath (addTrailingPathSeparator)
23−#if !MIN_VERSION_wai_app_static(3,1,0)
24−import Filesystem.Path.CurrentOS (decodeString)
25−#endif
26−import WaiAppStatic.Storage.Filesystem (ETagLookup)
27−
28−-- | Serve anything under the specified directory as a 'Raw' endpoint.
29−--
30−-- @
31−-- type MyApi = "static" :> Raw
32−--
33−-- server :: Server MyApi
34−-- server = serveDirectoryWebApp "\/var\/www"
35−-- @
36−--
37−-- would capture any request to @\/static\/\<something>@ and look for
38−-- @\<something>@ under @\/var\/www@.
39−--
40−-- It will do its best to guess the MIME type for that file, based on the extension,
41−-- and send an appropriate /Content-Type/ header if possible.
42−--
43−-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API
44−-- as a webapp backend, you will most likely not want the static files to be hidden
45−-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp'
46−-- handler in the last position, because /servant/ will try to match the handlers
47−-- in order.
48−--
49−-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.
50−serveDirectoryWebApp :: FilePath -> ServerT Raw m
51−serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath
52−
53−-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.
54−serveDirectoryFileServer :: FilePath -> ServerT Raw m
55−serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath
56−
57−-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.
58−serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m
59−serveDirectoryWebAppLookup etag =
60− serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath
61−
62−-- | Uses 'embeddedSettings'.
63−serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m
64−serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)
65−
66−-- | Alias for 'staticApp'. Lets you serve a directory
67−-- with arbitrary 'StaticSettings'. Useful when you want
68−-- particular settings not covered by the four other
69−-- variants. This is the most flexible method.
70−serveDirectoryWith :: StaticSettings -> ServerT Raw m
71−serveDirectoryWith = Tagged . staticApp
72−
73−-- | Same as 'serveDirectoryFileServer'. It used to be the only
74−-- file serving function in servant pre-0.10 and will be kept
75−-- around for a few versions, but is deprecated.
76−serveDirectory :: FilePath -> ServerT Raw m
77−serveDirectory = serveDirectoryFileServer
78−{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-}
79−
80−fixPath :: FilePath -> FilePath
81−fixPath =
82−#if MIN_VERSION_wai_app_static(3,1,0)
83− addTrailingPathSeparator
84−#else
85− decodeString . addTrailingPathSeparator
86−#endif
servant-server/test/Servant/Utils/StaticFilesSpec.hs → servant-server/test/Servant/Server/StaticFilesSpec.hsrenamed+25−16
@@ -3,22 +3,31 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeOperators #-}
5{-# OPTIONS_GHC -fno-warn-orphans #-}
5{-# OPTIONS_GHC -fno-warn-orphans #-}
6−module Servant.Utils.StaticFilesSpec where
6+module Servant.Server.StaticFilesSpec where
7−
7+
8−import Control.Exception (bracket)
8+import Control.Exception
9+ (bracket)
9−import Data.Proxy (Proxy (Proxy))
10+import Data.Proxy
11+ (Proxy (Proxy))
10−import Network.Wai (Application)
12+import Network.Wai
13+ (Application)
11−import System.Directory (createDirectory,
14+import System.Directory
12− getCurrentDirectory,
15+ (createDirectory, getCurrentDirectory, setCurrentDirectory)
13− setCurrentDirectory)
16+import System.IO.Temp
14−import System.IO.Temp (withSystemTempDirectory)
17+ (withSystemTempDirectory)
18+import Test.Hspec
15−import Test.Hspec (Spec, around_, describe, it)
19+ (Spec, around_, describe, it)
20+import Test.Hspec.Wai
16−import Test.Hspec.Wai (get, shouldRespondWith, with)
21+ (get, shouldRespondWith, with)
17−
22+
18−import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
23+import Servant.API
24+ ((:<|>) ((:<|>)), (:>), Capture, Get, JSON, Raw)
19−import Servant.Server (Server, serve)
25+import Servant.Server
26+ (Server, serve)
20−import Servant.ServerSpec (Person (Person))
27+import Servant.Server.StaticFiles
21−import Servant.Utils.StaticFiles (serveDirectoryFileServer)
28+ (serveDirectoryFileServer)
29+import Servant.ServerSpec
30+ (Person (Person))
22
31
23type Api =
32type Api =
24 "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person
33 "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person
servant/CHANGELOG.md+13
@@ -1,5 +1,18 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2
2
3+0.14.1
4+------
5+
6+- Merge in (and slightly refactor) `servant-generic`
7+ (by [Patrick Chilton](https://github.com/chpatrick))
8+ into `servant` (`Servant.API.Generic`),
9+ `servant-client-code` (`Servant.Client.Generic`)
10+ and `servant-server` (`Servant.Server.Generic`).
11+
12+- Deprecate `Servant.Utils.Links`, use `Servant.Links`.
13+
14+- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`.
15+
30.14
160.14
4----
17----
5
18
servant/servant.cabal+9−4
@@ -1,5 +1,5 @@
1name: servant
1name: servant
2−version: 0.14
2+version: 0.14.1
3synopsis: A family of combinators for defining webservices APIs
3synopsis: A family of combinators for defining webservices APIs
4description:
4description:
5 A family of combinators for defining webservices APIs and serving them
5 A family of combinators for defining webservices APIs and serving them
@@ -46,6 +46,7 @@ library
46 Servant.API.Description
46 Servant.API.Description
47 Servant.API.Empty
47 Servant.API.Empty
48 Servant.API.Experimental.Auth
48 Servant.API.Experimental.Auth
49+ Servant.API.Generic
49 Servant.API.Header
50 Servant.API.Header
50 Servant.API.HttpVersion
51 Servant.API.HttpVersion
51 Servant.API.Internal.Test.ComprehensiveAPI
52 Servant.API.Internal.Test.ComprehensiveAPI
@@ -62,6 +63,10 @@ library
62 Servant.API.Vault
63 Servant.API.Vault
63 Servant.API.Verbs
64 Servant.API.Verbs
64 Servant.API.WithNamedContext
65 Servant.API.WithNamedContext
66+ Servant.Links
67+
68+ -- Deprecated modules, to be removed in late 2019
69+ exposed-modules:
65 Servant.Utils.Links
70 Servant.Utils.Links
66 Servant.Utils.Enter
71 Servant.Utils.Enter
67
72
@@ -133,8 +138,8 @@ test-suite spec
133 other-modules:
138 other-modules:
134 Servant.API.ContentTypesSpec
139 Servant.API.ContentTypesSpec
135 Servant.API.ResponseHeadersSpec
140 Servant.API.ResponseHeadersSpec
136− Servant.Utils.LinksSpec
137 Servant.Utils.EnterSpec
141 Servant.Utils.EnterSpec
142+ Servant.LinksSpec
138
143
139 -- Dependencies inherited from the library. No need to specify bounds.
144 -- Dependencies inherited from the library. No need to specify bounds.
140 build-depends:
145 build-depends:
@@ -164,7 +169,7 @@ test-suite doctests
164 build-depends:
169 build-depends:
165 base
170 base
166 , servant
171 , servant
167− , doctest >= 0.15.0 && <0.16
172+ , doctest >= 0.15.0 && <0.17
168
173
169 -- We test Links failure with doctest, so we need extra dependencies
174 -- We test Links failure with doctest, so we need extra dependencies
170 build-depends:
175 build-depends:
@@ -179,4 +184,4 @@ test-suite doctests
179 x-doctest-options: -fdiagnostics-color=never
184 x-doctest-options: -fdiagnostics-color=never
180 include-dirs: include
185 include-dirs: include
181 x-doctest-source-dirs: test
186 x-doctest-source-dirs: test
182− x-doctest-modules: Servant.Utils.LinksSpec
187+ x-doctest-modules: Servant.LinksSpec
servant/src/Servant/API.hs+3−3
@@ -63,8 +63,8 @@ module Servant.API (
63 module Servant.API.Experimental.Auth,
63 module Servant.API.Experimental.Auth,
64 -- | General Authentication
64 -- | General Authentication
65
65
66− -- * Utilities
66+ -- * Links
67− module Servant.Utils.Links,
67+ module Servant.Links,
68 -- | Type-safe internal URIs
68 -- | Type-safe internal URIs
69
69
70 -- * Re-exports
70 -- * Re-exports
@@ -134,7 +134,7 @@ import Servant.API.Verbs
134 ReflectMethod (reflectMethod), StdMethod (..), Verb)
134 ReflectMethod (reflectMethod), StdMethod (..), Verb)
135import Servant.API.WithNamedContext
135import Servant.API.WithNamedContext
136 (WithNamedContext)
136 (WithNamedContext)
137−import Servant.Utils.Links
137+import Servant.Links
138 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
138 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
139import Web.HttpApiData
139import Web.HttpApiData
140 (FromHttpApiData (..), ToHttpApiData (..))
140 (FromHttpApiData (..), ToHttpApiData (..))
servant/src/Servant/API/Generic.hsnew file+146
@@ -0,0 +1,146 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeOperators #-}
5+-- | Define servant servers from record types. Generics for the win.
6+--
7+-- The usage is simple, if you only need a collection of routes. First you
8+-- define a record with field types prefixed by a parameter `route`:
9+--
10+-- @
11+-- data Routes route = Routes
12+-- { _get :: route :- Capture "id" Int :> Get '[JSON] String
13+-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
14+-- }
15+-- deriving ('Generic')
16+-- @
17+--
18+-- You can get a 'Proxy' of the server using
19+--
20+-- @
21+-- api :: Proxy (ToServantApi Routes)
22+-- api = genericApi (Proxy :: Proxy Routes)
23+-- @
24+--
25+-- Using 'genericApi' is better as it checks that instances exists,
26+-- i.e. you get better error messages than simply using 'Proxy' value.
27+--
28+-- __Note:__ in 0.14 series this module isn't re-exported from 'Servant.API'.
29+--
30+-- "Servant.API.Generic" is based on @servant-generic@ package by
31+-- [Patrick Chilton](https://github.com/chpatrick)
32+--
33+-- @since 0.14.1
34+module Servant.API.Generic (
35+ GenericMode (..),
36+ GenericServant,
37+ ToServant,
38+ toServant,
39+ fromServant,
40+ -- * AsApi
41+ AsApi,
42+ ToServantApi,
43+ genericApi,
44+ -- * Utility
45+ GServantProduct,
46+ -- * re-exports
47+ Generic (Rep),
48+ ) where
49+
50+-- Based on servant-generic licensed under MIT License
51+--
52+-- Copyright (c) 2017 Patrick Chilton
53+--
54+-- Permission is hereby granted, free of charge, to any person obtaining a copy
55+-- of this software and associated documentation files (the "Software"), to deal
56+-- in the Software without restriction, including without limitation the rights
57+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
58+-- copies of the Software, and to permit persons to whom the Software is
59+-- furnished to do so, subject to the following conditions:
60+--
61+-- The above copyright notice and this permission notice shall be included in all
62+-- copies or substantial portions of the Software.
63+--
64+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
65+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
66+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
67+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
68+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
69+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
70+-- SOFTWARE.
71+
72+import Data.Proxy
73+ (Proxy (..))
74+import GHC.Generics
75+ ((:*:) (..), Generic (..), K1 (..), M1 (..))
76+
77+import Servant.API.Alternative
78+
79+-- | A constraint alias, for work with 'mode' and 'routes'.
80+type GenericServant routes mode = (GenericMode mode, Generic (routes mode), GServantProduct (Rep (routes mode)))
81+
82+-- | A class with a type family that applies an appropriate type family to the @api@
83+-- parameter. For example, 'AsApi' will leave @api@ untouched, while
84+-- @'AsServerT' m@ will produce @'ServerT' api m@.
85+class GenericMode mode where
86+ type mode :- api :: *
87+
88+infixl 0 :-
89+
90+-- | Turns a generic product type into a tree of `:<|>` combinators.
91+type ToServant routes mode = GToServant (Rep (routes mode))
92+
93+type ToServantApi routes = ToServant routes AsApi
94+
95+-- | See `ToServant`, but at value-level.
96+toServant
97+ :: GenericServant routes mode
98+ => routes mode -> ToServant routes mode
99+toServant = gtoServant . from
100+
101+-- | Inverse of `toServant`.
102+--
103+-- This can be used to turn 'generated' values such as client functions into records.
104+--
105+-- You may need to provide a type signature for the /output/ type (your record type).
106+fromServant
107+ :: GenericServant routes mode
108+ => ToServant routes mode -> routes mode
109+fromServant = to . gfromServant
110+
111+-- | A type that specifies that an API record contains an API definition. Only useful at type-level.
112+data AsApi
113+instance GenericMode AsApi where
114+ type AsApi :- api = api
115+
116+-- | Get a 'Proxy' of an API type.
117+genericApi
118+ :: GenericServant routes AsApi
119+ => Proxy routes
120+ -> Proxy (ToServantApi routes)
121+genericApi _ = Proxy
122+
123+-------------------------------------------------------------------------------
124+-- Class
125+-------------------------------------------------------------------------------
126+
127+
128+class GServantProduct f where
129+ type GToServant f
130+ gtoServant :: f p -> GToServant f
131+ gfromServant :: GToServant f -> f p
132+
133+instance GServantProduct f => GServantProduct (M1 i c f) where
134+ type GToServant (M1 i c f) = GToServant f
135+ gtoServant = gtoServant . unM1
136+ gfromServant = M1 . gfromServant
137+
138+instance (GServantProduct l, GServantProduct r) => GServantProduct (l :*: r) where
139+ type GToServant (l :*: r) = GToServant l :<|> GToServant r
140+ gtoServant (l :*: r) = gtoServant l :<|> gtoServant r
141+ gfromServant (l :<|> r) = gfromServant l :*: gfromServant r
142+
143+instance GServantProduct (K1 i c) where
144+ type GToServant (K1 i c) = c
145+ gtoServant = unK1
146+ gfromServant = K1
servant/src/Servant/API/Verbs.hs+1−1
@@ -58,7 +58,7 @@ type Patch = Verb 'PATCH 200
58--
58--
59-- If the resource cannot be created immediately, use 'PostAccepted'.
59-- If the resource cannot be created immediately, use 'PostAccepted'.
60--
60--
61−-- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header
61+-- Consider using 'Servant.Links.safeLink' for the @Location@ header
62-- field.
62-- field.
63
63
64-- | 'POST' with 201 status code.
64-- | 'POST' with 201 status code.
servant/src/Servant/Links.hsnew file+573
@@ -0,0 +1,573 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-# OPTIONS_HADDOCK not-home #-}
12+
13+-- | Type safe generation of internal links.
14+--
15+-- Given an API with a few endpoints:
16+--
17+-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
18+-- >>> import Servant.API
19+-- >>> import Servant.Links
20+-- >>> import Data.Proxy
21+-- >>>
22+-- >>> type Hello = "hello" :> Get '[JSON] Int
23+-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
24+-- >>> type API = Hello :<|> Bye
25+-- >>> let api = Proxy :: Proxy API
26+--
27+-- It is possible to generate links that are guaranteed to be within 'API' with
28+-- 'safeLink'. The first argument to 'safeLink' is a type representing the API
29+-- you would like to restrict links to. The second argument is the destination
30+-- endpoint you would like the link to point to, this will need to end with a
31+-- verb like GET or POST. Further arguments may be required depending on the
32+-- type of the endpoint. If everything lines up you will get a 'Link' out the
33+-- other end.
34+--
35+-- You may omit 'QueryParam's and the like should you not want to provide them,
36+-- but types which form part of the URL path like 'Capture' must be included.
37+-- The reason you may want to omit 'QueryParam's is that safeLink is a bit
38+-- magical: if parameters are included that could take input it will return a
39+-- function that accepts that input and generates a link. This is best shown
40+-- with an example. Here, a link is generated with no parameters:
41+--
42+-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
43+-- >>> toUrlPiece (safeLink api hello :: Link)
44+-- "hello"
45+--
46+-- If the API has an endpoint with parameters then we can generate links with
47+-- or without those:
48+--
49+-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)
50+-- >>> toUrlPiece $ safeLink api with (Just "Hubert")
51+-- "bye?name=Hubert"
52+--
53+-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
54+-- >>> toUrlPiece $ safeLink api without
55+-- "bye"
56+--
57+-- If you would like create a helper for generating links only within that API,
58+-- you can partially apply safeLink if you specify a correct type signature
59+-- like so:
60+--
61+-- >>> :set -XConstraintKinds
62+-- >>> :{
63+-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
64+-- >>> => Proxy endpoint -> MkLink endpoint Link
65+-- >>> apiLink = safeLink api
66+-- >>> :}
67+--
68+-- `safeLink'` allows to make specialise the output:
69+--
70+-- >>> safeLink' toUrlPiece api without
71+-- "bye"
72+--
73+-- >>> :{
74+-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
75+-- >>> => Proxy endpoint -> MkLink endpoint Text
76+-- >>> apiTextLink = safeLink' toUrlPiece api
77+-- >>> :}
78+--
79+-- >>> apiTextLink without
80+-- "bye"
81+--
82+-- Attempting to construct a link to an endpoint that does not exist in api
83+-- will result in a type error like this:
84+--
85+-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
86+-- >>> safeLink api bad_link
87+-- ...
88+-- ...Could not deduce...
89+-- ...
90+--
91+-- This error is essentially saying that the type family couldn't find
92+-- bad_link under api after trying the open (but empty) type family
93+-- `IsElem'` as a last resort.
94+--
95+-- @since 0.14.1
96+module Servant.Links (
97+ module Servant.API.TypeLevel,
98+
99+ -- * Building and using safe links
100+ --
101+ -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
102+ safeLink
103+ , safeLink'
104+ , allLinks
105+ , allLinks'
106+ , URI(..)
107+ -- * Generics
108+ , AsLink
109+ , fieldLink
110+ , fieldLink'
111+ , allFieldLinks
112+ , allFieldLinks'
113+ -- * Adding custom types
114+ , HasLink(..)
115+ , Link
116+ , linkURI
117+ , linkURI'
118+ , LinkArrayElementStyle (..)
119+ -- ** Link accessors
120+ , Param (..)
121+ , linkSegments
122+ , linkQueryParams
123+) where
124+
125+import Data.List
126+import Data.Proxy
127+ (Proxy (..))
128+import Data.Semigroup
129+ ((<>))
130+import Data.Singletons.Bool
131+ (SBool (..), SBoolI (..))
132+import qualified Data.Text as Text
133+import qualified Data.Text.Encoding as TE
134+import Data.Type.Bool
135+ (If)
136+import GHC.TypeLits
137+ (KnownSymbol, symbolVal)
138+import Network.URI
139+ (URI (..), escapeURIString, isUnreserved)
140+import Prelude ()
141+import Prelude.Compat
142+
143+import Servant.API.Alternative
144+ ((:<|>) ((:<|>)))
145+import Servant.API.BasicAuth
146+ (BasicAuth)
147+import Servant.API.Capture
148+ (Capture', CaptureAll)
149+import Servant.API.Description
150+ (Description, Summary)
151+import Servant.API.Empty
152+ (EmptyAPI (..))
153+import Servant.API.Experimental.Auth
154+ (AuthProtect)
155+import Servant.API.Generic
156+import Servant.API.Header
157+ (Header')
158+import Servant.API.HttpVersion
159+ (HttpVersion)
160+import Servant.API.IsSecure
161+ (IsSecure)
162+import Servant.API.Modifiers
163+ (FoldRequired)
164+import Servant.API.QueryParam
165+ (QueryFlag, QueryParam', QueryParams)
166+import Servant.API.Raw
167+ (Raw)
168+import Servant.API.RemoteHost
169+ (RemoteHost)
170+import Servant.API.ReqBody
171+ (ReqBody')
172+import Servant.API.Stream
173+ (Stream)
174+import Servant.API.Sub
175+ (type (:>))
176+import Servant.API.TypeLevel
177+import Servant.API.Vault
178+ (Vault)
179+import Servant.API.Verbs
180+ (Verb)
181+import Servant.API.WithNamedContext
182+ (WithNamedContext)
183+import Web.HttpApiData
184+
185+-- | A safe link datatype.
186+-- The only way of constructing a 'Link' is using 'safeLink', which means any
187+-- 'Link' is guaranteed to be part of the mentioned API.
188+data Link = Link
189+ { _segments :: [Escaped]
190+ , _queryParams :: [Param]
191+ } deriving Show
192+
193+newtype Escaped = Escaped String
194+
195+escaped :: String -> Escaped
196+escaped = Escaped . escapeURIString isUnreserved
197+
198+getEscaped :: Escaped -> String
199+getEscaped (Escaped s) = s
200+
201+instance Show Escaped where
202+ showsPrec d (Escaped s) = showsPrec d s
203+ show (Escaped s) = show s
204+
205+linkSegments :: Link -> [String]
206+linkSegments = map getEscaped . _segments
207+
208+linkQueryParams :: Link -> [Param]
209+linkQueryParams = _queryParams
210+
211+instance ToHttpApiData Link where
212+ toHeader = TE.encodeUtf8 . toUrlPiece
213+ toUrlPiece l =
214+ let uri = linkURI l
215+ in Text.pack $ uriPath uri ++ uriQuery uri
216+
217+-- | Query parameter.
218+data Param
219+ = SingleParam String Text.Text
220+ | ArrayElemParam String Text.Text
221+ | FlagParam String
222+ deriving Show
223+
224+addSegment :: Escaped -> Link -> Link
225+addSegment seg l = l { _segments = _segments l <> [seg] }
226+
227+addQueryParam :: Param -> Link -> Link
228+addQueryParam qp l =
229+ l { _queryParams = _queryParams l <> [qp] }
230+
231+-- | Transform 'Link' into 'URI'.
232+--
233+-- >>> type API = "something" :> Get '[JSON] Int
234+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
235+-- something
236+--
237+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
238+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
239+-- sum?x[]=1&x[]=2&x[]=3
240+--
241+-- >>> type API = "foo/bar" :> Get '[JSON] Int
242+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
243+-- foo%2Fbar
244+--
245+-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
246+-- >>> let someRoute = Proxy :: Proxy SomeRoute
247+-- >>> safeLink someRoute someRoute "test@example.com"
248+-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
249+--
250+-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
251+-- abc/test%40example.com
252+--
253+linkURI :: Link -> URI
254+linkURI = linkURI' LinkArrayElementBracket
255+
256+-- | How to encode array query elements.
257+data LinkArrayElementStyle
258+ = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@
259+ | LinkArrayElementPlain -- ^ @foo=1&foo=2@
260+ deriving (Eq, Ord, Show, Enum, Bounded)
261+
262+-- | Configurable 'linkURI'.
263+--
264+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
265+-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
266+-- sum?x[]=1&x[]=2&x[]=3
267+--
268+-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
269+-- sum?x=1&x=2&x=3
270+--
271+linkURI' :: LinkArrayElementStyle -> Link -> URI
272+linkURI' addBrackets (Link segments q_params) =
273+ URI mempty -- No scheme (relative)
274+ Nothing -- Or authority (relative)
275+ (intercalate "/" $ map getEscaped segments)
276+ (makeQueries q_params) mempty
277+ where
278+ makeQueries :: [Param] -> String
279+ makeQueries [] = ""
280+ makeQueries xs =
281+ "?" <> intercalate "&" (fmap makeQuery xs)
282+
283+ makeQuery :: Param -> String
284+ makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
285+ makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
286+ makeQuery (FlagParam k) = escape k
287+
288+ style = case addBrackets of
289+ LinkArrayElementBracket -> "[]="
290+ LinkArrayElementPlain -> "="
291+
292+escape :: String -> String
293+escape = escapeURIString isUnreserved
294+
295+-- | Create a valid (by construction) relative URI with query params.
296+--
297+-- This function will only typecheck if `endpoint` is part of the API `api`
298+safeLink
299+ :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
300+ => Proxy api -- ^ The whole API that this endpoint is a part of
301+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
302+ -> MkLink endpoint Link
303+safeLink = safeLink' id
304+
305+-- | More general 'safeLink'.
306+--
307+safeLink'
308+ :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
309+ => (Link -> a)
310+ -> Proxy api -- ^ The whole API that this endpoint is a part of
311+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
312+ -> MkLink endpoint a
313+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
314+
315+-- | Create all links in an API.
316+--
317+-- Note that the @api@ type must be restricted to the endpoints that have
318+-- valid links to them.
319+--
320+-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double
321+-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)
322+-- >>> :t fooLink
323+-- fooLink :: Text -> Link
324+-- >>> :t barLink
325+-- barLink :: Int -> Link
326+--
327+-- Note: nested APIs don't work well with this approach
328+--
329+-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
330+-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
331+-- = Char -> (Int -> Link) :<|> (Double -> Link)
332+allLinks
333+ :: forall api. HasLink api
334+ => Proxy api
335+ -> MkLink api Link
336+allLinks = allLinks' id
337+
338+-- | More general 'allLinks'. See `safeLink'`.
339+allLinks'
340+ :: forall api a. HasLink api
341+ => (Link -> a)
342+ -> Proxy api
343+ -> MkLink api a
344+allLinks' toA api = toLink toA api (Link mempty mempty)
345+
346+-------------------------------------------------------------------------------
347+-- Generics
348+-------------------------------------------------------------------------------
349+
350+-- | Given an API record field, create a link for that route. Only the field's
351+-- type is used.
352+--
353+-- @
354+-- data Record route = Record
355+-- { _get :: route :- Capture "id" Int :> Get '[JSON] String
356+-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
357+-- }
358+-- deriving ('Generic')
359+--
360+-- getLink :: Int -> Link
361+-- getLink = 'fieldLink' _get
362+-- @
363+--
364+-- @since 0.14.1
365+fieldLink
366+ :: ( IsElem endpoint (ToServantApi routes), HasLink endpoint
367+ , GenericServant routes AsApi
368+ )
369+ => (routes AsApi -> endpoint)
370+ -> MkLink endpoint Link
371+fieldLink = fieldLink' id
372+
373+-- | More general version of 'fieldLink'
374+--
375+-- @since 0.14.1
376+fieldLink'
377+ :: forall routes endpoint a.
378+ ( IsElem endpoint (ToServantApi routes), HasLink endpoint
379+ , GenericServant routes AsApi
380+ )
381+ => (Link -> a)
382+ -> (routes AsApi -> endpoint)
383+ -> MkLink endpoint a
384+fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)
385+
386+-- | A type that specifies that an API record contains a set of links.
387+--
388+-- @since 0.14.1
389+data AsLink (a :: *)
390+instance GenericMode (AsLink a) where
391+ type (AsLink a) :- api = MkLink api a
392+
393+-- | Get all links as a record.
394+--
395+-- @since 0.14.1
396+allFieldLinks
397+ :: ( HasLink (ToServantApi routes)
398+ , GenericServant routes (AsLink Link)
399+ , ToServant routes (AsLink Link) ~ MkLink (ToServantApi routes) Link
400+ )
401+ => routes (AsLink Link)
402+allFieldLinks = allFieldLinks' id
403+
404+-- | More general version of 'allFieldLinks'.
405+--
406+-- @since 0.14.1
407+allFieldLinks'
408+ :: forall routes a.
409+ ( HasLink (ToServantApi routes)
410+ , GenericServant routes (AsLink a)
411+ , ToServant routes (AsLink a) ~ MkLink (ToServantApi routes) a
412+ )
413+ => (Link -> a)
414+ -> routes (AsLink a)
415+allFieldLinks' toA
416+ = fromServant
417+ $ allLinks' toA (Proxy :: Proxy (ToServantApi routes))
418+
419+-------------------------------------------------------------------------------
420+-- HasLink
421+-------------------------------------------------------------------------------
422+
423+-- | Construct a toLink for an endpoint.
424+class HasLink endpoint where
425+ type MkLink endpoint (a :: *)
426+ toLink
427+ :: (Link -> a)
428+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
429+ -> Link
430+ -> MkLink endpoint a
431+
432+-- Naked symbol instance
433+instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
434+ type MkLink (sym :> sub) a = MkLink sub a
435+ toLink toA _ =
436+ toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
437+ where
438+ seg = symbolVal (Proxy :: Proxy sym)
439+
440+-- QueryParam instances
441+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
442+ => HasLink (QueryParam' mods sym v :> sub)
443+ where
444+ type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
445+ toLink toA _ l mv =
446+ toLink toA (Proxy :: Proxy sub) $
447+ case sbool :: SBool (FoldRequired mods) of
448+ STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
449+ SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
450+ where
451+ k :: String
452+ k = symbolVal (Proxy :: Proxy sym)
453+
454+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
455+ => HasLink (QueryParams sym v :> sub)
456+ where
457+ type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
458+ toLink toA _ l =
459+ toLink toA (Proxy :: Proxy sub) .
460+ foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
461+ where
462+ k = symbolVal (Proxy :: Proxy sym)
463+
464+instance (KnownSymbol sym, HasLink sub)
465+ => HasLink (QueryFlag sym :> sub)
466+ where
467+ type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
468+ toLink toA _ l False =
469+ toLink toA (Proxy :: Proxy sub) l
470+ toLink toA _ l True =
471+ toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
472+ where
473+ k = symbolVal (Proxy :: Proxy sym)
474+
475+-- :<|> instance - Generate all links at once
476+instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
477+ type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
478+ toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
479+
480+-- Misc instances
481+instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
482+ type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
483+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
484+
485+instance (ToHttpApiData v, HasLink sub)
486+ => HasLink (Capture' mods sym v :> sub)
487+ where
488+ type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
489+ toLink toA _ l v =
490+ toLink toA (Proxy :: Proxy sub) $
491+ addSegment (escaped . Text.unpack $ toUrlPiece v) l
492+
493+instance (ToHttpApiData v, HasLink sub)
494+ => HasLink (CaptureAll sym v :> sub)
495+ where
496+ type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
497+ toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
498+ foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
499+
500+instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
501+ type MkLink (Header' mods sym a :> sub) r = MkLink sub r
502+ toLink = simpleToLink (Proxy :: Proxy sub)
503+
504+instance HasLink sub => HasLink (Vault :> sub) where
505+ type MkLink (Vault :> sub) a = MkLink sub a
506+ toLink = simpleToLink (Proxy :: Proxy sub)
507+
508+instance HasLink sub => HasLink (Description s :> sub) where
509+ type MkLink (Description s :> sub) a = MkLink sub a
510+ toLink = simpleToLink (Proxy :: Proxy sub)
511+
512+instance HasLink sub => HasLink (Summary s :> sub) where
513+ type MkLink (Summary s :> sub) a = MkLink sub a
514+ toLink = simpleToLink (Proxy :: Proxy sub)
515+
516+instance HasLink sub => HasLink (HttpVersion :> sub) where
517+ type MkLink (HttpVersion:> sub) a = MkLink sub a
518+ toLink = simpleToLink (Proxy :: Proxy sub)
519+
520+instance HasLink sub => HasLink (IsSecure :> sub) where
521+ type MkLink (IsSecure :> sub) a = MkLink sub a
522+ toLink = simpleToLink (Proxy :: Proxy sub)
523+
524+instance HasLink sub => HasLink (WithNamedContext name context sub) where
525+ type MkLink (WithNamedContext name context sub) a = MkLink sub a
526+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
527+
528+instance HasLink sub => HasLink (RemoteHost :> sub) where
529+ type MkLink (RemoteHost :> sub) a = MkLink sub a
530+ toLink = simpleToLink (Proxy :: Proxy sub)
531+
532+instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
533+ type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
534+ toLink = simpleToLink (Proxy :: Proxy sub)
535+
536+instance HasLink EmptyAPI where
537+ type MkLink EmptyAPI a = EmptyAPI
538+ toLink _ _ _ = EmptyAPI
539+
540+-- Verb (terminal) instances
541+instance HasLink (Verb m s ct a) where
542+ type MkLink (Verb m s ct a) r = r
543+ toLink toA _ = toA
544+
545+instance HasLink Raw where
546+ type MkLink Raw a = a
547+ toLink toA _ = toA
548+
549+instance HasLink (Stream m status fr ct a) where
550+ type MkLink (Stream m status fr ct a) r = r
551+ toLink toA _ = toA
552+
553+-- AuthProtext instances
554+instance HasLink sub => HasLink (AuthProtect tag :> sub) where
555+ type MkLink (AuthProtect tag :> sub) a = MkLink sub a
556+ toLink = simpleToLink (Proxy :: Proxy sub)
557+
558+-- | Helper for implemneting 'toLink' for combinators not affecting link
559+-- structure.
560+simpleToLink
561+ :: forall sub a combinator.
562+ (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
563+ => Proxy sub
564+ -> (Link -> a)
565+ -> Proxy (combinator :> sub)
566+ -> Link
567+ -> MkLink (combinator :> sub) a
568+simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
569+
570+
571+-- $setup
572+-- >>> import Servant.API
573+-- >>> import Data.Text (Text)
servant/src/Servant/Utils/Links.hs+4−485
@@ -1,487 +1,6 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE UndecidableInstances #-}
11−{-# OPTIONS_HADDOCK not-home #-}
12−
13−-- | Type safe generation of internal links.
14−--
15−-- Given an API with a few endpoints:
16−--
17−-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
18−-- >>> import Servant.API
19−-- >>> import Servant.Utils.Links
1+module Servant.Utils.Links
20−-- >>> import Data.Proxy
21−-- >>>
22−-- >>> type Hello = "hello" :> Get '[JSON] Int
23−-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
24−-- >>> type API = Hello :<|> Bye
25−-- >>> let api = Proxy :: Proxy API
26−--
27−-- It is possible to generate links that are guaranteed to be within 'API' with
28−-- 'safeLink'. The first argument to 'safeLink' is a type representing the API
29−-- you would like to restrict links to. The second argument is the destination
30−-- endpoint you would like the link to point to, this will need to end with a
31−-- verb like GET or POST. Further arguments may be required depending on the
32−-- type of the endpoint. If everything lines up you will get a 'Link' out the
33−-- other end.
34−--
35−-- You may omit 'QueryParam's and the like should you not want to provide them,
36−-- but types which form part of the URL path like 'Capture' must be included.
37−-- The reason you may want to omit 'QueryParam's is that safeLink is a bit
38−-- magical: if parameters are included that could take input it will return a
39−-- function that accepts that input and generates a link. This is best shown
40−-- with an example. Here, a link is generated with no parameters:
41−--
42−-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
43−-- >>> toUrlPiece (safeLink api hello :: Link)
44−-- "hello"
45−--
46−-- If the API has an endpoint with parameters then we can generate links with
47−-- or without those:
48−--
49−-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)
50−-- >>> toUrlPiece $ safeLink api with (Just "Hubert")
51−-- "bye?name=Hubert"
52−--
53−-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
54−-- >>> toUrlPiece $ safeLink api without
55−-- "bye"
56−--
57−-- If you would like create a helper for generating links only within that API,
58−-- you can partially apply safeLink if you specify a correct type signature
59−-- like so:
60−--
61−-- >>> :set -XConstraintKinds
62−-- >>> :{
63−-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
64−-- >>> => Proxy endpoint -> MkLink endpoint Link
65−-- >>> apiLink = safeLink api
66−-- >>> :}
67−--
68−-- `safeLink'` allows to make specialise the output:
69−--
70−-- >>> safeLink' toUrlPiece api without
71−-- "bye"
72−--
73−-- >>> :{
74−-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
75−-- >>> => Proxy endpoint -> MkLink endpoint Text
76−-- >>> apiTextLink = safeLink' toUrlPiece api
77−-- >>> :}
78−--
79−-- >>> apiTextLink without
80−-- "bye"
81−--
82−-- Attempting to construct a link to an endpoint that does not exist in api
83−-- will result in a type error like this:
84−--
85−-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
86−-- >>> safeLink api bad_link
87−-- ...
88−-- ...Could not deduce...
89−-- ...
90−--
91−-- This error is essentially saying that the type family couldn't find
92−-- bad_link under api after trying the open (but empty) type family
93−-- `IsElem'` as a last resort.
94−module Servant.Utils.Links (
2+ {-# DEPRECATED "Use Servant.Links." #-}
95− module Servant.API.TypeLevel,
3+ ( module Servant.Links )
96−
97− -- * Building and using safe links
98− --
99− -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
100− safeLink
101− , safeLink'
102− , allLinks
103− , allLinks'
104− , URI(..)
105− -- * Adding custom types
106− , HasLink(..)
107− , Link
108− , linkURI
109− , linkURI'
110− , LinkArrayElementStyle (..)
111− -- ** Link accessors
112− , Param (..)
113− , linkSegments
114− , linkQueryParams
115−) where
116−
117−import Data.List
118−import Data.Proxy
119− (Proxy (..))
120−import Data.Semigroup
121− ((<>))
122−import Data.Singletons.Bool
123− (SBool (..), SBoolI (..))
124−import qualified Data.Text as Text
125−import qualified Data.Text.Encoding as TE
126−import Data.Type.Bool
127− (If)
128−import GHC.TypeLits
129− (KnownSymbol, symbolVal)
130−import Network.URI
131− (URI (..), escapeURIString, isUnreserved)
132−import Prelude ()
133−import Prelude.Compat
134−
135−import Servant.API.Alternative
136− ((:<|>) ((:<|>)))
137−import Servant.API.BasicAuth
138− (BasicAuth)
139−import Servant.API.Capture
140− (Capture', CaptureAll)
141−import Servant.API.Description
142− (Description, Summary)
143−import Servant.API.Empty
144− (EmptyAPI (..))
145−import Servant.API.Experimental.Auth
146− (AuthProtect)
147−import Servant.API.Header
148− (Header')
149−import Servant.API.HttpVersion
150− (HttpVersion)
151−import Servant.API.IsSecure
152− (IsSecure)
153−import Servant.API.Modifiers
154− (FoldRequired)
155−import Servant.API.QueryParam
156− (QueryFlag, QueryParam', QueryParams)
157−import Servant.API.Raw
158− (Raw)
159−import Servant.API.RemoteHost
160− (RemoteHost)
161−import Servant.API.ReqBody
162− (ReqBody')
163−import Servant.API.Stream
164− (Stream)
165−import Servant.API.Sub
166− (type (:>))
167−import Servant.API.TypeLevel
168−import Servant.API.Vault
169− (Vault)
170−import Servant.API.Verbs
171− (Verb)
172−import Servant.API.WithNamedContext
173− (WithNamedContext)
174−import Web.HttpApiData
175−
176−-- | A safe link datatype.
177−-- The only way of constructing a 'Link' is using 'safeLink', which means any
178−-- 'Link' is guaranteed to be part of the mentioned API.
179−data Link = Link
180− { _segments :: [Escaped]
181− , _queryParams :: [Param]
182− } deriving Show
183−
184−newtype Escaped = Escaped String
185−
186−escaped :: String -> Escaped
187−escaped = Escaped . escapeURIString isUnreserved
188−
189−getEscaped :: Escaped -> String
190−getEscaped (Escaped s) = s
191−
192−instance Show Escaped where
193− showsPrec d (Escaped s) = showsPrec d s
194− show (Escaped s) = show s
195−
196−linkSegments :: Link -> [String]
197−linkSegments = map getEscaped . _segments
198−
199−linkQueryParams :: Link -> [Param]
200−linkQueryParams = _queryParams
201−
202−instance ToHttpApiData Link where
203− toHeader = TE.encodeUtf8 . toUrlPiece
204− toUrlPiece l =
205− let uri = linkURI l
206− in Text.pack $ uriPath uri ++ uriQuery uri
207−
208−-- | Query parameter.
209−data Param
210− = SingleParam String Text.Text
211− | ArrayElemParam String Text.Text
212− | FlagParam String
213− deriving Show
214−
215−addSegment :: Escaped -> Link -> Link
216−addSegment seg l = l { _segments = _segments l <> [seg] }
217−
218−addQueryParam :: Param -> Link -> Link
219−addQueryParam qp l =
220− l { _queryParams = _queryParams l <> [qp] }
221−
222−-- | Transform 'Link' into 'URI'.
223−--
224−-- >>> type API = "something" :> Get '[JSON] Int
225−-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
226−-- something
227−--
228−-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
229−-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
230−-- sum?x[]=1&x[]=2&x[]=3
231−--
232−-- >>> type API = "foo/bar" :> Get '[JSON] Int
233−-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
234−-- foo%2Fbar
235−--
236−-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
237−-- >>> let someRoute = Proxy :: Proxy SomeRoute
238−-- >>> safeLink someRoute someRoute "test@example.com"
239−-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
240−--
241−-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
242−-- abc/test%40example.com
243−--
244−linkURI :: Link -> URI
245−linkURI = linkURI' LinkArrayElementBracket
246−
247−-- | How to encode array query elements.
248−data LinkArrayElementStyle
249− = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@
250− | LinkArrayElementPlain -- ^ @foo=1&foo=2@
251− deriving (Eq, Ord, Show, Enum, Bounded)
252−
253−-- | Configurable 'linkURI'.
254−--
255−-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
256−-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
257−-- sum?x[]=1&x[]=2&x[]=3
258−--
259−-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
260−-- sum?x=1&x=2&x=3
261−--
262−linkURI' :: LinkArrayElementStyle -> Link -> URI
263−linkURI' addBrackets (Link segments q_params) =
264− URI mempty -- No scheme (relative)
265− Nothing -- Or authority (relative)
266− (intercalate "/" $ map getEscaped segments)
267− (makeQueries q_params) mempty
268 where
4 where
269− makeQueries :: [Param] -> String
270− makeQueries [] = ""
271− makeQueries xs =
272− "?" <> intercalate "&" (fmap makeQuery xs)
273−
274− makeQuery :: Param -> String
275− makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
276− makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
277− makeQuery (FlagParam k) = escape k
278−
279− style = case addBrackets of
280− LinkArrayElementBracket -> "[]="
281− LinkArrayElementPlain -> "="
282−
283−escape :: String -> String
284−escape = escapeURIString isUnreserved
285−
286−-- | Create a valid (by construction) relative URI with query params.
287−--
288−-- This function will only typecheck if `endpoint` is part of the API `api`
289−safeLink
290− :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
291− => Proxy api -- ^ The whole API that this endpoint is a part of
292− -> Proxy endpoint -- ^ The API endpoint you would like to point to
293− -> MkLink endpoint Link
294−safeLink = safeLink' id
295−
296−-- | More general 'safeLink'.
297−--
298−safeLink'
299− :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
300− => (Link -> a)
301− -> Proxy api -- ^ The whole API that this endpoint is a part of
302− -> Proxy endpoint -- ^ The API endpoint you would like to point to
303− -> MkLink endpoint a
304−safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
305−
306−-- | Create all links in an API.
307−--
308−-- Note that the @api@ type must be restricted to the endpoints that have
309−-- valid links to them.
310−--
311−-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double
312−-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)
313−-- >>> :t fooLink
314−-- fooLink :: Text -> Link
315−-- >>> :t barLink
316−-- barLink :: Int -> Link
317−--
318−-- Note: nested APIs don't work well with this approach
319−--
320−-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
321−-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
322−-- = Char -> (Int -> Link) :<|> (Double -> Link)
323−allLinks
324− :: forall api. HasLink api
325− => Proxy api
326− -> MkLink api Link
327−allLinks = allLinks' id
328−
329−-- | More general 'allLinks'. See `safeLink'`.
330−allLinks'
331− :: forall api a. HasLink api
332− => (Link -> a)
333− -> Proxy api
334− -> MkLink api a
335−allLinks' toA api = toLink toA api (Link mempty mempty)
336−
337−-- | Construct a toLink for an endpoint.
338−class HasLink endpoint where
339− type MkLink endpoint (a :: *)
340− toLink
341− :: (Link -> a)
342− -> Proxy endpoint -- ^ The API endpoint you would like to point to
343− -> Link
344− -> MkLink endpoint a
345−
346−-- Naked symbol instance
347−instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
348− type MkLink (sym :> sub) a = MkLink sub a
349− toLink toA _ =
350− toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
351− where
352− seg = symbolVal (Proxy :: Proxy sym)
353−
354−-- QueryParam instances
355−instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
356− => HasLink (QueryParam' mods sym v :> sub)
357− where
358− type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
359− toLink toA _ l mv =
360− toLink toA (Proxy :: Proxy sub) $
361− case sbool :: SBool (FoldRequired mods) of
362− STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
363− SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
364− where
365− k :: String
366− k = symbolVal (Proxy :: Proxy sym)
367−
368−instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
369− => HasLink (QueryParams sym v :> sub)
370− where
371− type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
372− toLink toA _ l =
373− toLink toA (Proxy :: Proxy sub) .
374− foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
375− where
376− k = symbolVal (Proxy :: Proxy sym)
377−
378−instance (KnownSymbol sym, HasLink sub)
379− => HasLink (QueryFlag sym :> sub)
380− where
381− type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
382− toLink toA _ l False =
383− toLink toA (Proxy :: Proxy sub) l
384− toLink toA _ l True =
385− toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
386− where
387− k = symbolVal (Proxy :: Proxy sym)
388−
389−-- :<|> instance - Generate all links at once
390−instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
391− type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
392− toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
393−
394−-- Misc instances
395−instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
396− type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
397− toLink toA _ = toLink toA (Proxy :: Proxy sub)
398−
399−instance (ToHttpApiData v, HasLink sub)
400− => HasLink (Capture' mods sym v :> sub)
401− where
402− type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
403− toLink toA _ l v =
404− toLink toA (Proxy :: Proxy sub) $
405− addSegment (escaped . Text.unpack $ toUrlPiece v) l
406−
407−instance (ToHttpApiData v, HasLink sub)
408− => HasLink (CaptureAll sym v :> sub)
409− where
410− type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
411− toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
412− foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
413−
414−instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
415− type MkLink (Header' mods sym a :> sub) r = MkLink sub r
416− toLink = simpleToLink (Proxy :: Proxy sub)
417−
418−instance HasLink sub => HasLink (Vault :> sub) where
419− type MkLink (Vault :> sub) a = MkLink sub a
420− toLink = simpleToLink (Proxy :: Proxy sub)
421−
422−instance HasLink sub => HasLink (Description s :> sub) where
423− type MkLink (Description s :> sub) a = MkLink sub a
424− toLink = simpleToLink (Proxy :: Proxy sub)
425−
426−instance HasLink sub => HasLink (Summary s :> sub) where
427− type MkLink (Summary s :> sub) a = MkLink sub a
428− toLink = simpleToLink (Proxy :: Proxy sub)
429−
430−instance HasLink sub => HasLink (HttpVersion :> sub) where
431− type MkLink (HttpVersion:> sub) a = MkLink sub a
432− toLink = simpleToLink (Proxy :: Proxy sub)
433−
434−instance HasLink sub => HasLink (IsSecure :> sub) where
435− type MkLink (IsSecure :> sub) a = MkLink sub a
436− toLink = simpleToLink (Proxy :: Proxy sub)
437−
438−instance HasLink sub => HasLink (WithNamedContext name context sub) where
439− type MkLink (WithNamedContext name context sub) a = MkLink sub a
440− toLink toA _ = toLink toA (Proxy :: Proxy sub)
441−
442−instance HasLink sub => HasLink (RemoteHost :> sub) where
443− type MkLink (RemoteHost :> sub) a = MkLink sub a
444− toLink = simpleToLink (Proxy :: Proxy sub)
445−
446−instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
447− type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
448− toLink = simpleToLink (Proxy :: Proxy sub)
449−
450−instance HasLink EmptyAPI where
451− type MkLink EmptyAPI a = EmptyAPI
452− toLink _ _ _ = EmptyAPI
453−
454−-- Verb (terminal) instances
455−instance HasLink (Verb m s ct a) where
456− type MkLink (Verb m s ct a) r = r
457− toLink toA _ = toA
458−
459−instance HasLink Raw where
460− type MkLink Raw a = a
461− toLink toA _ = toA
462−
463−instance HasLink (Stream m fr ct a) where
464− type MkLink (Stream m fr ct a) r = r
465− toLink toA _ = toA
466−
467−-- AuthProtext instances
468−instance HasLink sub => HasLink (AuthProtect tag :> sub) where
469− type MkLink (AuthProtect tag :> sub) a = MkLink sub a
470− toLink = simpleToLink (Proxy :: Proxy sub)
471−
472−-- | Helper for implemneting 'toLink' for combinators not affecting link
473−-- structure.
474−simpleToLink
475− :: forall sub a combinator.
476− (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
477− => Proxy sub
478− -> (Link -> a)
479− -> Proxy (combinator :> sub)
480− -> Link
481− -> MkLink (combinator :> sub) a
482−simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
483−
484
5
485−-- $setup
486−-- >>> import Servant.API
6+import Servant.Links
487−-- >>> import Data.Text (Text)
servant/test/Servant/Utils/LinksSpec.hs → servant/test/Servant/LinksSpec.hsrenamed+3−3
@@ -7,7 +7,7 @@
7#if __GLASGOW_HASKELL__ < 709
7#if __GLASGOW_HASKELL__ < 709
8{-# OPTIONS_GHC -fcontext-stack=41 #-}
8{-# OPTIONS_GHC -fcontext-stack=41 #-}
9#endif
9#endif
10−module Servant.Utils.LinksSpec where
10+module Servant.LinksSpec where
11
11
12import Data.Proxy (Proxy (..))
12import Data.Proxy (Proxy (..))
13import Test.Hspec (Expectation, Spec, describe, it,
13import Test.Hspec (Expectation, Spec, describe, it,
@@ -15,7 +15,7 @@ import Test.Hspec (Expectation, Spec, describe, it,
15import Data.String (fromString)
15import Data.String (fromString)
16
16
17import Servant.API
17import Servant.API
18−import Servant.Utils.Links
18+import Servant.Links
19import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
19import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
20
20
21type TestApi =
21type TestApi =
@@ -51,7 +51,7 @@ shouldBeLink link expected =
51 toUrlPiece link `shouldBe` fromString expected
51 toUrlPiece link `shouldBe` fromString expected
52
52
53spec :: Spec
53spec :: Spec
54−spec = describe "Servant.Utils.Links" $ do
54+spec = describe "Servant.Links" $ do
55 it "generates correct links for capture query params" $ do
55 it "generates correct links for capture query params" $ do
56 let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)
56 let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)
57 apiLink l1 "hi" `shouldBeLink` "hello/hi"
57 apiLink l1 "hi" `shouldBeLink` "hello/hi"