Get rid of ExceptT, compat w/ new http-conduit & monad-metrics

http-conduit now requires MonadUnliftIO:
snoyberg/http-client@dfbcb6c

It's possible to work around that by running the http client
body handlers in a fresh ReaderT. But that's an extra limitation.

monad-metrics now requires MonadMask:
parsonsmatt/monad-metrics@17546b9

It's *not* possible to work around if you want to measure whole
handlers.

So, ExceptT is slower anyway, and an antipattern:
https://www.parsonsmatt.org/2017/06/21/exceptional_servant_handling.html

Now we're free of it! And exporting UnliftIO by default.

examples/larger.hs

@@ -20,10 +20,12 @@ instance FromEnv LargeAppConf where
 
 type HelloRoute = "hello" :> QueryParam "to" Text :> Get '[PlainText] Text
 type SplinesRoute = "splines" :> QueryParam "count" Int :> Get '[PlainText] Text
-type ExampleAPI = HelloRoute :<|> SplinesRoute
+type ReqRoute = "req" :> Get '[PlainText] Text
+type ErrRoute = "err" :> Get '[PlainText] Text
+type ExampleAPI = HelloRoute :<|> SplinesRoute :<|> ReqRoute :<|> ErrRoute
 exampleAPI = Proxy ∷ Proxy ExampleAPI
 
-type LargeAppCtx = (ModLogger, ModMetrics, LargeAppConf)
+type LargeAppCtx = (ModLogger, ModMetrics, ModHttpClient, LargeAppConf)
 type LargeApp = MagicbaneApp LargeAppCtx
 
 hello ∷ Maybe Text → LargeApp Text
@@ -44,6 +46,17 @@ splines t = timed "app.important_work" $ do -- this easy to time an action
   $logDebug $ "Done in " ++ tshow fgTime ++ " second(s)"
   return "done"
 
+req ∷ LargeApp Text
+req = timed "app.http_request" $ do
+  resp ← runHTTP $ performWithBytes =<< reqS (asText "https://httpbin.org/get")
+  return $ case resp of
+                Right resp' → cs $ responseBody resp'
+                Left err → err
+
+showErr ∷ LargeApp Text
+showErr = timed "app.err_throwing" $ do
+  throwIO $ errText err418 "Hello World"
+
 -- This isn't a Java framework, so there's no inversion of control with magical main :)
 main = withEnvConfig $ \conf → do
   (_, modLogg) ← newLogger $ LogStderr defaultBufSize
@@ -54,7 +67,9 @@ main = withEnvConfig $ \conf → do
   metrWai ← registerWaiMetrics metrStore -- This one for the middleware
   modMetr ← newMetricsWith metrStore -- And this one for the Magicbane app (for timed/gauge/etc. calls in your actions)
 
-  let ctx = (modLogg, modMetr, conf)
+  modHc ← newHttpClient
+
+  let ctx = (modLogg, modMetr, modHc, conf)
 
   let waiMiddleware = metrics metrWai -- you can compose it with other middleware here
-  defWaiMain $ waiMiddleware $ magicbaneApp exampleAPI EmptyContext ctx $ hello :<|> splines
+  defWaiMain $ waiMiddleware $ magicbaneApp exampleAPI EmptyContext ctx $ hello :<|> splines :<|> req :<|> showErr

library/Magicbane/App.hs

@@ -9,33 +9,32 @@ module Magicbane.App (
 , module Magicbane.App
 ) where
 
-import           Control.Exception.Safe hiding (Handler)
-import           Control.Monad.Base
-import           Control.Monad.Error.Class as X (MonadError, throwError)
-import           Control.Monad.IO.Class
 import           Control.Monad.Reader
-import           Control.Monad.Trans.Control
-import           Control.Monad.Trans.Except as X
+import           Control.Monad.Base (MonadBase)
+import           Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
+import           Control.Monad.Trans.Control (MonadBaseControl)
+import           Control.Monad.Trans.Except (ExceptT (..))
+import           Control.Monad.IO.Class (MonadIO)
+import           Control.Monad.IO.Unlift
+import           UnliftIO.Exception as X hiding (Handler)
 import           Data.Proxy as X
 import           Data.Has as X
 import           Servant as X hiding (And)
+import qualified Servant
 
 newtype MagicbaneApp β α = MagicbaneApp {
-  unMagicbaneApp ∷ ReaderT β Handler α
-} deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO,
-            MonadThrow, MonadCatch, MonadError ServantErr, MonadReader β)
+  unMagicbaneApp ∷ ReaderT β IO α
+} deriving (Functor, Applicative, Monad,
+            MonadIO, MonadBase IO, MonadBaseControl IO, MonadUnliftIO,
+            MonadThrow, MonadCatch, MonadMask,
+            MonadReader β)
 
