02fad69 · servant · git.iko.soy

doc/tutorial/Docs.lhs+4−6

compare with master

unifiedsplit

@@ -220,12 +220,10 @@ api :: Proxy DocsAPI

220api = Proxy

221

222server :: Server DocsAPI

223−server = Server.server3 :<|> serveDocs

223+server = Server.server3 :<|> Tagged serveDocs where

224−

225− where serveDocs _ respond =

224+ serveDocs _ respond =

226− respond $ responseLBS ok200 [plain] docsBS

225+ respond $ responseLBS ok200 [plain] docsBS

227−

228− plain = ("Content-Type", "text/plain")

226+ plain = ("Content-Type", "text/plain")

229

227

230app :: Application

228app :: Application

231app = serve api server

229app = serve api server

servant-client/test/Servant/ClientSpec.hs+5−5

@@ -157,8 +157,8 @@ server = serve api (

157 Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])

158 :<|> (\ names -> return (zipWith Person names [0..]))

159 :<|> return

160− :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")

160+ :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")

161− :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")

161+ :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")

162 :<|> (\ a b c d -> return (a, b, c, d))

163 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

164 :<|> return NoContent

@@ -174,9 +174,9 @@ failApi = Proxy

174

175failServer :: Application

176failServer = serve failApi (

177− (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")

177+ (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "")

178− :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")

178+ :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")

179− :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

179+ :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

180 )

181

182-- * basic auth stuff

servant-server/servant-server.cabal+1

@@ -70,6 +70,7 @@ library

70 , system-filepath >= 0.4 && < 0.5

71 , filepath >= 1 && < 1.5

72 , resourcet >= 1.1.6 && <1.2

73+ , tagged >= 0.7.3 && <0.9

73 , text >= 1.2 && < 1.3

74 , text >= 1.2 && < 1.3

74 , transformers >= 0.3 && < 0.6

75 , transformers >= 0.3 && < 0.6

75 , transformers-base >= 0.4.4 && < 0.5

76 , transformers-base >= 0.4.4 && < 0.5

servant-server/src/Servant/Server.hs+6−2

@@ -100,10 +100,12 @@ module Servant.Server

100

101 -- * Re-exports

102 , Application

103+ , Tagged (..)

103

104

104 ) where

105 ) where

105

106

106import Data.Proxy (Proxy)

107import Data.Proxy (Proxy)

108+import Data.Tagged (Tagged (..))

107import Data.Text (Text)

109import Data.Text (Text)

108import Network.Wai (Application)

110import Network.Wai (Application)

109import Servant.Server.Internal

111import Servant.Server.Internal

@@ -213,10 +215,12 @@ layoutWithContext p context =

213-- newtype, to convert any number of endpoints from one type constructor to

215-- newtype, to convert any number of endpoints from one type constructor to

214-- another. For example

216-- another. For example

215--

217--

218+-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged.

219+--

216-- >>> import Control.Monad.Reader

220-- >>> import Control.Monad.Reader

217-- >>> import qualified Control.Category as C

221-- >>> import qualified Control.Category as C

218−-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String

222+-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw

219−-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String)

223+-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :: ServerT ReaderAPI (Reader String)

220-- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler

224-- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler

221-- >>> let mainServer = enter nt readerServer :: Server ReaderAPI

225-- >>> let mainServer = enter nt readerServer :: Server ReaderAPI

222--

226--

servant-server/src/Servant/Server/Internal.hs+4−3

@@ -15,8 +15,8 @@

15

16module Servant.Server.Internal

