module Tendermint.SDK.BaseApp.Router.Router
  ( Router
  , Router'(..)
  , runRouter
  , pathRouter
  , leafRouter
  , choice
  ) where

import           Control.Lens                        ((&), (.~), (^.))
import           Data.Map                            (Map)
import qualified Data.Map                            as M
import           Data.Text                           (Text)
import qualified Data.Text                           as T
import qualified Data.Text.Encoding                  as T
import           Network.HTTP.Types                  (decodePathSegments)
import           Polysemy                            (Sem)
import           Tendermint.SDK.BaseApp.Router.Types (Application, HasPath (..),
                                                      RouteResult (..),
                                                      RouterError (..))


-- NOTE: most of this was vendored and repurposed from servant

data Router' env a =
    StaticRouter (Map Text (Router' env a)) [env -> a]
  | CaptureRouter (Router' (Text, env) a)
  | Choice (Router' env a) (Router' env a)


type Router env r req res = Router' env (Application (Sem r) req res)

pathRouter
  :: Text
  -> Router' env a
  -> Router' env a
pathRouter :: Text -> Router' env a -> Router' env a
pathRouter t :: Text
t r :: Router' env a
r = Map Text (Router' env a) -> [env -> a] -> Router' env a
forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter (Text -> Router' env a -> Map Text (Router' env a)
forall k a. k -> a -> Map k a
M.singleton Text
t Router' env a
r) []

leafRouter
  :: (env -> a)
  -> Router' env a
leafRouter :: (env -> a) -> Router' env a
leafRouter l :: env -> a
l = Map Text (Router' env a) -> [env -> a] -> Router' env a
forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter Map Text (Router' env a)
forall k a. Map k a
M.empty [env -> a
l]

choice
  :: Router' env a
  -> Router' env a
  -> Router' env a
choice :: Router' env a -> Router' env a -> Router' env a
choice (StaticRouter table1 :: Map Text (Router' env a)
table1 ls1 :: [env -> a]
ls1) (StaticRouter table2 :: Map Text (Router' env a)
table2 ls2 :: [env -> a]
ls2) =
  Map Text (Router' env a) -> [env -> a] -> Router' env a
forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter ((Router' env a -> Router' env a -> Router' env a)
-> Map Text (Router' env a)
-> Map Text (Router' env a)
-> Map Text (Router' env a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Router' env a -> Router' env a -> Router' env a
forall env a. Router' env a -> Router' env a -> Router' env a
choice Map Text (Router' env a)
table1 Map Text (Router' env a)
table2) ([env -> a]
ls1 [env -> a] -> [env -> a] -> [env -> a]
forall a. [a] -> [a] -> [a]
++ [env -> a]
ls2)
choice (CaptureRouter router1 :: Router' (Text, env) a
router1) (CaptureRouter router2 :: Router' (Text, env) a
router2) =
  Router' (Text, env) a -> Router' env a
forall env a. Router' (Text, env) a -> Router' env a
CaptureRouter (Router' (Text, env) a
-> Router' (Text, env) a -> Router' (Text, env) a
forall env a. Router' env a -> Router' env a -> Router' env a
choice Router' (Text, env) a
router1 Router' (Text, env) a
router2)
choice router1 :: Router' env a
router1 (Choice router2 :: Router' env a
router2 router3 :: Router' env a
router3) = Router' env a -> Router' env a -> Router' env a
forall env a. Router' env a -> Router' env a -> Router' env a
Choice (Router' env a -> Router' env a -> Router' env a
forall env a. Router' env a -> Router' env a -> Router' env a
choice Router' env a
router1 Router' env a
router2) Router' env a
router3
choice router1 :: Router' env a
router1 router2 :: Router' env a
router2 = Router' env a -> Router' env a -> Router' env a
forall env a. Router' env a -> Router' env a -> Router' env a
Choice Router' env a
router1 Router' env a
router2

runRouter
  :: HasPath req
  => Router env r req res
  -> env
  -> Application (Sem r) req res
runRouter :: Router env r req res -> env -> Application (Sem r) req res
runRouter router :: Router env r req res
router env :: env
env req :: req
req =
  case Router env r req res
router of
    StaticRouter table :: Map Text (Router env r req res)
table ls :: [env -> Application (Sem r) req res]
ls ->
      case ByteString -> [Text]
decodePathSegments (ByteString -> [Text]) -> (Text -> ByteString) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ req
req req -> Getting Text req Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text req Text
forall t. HasPath t => Lens' t Text
path  of
        []   -> [env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
forall env (r :: EffectRow) req res.
[env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
runChoice [env -> Application (Sem r) req res]
ls env
env req
req
        -- This case is to handle trailing slashes.
        [""] -> [env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
forall env (r :: EffectRow) req res.
[env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
runChoice [env -> Application (Sem r) req res]
ls env
env req
req
        first :: Text
first : rest :: [Text]
rest | Just router' :: Router env r req res
router' <- Text
-> Map Text (Router env r req res) -> Maybe (Router env r req res)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
first Map Text (Router env r req res)
table
          -> let req' :: req
req' = req
req req -> (req -> req) -> req
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> req -> Identity req
forall t. HasPath t => Lens' t Text
path ((Text -> Identity Text) -> req -> Identity req)
-> Text -> req -> req
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> [Text] -> Text
T.intercalate "/" [Text]
rest
             in  Router env r req res -> env -> Application (Sem r) req res
forall req env (r :: EffectRow) res.
HasPath req =>
Router env r req res -> env -> Application (Sem r) req res
runRouter Router env r req res
router' env
env req
req'
        _ -> RouteResult res -> Sem r (RouteResult res)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteResult res -> Sem r (RouteResult res))
-> RouteResult res -> Sem r (RouteResult res)
forall a b. (a -> b) -> a -> b
$ RouterError -> RouteResult res
forall a. RouterError -> RouteResult a
Fail RouterError
PathNotFound
    CaptureRouter router' :: Router' (Text, env) (Application (Sem r) req res)
router' ->
      case ByteString -> [Text]
decodePathSegments (ByteString -> [Text]) -> (Text -> ByteString) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ req
req req -> Getting Text req Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text req Text
forall t. HasPath t => Lens' t Text
path of
        []   -> RouteResult res -> Sem r (RouteResult res)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteResult res -> Sem r (RouteResult res))
-> RouteResult res -> Sem r (RouteResult res)
forall a b. (a -> b) -> a -> b
$ RouterError -> RouteResult res
forall a. RouterError -> RouteResult a
Fail RouterError
PathNotFound
        -- This case is to handle trailing slashes.
        [""] -> RouteResult res -> Sem r (RouteResult res)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteResult res -> Sem r (RouteResult res))
-> RouteResult res -> Sem r (RouteResult res)
forall a b. (a -> b) -> a -> b
$ RouterError -> RouteResult res
forall a. RouterError -> RouteResult a
Fail RouterError
PathNotFound
        first :: Text
first : rest :: [Text]
rest
          -> let req' :: req
req' = req
req req -> (req -> req) -> req
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> req -> Identity req
forall t. HasPath t => Lens' t Text
path ((Text -> Identity Text) -> req -> Identity req)
-> Text -> req -> req
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> [Text] -> Text
T.intercalate "/" [Text]
rest
             in  Router' (Text, env) (Application (Sem r) req res)
-> (Text, env) -> Application (Sem r) req res
forall req env (r :: EffectRow) res.
HasPath req =>
Router env r req res -> env -> Application (Sem r) req res
runRouter Router' (Text, env) (Application (Sem r) req res)
router' (Text
first, env
env) req
req'
    Choice r1 :: Router env r req res
r1 r2 :: Router env r req res
r2 ->
      [env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
forall env (r :: EffectRow) req res.
[env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
runChoice [Router env r req res -> env -> Application (Sem r) req res
forall req env (r :: EffectRow) res.
HasPath req =>
Router env r req res -> env -> Application (Sem r) req res
runRouter Router env r req res
r1, Router env r req res -> env -> Application (Sem r) req res
forall req env (r :: EffectRow) res.
HasPath req =>
Router env r req res -> env -> Application (Sem r) req res
runRouter Router env r req res
r2] env
env req
req

runChoice
  :: [env -> Application (Sem r) req res]
  -> env
  -> Application (Sem r) req res
runChoice :: [env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
runChoice ls :: [env -> Application (Sem r) req res]
ls =
  case [env -> Application (Sem r) req res]
ls of
    []       -> \ _ _ -> RouteResult res -> Sem r (RouteResult res)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteResult res -> Sem r (RouteResult res))
-> RouteResult res -> Sem r (RouteResult res)
forall a b. (a -> b) -> a -> b
$ RouterError -> RouteResult res
forall a. RouterError -> RouteResult a
Fail RouterError
PathNotFound
    [r :: env -> Application (Sem r) req res
r]      -> env -> Application (Sem r) req res
r
    (r :: env -> Application (Sem r) req res
r : rs :: [env -> Application (Sem r) req res]
rs) ->
      \ env :: env
env query :: req
query -> do
        RouteResult res
response1 <- env -> Application (Sem r) req res
r env
env req
query
        case RouteResult res
response1 of
          Fail _ -> [env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
forall env (r :: EffectRow) req res.
[env -> Application (Sem r) req res]
-> env -> Application (Sem r) req res
runChoice [env -> Application (Sem r) req res]
rs env
env req
query
          _      ->  RouteResult res -> Sem r (RouteResult res)
forall (f :: * -> *) a. Applicative f => a -> f a
pure RouteResult res
response1