Handler.hs

{- |
 Server implementation of WebGear handlers
-}
module WebGear.Server.Handler (
  ServerHandler (..),
  RoutePath (..),
  runServerHandler,
  toApplication,
  transform,
) where

import Control.Arrow (Arrow (..), ArrowChoice (..), ArrowPlus (..), ArrowZero (..))
import Control.Arrow.Operations (ArrowError (..))
import qualified Control.Category as Cat
import Data.ByteString (ByteString)
import Data.Either (fromRight)
import qualified Data.HashMap.Strict as HM
import Data.String (fromString)
import Data.Version (showVersion)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import Paths_webgear_server (version)
import WebGear.Core.Handler (Description, Handler (..), RouteMismatch (..), RoutePath (..), Summary)
import WebGear.Core.Request (Request (..))
import WebGear.Core.Response (Response (..), toWaiResponse)
import WebGear.Core.Trait (Linked, linkzero)

{- | An arrow implementing a WebGear server.

 It can be thought of equivalent to the function arrow @a -> m b@
 where @m@ is a monad. It also supports routing and possibly failing
 the computation when the route does not match.
-}
newtype ServerHandler m a b = ServerHandler {unServerHandler :: (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)}

instance Monad m => Cat.Category (ServerHandler m) where
  {-# INLINE id #-}
  id = ServerHandler $ \(a, s) -> pure (Right a, s)

  {-# INLINE (.) #-}
  ServerHandler f . ServerHandler g = ServerHandler $ \(a, s) ->
    g (a, s) >>= \case
      (Left e, s') -> pure (Left e, s')
      (Right b, s') -> f (b, s')

instance Monad m => Arrow (ServerHandler m) where
  arr f = ServerHandler (\(a, s) -> pure (Right (f a), s))

  {-# INLINE first #-}
  first (ServerHandler f) = ServerHandler $ \((a, c), s) ->
    f (a, s) >>= \case
      (Left e, s') -> pure (Left e, s')
      (Right b, s') -> pure (Right (b, c), s')

  {-# INLINE second #-}
  second (ServerHandler f) = ServerHandler $ \((c, a), s) ->
    f (a, s) >>= \case
      (Left e, s') -> pure (Left e, s')
      (Right b, s') -> pure (Right (c, b), s')

instance Monad m => ArrowZero (ServerHandler m) where
  {-# INLINE zeroArrow #-}
  zeroArrow = ServerHandler (\(_a, s) -> pure (Left mempty, s))

instance Monad m => ArrowPlus (ServerHandler m) where
  {-# INLINE (<+>) #-}
  ServerHandler f <+> ServerHandler g = ServerHandler $ \(a, s) ->
    f (a, s) >>= \case
      (Left _e, _s') -> g (a, s)
      (Right b, s') -> pure (Right b, s')

instance Monad m => ArrowChoice (ServerHandler m) where
  {-# INLINE left #-}
  left (ServerHandler f) = ServerHandler $ \(bd, s) ->
    case bd of
      Right d -> pure (Right (Right d), s)
      Left b ->
        f (b, s) >>= \case
          (Left e, s') -> pure (Left e, s')
          (Right c, s') -> pure (Right (Left c), s')

  {-# INLINE right #-}
  right (ServerHandler f) = ServerHandler $ \(db, s) ->
    case db of
      Left d -> pure (Right (Left d), s)
      Right b ->
        f (b, s) >>= \case
          (Left e, s') -> pure (Left e, s')
          (Right c, s') -> pure (Right (Right c), s')

instance Monad m => ArrowError RouteMismatch (ServerHandler m) where
  {-# INLINE raise #-}
  raise = ServerHandler $ \(e, s) -> pure (Left e, s)

  {-# INLINE handle #-}
  (ServerHandler action) `handle` (ServerHandler errHandler) = ServerHandler $ \(a, s) ->
    action (a, s) >>= \case
      (Left e, s') -> errHandler ((a, e), s')
      (Right b, s') -> pure (Right b, s')

  {-# INLINE tryInUnless #-}
  tryInUnless (ServerHandler action) (ServerHandler resHandler) (ServerHandler errHandler) =
    ServerHandler $ \(a, s) ->
      action (a, s) >>= \case
        (Left e, s') -> errHandler ((a, e), s')
        (Right b, s') -> resHandler ((a, b), s')

instance Monad m => Handler (ServerHandler m) m where
  {-# INLINE arrM #-}
  arrM :: (a -> m b) -> ServerHandler m a b
  arrM f = ServerHandler $ \(a, s) -> f a >>= \b -> pure (Right b, s)

  {-# INLINE consumeRoute #-}
  consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a
  consumeRoute (ServerHandler h) = ServerHandler $
    \((), path) -> h (path, RoutePath [])

  {-# INLINE setDescription #-}
  setDescription :: Description -> ServerHandler m a a
  setDescription _ = Cat.id

  {-# INLINE setSummary #-}
  setSummary :: Summary -> ServerHandler m a a
  setSummary _ = Cat.id

-- | Run a ServerHandler to produce a result or a route mismatch error.
runServerHandler ::
  Monad m =>
  -- | The handler to run
  ServerHandler m a b ->
  -- | Path used for routing
  RoutePath ->
  -- | Input value to the arrow
  a ->
  -- | The result of the arrow
  m (Either RouteMismatch b)
runServerHandler (ServerHandler h) path a = fst <$> h (a, path)
{-# INLINE runServerHandler #-}

-- | Convert a ServerHandler to a WAI application
toApplication :: ServerHandler IO (Linked '[] Request) Response -> Wai.Application
toApplication h rqt cont =
  runServerHandler h path request
    >>= cont . toWaiResponse . addServerHeader . mkWebGearResponse
  where
    request :: Linked '[] Request
    request = linkzero $ Request rqt

    path :: RoutePath
    path = RoutePath $ Wai.pathInfo rqt

    mkWebGearResponse :: Either RouteMismatch Response -> Response
    mkWebGearResponse = fromRight (Response HTTP.notFound404 [] mempty)

    addServerHeader :: Response -> Response
    addServerHeader resp@Response{..} = resp{responseHeaders = responseHeaders <> webGearServerHeader}

    webGearServerHeader :: HM.HashMap HTTP.HeaderName ByteString
    webGearServerHeader = HM.singleton HTTP.hServer (fromString $ "WebGear/" ++ showVersion version)
{-# INLINE toApplication #-}

{- | Transform a `ServerHandler` running in one monad to another monad.

 This is useful in cases where the server is running in a custom
 monad but you would like to convert it to a WAI application using
 `toApplication`.

 Example usage with a ReaderT monad stack:

@
 `toApplication` (transform f server)
   where
     server :: `ServerHandler` (ReaderT r IO) (`Linked` '[] `Request`) `Response`
     server = ....

     f :: ReaderT r IO a -> IO a
     f action = runReaderT action r
@
-}
transform ::
  (forall x. m x -> n x) ->
  ServerHandler m a b ->
  ServerHandler n a b
transform f (ServerHandler g) =
  ServerHandler $ f . g
{-# INLINE transform #-}