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
server :: Server DocsAPI
server = Server.server3 :<|> serveDocs
where serveDocs _ respond =
server = Server.server3 :<|> Tagged serveDocs where
serveDocs _ respond =
respond $ responseLBS ok200 [plain] docsBS
plain = ("Content-Type", "text/plain")
app :: Application

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

@ -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

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

@ -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

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

@ -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
--

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.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

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

@ -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

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

@ -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,8 +494,9 @@ type RawApi = "foo" :> Raw
rawApi :: Proxy RawApi
rawApi = Proxy
rawApplication :: Show a => (Request -> a) -> Application
rawApplication f request_ respond = respond $ responseLBS ok200 []
rawApplication :: Show a => (Request -> a) -> Tagged m Application
rawApplication f = Tagged $ \request_ respond ->
respond $ responseLBS ok200 []
(cs $ show $ f request_)
rawSpec :: Spec
@ -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") = ()

1
servant/servant.cabal
View file

@ -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

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.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