-instance MonadBaseControl IO (MagicbaneApp β) where
-  type StM (MagicbaneApp β) α = StM (ReaderT β Handler) α
-  liftBaseWith f = MagicbaneApp $ liftBaseWith $ \x → f $ x . unMagicbaneApp
-  restoreM       = MagicbaneApp . restoreM
-
-runMagicbaneHandler ∷ β → MagicbaneApp β α → Handler α
-runMagicbaneHandler ctx a = Handler $ ExceptT $ liftIO $ runHandler $ runReaderT (unMagicbaneApp a) ctx
+runMagicbaneHandler ∷ β → MagicbaneApp β α → Servant.Handler α
+runMagicbaneHandler ctx a = Servant.Handler $ ExceptT $ try $ runReaderT (unMagicbaneApp a) ctx
 
 #if MIN_VERSION_servant_server(0,12,0)
 #else
-magicbaneToHandler ∷ β → MagicbaneApp β :~> Handler
+magicbaneToHandler ∷ β → MagicbaneApp β :~> Servant.Handler
 #if MIN_VERSION_servant_server(0,10,0)
 magicbaneToHandler ctx = NT $ runMagicbaneHandler ctx
 #else

library/Magicbane/HTTPClient.hs

@@ -3,17 +3,19 @@
 
 -- | Provides an HTTP(S) client via http-client(-tls) in a Magicbane app context.
 --   Also provides a simple composable interface for making arbitrary requests, based on http-client-conduit.
---   That lets you plug stream parsers (e.g. html-conduit: 'performWithFn ($$ sinkDoc)') directly into the reading of the response body.
+--   That lets you plug stream parsers (e.g. html-conduit: 'performWithFn (.| sinkDoc)') directly into the reading of the response body.
 module Magicbane.HTTPClient (
   module Magicbane.HTTPClient
 , module X
 ) where
 
-import           Control.Exception.Safe
-import           Control.Monad.IO.Class
 import           Control.Monad.Reader
-import           Control.Monad.Trans.Control
+import           Control.Monad.Catch (MonadCatch)
+import           Control.Monad.Trans.Control (MonadBaseControl)
 import           Control.Monad.Trans.Except
+import           Control.Monad.IO.Class
+import           Control.Monad.IO.Unlift (MonadUnliftIO)
+import           UnliftIO.Exception (tryAny)
 import           Data.Has
 import           Data.Bifunctor
 import           Data.ByteString (ByteString)
@@ -39,7 +41,7 @@ instance (Has ModHttpClient α) ⇒ HasHttpManager α where
 newHttpClient ∷ IO ModHttpClient
 newHttpClient = ModHttpClient <$> newTlsManager
 
-type MonadHTTP ψ μ = (HasHttpManager ψ, MonadReader ψ μ, MonadIO μ, MonadBaseControl IO μ)
+type MonadHTTP ψ μ = (HasHttpManager ψ, MonadReader ψ μ, MonadIO μ, MonadBaseControl IO μ, MonadUnliftIO μ)
 
 runHTTP ∷ ExceptT ε μ α → μ (Either ε α)
 runHTTP = runExceptT
@@ -64,10 +66,10 @@ postForm form req =
              , requestBody = RequestBodyBS $ writeForm form }
 
 -- | Performs the request, using a given function to read the body. This is what all other performWith functions are based on.
-performWithFn ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ (ConduitM ι ByteString μ () → μ ρ) → Request → ExceptT Text μ (Response ρ)
+performWithFn ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ (ConduitM ι ByteString μ () → ConduitT () Void μ ρ) → Request → ExceptT Text μ (Response ρ)
 performWithFn fn req = do
   res ← lift $ tryAny $ HCC.withResponse req $ \res → do
-    body ← fn $ responseBody res
+    body ← runConduit $ fn $ responseBody res
     return res { responseBody = body }
   ExceptT $ return $ bimap (pack.show) id res
 
@@ -77,4 +79,4 @@ performWithVoid = performWithFn (const $ return ())
 
 -- | Performs the request, reading the body into a lazy ByteString.
 performWithBytes ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ Request → ExceptT Text μ (Response L.ByteString)
-performWithBytes = performWithFn ($$ C.sinkLazy)
+performWithBytes = performWithFn (.| C.sinkLazy)

package.yaml

@@ -17,14 +17,16 @@ dependencies:
   - base >=4.8.0.0 && <5
   - transformers
   - transformers-base
-  - safe-exceptions
+  - exceptions
   - errors
   - split
   - mtl
   - refined
   - async
   - lifted-async
   - lifted-base
+  - unliftio-core
+  - unliftio
   - monad-control
   - monad-metrics
   - monad-logger

stack.yaml

@@ -1,8 +1,4 @@
 packages:
   - '.'
-resolver: nightly-2017-11-24
-extra-deps:
-  - servant-0.12
-  - servant-server-0.12
-  - either-5
+resolver: nightly-2018-03-12
 pvp-bounds: none