From 5d40b7787fa454ef0654af0c990ae93bade72b44 Mon Sep 17 00:00:00 2001
From: Alexander Vieth <alexander.vieth@mail.mcgill.ca>
Date: Wed, 2 Dec 2015 15:48:12 -0500
Subject: [PATCH] RawServer datatype, for uniformity of Enter

Previously, ServerT raw m ~ Application. Seems reasonable, but has the
unfortunate consequence of making Enter useless for Raw routes.
Attempting to solve the Enter class constraint for a Raw route will run
up to IO ResponseReceived, the tail end of the Wai Application type,
in practical use ultimately demanding something along the lines of:

    Enter (IO ResponseReceived)
          (yourMonad :~> EitherT ServantErr IO)
          (IO ResponseReceived)

There's no need to use Enter on a Raw route anyway, I know, but with
this change, the programmer can treat Raw routes and non-Raw routes
uniformly with respect to Enter.
---
 servant-server/servant-server.cabal           |  1 +
 servant-server/src/Servant/Server/Internal.hs |  5 +++--
 .../src/Servant/Server/Internal/Enter.hs      |  5 +++++
 .../src/Servant/Server/Internal/RawServer.hs  | 22 +++++++++++++++++++
 .../src/Servant/Utils/StaticFiles.hs          |  3 ++-
 5 files changed, 33 insertions(+), 3 deletions(-)
 create mode 100644 servant-server/src/Servant/Server/Internal/RawServer.hs

diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal
index 8d6beac4..482d5283 100644
--- a/servant-server/servant-server.cabal
+++ b/servant-server/servant-server.cabal
@@ -40,6 +40,7 @@ library
     Servant.Server.Internal.Router
     Servant.Server.Internal.RoutingApplication
     Servant.Server.Internal.ServantErr
+    Servant.Server.Internal.RawServer
     Servant.Utils.StaticFiles
   build-depends:
         base               >= 4.7  && < 5
diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index 4200d052..174ff74d 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -55,6 +55,7 @@ import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
 import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
+import           Servant.Server.Internal.RawServer
 
 import           Web.HttpApiData          (FromHttpApiData)
 import           Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
@@ -565,12 +566,12 @@ instance (KnownSymbol sym, HasServer sublayout)
 -- > server = serveDirectory "/var/www/images"
 instance HasServer Raw where
 
-  type ServerT Raw m = Application
+  type ServerT Raw m = RawServer m
 
   route Proxy rawApplication = LeafRouter $ \ request respond -> do
     r <- runDelayed rawApplication
     case r of
-      Route app   -> app request (respond . Route)
+      Route app   -> (getRawServer app) request (respond . Route)
       Fail a      -> respond $ Fail a
       FailFatal e -> respond $ FailFatal e
 
diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs
index 5bcebe9d..d3491917 100644
--- a/servant-server/src/Servant/Server/Internal/Enter.hs
+++ b/servant-server/src/Servant/Server/Internal/Enter.hs
@@ -25,7 +25,9 @@ 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.Typeable
+import           Data.Coerce
 import           Servant.API
+import           Servant.Server.Internal.RawServer (RawServer)
 
 class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
     enter :: arg -> typ -> ret
@@ -39,6 +41,9 @@ instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
 instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
     enter arg f a = enter arg (f a)
 
+instance Enter (RawServer m) (m :~> n) (RawServer n) where
+    enter _ = coerce
+
 -- ** Useful instances
 
 -- | A natural transformation from @m@ to @n@. Used to `enter` particular
diff --git a/servant-server/src/Servant/Server/Internal/RawServer.hs b/servant-server/src/Servant/Server/Internal/RawServer.hs
new file mode 100644
index 00000000..b616e0be
--- /dev/null
+++ b/servant-server/src/Servant/Server/Internal/RawServer.hs
@@ -0,0 +1,22 @@
+{-|
+Module      : Servant.Server.Internal.RawServer
+Description : Definition of the RawServer type.
+Copyright   : (c) Alexander Vieth, 2015
+Licence     : BSD3
+-}
+
+{-# LANGUAGE AutoDeriveTypeable #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Servant.Server.Internal.RawServer (
+
+      RawServer(..)
+
+    ) where
+
+import Network.Wai (Application)
+
+-- | A Wai Application, but with a phantom type.
+newtype RawServer (m :: * -> *) = RawServer {
+      getRawServer :: Application
+    }
diff --git a/servant-server/src/Servant/Utils/StaticFiles.hs b/servant-server/src/Servant/Utils/StaticFiles.hs
index 08d01ada..5b97bcf6 100644
--- a/servant-server/src/Servant/Utils/StaticFiles.hs
+++ b/servant-server/src/Servant/Utils/StaticFiles.hs
@@ -12,6 +12,7 @@ import           Network.Wai.Application.Static (defaultFileServerSettings,
 import           Servant.API.Raw                (Raw)
 import           Servant.Server                 (Server)
 import           System.FilePath                (addTrailingPathSeparator)
+import Servant.Server.Internal.RawServer (RawServer(..))
 #if !MIN_VERSION_wai_app_static(3,1,0)
 import           Filesystem.Path.CurrentOS      (decodeString)
 #endif
@@ -37,7 +38,7 @@ import           Filesystem.Path.CurrentOS      (decodeString)
 -- handler in the last position, because /servant/ will try to match the handlers
 -- in order.
 serveDirectory :: FilePath -> Server Raw
-serveDirectory =
+serveDirectory = RawServer .
 #if MIN_VERSION_wai_app_static(3,1,0)
     staticApp . defaultFileServerSettings . addTrailingPathSeparator
 #else