eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #748 from phadej/raw-server

Browse source 
ServerT Raw m = Tagged m Application
This commit is contained in:
Oleg Grenrus 2017-05-16 10:23:43 +03:00 committed by GitHub
commit 02fad699aa
9 changed files with 45 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
doc/tutorial/Docs.lhs
View file

@ -220,11 +220,9 @@ api :: Proxy DocsAPI
api = Proxy api = Proxy
server :: Server DocsAPI server :: Server DocsAPI
server = Server.server3 :<|> serveDocs server = Server.server3 :<|> Tagged serveDocs where
serveDocs _ respond =
where serveDocs _ respond =
respond $ responseLBS ok200 [plain] docsBS respond $ responseLBS ok200 [plain] docsBS
plain = ("Content-Type", "text/plain") plain = ("Content-Type", "text/plain")
app :: Application app :: Application

10
servant-client/test/Servant/ClientSpec.hs
View file

@ -157,8 +157,8 @@ server = serve api (
Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
:<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d)) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent :<|> return NoContent
@ -174,9 +174,9 @@ failApi = Proxy
failServer :: Application failServer :: Application
failServer = serve failApi ( failServer = serve failApi (
(\ _request respond -> respond $ responseLBS HTTP.ok200 [] "") (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") :<|> (\ _capture -> Tagged $ \_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 [("content-type", "fooooo")] "")
) )
-- * basic auth stuff -- * basic auth stuff

1
servant-server/servant-server.cabal
View file

@ -70,6 +70,7 @@ library
, system-filepath >= 0.4 && < 0.5 , system-filepath >= 0.4 && < 0.5
, filepath >= 1 && < 1.5 , filepath >= 1 && < 1.5
, resourcet >= 1.1.6 && <1.2 , resourcet >= 1.1.6 && <1.2
, tagged >= 0.7.3 && <0.9
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.6 , transformers >= 0.3 && < 0.6
, transformers-base >= 0.4.4 && < 0.5 , transformers-base >= 0.4.4 && < 0.5

8
servant-server/src/Servant/Server.hs
View file

@ -100,10 +100,12 @@ module Servant.Server
-- * Re-exports -- * Re-exports
, Application , Application
, Tagged (..)
) where ) where
import Data.Proxy (Proxy) import Data.Proxy (Proxy)
import Data.Tagged (Tagged (..))
import Data.Text (Text) import Data.Text (Text)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.Server.Internal import Servant.Server.Internal
@ -213,10 +215,12 @@ layoutWithContext p context =
-- newtype, to convert any number of endpoints from one type constructor to -- newtype, to convert any number of endpoints from one type constructor to
-- another. For example -- another. For example
-- --
-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged.
--
-- >>> import Control.Monad.Reader -- >>> import Control.Monad.Reader
-- >>> import qualified Control.Category as C -- >>> import qualified Control.Category as C
-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String -- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw
-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String) -- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :: ServerT ReaderAPI (Reader String)
-- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler -- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler
-- >>> let mainServer = enter nt readerServer :: Server ReaderAPI -- >>> let mainServer = enter nt readerServer :: Server ReaderAPI
-- --

7
servant-server/src/Servant/Server/Internal.hs
View file

@ -15,8 +15,8 @@
module Servant.Server.Internal module Servant.Server.Internal
( module Servant.Server.Internal ( module Servant.Server.Internal
, module Servant.Server.Internal.Context
, module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.BasicAuth
, module Servant.Server.Internal.Context
, module Servant.Server.Internal.Handler , module Servant.Server.Internal.Handler
, module Servant.Server.Internal.Router , module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.RoutingApplication
@ -32,6 +32,7 @@ import Data.Maybe (fromMaybe, mapMaybe)
import Data.Either (partitionEithers) import Data.Either (partitionEithers)
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs, (<>)) import Data.String.Conversions (cs, (<>))
import Data.Tagged (Tagged, untag)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownNat, KnownSymbol, natVal, import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
@ -429,7 +430,7 @@ instance (KnownSymbol sym, HasServer api context)
-- > server = serveDirectory "/var/www/images" -- > server = serveDirectory "/var/www/images"
instance HasServer Raw context where 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 route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
-- note: a Raw application doesn't register any cleanup -- note: a Raw application doesn't register any cleanup
@ -439,7 +440,7 @@ instance HasServer Raw context where
liftIO $ go r request respond liftIO $ go r request respond
where go r request respond = case r of 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 Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e FailFatal e -> respond $ FailFatal e

12
servant-server/src/Servant/Utils/StaticFiles.hs
View file

@ -18,7 +18,7 @@ module Servant.Utils.StaticFiles
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Network.Wai.Application.Static import Network.Wai.Application.Static
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.Server (Server) import Servant.Server (Server, Tagged (..))
import System.FilePath (addTrailingPathSeparator) import System.FilePath (addTrailingPathSeparator)
#if !MIN_VERSION_wai_app_static(3,1,0) #if !MIN_VERSION_wai_app_static(3,1,0)
import Filesystem.Path.CurrentOS (decodeString) import Filesystem.Path.CurrentOS (decodeString)
@ -48,27 +48,27 @@ import WaiAppStatic.Storage.Filesystem (ETagLookup)
-- --
-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value. -- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.
serveDirectoryWebApp :: FilePath -> Server Raw serveDirectoryWebApp :: FilePath -> Server Raw
serveDirectoryWebApp = staticApp . defaultWebAppSettings . fixPath serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath
-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.
serveDirectoryFileServer :: FilePath -> Server Raw serveDirectoryFileServer :: FilePath -> Server Raw
serveDirectoryFileServer = staticApp . defaultFileServerSettings . fixPath serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath
-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.
serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw
serveDirectoryWebAppLookup etag = serveDirectoryWebAppLookup etag =
staticApp . flip webAppSettingsWithLookup etag . fixPath serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath
-- | Uses 'embeddedSettings'. -- | Uses 'embeddedSettings'.
serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw
serveDirectoryEmbedded files = staticApp (embeddedSettings files) serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)
-- | Alias for 'staticApp'. Lets you serve a directory -- | Alias for 'staticApp'. Lets you serve a directory
-- with arbitrary 'StaticSettings'. Useful when you want -- with arbitrary 'StaticSettings'. Useful when you want
-- particular settings not covered by the four other -- particular settings not covered by the four other
-- variants. This is the most flexible method. -- variants. This is the most flexible method.
serveDirectoryWith :: StaticSettings -> Server Raw serveDirectoryWith :: StaticSettings -> Server Raw
serveDirectoryWith = staticApp serveDirectoryWith = Tagged . staticApp
-- | Same as 'serveDirectoryFileServer'. It used to be the only -- | Same as 'serveDirectoryFileServer'. It used to be the only
-- file serving function in servant pre-0.10 and will be kept -- file serving function in servant pre-0.10 and will be kept

