{- |
 WebGear handlers
-}
module WebGear.Core.Handler (
  Handler (..),
  RoutePath (..),
  RouteMismatch (..),
  Description (..),
  Summary (..),
  RequestHandler,
  Middleware,
  routeMismatch,
  unwitnessA,
  (>->),
  (<-<),
) where

import Control.Arrow (Arrow, ArrowChoice, ArrowPlus, arr)
import Control.Arrow.Operations (ArrowError (..))
import Data.String (IsString)
import Data.Text (Text)
import GHC.Exts (IsList (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response (..))
import WebGear.Core.Trait (With (unwitness))

-- | Parts of the request path used by the routing machinery
newtype RoutePath = RoutePath [Text]
  deriving newtype (Int -> RoutePath -> ShowS
[RoutePath] -> ShowS
RoutePath -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RoutePath] -> ShowS
$cshowList :: [RoutePath] -> ShowS
show :: RoutePath -> String
$cshow :: RoutePath -> String
showsPrec :: Int -> RoutePath -> ShowS
$cshowsPrec :: Int -> RoutePath -> ShowS
Show, RoutePath -> RoutePath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RoutePath -> RoutePath -> Bool
$c/= :: RoutePath -> RoutePath -> Bool
== :: RoutePath -> RoutePath -> Bool
$c== :: RoutePath -> RoutePath -> Bool
Eq)

instance IsList RoutePath where
  type Item RoutePath = Text
  fromList :: [Item RoutePath] -> RoutePath
fromList = [Text] -> RoutePath
RoutePath
  toList :: RoutePath -> [Item RoutePath]
toList (RoutePath [Text]
ps) = [Text]
ps

{- | A handler is an arrow with a monadic context.

 Handlers have the following capabilities:

 * Lift a monadic action into a handler arrow.
 * Implement `ArrowChoice` typeclass so that conditionals can be used in arrow code.
 * Implement `ArrowPlus` for routing requests to specific handlers.
 * Provide contextual documentation elements - description and summary
-}
class (ArrowChoice h, ArrowPlus h, ArrowError RouteMismatch h, Monad m) => Handler h m | h -> m where
  -- | Lift a monadic function to a handler arrow
  arrM :: (a -> m b) -> h a b

  -- | Consume all remaining path components with an arrow
  consumeRoute :: h RoutePath a -> h () a

  -- | Set a description of a part of an API
  setDescription :: Description -> h a a

  -- | Set a summary of a part of an API
  setSummary :: Summary -> h a a

-- | A handler arrow from a witnessed request to response.
type RequestHandler h ts = h (Request `With` ts) Response

-- | A middleware enhances a `RequestHandler` and produces another handler.
type Middleware h tsOut tsIn = RequestHandler h tsIn -> RequestHandler h tsOut

-- | Description associated with part of an API
newtype Description = Description {Description -> Text
getDescription :: Text}
  deriving stock (Description -> Description -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Description -> Description -> Bool
$c/= :: Description -> Description -> Bool
== :: Description -> Description -> Bool
$c== :: Description -> Description -> Bool
Eq, Eq Description
Description -> Description -> Bool
Description -> Description -> Ordering
Description -> Description -> Description
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Description -> Description -> Description
$cmin :: Description -> Description -> Description
max :: Description -> Description -> Description
$cmax :: Description -> Description -> Description
>= :: Description -> Description -> Bool
$c>= :: Description -> Description -> Bool
> :: Description -> Description -> Bool
$c> :: Description -> Description -> Bool
<= :: Description -> Description -> Bool
$c<= :: Description -> Description -> Bool
< :: Description -> Description -> Bool
$c< :: Description -> Description -> Bool
compare :: Description -> Description -> Ordering
$ccompare :: Description -> Description -> Ordering
Ord, Int -> Description -> ShowS
[Description] -> ShowS
Description -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Description] -> ShowS
$cshowList :: [Description] -> ShowS
show :: Description -> String
$cshow :: Description -> String
showsPrec :: Int -> Description -> ShowS
$cshowsPrec :: Int -> Description -> ShowS
Show, ReadPrec [Description]
ReadPrec Description
Int -> ReadS Description
ReadS [Description]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Description]
$creadListPrec :: ReadPrec [Description]
readPrec :: ReadPrec Description
$creadPrec :: ReadPrec Description
readList :: ReadS [Description]
$creadList :: ReadS [Description]
readsPrec :: Int -> ReadS Description
$creadsPrec :: Int -> ReadS Description
Read)
  deriving newtype (String -> Description
forall a. (String -> a) -> IsString a
fromString :: String -> Description
$cfromString :: String -> Description
IsString)

