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

modify Raw to work with Enter

Browse source
This commit is contained in:
Brandon Martin 2015-07-30 10:44:13 -06:00
parent 761443fffe
commit b7c788a1d8
28 changed files with 322 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client/CHANGELOG.md
View file

@ -2,6 +2,7 @@ HEAD
----
* Use the `text` package instead of `String`.
* Update `instance HasClient Raw` for servant Raw changes
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
* Added support for `path` on `BaseUrl`.
* `client` now takes an explicit `Manager` argument.

6
servant-client/src/Servant/Client.hs
View file

@ -347,10 +347,10 @@ instance (KnownSymbol sym, HasClient sublayout)
-- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`.
instance HasClient Raw where
type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
instance HasClient (Raw m a) where
type Client (Raw m a) = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw
clientWithRoute :: Proxy (Raw m a) -> Req -> BaseUrl -> Manager -> Client (Raw m a)
clientWithRoute Proxy req baseurl manager httpMethod = do
performRequest httpMethod req baseurl manager

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

@ -40,7 +40,7 @@ import qualified Network.HTTP.Client as C
import Network.HTTP.Media
import Network.HTTP.Types (Status (..), badRequest400,
methodGet, ok200, status400)
import Network.Socket
import Network.Socket hiding (Raw)
import Network.Wai (Application, responseLBS)
import Network.Wai.Handler.Warp
import System.IO.Unsafe (unsafePerformIO)
@ -101,8 +101,8 @@ type Api =
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
:<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
:<|> "rawSuccess" :> Raw
:<|> "rawFailure" :> Raw
:<|> "rawSuccess" :> Raw IO Application
:<|> "rawFailure" :> Raw IO Application
:<|> "multiple" :>
Capture "first" String :>
QueryParam "second" Int :>
@ -126,8 +126,8 @@ server = serve api EmptyConfig (
Nothing -> throwE $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
:<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> Raw (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
:<|> Raw (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent
@ -135,17 +135,17 @@ server = serve api EmptyConfig (
type FailApi =
"get" :> Raw
:<|> "capture" :> Capture "name" String :> Raw
:<|> "body" :> Raw
"get" :> Raw IO Application
:<|> "capture" :> Capture "name" String :> Raw IO Application
:<|> "body" :> Raw IO Application
failApi :: Proxy FailApi
failApi = Proxy
failServer :: Application
failServer = serve failApi EmptyConfig (
(\ _request respond -> respond $ responseLBS ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
Raw (\ _request respond -> respond $ responseLBS ok200 [] "")
:<|> (\ _capture -> Raw (\ _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] ""))
:<|> Raw (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
)
{-# NOINLINE manager #-}

2
servant-docs/CHANGELOG.md
View file

@ -1,6 +1,6 @@
HEAD
----
* Update `instance HasDocs Raw` for servant Raw changes
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
* Support maximum samples setting with new `DocOptions` type (used by `docsWithOptions` and `docsWith`)
* Remove redundant second parameter of ToSample

6
servant-examples/socket-io-chat/socket-io-chat.hs
View file

@ -21,8 +21,8 @@ import qualified Network.SocketIO as SocketIO
import Chat (ServerState (..), eioServer)
type API = "socket.io" :> Raw
:<|> Raw
type API = "socket.io" :> Raw IO Application
:<|> Raw IO Application
api :: Proxy API
@ -34,7 +34,7 @@ server sHandler = socketIOHandler
:<|> serveDirectory "socket-io-chat/resources"
where
socketIOHandler req respond = toWaiApplication sHandler req respond
socketIOHandler = Raw $ toWaiApplication sHandler
app :: WaiMonad () -> Application

6
servant-examples/tutorial/T10.hs
View file

@ -15,7 +15,7 @@ import Servant
import Servant.Docs
import qualified T3
type DocsAPI = T3.API :<|> Raw
type DocsAPI = T3.API :<|> Raw IO Application
instance ToCapture (Capture "x" Int) where
toCapture _ = DocCapture "x" "(integer) position on the x axis"
@ -62,8 +62,8 @@ docsBS = encodeUtf8
server :: Server DocsAPI
server = T3.server :<|> serveDocs
where serveDocs _ respond =
respond $ responseLBS ok200 [plain] docsBS
where serveDocs = Raw (\_ respond ->
respond $ responseLBS ok200 [plain] docsBS)
plain = ("Content-Type", "text/plain")

2
servant-examples/tutorial/T6.hs
View file

@ -6,7 +6,7 @@ module T6 where
import Network.Wai
import Servant
type API = "code" :> Raw
type API = "code" :> Raw IO Application
api :: Proxy API
api = Proxy

2
servant-examples/tutorial/T9.hs
View file

@ -76,7 +76,7 @@ searchBook (Just q) = return (mkSearch q books')
type API = "point" :> Get '[JSON] Point
:<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book)
type API' = API :<|> Raw
type API' = API :<|> Raw IO Application
api :: Proxy API
api = Proxy

4
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -249,8 +249,8 @@ instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang subl
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy a))
instance HasForeign lang Raw where
type Foreign Raw = HTTP.Method -> Req
instance HasForeign lang (Raw m a) where
type Foreign (Raw m a) = HTTP.Method -> Req
foreignFor _ Proxy req method =
req & funcName %~ ((toLower $ decodeUtf8 method) :)

2
servant-js/CHANGELOG.md
View file

@ -1,6 +1,6 @@
HEAD
----
* Update `instance HasJS Raw` for servant Raw changes
* Provide new targets for code generation along with the old jQuery one: vanilla Javascript and Angular.js
* Greatly simplify usage of this library by reducing down the API to just 2 functions: `jsForAPI` and `writeJSForAPI` + the choice of a code generator
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators

2
servant-js/README.md
View file

@ -55,7 +55,7 @@ type TestApi = "counter" :> Post '[JSON] Counter -- endpoint for increasing the
:<|> "counter" :> Get '[JSON] Counter -- endpoint to get the current value
type TestApi' = TestApi -- The API we want a JS handler for
:<|> Raw -- used for serving static files
:<|> Raw Application IO -- used for serving static files
-- this proxy only targets the proper endpoints of our API,
-- not the static file serving bit

2
servant-js/examples/counter.hs
View file

@ -43,7 +43,7 @@ type TestApi = "counter" :> Post '[JSON] Counter -- endpoint for increasing the
:<|> "counter" :> Get '[JSON] Counter -- endpoint to get the current value
type TestApi' = TestApi
:<|> Raw -- used for serving static files
:<|> Raw IO Application -- used for serving static files
-- this proxy only targets the proper endpoints of our API,
-- not the static file serving bit

2
servant-js/test/Servant/JSSpec.hs
View file

@ -41,7 +41,7 @@ type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] Text :> Post '[JSON] B
:<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool
type TopLevelRawAPI = "something" :> Get '[JSON] Int
:<|> Raw
:<|> Raw IO ()
type HeaderHandlingAPI = "something" :> Header "Foo" Text
:> Get '[JSON] Int

0
servant-mock/CHANGELOG.md Normal file
View file

7
servant-mock/src/Servant/Mock.hs
View file

@ -68,6 +68,7 @@ import Network.Wai
import Servant
import Servant.API.ContentTypes
import Servant.Server.Internal.Config
import Servant.Server.Internal (ToRawApplication)
import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
import Test.QuickCheck.Gen (Gen, generate)
@ -155,10 +156,10 @@ instance OVERLAPPING_
=> HasMock (Verb method status ctypes (Headers headerTypes a)) config where
mock _ _ = mockArbitrary
instance HasMock Raw config where
mock _ _ = \_req respond -> do
instance HasMock (Raw m Application) config where
mock _ _ = Raw (\_req respond -> do
bdy <- genBody
respond $ responseLBS status200 [] bdy
respond $ responseLBS status200 [] bdy)
where genBody = pack <$> generate (vector 100 :: Gen [Char])

8
servant-server/CHANGELOG.md
View file

@ -1,9 +1,13 @@
HEAD
----
typeclass `HasServer` now take an additional parameter.
* Add `serveDirectoryWith` user can supply custom `StaticSettings`
* Update `serveDirectory` for servant Raw changes
* Add `class ToRawApplication` for servant Raw changes
* Update `instance Server Raw` for servant Raw changes
* Add `instance Enter Raw` for servant Raw changes
* Add `Config` machinery (https://github.com/haskell-servant/servant/pull/327).
This is a breaking change, as the signatures of both `route`, `serve` and the
typeclass `HasServer` now take an additional parameter.
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
* Drop `EitherT` in favor of `ExceptT`
* Use `http-api-data` instead of `Servant.Common.Text`

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

@ -52,7 +52,7 @@ import Servant.API ((:<|>) (..), (:>), Capture,
Verb, ReflectMethod(reflectMethod),
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault,
Raw(..), RemoteHost, ReqBody, Vault,
WithNamedConfig)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
@ -354,18 +354,23 @@ instance (KnownSymbol sym, HasServer sublayout config)
--
-- Example:
--
-- > type MyApi = "images" :> Raw
-- > type MyApi = "images" :> Raw IO Application
-- >
-- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images"
instance HasServer Raw config where
class ToRawApplication a where
toRawApplication :: a -> Application
type ServerT Raw m = Application
instance ToRawApplication Application where
toRawApplication = id
instance ToRawApplication a => HasServer (Raw m a) config where
type ServerT (Raw m a) n = Raw n a
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication
case r of
Route app -> app request (respond . Route)
Route (Raw app) -> (toRawApplication app) request (respond . Route)
Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e

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

@ -8,6 +8,9 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
module Servant.Server.Internal.Enter where
#if !MIN_VERSION_base(4,8,0)
@ -27,16 +30,15 @@ import qualified Control.Monad.Writer.Strict as SWriter
import Data.Typeable
import Servant.API
class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
class Enter typ arg ret | typ ret -> arg, arg ret -> typ where
enter :: arg -> typ -> ret
-- ** Servant combinators
instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
, arg1 ~ arg2
instance ( Enter typ1 arg1 ret1 , Enter typ2 arg1 ret2
) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where
enter e (a :<|> b) = enter e a :<|> enter e b
instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
enter arg f a = enter arg (f a)
-- ** Useful instances
@ -49,8 +51,19 @@ instance C.Category (:~>) where
id = Nat id
Nat f . Nat g = Nat (f . g)
instance Enter (m a) (m :~> n) (n a) where
enter (Nat f) = f
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
Enter (m a) (m :~> n) (n a) where
enter (Nat f) = f
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(Raw m' ~ m, Raw n' ~ n) => Enter (m a) (m' :~> n') (n a) where
enter _ (Raw a) = Raw a
-- | Like `lift`.
liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m

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

@ -8,9 +8,11 @@ module Servant.Utils.StaticFiles (
) where
import Network.Wai.Application.Static (defaultFileServerSettings,
StaticSettings,
staticApp)
import Servant.API.Raw (Raw)
import Servant.Server (Server)
import Network.Wai (Application)
import Servant.API.Raw (Raw(..))
import Servant.Server (ServerT)
import System.FilePath (addTrailingPathSeparator)
#if !MIN_VERSION_wai_app_static(3,1,0)
import Filesystem.Path.CurrentOS (decodeString)
@ -36,10 +38,12 @@ import Filesystem.Path.CurrentOS (decodeString)
-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory'
-- handler in the last position, because /servant/ will try to match the handlers
-- in order.
serveDirectory :: FilePath -> Server Raw
serveDirectory =
#if MIN_VERSION_wai_app_static(3,1,0)
staticApp . defaultFileServerSettings . addTrailingPathSeparator
#else
staticApp . defaultFileServerSettings . decodeString . addTrailingPathSeparator
serveDirectoryWith :: StaticSettings -> ServerT (Raw m Application) n
serveDirectoryWith settings = Raw (staticApp settings)
serveDirectory :: FilePath -> ServerT (Raw m Application) n
serveDirectory = serveDirectoryWith . defaultFileServerSettings .
#if !MIN_VERSION_wai_app_static(3,1,0)
decodeString .
#endif
addTrailingPathSeparator

75
servant-server/test/Servant/Server/Internal/EnterSpec.hs
View file

@ -6,12 +6,24 @@ module Servant.Server.Internal.EnterSpec where
import qualified Control.Category as C
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Writer
import Data.IORef
import Data.Proxy
import Servant.API
import Servant.Server
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Wai (get, matchStatus, post,
import Control.Exception (bracket)
import Network.Wai (Application)
import Network.HTTP.Types (methodPost)
import Servant.Utils.StaticFiles (serveDirectory)
import System.Directory (createDirectory,
getCurrentDirectory,
setCurrentDirectory)
import System.IO.Temp (withSystemTempDirectory)
import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec (Spec, around_, context, describe,
it, shouldReturn)
import Test.Hspec.Wai (get, matchStatus, post, request,
shouldRespondWith, with)
spec :: Spec
@ -20,22 +32,35 @@ spec = describe "module Servant.Server.Enter" $ do
type ReaderAPI = "int" :> Get '[JSON] Int
:<|> "string" :> Post '[JSON] String
:<|> "static" :> Raw (Reader String) Application
type IdentityAPI = "bool" :> Get '[JSON] Bool
type WriterAPI = "fn" :> ReqBody '[JSON] Int :> Post '[JSON] Int
type CombinedAPI = ReaderAPI :<|> IdentityAPI
type CombinedAPI2 = CombinedAPI :<|> WriterAPI
readerAPI :: Proxy ReaderAPI
readerAPI = Proxy
combinedAPI :: Proxy CombinedAPI
combinedAPI = Proxy
combinedAPI2 :: Proxy CombinedAPI2
combinedAPI2 = Proxy
readerServer' :: ServerT ReaderAPI (Reader String)
readerServer' = return 1797 :<|> ask
readerServer' = return 1797
:<|> ask
:<|> serveDirectory "static"
writerServer :: ServerT WriterAPI (WriterT String IO)
writerServer x = tell "hi" >> return x
fReader :: Reader String :~> ExceptT ServantErr IO
fReader = generalizeNat C.. (runReaderTNat "hi")
fReader = generalizeNat C.. runReaderTNat "hi"
readerServer :: Server ReaderAPI
readerServer = enter fReader readerServer'
@ -46,14 +71,52 @@ combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True)
combinedReaderServer :: Server CombinedAPI
combinedReaderServer = enter fReader combinedReaderServer'
combinedServer2 :: IORef String -> Server CombinedAPI2
combinedServer2 ref'
= enter fReader combinedReaderServer'
:<|> enter (liftNat C.. logWriterTLNat (writeIORef ref')) writerServer
withStaticFiles :: IO () -> IO ()
withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
bracket (setup tmpDir) teardown (const action)
where
setup tmpDir = do
outer <- getCurrentDirectory
setCurrentDirectory tmpDir
createDirectory "static"
writeFile "static/foo.txt" "bar"
writeFile "static/index.html" "index"
return outer
teardown outer = do
setCurrentDirectory outer
enterSpec :: Spec
enterSpec = describe "Enter" $ do
with (return (serve readerAPI EmptyConfig readerServer)) $ do
around_ withStaticFiles $ with (return (serve readerAPI EmptyConfig readerServer)) $ do
it "allows running arbitrary monads" $ do
get "int" `shouldRespondWith` "1797"
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do
it "allows combnation of enters" $ do
it "allows combination of enters" $ do
get "bool" `shouldRespondWith` "true"
with (newIORef "h" >>= \r -> return (serve combinedAPI2 EmptyConfig $ combinedServer2 r)) $ do
it "allows nested combination of enters" $ do
get "bool" `shouldRespondWith` "true"
request methodPost "fn" [("Content-Type", "application/json")] "3"
`shouldRespondWith` "3"{ matchStatus = 200 }
context "logWriter" $ do
with (return (serve combinedAPI2 EmptyConfig $ combinedServer2 ref)) $ do
it "runs the function provided with the logs as argument" $ do
void $ request methodPost "fn" [("Content-Type", "application/json")] "3"
liftIO $ readIORef ref `shouldReturn` "hi"
{-# NOINLINE ref #-}
ref :: IORef String
ref = unsafePerformIO $ newIORef ""

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

@ -45,7 +45,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
NoContent (..), Patch, PlainText,
Post, Put,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody,
Raw(..), RemoteHost, ReqBody,
StdMethod (..), Verb, addHeader)
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Server (ServantErr (..), Server, err404,
@ -197,10 +197,10 @@ captureSpec = do
get "/notAnInt" `shouldRespondWith` 404
with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw))
(Proxy :: Proxy (Capture "captured" String :> Raw IO Application))
EmptyConfig
(\ "captured" request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
(\ "captured" -> Raw (\ 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]))
@ -360,7 +360,7 @@ headerSpec = describe "Servant.API.Header" $ do
-- * rawSpec {{{
------------------------------------------------------------------------------
type RawApi = "foo" :> Raw
type RawApi = "foo" :> Raw IO Application
rawApi :: Proxy RawApi
rawApi = Proxy
@ -373,7 +373,7 @@ rawSpec :: Spec
rawSpec = do
describe "Servant.API.Raw" $ do
it "runs applications" $ do
(flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do
(flip runSession) (serve rawApi EmptyConfig (Raw (rawApplication (const (42 :: Integer))))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo"]
}
@ -381,7 +381,7 @@ rawSpec = do
simpleBody response `shouldBe` "42"
it "gets the pathInfo modified" $ do
(flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do
(flip runSession) (serve rawApi EmptyConfig (Raw (rawApplication pathInfo))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo", "bar"]
}

4
servant-server/test/Servant/Utils/StaticFilesSpec.hs
View file

@ -15,14 +15,14 @@ import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec (Spec, around_, describe, it)
import Test.Hspec.Wai (get, shouldRespondWith, with)
import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw(..), (:>), JSON)
import Servant.Server (Server, serve, Config(EmptyConfig))
import Servant.ServerSpec (Person (Person))
import Servant.Utils.StaticFiles (serveDirectory)
type Api =
"dummy_api" :> Capture "person_name" String :> Get '[JSON] Person
:<|> "static" :> Raw
:<|> "static" :> Raw IO Application
api :: Proxy Api

2
servant/CHANGELOG.md
View file

@ -1,6 +1,6 @@
HEAD
----
* Change Raw from `data Raw ...` to `newtype Raw (m :: * -> *) a = Raw ... a`
* Add `WithNamedConfig` combinator.
* Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
* Fix safeLink, so Header is not in fact required.

2
servant/src/Servant/API.hs
View file

@ -62,7 +62,7 @@ import Servant.API.HttpVersion (HttpVersion (..))
import Servant.API.IsSecure (IsSecure (..))
import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams)
import Servant.API.Raw (Raw)
import Servant.API.Raw (Raw(..))
import Servant.API.RemoteHost (RemoteHost)
import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders (AddHeader (addHeader),

147
servant/src/Servant/API/Raw.hs
View file

@ -1,14 +1,151 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Raw where
import Data.Typeable (Typeable)
import Control.Monad (liftM)
import Data.Typeable (Typeable)
import Data.Data (Data)
import Data.Foldable
import Data.Ix (Ix(..))
import GHC.Generics (Generic, Generic1)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
import Data.Traversable (Traversable(..))
import Control.Applicative (liftA2, (<$>), Applicative(..))
#else
import Control.Applicative (liftA2)
#endif
-- | Endpoint for plugging in your own Wai 'Application's.
--
-- The given 'Application' will get the request as received by the server, potentially with
-- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'.
-- The given 'Application' will get the request as received by the server,
-- potentially with a modified (stripped) 'pathInfo' if the 'Application' is
-- being routed with 'Servant.API.Sub.:>'.
--
-- In addition to just letting you plug in your existing WAI 'Application's,
-- this can also be used with 'Servant.Utils.StaticFiles.serveDirectory' to serve
-- static files stored in a particular directory on your filesystem
data Raw deriving Typeable
--
-- The phantom type (@m@) is used to describe which monad your web handlers run
-- in: IO for wai (the default server provided in servant-server), or another
-- monad specific to your handler or application (e.g. @AppHandler@ in @Snap@).
-- Non-server Servant interpretations generally don't look at (@m@).
newtype Raw (m :: * -> *) a = Raw {
unRaw :: a
} deriving (Eq, Read, Show, Ord, Typeable, Ix, Bounded, Data, Generic, Generic1)
instance Monoid a => Monoid (Raw m a) where
mempty = Raw mempty
mappend (Raw a) (Raw b) = Raw (mappend a b)
instance Functor (Raw m) where
fmap f (Raw x) = Raw (f x)
instance Applicative (Raw m) where
pure = Raw
Raw f <*> Raw x = Raw (f x)
instance Monad (Raw m) where
return = Raw
Raw m >>= k = k m
_ >> n = n
instance Foldable (Raw m) where
foldMap f (Raw x) = f x
fold (Raw x) = x
foldr f z (Raw x) = f x z
foldl f z (Raw x) = f z x
foldl1 _ (Raw x) = x
foldr1 _ (Raw x) = x
instance Traversable (Raw m) where
traverse f (Raw x) = Raw <$> f x
sequenceA (Raw x) = Raw <$> x
mapM f (Raw x) = liftM Raw (f x)
sequence (Raw x) = liftM Raw x
instance Enum a => Enum (Raw m a) where
succ = fmap succ
pred = fmap pred
toEnum = Raw . toEnum
fromEnum (Raw x) = fromEnum x
enumFrom (Raw x) = map Raw (enumFrom x)
enumFromThen (Raw x) (Raw y) = map Raw (enumFromThen x y)
enumFromTo (Raw x) (Raw y) = map Raw (enumFromTo x y)
enumFromThenTo (Raw x) (Raw y) (Raw z) = map Raw (enumFromThenTo x y z)
instance Num a => Num (Raw m a) where
(+) = liftA2 (+)
(-) = liftA2 (-)
(*) = liftA2 (*)
negate = fmap negate
abs = fmap abs
signum = fmap signum
fromInteger = Raw . fromInteger
instance Real a => Real (Raw m a) where
toRational (Raw x) = toRational x
instance Integral a => Integral (Raw m a) where
quot = liftA2 quot
rem = liftA2 rem
div = liftA2 div
mod = liftA2 mod
quotRem (Raw x) (Raw y) = (Raw a, Raw b) where
(a, b) = quotRem x y
divMod (Raw x) (Raw y) = (Raw a, Raw b) where
(a, b) = divMod x y
toInteger (Raw x) = toInteger x
instance Fractional a => Fractional (Raw m a) where
(/) = liftA2 (/)
recip = fmap recip
fromRational = Raw . fromRational
instance Floating a => Floating (Raw m a) where
pi = Raw pi
exp = fmap exp
log = fmap log
sqrt = fmap sqrt
sin = fmap sin
cos = fmap cos
tan = fmap tan
asin = fmap asin
acos = fmap acos
atan = fmap atan
sinh = fmap sinh
cosh = fmap cosh
tanh = fmap tanh
asinh = fmap asinh
acosh = fmap acosh
atanh = fmap atanh
(**) = liftA2 (**)
logBase = liftA2 (**)
instance RealFrac a => RealFrac (Raw m a) where
properFraction (Raw x) = (a, Raw b) where
(a, b) = properFraction x
truncate (Raw x) = truncate x
round (Raw x) = round x
ceiling (Raw x) = ceiling x
floor (Raw x) = floor x
instance RealFloat a => RealFloat (Raw m a) where
floatRadix (Raw x) = floatRadix x
floatDigits (Raw x) = floatDigits x
floatRange (Raw x) = floatRange x
decodeFloat (Raw x) = decodeFloat x
encodeFloat m n = Raw (encodeFloat m n)
exponent (Raw x) = exponent x
significand = fmap significand
scaleFloat n = fmap (scaleFloat n)
isNaN (Raw x) = isNaN x
isInfinite (Raw x) = isInfinite x
isDenormalized (Raw x) = isDenormalized x
isNegativeZero (Raw x) = isNegativeZero x
isIEEE (Raw x) = isIEEE x
atan2 = liftA2 atan2

4
servant/src/Servant/Utils/Links.hs
View file

@ -300,6 +300,6 @@ instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = URI
toLink _ = linkURI
instance HasLink Raw where
type MkLink Raw = URI
instance HasLink (Raw m a) where
type MkLink (Raw m a) = URI
toLink _ = linkURI

15
servant/test/Servant/API/RawSpec.hs Normal file
View file

@ -0,0 +1,15 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.API.RawSpec where
import Test.Hspec
import Servant.API.Raw
spec :: Spec
spec = describe "Servant.API.Raw" $ do
describe "unRaw" $ do
it "unRaw returns proper value" $ do
let p = Raw "testing" :: Raw IO String
p `shouldBe` (Raw "testing")
(unRaw p) `shouldBe` "testing"

4
servant/test/Servant/Utils/LinksSpec.hs
View file

@ -22,7 +22,7 @@ type TestApi =
:<|> "put" :> Put '[JSON] ()
:<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] ()
:<|> "delete" :> Header "ponies" String :> Delete '[JSON] ()
:<|> "raw" :> Raw
:<|> "raw" :> Raw IO ()
apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
@ -58,7 +58,7 @@ spec = describe "Servant.Utils.Links" $ do
apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put"
apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post"
apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete"
apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"
apiLink (Proxy :: Proxy ("raw" :> Raw IO ())) `shouldBeURI` "raw"
-- |