{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Linnet.Endpoint
( EndpointResult(..)
, Endpoint(..)
, NotMatchedReason(..)
, Trace
, isMatched
, maybeReminder
, maybeTrace
, lift
, liftOutputM
, mapM'
, mapOutput
, mapOutputM
, handle
, handleAll
, try
, transformOutput
, transform
, (~>)
, (~>>)
, productWith
, (//)
, (|+|)
, root
, zero
) where
import Control.Applicative (Alternative (..))
import Control.Exception (Exception, SomeException)
import qualified Control.Monad.Catch as MC
import Data.Text (Text, append, unpack)
import GHC.Base (liftA2)
import Linnet.Errors (LinnetError (..))
import Linnet.Input
import Linnet.Internal.Coproduct
import Linnet.Internal.HList
import Linnet.Output
import Network.HTTP.Types (Method)
import Network.Wai (Request)
infixl 0 ~>
infixl 0 ~>>
infixr 2 //
infixl 2 |+|
data EndpointResult (m :: * -> *) a
= Matched
{ matchedReminder :: Input
, matchedTrace :: [Text]
, matchedOutput :: m (Output a)
}
| NotMatched
{ reason :: NotMatchedReason
}
type Trace = [Text]
data NotMatchedReason
= MethodNotAllowed
{ allowedMethod :: Method
}
| Other
deriving (Show, Eq)
isMatched :: EndpointResult m a -> Bool
isMatched Matched {} = True
isMatched _ = False
maybeReminder :: EndpointResult m a -> Maybe Input
maybeReminder Matched {..} = Just matchedReminder
maybeReminder _ = Nothing
maybeTrace :: EndpointResult m a -> Maybe Trace
maybeTrace Matched {..} = Just matchedTrace
maybeTrace _ = Nothing
instance (Show (m (Output a))) => Show (EndpointResult m a) where
show (Matched _ _ out) = "EndpointResult.Matched(" ++ show out ++ ")"
show (NotMatched r) = "EndpointResult.NotMatched(" ++ show r ++ ")"
instance (Functor m) => Functor (EndpointResult m) where
fmap f matched@Matched {..} = matched {matchedOutput = (fmap . fmap) f matchedOutput}
fmap _ (NotMatched r) = NotMatched r
data Endpoint (m :: * -> *) a =
Endpoint
{ runEndpoint :: Input -> EndpointResult m a
, toString :: Text
}
instance Show (Endpoint m a) where
show Endpoint {..} = "Endpoint(" ++ unpack toString ++ ")"
instance (Functor m) => Functor (Endpoint m) where
fmap f e = Endpoint {runEndpoint = fmap f . runEndpoint e, toString = toString e}
instance (MC.MonadCatch m) => Applicative (Endpoint m) where
pure a = Endpoint {runEndpoint = \i -> Matched i [] $ pure (ok a), toString = "const"}
liftA2 fn fa fb = productWith fa fb fn
instance (MC.MonadCatch m) => Alternative (Endpoint m) where
empty = Endpoint {runEndpoint = const $ NotMatched Other, toString = "empty"}
(<|>) ea eb =
Endpoint
{ runEndpoint =
\input ->
case runEndpoint ea input of
a@(Matched remA _ _) ->
case runEndpoint eb input of
b@(Matched remB _ _) ->
if length (reminder remA) <= length (reminder remB)
then a
else b
NotMatched _ -> a
NotMatched _ -> runEndpoint eb input
, toString = toString ea `append` "<|>" `append` toString eb
}
mapM' :: (Monad m) => (a -> m b) -> Endpoint m a -> Endpoint m b
mapM' fn = transformOutput (>>= traverse fn)
mapOutput :: (Monad m) => (a -> Output b) -> Endpoint m a -> Endpoint m b
mapOutput fn = mapOutputM $ pure . fn
mapOutputM :: (Monad m) => (a -> m (Output b)) -> Endpoint m a -> Endpoint m b
mapOutputM fn ea =
ea
{ runEndpoint =
\input ->
case runEndpoint ea input of
matched@Matched {..} -> matched {matchedOutput = matchedOutput >>= transformM fn}
NotMatched r -> NotMatched r
}
transformOutput :: (m (Output a) -> m (Output b)) -> Endpoint m a -> Endpoint m b
transformOutput fn ea =
ea
{ runEndpoint =
\input ->
case runEndpoint ea input of
matched@Matched {..} -> matched {matchedOutput = fn matchedOutput}
NotMatched r -> NotMatched r
}
transform :: (Monad m) => (m a -> m b) -> Endpoint m a -> Endpoint m b
transform fn ea =
ea
{ runEndpoint =
\input ->
case runEndpoint ea input of
matched@Matched {..} -> matched {matchedOutput = matchedOutput >>= traverse (fn . pure)}
NotMatched r -> NotMatched r
}
handle :: (MC.MonadCatch m, Exception e) => (e -> m (Output a)) -> Endpoint m a -> Endpoint m a
handle = transformOutput . MC.handle
handleAll :: (MC.MonadCatch m) => (SomeException -> m (Output a)) -> Endpoint m a -> Endpoint m a
handleAll = transformOutput . MC.handleAll
try :: (Exception e, MC.MonadCatch m) => Endpoint m a -> Endpoint m (Either e a)
try ea =
ea
{ runEndpoint =
\input ->
let traverseEither :: Either e (Output a) -> Output (Either e a)
traverseEither (Left e) = ok $ Left e
traverseEither (Right out) = Right <$> out
in case runEndpoint ea input of
matched@Matched {..} -> matched {matchedOutput = traverseEither <$> MC.try matchedOutput}
NotMatched r -> NotMatched r
}
(~>) :: (Monad m) => Endpoint m a -> (a -> m (Output b)) -> Endpoint m b
(~>) ea fn = mapOutputM fn ea
(~>>) :: (Monad m, FnToProduct fn ls (m (Output b))) => Endpoint m (HList ls) -> fn -> Endpoint m b
(~>>) ea fn = mapOutputM (fromFunction fn) ea
lift :: (Functor m) => m a -> Endpoint m a
lift m = Endpoint {runEndpoint = \i -> Matched i [] $ fmap ok m, toString = "lift"}
liftOutputM :: m (Output a) -> Endpoint m a
liftOutputM m = Endpoint {runEndpoint = \i -> Matched i [] m, toString = "liftOutputM"}
productWith ::
forall m a b c. MC.MonadCatch m
=> Endpoint m a
-> Endpoint m b
-> (a -> b -> c)
-> Endpoint m c
productWith ea eb f =
ea
{ runEndpoint =
\req ->
case runEndpoint ea req of
Matched aRem trcA aOutM ->
case runEndpoint eb aRem of
Matched bRem trcB bOutM ->
let out = do
oa <- MC.try aOutM
ob <- MC.try bOutM
product_ oa ob
in Matched bRem (trcA ++ trcB) out
NotMatched r -> NotMatched r
NotMatched r -> NotMatched r
}
where
product_ :: Either LinnetError (Output a) -> Either LinnetError (Output b) -> m (Output c)
product_ eitherA eitherB =
case (eitherA, eitherB) of
(Right oa, Right ob) -> pure $ oa >>= \a -> fmap (f a) ob
(Left a, Left b) -> MC.throwM $ a <> b
(Left a, _) -> MC.throwM a
(_, Left b) -> MC.throwM b
(//) :: (MC.MonadCatch m, AdjoinHList (a ': b ': '[]) out) => Endpoint m a -> Endpoint m b -> Endpoint m (HList out)
(//) ea eb =
Endpoint
{ runEndpoint = runEndpoint $ productWith ea eb (\a b -> adjoin (a ::: b ::: HNil))
, toString = toString ea `append` " // " `append` toString eb
}
(|+|) ::
forall m a b out. (MC.MonadCatch m, AdjoinCoproduct (Coproduct a (Coproduct b CNil)) out)
=> Endpoint m a
-> Endpoint m b
-> Endpoint m out
(|+|) ea eb = fmap left ea <|> fmap right eb
where
left :: a -> out
left a = adjoinCoproduct @(Coproduct a (Coproduct b CNil)) $ Inl a
right :: b -> out
right b = adjoinCoproduct @(Coproduct a (Coproduct b CNil)) $ Inr (Inl b)
root :: (Applicative m) => Endpoint m Request
root =
Endpoint
{ runEndpoint =
\input -> Matched {matchedReminder = input, matchedTrace = [], matchedOutput = pure . ok $ request input}
, toString = "root"
}
zero :: (Applicative m) => Endpoint m (HList '[])
zero =
Endpoint
{ runEndpoint = \input -> Matched {matchedReminder = input, matchedTrace = [], matchedOutput = pure . ok $ HNil}
, toString = "zero"
}