17 ( module Servant.Server.Internal

18− , module Servant.Server.Internal.Context

19 , module Servant.Server.Internal.BasicAuth

18 , module Servant.Server.Internal.BasicAuth

19+ , module Servant.Server.Internal.Context

20 , module Servant.Server.Internal.Handler

21 , module Servant.Server.Internal.Router

22 , module Servant.Server.Internal.RoutingApplication

@@ -32,6 +32,7 @@ import Data.Maybe (fromMaybe, mapMaybe)

32import Data.Either (partitionEithers)

33import Data.String (fromString)

34import Data.String.Conversions (cs, (<>))

35+import Data.Tagged (Tagged, untag)

35import qualified Data.Text as T

36import qualified Data.Text as T

36import Data.Typeable

37import Data.Typeable

37import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

38import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

@@ -429,7 +430,7 @@ instance (KnownSymbol sym, HasServer api context)

429-- > server = serveDirectory "/var/www/images"

430-- > server = serveDirectory "/var/www/images"

430instance HasServer Raw context where

431instance HasServer Raw context where

431

432

432− type ServerT Raw m = Application

433+ type ServerT Raw m = Tagged m Application

433

434

434 route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do

435 route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do

435 -- note: a Raw application doesn't register any cleanup

436 -- note: a Raw application doesn't register any cleanup

@@ -439,7 +440,7 @@ instance HasServer Raw context where

439 liftIO $ go r request respond

440 liftIO $ go r request respond

440

441

441 where go r request respond = case r of

442 where go r request respond = case r of

442− Route app -> app request (respond . Route)

443+ Route app -> untag app request (respond . Route)

443 Fail a -> respond $ Fail a

444 Fail a -> respond $ Fail a

444 FailFatal e -> respond $ FailFatal e

445 FailFatal e -> respond $ FailFatal e

445

446

servant-server/src/Servant/Utils/StaticFiles.hs+6−6

@@ -18,7 +18,7 @@ module Servant.Utils.StaticFiles

18import Data.ByteString (ByteString)

19import Network.Wai.Application.Static

20import Servant.API.Raw (Raw)

21−import Servant.Server (Server)

21+import Servant.Server (Server, Tagged (..))

22import System.FilePath (addTrailingPathSeparator)

23#if !MIN_VERSION_wai_app_static(3,1,0)

24import Filesystem.Path.CurrentOS (decodeString)

@@ -48,27 +48,27 @@ import WaiAppStatic.Storage.Filesystem (ETagLookup)

48--

49-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.

50serveDirectoryWebApp :: FilePath -> Server Raw

51−serveDirectoryWebApp = staticApp . defaultWebAppSettings . fixPath

51+serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath

52

53-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.

54serveDirectoryFileServer :: FilePath -> Server Raw

55−serveDirectoryFileServer = staticApp . defaultFileServerSettings . fixPath

55+serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath

56

57-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.

58serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw

59serveDirectoryWebAppLookup etag =

60− staticApp . flip webAppSettingsWithLookup etag . fixPath

60+ serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath

61

62-- | Uses 'embeddedSettings'.

63serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw

64−serveDirectoryEmbedded files = staticApp (embeddedSettings files)

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.

70serveDirectoryWith :: StaticSettings -> Server Raw

71−serveDirectoryWith = staticApp

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

servant-server/test/Servant/ServerSpec.hs+9−8

@@ -47,7 +47,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect,

47 Raw, RemoteHost, ReqBody,

48 StdMethod (..), Verb, addHeader)

49import Servant.API.Internal.Test.ComprehensiveAPI

