modify Raw to work with Enter

servant-client/CHANGELOG.md

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

servant-client/src/Servant/Client.hs

@@ -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
+instance HasClient (Raw m a) where
-  type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
+  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
 

servant-client/test/Servant/ClientSpec.hs

@@ -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
+  :<|> "rawSuccess" :> Raw IO Application
-  :<|> "rawFailure" :> Raw
+  :<|> "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")
+  :<|> Raw (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
-  :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
+  :<|> 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
+       "get" :> Raw IO Application
-  :<|> "capture" :> Capture "name" String :> Raw
+  :<|> "capture" :> Capture "name" String :> Raw IO Application
-  :<|> "body" :> Raw
+  :<|> "body" :> Raw IO Application
 failApi :: Proxy FailApi
 failApi = Proxy
 
 failServer :: Application
 failServer = serve failApi EmptyConfig (
-       (\ _request respond -> respond $ responseLBS ok200 [] "")
+       Raw (\ _request respond -> respond $ responseLBS ok200 [] "")
-  :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
+  :<|> (\ _capture -> Raw (\ _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] ""))
-  :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
+  :<|> Raw (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
  )
 
 {-# NOINLINE manager #-}

servant-docs/CHANGELOG.md

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

servant-examples/socket-io-chat/socket-io-chat.hs

@@ -21,8 +21,8 @@ import qualified Network.SocketIO         as SocketIO
 import           Chat                     (ServerState (..), eioServer)
 
 
-type API = "socket.io" :> Raw
+type API = "socket.io" :> Raw IO Application
-    :<|> Raw
+    :<|> 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

servant-examples/tutorial/T10.hs

@@ -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 =
+  where serveDocs = Raw (\_ respond ->
-          respond $ responseLBS ok200 [plain] docsBS
+          respond $ responseLBS ok200 [plain] docsBS)
 
         plain = ("Content-Type", "text/plain")
 

servant-examples/tutorial/T6.hs

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

servant-examples/tutorial/T9.hs

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

servant-foreign/src/Servant/Foreign/Internal.hs

@@ -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
+instance HasForeign lang (Raw m a) where
-  type Foreign Raw = HTTP.Method -> Req
+  type Foreign (Raw m a) = HTTP.Method -> Req
 
   foreignFor _ Proxy req method =
     req & funcName %~ ((toLower $ decodeUtf8 method) :)

servant-js/CHANGELOG.md

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

servant-js/README.md

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

servant-js/examples/counter.hs

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

servant-js/test/Servant/JSSpec.hs

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

servant-mock/src/Servant/Mock.hs

@@ -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
+instance HasMock (Raw m Application) config where
-  mock _ _ = \_req respond -> do
+  mock _ _ = Raw (\_req respond -> do
     bdy <- genBody
-    respond $ responseLBS status200 [] bdy
+    respond $ responseLBS status200 [] bdy)
 
     where genBody = pack <$> generate (vector 100 :: Gen [Char])
 

servant-server/CHANGELOG.md

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

servant-server/src/Servant/Server/Internal.hs

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

servant-server/src/Servant/Server/Internal/Enter.hs

@@ -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
+instance ( Enter typ1 arg1 ret1 , Enter typ2 arg1 ret2
-         , arg1 ~ arg2
          ) => 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
+instance
-    enter (Nat f) = f
+#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

servant-server/src/Servant/Utils/StaticFiles.hs

@@ -8,9 +8,11 @@ module Servant.Utils.StaticFiles (
  ) where
 
 import           Network.Wai.Application.Static (defaultFileServerSettings,
+                                                 StaticSettings,
                                                  staticApp)
-import           Servant.API.Raw                (Raw)
+import           Network.Wai                    (Application)
-import           Servant.Server                 (Server)
+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
+serveDirectoryWith :: StaticSettings -> ServerT (Raw m Application) n
-serveDirectory =
+serveDirectoryWith settings = Raw (staticApp settings)
-#if MIN_VERSION_wai_app_static(3,1,0)
+
-    staticApp . defaultFileServerSettings . addTrailingPathSeparator
+serveDirectory :: FilePath -> ServerT (Raw m Application) n
-#else
+serveDirectory = serveDirectoryWith . defaultFileServerSettings .
-    staticApp . defaultFileServerSettings . decodeString . addTrailingPathSeparator
+#if !MIN_VERSION_wai_app_static(3,1,0)
+  decodeString .
 #endif
+  addTrailingPathSeparator

servant-server/test/Servant/Server/Internal/EnterSpec.hs

@@ -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           Control.Exception          (bracket)
-import           Test.Hspec.Wai             (get, matchStatus, post,
+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 ""

servant-server/test/Servant/ServerSpec.hs

@@ -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 ->
+        (\ "captured" -> Raw (\ 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
         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"]
          }

servant-server/test/Servant/Utils/StaticFilesSpec.hs

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

servant/CHANGELOG.md

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

servant/src/Servant/API.hs

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

servant/src/Servant/API/Raw.hs

@@ -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
+-- The given 'Application' will get the request as received by the server,
--- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'.
+-- 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

servant/src/Servant/Utils/Links.hs

@@ -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
+instance HasLink (Raw m a) where
-    type MkLink Raw = URI
+    type MkLink (Raw m a) = URI
     toLink _ = linkURI

servant/test/Servant/API/RawSpec.hs

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

servant/test/Servant/Utils/LinksSpec.hs

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