{- |
 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 {forall (m :: * -> *) a b.
ServerHandler m a b
-> (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
unServerHandler :: (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)}

instance Monad m => Cat.Category (ServerHandler m) where
  {-# INLINEABLE id #-}
  id :: forall a. ServerHandler m a a
id = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(a
a, RoutePath
s) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right a
a, RoutePath
s)

  {-# INLINEABLE (.) #-}
  ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f . :: forall b c a.
ServerHandler m b c -> ServerHandler m a b -> ServerHandler m a c
. ServerHandler (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
g = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(a
a, RoutePath
s) ->
    (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
g (a
a, RoutePath
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
e, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
      (Right b
b, RoutePath
s') -> (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
b, RoutePath
s')

instance Monad m => Arrow (ServerHandler m) where
  arr :: forall b c. (b -> c) -> ServerHandler m b c
arr b -> c
f = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (\(b
a, RoutePath
s) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (b -> c
f b
a), RoutePath
s))

  {-# INLINEABLE first #-}
  first :: forall b c d. ServerHandler m b c -> ServerHandler m (b, d) (c, d)
first (ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f) = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \((b
a, d
c), RoutePath
s) ->
    (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
a, RoutePath
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
e, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
      (Right c
b, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (c
b, d
c), RoutePath
s')

  {-# INLINEABLE second #-}
  second :: forall b c d. ServerHandler m b c -> ServerHandler m (d, b) (d, c)
second (ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f) = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \((d
c, b
a), RoutePath
s) ->
    (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
a, RoutePath
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
e, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
      (Right c
b, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (d
c, c
b), RoutePath
s')

instance Monad m => ArrowZero (ServerHandler m) where
  {-# INLINEABLE zeroArrow #-}
  zeroArrow :: forall b c. ServerHandler m b c
zeroArrow = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (\(b
_a, RoutePath
s) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left forall a. Monoid a => a
mempty, RoutePath
s))

instance Monad m => ArrowPlus (ServerHandler m) where
  {-# INLINEABLE (<+>) #-}
  ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f <+> :: forall b c.
ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c
<+> ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
g = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(b
a, RoutePath
s) ->
    (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
a, RoutePath
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
_e, RoutePath
_s') -> (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
g (b
a, RoutePath
s)
      (Right c
b, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right c
b, RoutePath
s')

instance Monad m => ArrowChoice (ServerHandler m) where
  {-# INLINEABLE left #-}
  left :: forall b c d.
ServerHandler m b c -> ServerHandler m (Either b d) (Either c d)
left (ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f) = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(Either b d
bd, RoutePath
s) ->
    case Either b d
bd of
      Right d
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (forall a b. b -> Either a b
Right d
d), RoutePath
s)
      Left b
b ->
        (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
b, RoutePath
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          (Left RouteMismatch
e, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
          (Right c
c, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (forall a b. a -> Either a b
Left c
c), RoutePath
s')

  {-# INLINEABLE right #-}
  right :: forall b c d.
ServerHandler m b c -> ServerHandler m (Either d b) (Either d c)
right (ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f) = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(Either d b
db, RoutePath
s) ->
    case Either d b
db of
      Left d
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (forall a b. a -> Either a b
Left d
d), RoutePath
s)
      Right b
b ->
        (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
b, RoutePath
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          (Left RouteMismatch
e, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
          (Right c
c, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (forall a b. b -> Either a b
Right c
c), RoutePath
s')

instance Monad m => ArrowError RouteMismatch (ServerHandler m) where
  {-# INLINEABLE raise #-}
  raise :: forall b. ServerHandler m RouteMismatch b
raise = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(RouteMismatch
e, RoutePath
s) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s)

  {-# INLINEABLE handle #-}
  (ServerHandler (e, RoutePath) -> m (Either RouteMismatch b, RoutePath)
action) handle :: forall e b.
ServerHandler m e b
-> ServerHandler m (e, RouteMismatch) b -> ServerHandler m e b
`handle` (ServerHandler ((e, RouteMismatch), RoutePath)
-> m (Either RouteMismatch b, RoutePath)
errHandler) = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(e
a, RoutePath
s) ->
    (e, RoutePath) -> m (Either RouteMismatch b, RoutePath)
action (e
a, RoutePath
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
e, RoutePath
s') -> ((e, RouteMismatch), RoutePath)
-> m (Either RouteMismatch b, RoutePath)
errHandler ((e
a, RouteMismatch
e), RoutePath
s')
      (Right b
b, RoutePath
s') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right b
b, RoutePath
s')

  {-# INLINEABLE tryInUnless #-}
  tryInUnless :: forall e b c.
ServerHandler m e b
-> ServerHandler m (e, b) c
-> ServerHandler m (e, RouteMismatch) c
-> ServerHandler m e c
tryInUnless (ServerHandler (e, RoutePath) -> m (Either RouteMismatch b, RoutePath)
action) (ServerHandler ((e, b), RoutePath) -> m (Either RouteMismatch c, RoutePath)
resHandler) (ServerHandler ((e, RouteMismatch), RoutePath)
-> m (Either RouteMismatch c, RoutePath)
errHandler) =
    forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(e
a, RoutePath
s) ->
      (e, RoutePath) -> m (Either RouteMismatch b, RoutePath)
action (e
a, RoutePath
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Left RouteMismatch
e, RoutePath
s') -> ((e, RouteMismatch), RoutePath)
-> m (Either RouteMismatch c, RoutePath)
errHandler ((e
a, RouteMismatch
e), RoutePath
s')
        (Right b
b, RoutePath
s') -> ((e, b), RoutePath) -> m (Either RouteMismatch c, RoutePath)
resHandler ((e
a, b
b), RoutePath
s')

instance Monad m => Handler (ServerHandler m) m where
  {-# INLINEABLE arrM #-}
  arrM :: (a -> m b) -> ServerHandler m a b
  arrM :: forall a b. (a -> m b) -> ServerHandler m a b
arrM a -> m b
f = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(a
a, RoutePath
s) -> a -> m b
f a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right b
b, RoutePath
s)

  {-# INLINEABLE consumeRoute #-}
  consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a
  consumeRoute :: forall a. ServerHandler m RoutePath a -> ServerHandler m () a
consumeRoute (ServerHandler (RoutePath, RoutePath) -> m (Either RouteMismatch a, RoutePath)
h) = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$
    \((), RoutePath
path) -> (RoutePath, RoutePath) -> m (Either RouteMismatch a, RoutePath)
h (RoutePath
path, [Text] -> RoutePath
RoutePath [])

  {-# INLINEABLE setDescription #-}
  setDescription :: Description -> ServerHandler m a a
  setDescription :: forall a. Description -> ServerHandler m a a
setDescription Description
_ = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Cat.id

  {-# INLINEABLE setSummary #-}
  setSummary :: Summary -> ServerHandler m a a
  setSummary :: forall a. Summary -> ServerHandler m a a
setSummary Summary
_ = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
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 :: forall (m :: * -> *) a b.
Monad m =>
ServerHandler m a b -> RoutePath -> a -> m (Either RouteMismatch b)
runServerHandler (ServerHandler (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
h) RoutePath
path a
a = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
h (a
a, RoutePath
path)

-- | Convert a ServerHandler to a WAI application
toApplication :: ServerHandler IO (Linked '[] Request) Response -> Wai.Application
toApplication :: ServerHandler IO (Linked '[] Request) Response -> Application
toApplication ServerHandler IO (Linked '[] Request) Response
h Request
rqt Response -> IO ResponseReceived
cont =
  forall (m :: * -> *) a b.
Monad m =>
ServerHandler m a b -> RoutePath -> a -> m (Either RouteMismatch b)
runServerHandler ServerHandler IO (Linked '[] Request) Response
h RoutePath
path Linked '[] Request
request
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
cont forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Response
toWaiResponse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Response
addServerHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either RouteMismatch Response -> Response
mkWebGearResponse
  where
    request :: Linked '[] Request
    request :: Linked '[] Request
request = forall a. a -> Linked '[] a
linkzero forall a b. (a -> b) -> a -> b
$ Request -> Request
Request Request
rqt

    path :: RoutePath
    path :: RoutePath
path = [Text] -> RoutePath
RoutePath forall a b. (a -> b) -> a -> b
$ Request -> [Text]
Wai.pathInfo Request
rqt

    mkWebGearResponse :: Either RouteMismatch Response -> Response
    mkWebGearResponse :: Either RouteMismatch Response -> Response
mkWebGearResponse = forall b a. b -> Either a b -> b
fromRight (Status
-> HashMap HeaderName ByteString -> Maybe ByteString -> Response
Response Status
HTTP.notFound404 [] forall a. Monoid a => a
mempty)

    addServerHeader :: Response -> Response
    addServerHeader :: Response -> Response
addServerHeader resp :: Response
resp@Response{Maybe ByteString
HashMap HeaderName ByteString
Status
responseStatus :: Response -> Status
responseHeaders :: Response -> HashMap HeaderName ByteString
responseBody :: Response -> Maybe ByteString
responseBody :: Maybe ByteString
responseHeaders :: HashMap HeaderName ByteString
responseStatus :: Status
..} = Response
resp{responseHeaders :: HashMap HeaderName ByteString
responseHeaders = HashMap HeaderName ByteString
responseHeaders forall a. Semigroup a => a -> a -> a
<> HashMap HeaderName ByteString
webGearServerHeader}

{- | 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 :: forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> ServerHandler m a b -> ServerHandler n a b
transform forall x. m x -> n x
f (ServerHandler (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
g) =
  forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ forall x. m x -> n x
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
g

webGearServerHeader :: HM.HashMap HTTP.HeaderName ByteString
webGearServerHeader :: HashMap HeaderName ByteString
webGearServerHeader = forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton HeaderName
HTTP.hServer (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [Char]
"WebGear/" forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version)