mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-22 00:51:34 +03:00
Clean up
This commit is contained in:
Rashad Gover
parent
e40d64d5e1
commit
47885da6e7
@ -53,25 +53,23 @@ import Okapi.Secret qualified as Secret
|
||||
import Text.Regex.TDFA qualified as Regex
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
type Tree r = [Node r]
|
||||
|
||||
type (:>) :: [Type] -> Type -> [Type]
|
||||
type family (:>) (a :: [Type]) (b :: Type) where
|
||||
(:>) '[] b = '[b]
|
||||
(:>) (aa : aas) b = aa : (aas :> b)
|
||||
|
||||
data Node (r :: [Type]) where
|
||||
Match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> Tree r -> Node r
|
||||
Param :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => Tree (r :> a) -> Node r
|
||||
-- Regex :: forall a (r :: [Type]). (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> Tree (a : r) -> Node (a : r)
|
||||
-- Splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => Tree (NonEmpty.NonEmpty a : r) -> Node (NonEmpty.NonEmpty a : r)
|
||||
-- Route :: forall a (r :: [Type]). Route.Parser a -> Tree (a : r) -> Node (a : r)
|
||||
Method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Node r
|
||||
|
||||
-- Query :: forall a. Query.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
-- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
-- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
-- Apply :: forall (r :: [Type]). Wai.Middleware -> Node r -> Node r
|
||||
data Atom (r :: [Type]) where
|
||||
Match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> [Atom r] -> Atom r
|
||||
Param :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (r :> a)] -> Atom r
|
||||
Regex :: forall a (r :: [Type]). (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> [Atom (r :> a)] -> Atom r
|
||||
Splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (NonEmpty.NonEmpty r :> a)] -> Atom r
|
||||
Route :: forall a (r :: [Type]). Route.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
Method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Atom r
|
||||
Headers :: forall a (r :: [Type]). Headers.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
Query :: forall a (r :: [Type]). Query.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
Body :: forall a (r :: [Type]). Body.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
Apply :: forall (r :: [Type]). Wai.Middleware -> Atom r -> Atom r
|
||||
Respond :: forall a (r :: [Type]). Response.Builder a -> [Atom (r :> a)] -> Atom r
|
||||
|
||||
type Handler :: [Type] -> (Type -> Type) -> Type
|
||||
type family Handler args env where
|
||||
@ -90,31 +88,55 @@ argsTest2 :: Handler '[Int, Int] IO
|
||||
argsTest2 = \x -> \y -> \request -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
|
||||
match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> Tree r -> Node r
|
||||
match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> [Atom r] -> Atom r
|
||||
match = Match
|
||||
|
||||
lit :: forall (r :: [Type]). Text.Text -> Tree r -> Node r
|
||||
lit :: forall (r :: [Type]). Text.Text -> [Atom r] -> Atom r
|
||||
lit = match @Text.Text
|
||||
|
||||
param :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => Tree (r :> a) -> Node r
|
||||
param = Param @a @r
|
||||
param :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (r :> a)] -> Atom r
|
||||
param = Param
|
||||
|
||||
method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Node r
|
||||
regex :: forall a (r :: [Type]). (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> [Atom (r :> a)] -> Atom r
|
||||
regex = Regex
|
||||
|
||||
splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (NonEmpty.NonEmpty r :> a)] -> Atom r
|
||||
splat = Splat
|
||||
|
||||
route :: forall a (r :: [Type]). Route.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
route = Route
|
||||
|
||||
method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Atom r
|
||||
method = Method
|
||||
|
||||
type Root = '[]
|
||||
headers :: forall a (r :: [Type]). Headers.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
headers = Headers
|
||||
|
||||
query :: forall a (r :: [Type]). Query.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
query = Query
|
||||
|
||||
body :: forall a (r :: [Type]). Body.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
body = Body
|
||||
|
||||
apply :: forall (r :: [Type]). Wai.Middleware -> Atom r -> Atom r
|
||||
apply = Apply
|
||||
|
||||
respond :: forall a (r :: [Type]). Response.Builder a -> [Atom (r :> a)] -> Atom r
|
||||
respond = Respond
|
||||
|
||||
myTest = Warp.run 8080 $ test `withDefault` \_ resp -> resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
test :: Tree Root
|
||||
test =
|
||||
[ lit "hello"
|
||||
[ lit "world"
|
||||
[ lit
|
||||
"hello"
|
||||
[ lit
|
||||
"world"
|
||||
[ param @Bool
|
||||
[ method HTTP.GET id testHandler1
|
||||
, param @Int
|
||||
[ method HTTP.GET id testHandler2
|
||||
, lit "foo"
|
||||
, lit
|
||||
"foo"
|
||||
[ method HTTP.POST id testHandler2
|
||||
]
|
||||
, param @Float
|
||||
@ -125,7 +147,8 @@ test =
|
||||
]
|
||||
]
|
||||
]
|
||||
, lit "world"
|
||||
, lit
|
||||
"world"
|
||||
[ method HTTP.GET id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
, method HTTP.HEAD id \req -> do
|
||||
@ -151,29 +174,24 @@ snoc :: forall (l :: [Type]) (e :: Type). HList l -> e -> HList (l :> e)
|
||||
snoc HNil x = HCons x HNil
|
||||
snoc (HCons h t) x = HCons h (snoc t x)
|
||||
|
||||
-- type Reverse :: [Type] -> [Type]
|
||||
-- type family Reverse l where
|
||||
-- Reverse '[] = '[]
|
||||
-- Reverse (h : t) = Reverse t :> h
|
||||
|
||||
fillHandler :: Handler args env -> HList args -> (Wai.Request -> env Wai.Response)
|
||||
fillHandler handler HNil = handler
|
||||
fillHandler handler (HCons x xs) = fillHandler (handler x) xs
|
||||
|
||||
myFunc :: Wai.Request -> IO Wai.Response
|
||||
myFunc = fillHandler handlerTest argsTest
|
||||
where
|
||||
handlerTest :: Handler [Bool, Int, Float] IO
|
||||
handlerTest = \b -> \i -> \f -> \req -> do
|
||||
undefined
|
||||
where
|
||||
handlerTest :: Handler [Bool, Int, Float] IO
|
||||
handlerTest = \b -> \i -> \f -> \req -> do
|
||||
undefined
|
||||
|
||||
argsTest :: HList [Bool, Int, Float]
|
||||
argsTest = HCons True (HCons 5 (HCons 5.8 HNil))
|
||||
argsTest :: HList [Bool, Int, Float]
|
||||
argsTest = HCons True (HCons 5 (HCons 5.8 HNil))
|
||||
|
||||
withDefault :: Tree Root -> Wai.Middleware
|
||||
withDefault :: [Atom '[]] -> Wai.Middleware
|
||||
withDefault = withDefaultLoop id HNil
|
||||
|
||||
withDefaultLoop :: Wai.Middleware -> HList args -> Tree args -> Wai.Middleware
|
||||
withDefaultLoop :: Wai.Middleware -> HList args -> [Atom args] -> Wai.Middleware
|
||||
withDefaultLoop middleware args tree backup request respond = case tree of
|
||||
[] -> backup request respond
|
||||
(node : remTree) ->
|
||||
@ -184,7 +202,7 @@ withDefaultLoop middleware args tree backup request respond = case tree of
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == Web.toUrlPiece value
|
||||
then do
|
||||
let newRequest = request {Wai.pathInfo = pathTail}
|
||||
let newRequest = request{Wai.pathInfo = pathTail}
|
||||
withDefaultLoop middleware args subTree backup newRequest respond
|
||||
else withDefaultLoop middleware args remTree backup request respond
|
||||
Param @t subTree ->
|
||||
@ -194,7 +212,7 @@ withDefaultLoop middleware args tree backup request respond = case tree of
|
||||
case Web.parseUrlPiece @t pathHead of
|
||||
Left _ -> withDefaultLoop middleware args remTree backup request respond
|
||||
Right value -> do
|
||||
let newRequest = request {Wai.pathInfo = pathTail}
|
||||
let newRequest = request{Wai.pathInfo = pathTail}
|
||||
withDefaultLoop middleware (snoc args value) subTree backup newRequest respond
|
||||
Method stdMethod transformation handler ->
|
||||
case HTTP.parseMethod $ Wai.requestMethod request of
|
||||
@ -210,98 +228,8 @@ withDefaultLoop middleware args tree backup request respond = case tree of
|
||||
request
|
||||
respond
|
||||
else withDefaultLoop middleware args remTree backup request respond
|
||||
{-
|
||||
url :: forall (args :: [Type]) (ah :: Type) (at :: [Type]). Tree args -> HList (ah : at) -> Text
|
||||
url tree a = case tree of
|
||||
[] -> ""
|
||||
(node : remTree) ->
|
||||
case node of
|
||||
Match value subTree ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> withDefaultLoop middleware args remTree backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == Web.toUrlPiece value
|
||||
then do
|
||||
let newRequest = request {Wai.pathInfo = pathTail}
|
||||
withDefaultLoop middleware args subTree backup newRequest respond
|
||||
else withDefaultLoop middleware args remTree backup request respond
|
||||
Param @t subTree ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> withDefaultLoop middleware args remTree backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @t pathHead of
|
||||
Left _ -> withDefaultLoop middleware args remTree backup request respond
|
||||
Right value -> do
|
||||
let newRequest = request {Wai.pathInfo = pathTail}
|
||||
withDefaultLoop middleware (snoc args value) subTree backup newRequest respond
|
||||
Method stdMethod transformation handler ->
|
||||
case HTTP.parseMethod $ Wai.requestMethod request of
|
||||
Left _ -> withDefaultLoop middleware args remTree backup request respond
|
||||
Right stdMethod' ->
|
||||
if stdMethod == stdMethod' && List.null (Wai.pathInfo request)
|
||||
then
|
||||
middleware
|
||||
( \request' respond' -> do
|
||||
response <- transformation $ fillHandler handler args request'
|
||||
respond' response
|
||||
)
|
||||
request
|
||||
respond
|
||||
else withDefaultLoop middleware args remTree backup request respond
|
||||
-}
|
||||
{-
|
||||
type Remove :: Exts.Symbol -> [Exts.Symbol] -> [Exts.Symbol]
|
||||
type family Remove x ys where
|
||||
Remove a '[] = '[]
|
||||
Remove a (a ': ys) = ys
|
||||
Remove a (y ': ys) = y ': (Remove a ys)
|
||||
-}
|
||||
|
||||
{-
|
||||
data Node (r :: [Type]) where
|
||||
Match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> Tree r -> Node r
|
||||
Param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> Tree) -> Node
|
||||
Regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> (Secret.Secret a -> Tree) -> Node
|
||||
Splat :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret (NonEmpty.NonEmpty a) -> Tree) -> Node
|
||||
Route :: forall a. Route.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
Method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> Node
|
||||
-- Query :: forall a. Query.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
-- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
-- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
Apply :: Wai.Middleware -> Node -> Node
|
||||
-}
|
||||
|
||||
-- Respond ::
|
||||
-- forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
|
||||
-- (Response.ToContentType contentType resultType) =>
|
||||
-- ((Response.Headers headerKeys -> resultType -> Wai.Response) -> Tree) ->
|
||||
-- Node
|
||||
|
||||
{-
|
||||
regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> (Secret.Secret a -> Tree) -> Node
|
||||
regex = Regex
|
||||
|
||||
splat :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret (NonEmpty.NonEmpty a) -> Tree) -> Node
|
||||
splat = Splat
|
||||
|
||||
route :: forall a. Route.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
route = Route
|
||||
|
||||
apply :: Wai.Middleware -> Node -> Node
|
||||
apply = Apply
|
||||
|
||||
scope :: Wai.Middleware -> Text.Text -> Tree -> Node
|
||||
scope mw t forest = apply mw $ lit t forest
|
||||
-}
|
||||
|
||||
{-
|
||||
-- respond ::
|
||||
-- forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
|
||||
-- (Response.ToContentType contentType resultType) =>
|
||||
-- ((Response.Headers headerKeys -> resultType -> Wai.Response) -> Tree) ->
|
||||
-- Node
|
||||
-- respond = Respond
|
||||
|
||||
withDefault :: Tree -> Wai.Middleware
|
||||
withDefault = loop id
|
||||
where
|
||||
@ -390,72 +318,72 @@ withDefault = loop id
|
||||
respond
|
||||
-}
|
||||
{-
|
||||
stringify :: Tree -> IO (Node.Tree String)
|
||||
stringify :: Tree -> IO (Atom.Tree String)
|
||||
stringify [] = return []
|
||||
stringify (tree:remForest) = case tree of
|
||||
Match value subForest -> do
|
||||
stringSubForest <- stringify subForest
|
||||
stringRemForest <- stringify remForest
|
||||
let string = "/" <> (Text.unpack $ Web.toUrlPiece value)
|
||||
return ((Tree.Node string stringSubForest) : stringRemForest)
|
||||
return ((Tree.Atom string stringSubForest) : stringRemForest)
|
||||
Param @t growSubForest -> do
|
||||
secret <- Secret.new @t
|
||||
stringSubForest <- stringify $ growSubForest secret
|
||||
stringRemForest <- stringify remForest
|
||||
let string = "/:" <> showType @t
|
||||
return ((Tree.Node string stringSubForest) : stringRemForest)
|
||||
return ((Tree.Atom string stringSubForest) : stringRemForest)
|
||||
Regex @t regex growSubForest -> do
|
||||
secret <- Secret.new @t
|
||||
stringSubForest <- stringify $ growSubForest secret
|
||||
stringRemForest <- stringify remForest
|
||||
let string = "/<" <> Text.unpack regex <> ">"
|
||||
return ((Tree.Node string stringSubForest) : stringRemForest)
|
||||
return ((Tree.Atom string stringSubForest) : stringRemForest)
|
||||
Splat @t growSubForest -> do
|
||||
secret <- Secret.new @(NonEmpty.NonEmpty ty)
|
||||
forest <- mapM $ produce secret
|
||||
return $ Tree.Node ("/*" <> showType @ty) forest
|
||||
return $ Tree.Atom ("/*" <> showType @ty) forest
|
||||
(Route @ty route produce) = do
|
||||
secret <- Secret.new @ty
|
||||
forest <- mapM $ produce secret
|
||||
return $ Tree.Node (Text.unpack (Route.rep route)) forest
|
||||
return $ Tree.Atom (Text.unpack (Route.rep route)) forest
|
||||
(Method m _ _) = do
|
||||
return $ Tree.Node (show m) []
|
||||
return $ Tree.Atom (show m) []
|
||||
(Apply _ api) = do
|
||||
(Tree.Node root subTrees) <- api
|
||||
return $ Tree.Node ("(" <> root <> ")") subTrees
|
||||
(Tree.Atom root subTrees) <- api
|
||||
return $ Tree.Atom ("(" <> root <> ")") subTrees
|
||||
-}
|
||||
{-
|
||||
forest :: Tree -> IO (Tree.Node String)
|
||||
forest [] = return $ Tree.Node ":root:" []
|
||||
forest :: Tree -> IO (Tree.Atom String)
|
||||
forest [] = return $ Tree.Atom ":root:" []
|
||||
forest apis = do
|
||||
forest' <- mapM tree apis
|
||||
return $ Tree.Node "\ESC[31m:root:\ESC[0m" forest'
|
||||
return $ Tree.Atom "\ESC[31m:root:\ESC[0m" forest'
|
||||
where
|
||||
tree :: Node -> IO (Tree.Node String)
|
||||
tree :: Atom -> IO (Tree.Atom String)
|
||||
tree (Match value apis) = do
|
||||
forest <- mapM tree apis
|
||||
return $ Tree.Node ("/" <> (Text.unpack $ Web.toUrlPiece value)) forest
|
||||
return $ Tree.Atom ("/" <> (Text.unpack $ Web.toUrlPiece value)) forest
|
||||
tree (Param @ty produce) = do
|
||||
secret <- Secret.new @ty
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node ("/:" <> showType @ty) forest
|
||||
return $ Tree.Atom ("/:" <> showType @ty) forest
|
||||
tree (Regex @ty regex produce) = do
|
||||
secret <- Secret.new @ty
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node ("/r<" <> Text.unpack regex <> ">") forest
|
||||
return $ Tree.Atom ("/r<" <> Text.unpack regex <> ">") forest
|
||||
tree (Splat @ty produce) = do
|
||||
secret <- Secret.new @(NonEmpty.NonEmpty ty)
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node ("/*" <> showType @ty) forest
|
||||
return $ Tree.Atom ("/*" <> showType @ty) forest
|
||||
tree (Route @ty route produce) = do
|
||||
secret <- Secret.new @ty
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node (Text.unpack (Route.rep route)) forest
|
||||
return $ Tree.Atom (Text.unpack (Route.rep route)) forest
|
||||
tree (Method m _ _) = do
|
||||
return $ Tree.Node (show m) []
|
||||
return $ Tree.Atom (show m) []
|
||||
tree (Apply _ api) = do
|
||||
(Tree.Node root subTrees) <- tree api
|
||||
return $ Tree.Node ("(" <> root <> ")") subTrees
|
||||
(Tree.Atom root subTrees) <- tree api
|
||||
return $ Tree.Atom ("(" <> root <> ")") subTrees
|
||||
|
||||
showType :: forall a. (Typeable.Typeable a) => String
|
||||
showType = show . Typeable.typeRep $ Typeable.Proxy @a
|
||||
@ -464,65 +392,3 @@ get_ = method HTTP.GET
|
||||
|
||||
getIO_ = method HTTP.GET id
|
||||
-}
|
||||
{-
|
||||
data Node where
|
||||
Match :: forall a. (Web.ToHttpApiData a) => a -> Tree -> Node
|
||||
Param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> Tree) -> Node
|
||||
Regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> (Secret.Secret a -> Tree) -> Node
|
||||
Splat :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret (NonEmpty.NonEmpty a) -> Tree) -> Node
|
||||
Route :: forall a. Route.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
Method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> Node
|
||||
-- Query :: forall a. Query.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
-- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
-- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> Tree) -> Node
|
||||
Pipe :: Wai.Middleware -> Node -> Node
|
||||
Respond ::
|
||||
forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
|
||||
(Response.ToContentType contentType resultType) =>
|
||||
((Response.Headers headerKeys -> resultType -> Wai.Response) -> Tree) ->
|
||||
Node
|
||||
|
||||
-- data AppF a where
|
||||
-- MatchF :: forall a b. (Web.ToHttpApiData b) => b -> [a] -> AppF a
|
||||
-- ParamF :: forall a b. (Web.FromHttpApiData b, Typeable.Typeable b) => (Secret.Secret b -> [a]) -> AppF a
|
||||
-- RegexF :: forall a b. (Regex.RegexContext Regex.Regex Text.Text b) => Text.Text -> (Secret.Secret b -> [a]) -> AppF a
|
||||
-- SplatF :: forall a b. (Web.FromHttpApiData b, Typeable.Typeable b) => (Secret.Secret (NonEmpty.NonEmpty b) -> [a]) -> AppF a
|
||||
-- RouteF :: forall a b. Route.Parser b -> (Secret.Secret b -> [a]) -> AppF a
|
||||
-- MethodF :: forall a env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> AppF a
|
||||
-- -- Query :: forall a. Query.Parser a -> (Secret.Secret a -> [AppF]) -> AppF
|
||||
-- -- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> [AppF]) -> AppF
|
||||
-- -- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> [AppF]) -> AppF
|
||||
-- PipeF :: forall a. Wai.Middleware -> a -> AppF a
|
||||
-- RespondF ::
|
||||
-- forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
|
||||
-- (Response.ToContentType contentType resultType) =>
|
||||
-- ((Response.Headers headerKeys -> resultType -> Wai.Response) -> [a]) ->
|
||||
-- AppF a
|
||||
|
||||
build' :: Tree -> Wai.Middleware -> Wai.Middleware
|
||||
build' root middleware backup request respond = Foldable.fold
|
||||
(\case
|
||||
Base.Nil -> backup request respond
|
||||
Base.Cons api (apis :: _) -> case api of
|
||||
Match value children ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> build' apis middleware backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == Web.toUrlPiece value
|
||||
then do
|
||||
let newReq = request {Wai.pathInfo = pathTail}
|
||||
build' children middleware backup newReq respond
|
||||
else build' apis middleware backup request respond
|
||||
)
|
||||
root
|
||||
|
||||
endpoint ::
|
||||
HTTP.StdMethod ->
|
||||
Route.Parser a ->
|
||||
(env Natural.~> IO) ->
|
||||
(Secret.Secret a -> Handler env) ->
|
||||
Node
|
||||
endpoint stdMethod routeP trans handlerWithSecret = route routeP \routeS ->
|
||||
[ method stdMethod trans (handlerWithSecret routeS)
|
||||
]
|
||||
-}
|
||||
@ -25,6 +25,7 @@
|
||||
|
||||
module Okapi.App2 where
|
||||
|
||||
{-
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Binary.Builder qualified as Builder
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
@ -566,4 +567,5 @@ endpoint ::
|
||||
endpoint stdMethod routeP trans handlerWithSecret = route routeP \routeS ->
|
||||
[ method stdMethod trans (handlerWithSecret routeS)
|
||||
]
|
||||
-}
|
||||
-}
|
||||
@ -149,3 +149,49 @@ data Response (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (content
|
||||
Headers headerKeys ->
|
||||
resultType ->
|
||||
Response status headerKeys contentType resultType
|
||||
|
||||
data Builder a where
|
||||
FMap :: (a -> b) -> Builder a -> Builder b
|
||||
Pure :: a -> Builder a
|
||||
Apply :: Builder (a -> b) -> Builder a -> Builder b
|
||||
Has ::
|
||||
forall
|
||||
(status :: Natural.Natural)
|
||||
(headerKeys :: [Exts.Symbol])
|
||||
(contentType :: Type)
|
||||
(resultType :: Type).
|
||||
Builder
|
||||
( Headers headerKeys ->
|
||||
resultType ->
|
||||
Response status headerKeys contentType resultType
|
||||
)
|
||||
|
||||
instance Functor Builder where
|
||||
fmap = FMap
|
||||
|
||||
instance Applicative Builder where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
has ::
|
||||
forall
|
||||
(status :: Natural.Natural)
|
||||
(headerKeys :: [Exts.Symbol])
|
||||
(contentType :: Type)
|
||||
(resultType :: Type).
|
||||
Builder
|
||||
( Headers headerKeys ->
|
||||
resultType ->
|
||||
Response status headerKeys contentType resultType
|
||||
)
|
||||
has = Has
|
||||
|
||||
-- equals :: Builder a -> Builder b -> Bool
|
||||
-- equals (FMap _ r) (FMap _ r') = equals r r'
|
||||
-- equals (Pure _) (Pure _) = True
|
||||
-- equals (Apply af ap) (Apply af' ap') = equals af af' && equals ap ap'
|
||||
-- equals (Has _) (Has _) = undefined
|
||||
-- equals _ _ = False
|
||||
|
||||
build :: Builder a -> a
|
||||
build = undefined
|
||||
|
||||
Loading…
Reference in New Issue
Block a user