From 80df1111b4cf745036c42bda79377c20efef7e22 Mon Sep 17 00:00:00 2001
From: Maxim Koltsov <kolmax94@gmail.com>
Date: Mon, 12 Oct 2020 19:24:57 +0200
Subject: [PATCH] Wrap Application in custom monad for Raw endpoint

Currently handler `Raw` endpoint for is just an `Application`: a value.
This value has no access to the context of an arbitrary monad that may
be used instead of the default `Handler`.

This commit changes handler type to `m Application`, allowing the user
to do arbitrary actions in `m` prior to generating an `Application`.

This is useful to do custom logic behind `servant`s back while still
having access to the environment of user's monad.
---
 servant-server/src/Servant/Server/Internal.hs    | 12 ++++++++----
 servant-server/src/Servant/Server/StaticFiles.hs | 16 ++++++++--------
 2 files changed, 16 insertions(+), 12 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index a234f145f..70c49d821 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -53,7 +53,7 @@ import           Data.String
 import           Data.String.Conversions
                  (cs)
 import           Data.Tagged
-                 (Tagged (..), retag, untag)
+                 (Tagged (..), retag)
 import qualified Data.Text                                  as T
 import           Data.Typeable
 import           GHC.TypeLits
@@ -587,9 +587,9 @@ instance (KnownSymbol sym, HasServer api context)
 -- > server = serveDirectory "/var/www/images"
 instance HasServer Raw context where
 
-  type ServerT Raw m = Tagged m Application
+  type ServerT Raw m = m Application
 
-  hoistServerWithContext _ _ _ = retag
+  hoistServerWithContext _ _ nt s = nt s
 
   route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
     -- note: a Raw application doesn't register any cleanup
@@ -599,7 +599,11 @@ instance HasServer Raw context where
     liftIO $ go r request respond
 
     where go r request respond = case r of
-            Route app   -> untag app request (respond . Route)
+            Route appH  -> do
+              r' <- runHandler appH
+              case r' of
+                Left e    -> respond $ FailFatal e
+                Right app -> app request (respond . Route)
             Fail a      -> respond $ Fail a
             FailFatal e -> respond $ FailFatal e
 
diff --git a/servant-server/src/Servant/Server/StaticFiles.hs b/servant-server/src/Servant/Server/StaticFiles.hs
index a628cdfec..0647dd3ec 100644
--- a/servant-server/src/Servant/Server/StaticFiles.hs
+++ b/servant-server/src/Servant/Server/StaticFiles.hs
@@ -21,7 +21,7 @@ import           Network.Wai.Application.Static
 import           Servant.API.Raw
                  (Raw)
 import           Servant.Server
-                 (ServerT, Tagged (..))
+                 (ServerT)
 import           System.FilePath
                  (addTrailingPathSeparator)
 import           WaiAppStatic.Storage.Filesystem
@@ -49,33 +49,33 @@ import           WaiAppStatic.Storage.Filesystem
 -- in order.
 --
 -- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.
-serveDirectoryWebApp :: FilePath -> ServerT Raw m
+serveDirectoryWebApp :: Monad m => FilePath -> ServerT Raw m
 serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath
 
 -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.
-serveDirectoryFileServer :: FilePath -> ServerT Raw m
+serveDirectoryFileServer :: Monad m => FilePath -> ServerT Raw m
 serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath
 
 -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.
-serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m
+serveDirectoryWebAppLookup :: Monad m => ETagLookup -> FilePath -> ServerT Raw m
 serveDirectoryWebAppLookup etag =
   serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath
 
 -- | Uses 'embeddedSettings'.
-serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m
+serveDirectoryEmbedded :: Monad m => [(FilePath, ByteString)] -> ServerT Raw m
 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 -> ServerT Raw m
-serveDirectoryWith = Tagged . staticApp
+serveDirectoryWith :: Monad m => StaticSettings -> ServerT Raw m
+serveDirectoryWith = return . staticApp
 
 -- | Same as 'serveDirectoryFileServer'. It used to be the only
 --   file serving function in servant pre-0.10 and will be kept
 --   around for a few versions, but is deprecated.
-serveDirectory :: FilePath -> ServerT Raw m
+serveDirectory :: Monad m => FilePath -> ServerT Raw m
 serveDirectory = serveDirectoryFileServer
 {-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-}