50−import Servant.Server (Server, Handler, err401, err403,

50+import Servant.Server (Server, Handler, Tagged (..), err401, err403,

51 err404, serve, serveWithContext,

52 Context((:.), EmptyContext))

53import Test.Hspec (Spec, context, describe, it,

@@ -210,7 +210,7 @@ captureSpec = do

210

211 with (return (serve

212 (Proxy :: Proxy (Capture "captured" String :> Raw))

213− (\ "captured" request_ respond ->

213+ (\ "captured" -> Tagged $ \request_ respond ->

214 respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

215 it "strips the captured path snippet from pathInfo" $ do

216 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

@@ -262,7 +262,7 @@ captureAllSpec = do

262

263 with (return (serve

264 (Proxy :: Proxy (CaptureAll "segments" String :> Raw))

265− (\ _captured request_ respond ->

265+ (\ _captured -> Tagged $ \request_ respond ->

266 respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

267 it "consumes everything from pathInfo" $ do

268 get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))

@@ -494,9 +494,10 @@ type RawApi = "foo" :> Raw

494rawApi :: Proxy RawApi

495rawApi = Proxy

496

497−rawApplication :: Show a => (Request -> a) -> Application

497+rawApplication :: Show a => (Request -> a) -> Tagged m Application

498+rawApplication f = Tagged $ \request_ respond ->

498−rawApplication f request_ respond = respond $ responseLBS ok200 []

499+ respond $ responseLBS ok200 []

499− (cs $ show $ f request_)

500+ (cs $ show $ f request_)

500

501

501rawSpec :: Spec

502rawSpec :: Spec

502rawSpec = do

503rawSpec = do

@@ -651,7 +652,7 @@ basicAuthApi = Proxy

651basicAuthServer :: Server BasicAuthAPI

652basicAuthServer :: Server BasicAuthAPI

652basicAuthServer =

653basicAuthServer =

653 const (return jerry) :<|>

654 const (return jerry) :<|>

654− (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")

655+ (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "")

655

656

656basicAuthContext :: Context '[ BasicAuthCheck () ]

657basicAuthContext :: Context '[ BasicAuthCheck () ]

657basicAuthContext =

658basicAuthContext =

@@ -696,7 +697,7 @@ genAuthApi = Proxy

696

697

697genAuthServer :: Server GenAuthAPI

698genAuthServer :: Server GenAuthAPI

698genAuthServer = const (return tweety)

699genAuthServer = const (return tweety)

699− :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")

700+ :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "")

700

701

701type instance AuthServerData (AuthProtect "auth") = ()

702type instance AuthServerData (AuthProtect "auth") = ()

702

703

servant/servant.cabal+1

@@ -66,6 +66,7 @@ library

66 , natural-transformation >= 0.4 && < 0.5

67 , mtl >= 2.0 && < 2.3

68 , mmorph >= 1 && < 1.1

69+ , tagged >= 0.7.3 && < 0.9

69 , text >= 1 && < 1.3

70 , text >= 1 && < 1.3

70 , string-conversions >= 0.3 && < 0.5

71 , string-conversions >= 0.3 && < 0.5

71 , network-uri >= 2.6 && < 2.7

72 , network-uri >= 2.6 && < 2.7

servant/src/Servant/Utils/Enter.hs+9−1

@@ -22,9 +22,9 @@ import qualified Control.Monad.State.Lazy as LState

22import qualified Control.Monad.State.Strict as SState

23import qualified Control.Monad.Writer.Lazy as LWriter

24import qualified Control.Monad.Writer.Strict as SWriter

25+import Data.Tagged (Tagged, retag)

25import Prelude ()

26import Prelude ()

26import Prelude.Compat

27import Prelude.Compat

27−

28import Servant.API

29

30-- | Helper type family to state the 'Enter' symmetry.

@@ -32,6 +32,7 @@ type family Entered m n api where

32 Entered m n (a -> api) = a -> Entered m n api

33 Entered m n (m a) = n a

34 Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2

35+ Entered m n (Tagged m a) = Tagged n a

35

36

36class

37class

37 ( Entered m n typ ~ ret

38 ( Entered m n typ ~ ret

@@ -62,6 +63,13 @@ instance

62

63

63-- ** Leaf instances

64-- ** Leaf instances

64

65

66+instance

67+ ( Entered m n (Tagged m a) ~ Tagged n a

68+ , Entered n m (Tagged n a) ~ Tagged m a

69+ ) => Enter (Tagged m a) m n (Tagged n a)

70+ where

71+ enter _ = retag

72+

65instance

73instance

66 ( Entered m n (m a) ~ n a

74 ( Entered m n (m a) ~ n a

67 , Entered n m (n a) ~ m a

75 , Entered n m (n a) ~ m a