-- | A summary associated with part of an API
newtype Summary = Summary {Summary -> Text
getSummary :: Text}
  deriving stock (Summary -> Summary -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Summary -> Summary -> Bool
$c/= :: Summary -> Summary -> Bool
== :: Summary -> Summary -> Bool
$c== :: Summary -> Summary -> Bool
Eq, Eq Summary
Summary -> Summary -> Bool
Summary -> Summary -> Ordering
Summary -> Summary -> Summary
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Summary -> Summary -> Summary
$cmin :: Summary -> Summary -> Summary
max :: Summary -> Summary -> Summary
$cmax :: Summary -> Summary -> Summary
>= :: Summary -> Summary -> Bool
$c>= :: Summary -> Summary -> Bool
> :: Summary -> Summary -> Bool
$c> :: Summary -> Summary -> Bool
<= :: Summary -> Summary -> Bool
$c<= :: Summary -> Summary -> Bool
< :: Summary -> Summary -> Bool
$c< :: Summary -> Summary -> Bool
compare :: Summary -> Summary -> Ordering
$ccompare :: Summary -> Summary -> Ordering
Ord, Int -> Summary -> ShowS
[Summary] -> ShowS
Summary -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Summary] -> ShowS
$cshowList :: [Summary] -> ShowS
show :: Summary -> String
$cshow :: Summary -> String
showsPrec :: Int -> Summary -> ShowS
$cshowsPrec :: Int -> Summary -> ShowS
Show, ReadPrec [Summary]
ReadPrec Summary
Int -> ReadS Summary
ReadS [Summary]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Summary]
$creadListPrec :: ReadPrec [Summary]
readPrec :: ReadPrec Summary
$creadPrec :: ReadPrec Summary
readList :: ReadS [Summary]
$creadList :: ReadS [Summary]
readsPrec :: Int -> ReadS Summary
$creadsPrec :: Int -> ReadS Summary
Read)
  deriving newtype (String -> Summary
forall a. (String -> a) -> IsString a
fromString :: String -> Summary
$cfromString :: String -> Summary
IsString)

-- | Indicates that a handler cannot process this route
data RouteMismatch = RouteMismatch
  deriving stock (Int -> RouteMismatch -> ShowS
[RouteMismatch] -> ShowS
RouteMismatch -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RouteMismatch] -> ShowS
$cshowList :: [RouteMismatch] -> ShowS
show :: RouteMismatch -> String
$cshow :: RouteMismatch -> String
showsPrec :: Int -> RouteMismatch -> ShowS
$cshowsPrec :: Int -> RouteMismatch -> ShowS
Show, RouteMismatch -> RouteMismatch -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouteMismatch -> RouteMismatch -> Bool
$c/= :: RouteMismatch -> RouteMismatch -> Bool
== :: RouteMismatch -> RouteMismatch -> Bool
$c== :: RouteMismatch -> RouteMismatch -> Bool
Eq, Eq RouteMismatch
RouteMismatch -> RouteMismatch -> Bool
RouteMismatch -> RouteMismatch -> Ordering
RouteMismatch -> RouteMismatch -> RouteMismatch
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RouteMismatch -> RouteMismatch -> RouteMismatch
$cmin :: RouteMismatch -> RouteMismatch -> RouteMismatch
max :: RouteMismatch -> RouteMismatch -> RouteMismatch
$cmax :: RouteMismatch -> RouteMismatch -> RouteMismatch
>= :: RouteMismatch -> RouteMismatch -> Bool
$c>= :: RouteMismatch -> RouteMismatch -> Bool
> :: RouteMismatch -> RouteMismatch -> Bool
$c> :: RouteMismatch -> RouteMismatch -> Bool
<= :: RouteMismatch -> RouteMismatch -> Bool
$c<= :: RouteMismatch -> RouteMismatch -> Bool
< :: RouteMismatch -> RouteMismatch -> Bool
$c< :: RouteMismatch -> RouteMismatch -> Bool
compare :: RouteMismatch -> RouteMismatch -> Ordering
$ccompare :: RouteMismatch -> RouteMismatch -> Ordering
Ord)

instance Semigroup RouteMismatch where
  RouteMismatch
RouteMismatch <> :: RouteMismatch -> RouteMismatch -> RouteMismatch
<> RouteMismatch
RouteMismatch = RouteMismatch
RouteMismatch

instance Monoid RouteMismatch where
  mempty :: RouteMismatch
mempty = RouteMismatch
RouteMismatch

-- | Indicates that the request does not match the current handler.
routeMismatch :: (ArrowError RouteMismatch h) => h a b
routeMismatch :: forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch = proc a
_a -> forall ex (a :: * -> * -> *) b. ArrowError ex a => a ex b
raise -< RouteMismatch
RouteMismatch
{-# INLINE routeMismatch #-}

-- | Lifts `unwitness` into a handler arrow.
unwitnessA :: (Handler h m) => h (Response `With` ts) Response
unwitnessA :: forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a (ts :: [*]). With a ts -> a
unwitness
{-# INLINE unwitnessA #-}

infixr 1 >->, <-<

{- | Thread a response through commands from left to right.

 For example, an HTTP 200 response with a body and Content-Type header
 can be generated with:

@
 (ok200 -< ())
   >-> (\resp -> setBody "text/plain" -< (resp, "Hello World"))
   >-> (\resp -> unwitnessA -< resp)
@
-}
(>->) :: (Arrow h) => h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
h (env, stack) a
f >-> :: forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> h (env, (a, stack)) b
g = proc (env
env, stack
stack) -> do
  a
a <- h (env, stack) a
f -< (env
env, stack
stack)
  h (env, (a, stack)) b
g -< (env
env, (a
a, stack
stack))
{-# INLINE (>->) #-}

{- | Thread a response through commands from right to left.

 For example, an HTTP 200 response with a body and Content-Type header
 can be generated with:

@
 (\resp -> unwitnessA -< resp)
   <-< (\resp -> setBody "text/plain" -< (resp, "Hello World"))
   <-< (ok200 -< ())
@
-}
(<-<) :: (Arrow h) => h (env, (a, stack)) b -> h (env, stack) a -> h (env, stack) b
h (env, (a, stack)) b
f <-< :: forall (h :: * -> * -> *) env a stack b.
Arrow h =>
h (env, (a, stack)) b -> h (env, stack) a -> h (env, stack) b
<-< h (env, stack) a
g = proc (env
env, stack
stack) -> do
  a
a <- h (env, stack) a
g -< (env
env, stack
stack)
  h (env, (a, stack)) b
f -< (env
env, (a
a, stack
stack))
{-# INLINE (<-<) #-}