15
servant-server/test/Servant/ServerSpec.hs
View file

@ -47,7 +47,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect,
Raw, RemoteHost, ReqBody, Raw, RemoteHost, ReqBody,
StdMethod (..), Verb, addHeader) StdMethod (..), Verb, addHeader)
import Servant.API.Internal.Test.ComprehensiveAPI import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Server (Server, Handler, err401, err403, import Servant.Server (Server, Handler, Tagged (..), err401, err403,
err404, serve, serveWithContext, err404, serve, serveWithContext,
Context((:.), EmptyContext)) Context((:.), EmptyContext))
import Test.Hspec (Spec, context, describe, it, import Test.Hspec (Spec, context, describe, it,
@ -210,7 +210,7 @@ captureSpec = do
with (return (serve with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw)) (Proxy :: Proxy (Capture "captured" String :> Raw))
(\ "captured" request_ respond -> (\ "captured" -> Tagged $ \request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
it "strips the captured path snippet from pathInfo" $ do it "strips the captured path snippet from pathInfo" $ do
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
@ -262,7 +262,7 @@ captureAllSpec = do
with (return (serve with (return (serve
(Proxy :: Proxy (CaptureAll "segments" String :> Raw)) (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
(\ _captured request_ respond -> (\ _captured -> Tagged $ \request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
it "consumes everything from pathInfo" $ do it "consumes everything from pathInfo" $ do
get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
@ -494,8 +494,9 @@ type RawApi = "foo" :> Raw
rawApi :: Proxy RawApi rawApi :: Proxy RawApi
rawApi = Proxy rawApi = Proxy
rawApplication :: Show a => (Request -> a) -> Application rawApplication :: Show a => (Request -> a) -> Tagged m Application
rawApplication f request_ respond = respond $ responseLBS ok200 [] rawApplication f = Tagged $ \request_ respond ->
respond $ responseLBS ok200 []
(cs $ show $ f request_) (cs $ show $ f request_)
rawSpec :: Spec rawSpec :: Spec
@ -651,7 +652,7 @@ basicAuthApi = Proxy
basicAuthServer :: Server BasicAuthAPI basicAuthServer :: Server BasicAuthAPI
basicAuthServer = basicAuthServer =
const (return jerry) :<|> const (return jerry) :<|>
(\ _ respond -> respond $ responseLBS imATeaPot418 [] "") (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "")
basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext :: Context '[ BasicAuthCheck () ]
basicAuthContext = basicAuthContext =
@ -696,7 +697,7 @@ genAuthApi = Proxy
genAuthServer :: Server GenAuthAPI genAuthServer :: Server GenAuthAPI
genAuthServer = const (return tweety) genAuthServer = const (return tweety)
:<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "")
type instance AuthServerData (AuthProtect "auth") = () type instance AuthServerData (AuthProtect "auth") = ()

1
servant/servant.cabal
View file

@ -66,6 +66,7 @@ library
, natural-transformation >= 0.4 && < 0.5 , natural-transformation >= 0.4 && < 0.5
, mtl >= 2.0 && < 2.3 , mtl >= 2.0 && < 2.3
, mmorph >= 1 && < 1.1 , mmorph >= 1 && < 1.1
, tagged >= 0.7.3 && < 0.9
, text >= 1 && < 1.3 , text >= 1 && < 1.3
, string-conversions >= 0.3 && < 0.5 , string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7

10
servant/src/Servant/Utils/Enter.hs
View file

@ -22,9 +22,9 @@ import qualified Control.Monad.State.Lazy as LState
import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.State.Strict as SState
import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Lazy as LWriter
import qualified Control.Monad.Writer.Strict as SWriter import qualified Control.Monad.Writer.Strict as SWriter
import Data.Tagged (Tagged, retag)
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Servant.API import Servant.API
-- | Helper type family to state the 'Enter' symmetry. -- | 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 (a -> api) = a -> Entered m n api
Entered m n (m a) = n a Entered m n (m a) = n a
Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2 Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2
Entered m n (Tagged m a) = Tagged n a
class class
( Entered m n typ ~ ret ( Entered m n typ ~ ret
@ -62,6 +63,13 @@ instance
-- ** Leaf instances -- ** 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 instance
( Entered m n (m a) ~ n a ( Entered m n (m a) ~ n a
, Entered n m (n a) ~ m a , Entered n m (n a) ~ m a