diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs index fa7b0c43..67f6f60c 100644 --- a/doc/tutorial/Docs.lhs +++ b/doc/tutorial/Docs.lhs @@ -220,12 +220,10 @@ api :: Proxy DocsAPI api = Proxy server :: Server DocsAPI -server = Server.server3 :<|> serveDocs - - where serveDocs _ respond = - respond $ responseLBS ok200 [plain] docsBS - - plain = ("Content-Type", "text/plain") +server = Server.server3 :<|> Tagged serveDocs where + serveDocs _ respond = + respond $ responseLBS ok200 [plain] docsBS + plain = ("Content-Type", "text/plain") app :: Application app = serve api server diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index fc6fc92f..219a178c 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -157,8 +157,8 @@ server = serve api ( Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent @@ -174,9 +174,9 @@ failApi = Proxy failServer :: Application failServer = serve failApi ( - (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "") - :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") - :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "") + :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") + :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") ) -- * basic auth stuff diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 2c37760e..11c80a6b 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -70,6 +70,7 @@ library , system-filepath >= 0.4 && < 0.5 , filepath >= 1 && < 1.5 , resourcet >= 1.1.6 && <1.2 + , tagged >= 0.7.3 && <0.9 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index b5ca9f87..47fdf0cf 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -100,10 +100,12 @@ module Servant.Server -- * Re-exports , Application + , Tagged (..) ) where import Data.Proxy (Proxy) +import Data.Tagged (Tagged (..)) import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal @@ -213,10 +215,12 @@ layoutWithContext p context = -- newtype, to convert any number of endpoints from one type constructor to -- another. For example -- +-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged. +-- -- >>> import Control.Monad.Reader -- >>> import qualified Control.Category as C --- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String --- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String) +-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw +-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :: ServerT ReaderAPI (Reader String) -- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler -- >>> let mainServer = enter nt readerServer :: Server ReaderAPI -- diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 926e654e..31d7b751 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -15,8 +15,8 @@ module Servant.Server.Internal ( module Servant.Server.Internal - , module Servant.Server.Internal.Context , module Servant.Server.Internal.BasicAuth + , module Servant.Server.Internal.Context , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication @@ -32,6 +32,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Either (partitionEithers) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) +import Data.Tagged (Tagged, untag) import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, @@ -429,7 +430,7 @@ instance (KnownSymbol sym, HasServer api context) -- > server = serveDirectory "/var/www/images" instance HasServer Raw context where - type ServerT Raw m = Application + type ServerT Raw m = Tagged m Application route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do -- note: a Raw application doesn't register any cleanup @@ -439,7 +440,7 @@ instance HasServer Raw context where liftIO $ go r request respond where go r request respond = case r of - Route app -> app request (respond . Route) + Route app -> untag app request (respond . Route) Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e diff --git a/servant-server/src/Servant/Utils/StaticFiles.hs b/servant-server/src/Servant/Utils/StaticFiles.hs index 4db1ed6b..12fa5e47 100644 --- a/servant-server/src/Servant/Utils/StaticFiles.hs +++ b/servant-server/src/Servant/Utils/StaticFiles.hs @@ -18,7 +18,7 @@ module Servant.Utils.StaticFiles import Data.ByteString (ByteString) import Network.Wai.Application.Static import Servant.API.Raw (Raw) -import Servant.Server (Server) +import Servant.Server (Server, Tagged (..)) import System.FilePath (addTrailingPathSeparator) #if !MIN_VERSION_wai_app_static(3,1,0) import Filesystem.Path.CurrentOS (decodeString) @@ -48,27 +48,27 @@ import WaiAppStatic.Storage.Filesystem (ETagLookup) -- -- Corresponds to the `defaultWebAppSettings` `StaticSettings` value. serveDirectoryWebApp :: FilePath -> Server Raw -serveDirectoryWebApp = staticApp . defaultWebAppSettings . fixPath +serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. serveDirectoryFileServer :: FilePath -> Server Raw -serveDirectoryFileServer = staticApp . defaultFileServerSettings . fixPath +serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw serveDirectoryWebAppLookup etag = - staticApp . flip webAppSettingsWithLookup etag . fixPath + serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath -- | Uses 'embeddedSettings'. serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw -serveDirectoryEmbedded files = staticApp (embeddedSettings files) +serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files) -- | Alias for 'staticApp'. Lets you serve a directory -- with arbitrary 'StaticSettings'. Useful when you want -- particular settings not covered by the four other -- variants. This is the most flexible method. serveDirectoryWith :: StaticSettings -> Server Raw -serveDirectoryWith = staticApp +serveDirectoryWith = Tagged . staticApp -- | Same as 'serveDirectoryFileServer'. It used to be the only -- file serving function in servant pre-0.10 and will be kept diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 40a850c7..3db3e27c 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -47,7 +47,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (Server, Handler, err401, err403, +import Servant.Server (Server, Handler, Tagged (..), err401, err403, err404, serve, serveWithContext, Context((:.), EmptyContext)) import Test.Hspec (Spec, context, describe, it, @@ -210,7 +210,7 @@ captureSpec = do with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) - (\ "captured" request_ respond -> + (\ "captured" -> Tagged $ \request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) @@ -262,7 +262,7 @@ captureAllSpec = do with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) - (\ _captured request_ respond -> + (\ _captured -> Tagged $ \request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "consumes everything from pathInfo" $ do get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) @@ -494,9 +494,10 @@ type RawApi = "foo" :> Raw rawApi :: Proxy RawApi rawApi = Proxy -rawApplication :: Show a => (Request -> a) -> Application -rawApplication f request_ respond = respond $ responseLBS ok200 [] - (cs $ show $ f request_) +rawApplication :: Show a => (Request -> a) -> Tagged m Application +rawApplication f = Tagged $ \request_ respond -> + respond $ responseLBS ok200 [] + (cs $ show $ f request_) rawSpec :: Spec rawSpec = do @@ -651,7 +652,7 @@ basicAuthApi = Proxy basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|> - (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") + (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = @@ -696,7 +697,7 @@ genAuthApi = Proxy genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety) - :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") + :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "") type instance AuthServerData (AuthProtect "auth") = () diff --git a/servant/servant.cabal b/servant/servant.cabal index 94d22668..14229d16 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -66,6 +66,7 @@ library , natural-transformation >= 0.4 && < 0.5 , mtl >= 2.0 && < 2.3 , mmorph >= 1 && < 1.1 + , tagged >= 0.7.3 && < 0.9 , text >= 1 && < 1.3 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 && < 2.7 diff --git a/servant/src/Servant/Utils/Enter.hs b/servant/src/Servant/Utils/Enter.hs index 6ca9d8e1..27eae586 100644 --- a/servant/src/Servant/Utils/Enter.hs +++ b/servant/src/Servant/Utils/Enter.hs @@ -22,9 +22,9 @@ import qualified Control.Monad.State.Lazy as LState import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter +import Data.Tagged (Tagged, retag) import Prelude () import Prelude.Compat - import Servant.API -- | Helper type family to state the 'Enter' symmetry. @@ -32,6 +32,7 @@ type family Entered m n api where Entered m n (a -> api) = a -> Entered m n api Entered m n (m a) = n a Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2 + Entered m n (Tagged m a) = Tagged n a class ( Entered m n typ ~ ret @@ -62,6 +63,13 @@ instance -- ** Leaf instances +instance + ( Entered m n (Tagged m a) ~ Tagged n a + , Entered n m (Tagged n a) ~ Tagged m a + ) => Enter (Tagged m a) m n (Tagged n a) + where + enter _ = retag + instance ( Entered m n (m a) ~ n a , Entered n m (n a) ~ m a