git.iko.soy/typeable/servant
on master help sign in
Change to ServerT Raw m = Tagged m Application

For uniformity of Enter. Previously, `ServerT Raw m ~ Application`. Seems reasonable, but has the unfortunate consequence of making `Enter` useless for `Raw` routes. With this change `Tagged m Application` is retagged by `Enter`.

commit63891344231986eaa4c9adde8e40d0867d1ce16d authorAlexander Vieth <alexander.vieth@mail.mcgill.ca> dateWed 2 Dec 2015, 15:48 (11 years ago) parent3015152
9 files changed+45−31
compare with master
unifiedsplit
doc/tutorial/Docs.lhs+4−6 servant-client/test/Servant/ClientSpec.hs+5−5 servant-server/servant-server.cabal+1 servant-server/src/Servant/Server.hs+6−2 servant-server/src/Servant/Server/Internal.hs+4−3 servant-server/src/Servant/Utils/StaticFiles.hs+6−6 servant-server/test/Servant/ServerSpec.hs+9−8 servant/servant.cabal+1 servant/src/Servant/Utils/Enter.hs+9−1
doc/tutorial/Docs.lhs+4−6
@@ -220,12 +220,10 @@ api :: Proxy DocsAPI
220220api = Proxy
221221
222222server :: Server DocsAPI
223−server = Server.server3 :<|> serveDocs
224−
225− where serveDocs _ respond =
226− respond $ responseLBS ok200 [plain] docsBS
227−
228− plain = ("Content-Type", "text/plain")
223+server = Server.server3 :<|> Tagged serveDocs where
224+ serveDocs _ respond =
225+ respond $ responseLBS ok200 [plain] docsBS
226+ plain = ("Content-Type", "text/plain")
229227
230228app :: Application
231229app = serve api server
servant-client/test/Servant/ClientSpec.hs+5−5
@@ -157,8 +157,8 @@ server = serve api (
157157 Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
158158 :<|> (\ names -> return (zipWith Person names [0..]))
159159 :<|> return
160− :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
161− :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
160+ :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
161+ :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
162162 :<|> (\ a b c d -> return (a, b, c, d))
163163 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
164164 :<|> return NoContent
@@ -174,9 +174,9 @@ failApi = Proxy
174174
175175failServer :: Application
176176failServer = serve failApi (
177− (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
178− :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
179− :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
177+ (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
178+ :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
179+ :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
180180 )
181181
182182-- * basic auth stuff
servant-server/servant-server.cabal+1
@@ -70,6 +70,7 @@ library
7070 , system-filepath >= 0.4 && < 0.5
7171 , filepath >= 1 && < 1.5
7272 , resourcet >= 1.1.6 && <1.2
73+ , tagged >= 0.7.3 && <0.9
7374 , text >= 1.2 && < 1.3
7475 , transformers >= 0.3 && < 0.6
7576 , transformers-base >= 0.4.4 && < 0.5
servant-server/src/Servant/Server.hs+6−2
@@ -100,10 +100,12 @@ module Servant.Server
100100
101101 -- * Re-exports
102102 , Application
103+ , Tagged (..)
103104
104105 ) where
105106
106107import Data.Proxy (Proxy)
108+import Data.Tagged (Tagged (..))
107109import Data.Text (Text)
108110import Network.Wai (Application)
109111import Servant.Server.Internal
@@ -213,10 +215,12 @@ layoutWithContext p context =
213215-- newtype, to convert any number of endpoints from one type constructor to
214216-- another. For example
215217--
218+-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged.
219+--
216220-- >>> import Control.Monad.Reader
217221-- >>> import qualified Control.Category as C
218−-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String
219−-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String)
222+-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw
223+-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :: ServerT ReaderAPI (Reader String)
220224-- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler
221225-- >>> let mainServer = enter nt readerServer :: Server ReaderAPI
222226--
servant-server/src/Servant/Server/Internal.hs+4−3
@@ -15,8 +15,8 @@
1515
1616module Servant.Server.Internal
1717 ( module Servant.Server.Internal
18− , module Servant.Server.Internal.Context
1918 , module Servant.Server.Internal.BasicAuth
19+ , module Servant.Server.Internal.Context
2020 , module Servant.Server.Internal.Handler
2121 , module Servant.Server.Internal.Router
2222 , module Servant.Server.Internal.RoutingApplication
@@ -32,6 +32,7 @@ import Data.Maybe (fromMaybe, mapMaybe)
3232import Data.Either (partitionEithers)
3333import Data.String (fromString)
3434import Data.String.Conversions (cs, (<>))
35+import Data.Tagged (Tagged, untag)
3536import qualified Data.Text as T
3637import Data.Typeable
3738import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
@@ -429,7 +430,7 @@ instance (KnownSymbol sym, HasServer api context)
429430-- > server = serveDirectory "/var/www/images"
430431instance HasServer Raw context where
431432
432− type ServerT Raw m = Application
433+ type ServerT Raw m = Tagged m Application
433434
434435 route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
435436 -- note: a Raw application doesn't register any cleanup
@@ -439,7 +440,7 @@ instance HasServer Raw context where
439440 liftIO $ go r request respond
440441
441442 where go r request respond = case r of
442− Route app -> app request (respond . Route)
443+ Route app -> untag app request (respond . Route)
443444 Fail a -> respond $ Fail a
444445 FailFatal e -> respond $ FailFatal e
445446
servant-server/src/Servant/Utils/StaticFiles.hs+6−6
@@ -18,7 +18,7 @@ module Servant.Utils.StaticFiles
1818import Data.ByteString (ByteString)
1919import Network.Wai.Application.Static
2020import Servant.API.Raw (Raw)
21−import Servant.Server (Server)
21+import Servant.Server (Server, Tagged (..))
2222import System.FilePath (addTrailingPathSeparator)
2323#if !MIN_VERSION_wai_app_static(3,1,0)
2424import Filesystem.Path.CurrentOS (decodeString)
@@ -48,27 +48,27 @@ import WaiAppStatic.Storage.Filesystem (ETagLookup)
4848--
4949-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.
5050serveDirectoryWebApp :: FilePath -> Server Raw
51−serveDirectoryWebApp = staticApp . defaultWebAppSettings . fixPath
51+serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath
5252
5353-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.
5454serveDirectoryFileServer :: FilePath -> Server Raw
55−serveDirectoryFileServer = staticApp . defaultFileServerSettings . fixPath
55+serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath
5656
5757-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.
5858serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw
5959serveDirectoryWebAppLookup etag =
60− staticApp . flip webAppSettingsWithLookup etag . fixPath
60+ serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath
6161
6262-- | Uses 'embeddedSettings'.
6363serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw
64−serveDirectoryEmbedded files = staticApp (embeddedSettings files)
64+serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)
6565
6666-- | Alias for 'staticApp'. Lets you serve a directory
6767-- with arbitrary 'StaticSettings'. Useful when you want
6868-- particular settings not covered by the four other
6969-- variants. This is the most flexible method.
7070serveDirectoryWith :: StaticSettings -> Server Raw
71−serveDirectoryWith = staticApp
71+serveDirectoryWith = Tagged . staticApp
7272
7373-- | Same as 'serveDirectoryFileServer'. It used to be the only
7474-- 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,
4747 Raw, RemoteHost, ReqBody,
4848 StdMethod (..), Verb, addHeader)
4949import Servant.API.Internal.Test.ComprehensiveAPI
50−import Servant.Server (Server, Handler, err401, err403,
50+import Servant.Server (Server, Handler, Tagged (..), err401, err403,
5151 err404, serve, serveWithContext,
5252 Context((:.), EmptyContext))
5353import Test.Hspec (Spec, context, describe, it,
@@ -210,7 +210,7 @@ captureSpec = do
210210
211211 with (return (serve
212212 (Proxy :: Proxy (Capture "captured" String :> Raw))
213− (\ "captured" request_ respond ->
213+ (\ "captured" -> Tagged $ \request_ respond ->
214214 respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
215215 it "strips the captured path snippet from pathInfo" $ do
216216 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
@@ -262,7 +262,7 @@ captureAllSpec = do
262262
263263 with (return (serve
264264 (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
265− (\ _captured request_ respond ->
265+ (\ _captured -> Tagged $ \request_ respond ->
266266 respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
267267 it "consumes everything from pathInfo" $ do
268268 get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
@@ -494,9 +494,10 @@ type RawApi = "foo" :> Raw
494494rawApi :: Proxy RawApi
495495rawApi = Proxy
496496
497−rawApplication :: Show a => (Request -> a) -> Application
498−rawApplication f request_ respond = respond $ responseLBS ok200 []
499− (cs $ show $ f request_)
497+rawApplication :: Show a => (Request -> a) -> Tagged m Application
498+rawApplication f = Tagged $ \request_ respond ->
499+ respond $ responseLBS ok200 []
500+ (cs $ show $ f request_)
500501
501502rawSpec :: Spec
502503rawSpec = do
@@ -651,7 +652,7 @@ basicAuthApi = Proxy
651652basicAuthServer :: Server BasicAuthAPI
652653basicAuthServer =
653654 const (return jerry) :<|>
654− (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
655+ (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "")
655656
656657basicAuthContext :: Context '[ BasicAuthCheck () ]
657658basicAuthContext =
@@ -696,7 +697,7 @@ genAuthApi = Proxy
696697
697698genAuthServer :: Server GenAuthAPI
698699genAuthServer = const (return tweety)
699− :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
700+ :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "")
700701
701702type instance AuthServerData (AuthProtect "auth") = ()
702703
servant/servant.cabal+1
@@ -66,6 +66,7 @@ library
6666 , natural-transformation >= 0.4 && < 0.5
6767 , mtl >= 2.0 && < 2.3
6868 , mmorph >= 1 && < 1.1
69+ , tagged >= 0.7.3 && < 0.9
6970 , text >= 1 && < 1.3
7071 , string-conversions >= 0.3 && < 0.5
7172 , 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
2222import qualified Control.Monad.State.Strict as SState
2323import qualified Control.Monad.Writer.Lazy as LWriter
2424import qualified Control.Monad.Writer.Strict as SWriter
25+import Data.Tagged (Tagged, retag)
2526import Prelude ()
2627import Prelude.Compat
27−
2828import Servant.API
2929
3030-- | Helper type family to state the 'Enter' symmetry.
@@ -32,6 +32,7 @@ type family Entered m n api where
3232 Entered m n (a -> api) = a -> Entered m n api
3333 Entered m n (m a) = n a
3434 Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2
35+ Entered m n (Tagged m a) = Tagged n a
3536
3637class
3738 ( Entered m n typ ~ ret
@@ -62,6 +63,13 @@ instance
6263
6364-- ** Leaf instances
6465
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+
6573instance
6674 ( Entered m n (m a) ~ n a
6775 , Entered n m (n a) ~ m a