mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-22 00:51:34 +03:00
Add To/From classes and Parsers/Builders
This commit is contained in:
Rashad Gover
parent
47885da6e7
commit
3928ad73f6
@ -28,11 +28,13 @@ source-repository head
|
||||
library
|
||||
exposed-modules:
|
||||
Okapi
|
||||
Okapi.Middleware
|
||||
Okapi.Route.Pattern
|
||||
Okapi.Headers
|
||||
Okapi.Query
|
||||
Okapi.Body
|
||||
Okapi.Secret
|
||||
Okapi.App
|
||||
Okapi.App2
|
||||
Okapi.Route
|
||||
Okapi.Response
|
||||
other-modules:
|
||||
|
||||
@ -46,7 +46,10 @@ import GHC.Natural qualified as Natural
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as Wai
|
||||
import Network.Wai.Handler.Warp qualified as Warp
|
||||
import Okapi.Body qualified as Body
|
||||
import Okapi.Headers qualified as Headers
|
||||
import Okapi.Middleware qualified as Middleware
|
||||
import Okapi.Query qualified as Query
|
||||
import Okapi.Response qualified as Response
|
||||
import Okapi.Route qualified as Route
|
||||
import Okapi.Secret qualified as Secret
|
||||
@ -62,14 +65,14 @@ 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
|
||||
Splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (r :> NonEmpty.NonEmpty a)] -> Atom r
|
||||
Route :: forall a (r :: [Type]). (Route.From a) => [Atom (r :> a)] -> Atom r
|
||||
Query :: forall a (r :: [Type]). (Query.From a) => [Atom (r :> a)] -> Atom r
|
||||
Headers :: forall a (r :: [Type]). (Headers.From a) => [Atom (r :> a)] -> Atom r
|
||||
Body :: forall a (r :: [Type]). (Body.From a) => [Atom (r :> a)] -> Atom r
|
||||
Apply :: forall a (r :: [Type]). (Middleware.To a) => Atom r -> Atom r
|
||||
Respond :: forall a (r :: [Type]). (Response.To 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
|
||||
@ -89,40 +92,55 @@ argsTest2 = \x -> \y -> \request -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
|
||||
match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> [Atom r] -> Atom r
|
||||
match = Match
|
||||
match = Match @a @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) => [Atom (r :> a)] -> Atom r
|
||||
param = Param
|
||||
param = Param @a @r
|
||||
|
||||
regex :: forall a (r :: [Type]). (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> [Atom (r :> a)] -> Atom r
|
||||
regex = Regex
|
||||
regex = Regex @a @r
|
||||
|
||||
splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (NonEmpty.NonEmpty r :> a)] -> Atom r
|
||||
splat = Splat
|
||||
splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (r :> NonEmpty.NonEmpty a)] -> Atom r
|
||||
splat = Splat @a @r
|
||||
|
||||
route :: forall a (r :: [Type]). Route.Parser a -> [Atom (r :> a)] -> Atom r
|
||||
route = Route
|
||||
route :: forall a (r :: [Type]). (Route.From a) => [Atom (r :> a)] -> Atom r
|
||||
route = Route @a @r
|
||||
|
||||
query :: forall a (r :: [Type]). (Query.From a) => [Atom (r :> a)] -> Atom r
|
||||
query = Query @a @r
|
||||
|
||||
headers :: forall a (r :: [Type]). (Headers.From a) => [Atom (r :> a)] -> Atom r
|
||||
headers = Headers @a @r
|
||||
|
||||
body :: forall a (r :: [Type]). (Body.From a) => [Atom (r :> a)] -> Atom r
|
||||
body = Body @a @r
|
||||
|
||||
apply :: forall a (r :: [Type]). (Middleware.To a) => Atom r -> Atom r
|
||||
apply = Apply @a @r
|
||||
|
||||
scope :: forall a m (r :: [Type]). (Route.From a, Middleware.To m) => Wai.Middleware -> [Atom (r :> a)] -> Atom r
|
||||
scope middleware children = apply @m @r $ route @a @r children
|
||||
|
||||
respond :: forall a (r :: [Type]). (Response.To a) => [Atom (r :> a)] -> Atom r
|
||||
respond = Respond @a @r
|
||||
|
||||
method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Atom r
|
||||
method = Method
|
||||
method = Method @env @r
|
||||
|
||||
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
|
||||
endpoint ::
|
||||
forall a env (r :: [Type]).
|
||||
(Route.From a) =>
|
||||
HTTP.StdMethod ->
|
||||
(env Natural.~> IO) ->
|
||||
Handler (r :> a) env ->
|
||||
Atom r
|
||||
endpoint stdMethod transformation handler =
|
||||
route @a
|
||||
[ method stdMethod transformation handler
|
||||
]
|
||||
|
||||
myTest = Warp.run 8080 $ test `withDefault` \_ resp -> resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
|
||||
@ -1,571 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QualifiedDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Okapi.App2 where
|
||||
|
||||
{-
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Binary.Builder qualified as Builder
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBSChar8
|
||||
import Data.Functor.Base qualified as Base
|
||||
import Data.Functor.Foldable qualified as Foldable
|
||||
import Data.Functor.Identity qualified as Identity
|
||||
import Data.Kind
|
||||
import Data.List qualified as List
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.Text qualified as Text
|
||||
import Data.Tree qualified as Tree
|
||||
import Data.Type.Equality qualified as Equality
|
||||
import Data.Typeable qualified as Typeable
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
import GHC.Exts qualified as Exts
|
||||
import GHC.Generics qualified as Generics
|
||||
import GHC.Natural qualified as Natural
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as Wai
|
||||
import Network.Wai.Handler.Warp qualified as Warp
|
||||
import Okapi.Headers qualified as Headers
|
||||
import Okapi.Response qualified as Response
|
||||
import Okapi.Route qualified as Route
|
||||
import Okapi.Secret qualified as Secret
|
||||
import Text.Regex.TDFA qualified as Regex
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
-- type Tree r s = [Node r s]
|
||||
|
||||
type (:>) :: [Type] -> Type -> [Type]
|
||||
type family (:>) (a :: [Type]) (b :: Type) where
|
||||
(:>) '[] b = '[b]
|
||||
(:>) (aa : aas) b = aa : (aas :> b)
|
||||
|
||||
type (:>>) :: [Datum] -> Datum -> [Datum]
|
||||
type family (:>>) (a :: [Datum]) (b :: Datum) where
|
||||
(:>>) '[] b = '[b]
|
||||
(:>>) (aa : aas) b = aa : (aas :>> b)
|
||||
|
||||
type Null :: [Type] -> Bool
|
||||
type family Null (a :: [Type]) where
|
||||
Null '[] = 'False
|
||||
Null _ = 'True
|
||||
|
||||
type Datum :: Type
|
||||
data Datum where
|
||||
Seg :: Exts.Symbol -> Datum
|
||||
Arg :: a -> Datum
|
||||
|
||||
type NODE :: Type
|
||||
data NODE where
|
||||
-- ROOT :: [NODE] -> NODE
|
||||
MATCH :: a -> [NODE] -> NODE
|
||||
PARAM :: a -> [NODE] -> NODE
|
||||
GET :: NODE
|
||||
POST :: NODE
|
||||
PUT :: NODE
|
||||
DELETE :: NODE
|
||||
|
||||
data Node (r :: [Type]) (p :: [Datum]) where -- r for args, p for path
|
||||
-- Root :: forall (r :: [Type]) (s :: [NODE]). [Node r s] -> Node '[] s
|
||||
Match :: forall a (r :: [Type]) (p :: [Datum]). (Web.ToHttpApiData a) => a -> [Node r p] -> Node r (p :>> Arg a)
|
||||
Param :: forall a (r :: [Type]) (p :: [Datum]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Node (r :> a) p] -> Node r (p :>> Arg a)
|
||||
-- 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 :: Type -> Type) (r :: [Type]) (s :: NODE). (env Natural.~> IO) -> Handler r env -> Node r ()
|
||||
-- Get :: forall (env :: Type -> Type) (r :: [Type]). (env Natural.~> IO) -> Handler r env -> Node r
|
||||
-- Post :: forall (env :: Type -> Type) (r :: [Type]). (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
|
||||
|
||||
type Handler :: [Type] -> (Type -> Type) -> Type
|
||||
type family Handler args env where
|
||||
Handler '[] env = Wai.Request -> env Wai.Response
|
||||
Handler (arg : args) env = arg -> Handler args env
|
||||
|
||||
typeTest = [Match @Int 5
|
||||
[ Match @Float 6.9
|
||||
[]
|
||||
, Param @Int
|
||||
[]
|
||||
]
|
||||
]
|
||||
{-
|
||||
argsTest :: Handler '[] IO
|
||||
argsTest = \request -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
|
||||
argsTest1 :: Handler '[Int] IO
|
||||
argsTest1 = \x -> \request -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
|
||||
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 = Match
|
||||
|
||||
lit :: forall (r :: [Type]). Text.Text -> Tree r -> Node 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
|
||||
|
||||
|
||||
-- TODO: Add type level method to node???
|
||||
method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Node r
|
||||
method = Method
|
||||
-}
|
||||
{-
|
||||
type Root = '[]
|
||||
|
||||
myTest = Warp.run 8080 $ test `withDefault` \_ resp -> resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
test :: Tree Root
|
||||
test =
|
||||
[ lit @'[] "hello"
|
||||
[ lit @'[] "world"
|
||||
[ param @Bool @'[]
|
||||
[ method @IO @'[Bool] HTTP.GET id testHandler1
|
||||
, param @Int @'[Bool]
|
||||
[ method @IO @'[Bool, Int] HTTP.GET id testHandler2
|
||||
, lit @'[Bool, Int] "foo"
|
||||
[ method @IO @'[Bool, Int] HTTP.POST id testHandler2
|
||||
]
|
||||
, param @Float @'[Bool, Int]
|
||||
[ method @IO @'[Bool, Int, Float] HTTP.PUT id \bool1 -> \int2 -> \f3 -> \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "many args"
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
, lit "world"
|
||||
[ method HTTP.GET id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
, method HTTP.HEAD id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "dub"
|
||||
]
|
||||
, method HTTP.GET id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "What's up??"
|
||||
]
|
||||
|
||||
testHandler1 :: Bool -> Wai.Request -> IO Wai.Response
|
||||
testHandler1 x request = do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show x
|
||||
|
||||
testHandler2 :: Bool -> Int -> Wai.Request -> IO Wai.Response
|
||||
testHandler2 x y request = do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show x <> show y
|
||||
|
||||
data HList (l :: [Type]) where
|
||||
HNil :: HList '[]
|
||||
HCons :: e -> HList l -> HList (e ': l)
|
||||
|
||||
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
|
||||
|
||||
argsTest :: HList [Bool, Int, Float]
|
||||
argsTest = HCons True (HCons 5 (HCons 5.8 HNil))
|
||||
-}
|
||||
{-
|
||||
withDefault :: Tree Root -> Wai.Middleware
|
||||
withDefault = withDefaultLoop id HNil
|
||||
|
||||
withDefaultLoop :: Wai.Middleware -> HList args -> Tree args -> Wai.Middleware
|
||||
withDefaultLoop middleware args tree backup request respond = case tree of
|
||||
[] -> backup request respond
|
||||
(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
|
||||
-}
|
||||
{-
|
||||
url :: forall (args :: [Type]). HList args -> Tree args -> Text
|
||||
url a tree = 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
|
||||
loop :: Wai.Middleware -> Tree -> Wai.Middleware
|
||||
loop middleware forest backup request respond = case forest of
|
||||
[] -> backup request respond
|
||||
(tree : remForest) ->
|
||||
case tree of
|
||||
Match value subForest ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> loop middleware remForest backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == Web.toUrlPiece value
|
||||
then do
|
||||
let newRequest = request {Wai.pathInfo = pathTail}
|
||||
loop middleware subForest backup newRequest respond
|
||||
else loop middleware remForest backup request respond
|
||||
Param @t growSubForest ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> loop middleware remForest backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @t pathHead of
|
||||
Left _ -> loop middleware remForest backup request respond
|
||||
Right value -> do
|
||||
key <- Vault.newKey @t
|
||||
let newVault = Vault.insert key value (Wai.vault request)
|
||||
newRequest = request {Wai.pathInfo = pathTail, Wai.vault = newVault}
|
||||
loop middleware (growSubForest $ Secret.Secret key) backup newRequest respond
|
||||
Regex @t regex growSubForest -> do
|
||||
case Wai.pathInfo request of
|
||||
[] -> loop middleware remForest backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
case pathHead Regex.=~~ regex of
|
||||
Nothing -> loop middleware remForest backup request respond
|
||||
Just value -> do
|
||||
key <- Vault.newKey @t
|
||||
let newVault = Vault.insert key value (Wai.vault request)
|
||||
newRequest = request {Wai.pathInfo = pathTail, Wai.vault = newVault}
|
||||
loop middleware (growSubForest $ Secret.Secret key) backup newRequest respond
|
||||
Splat @t growSubForest -> do
|
||||
case Wai.pathInfo request of
|
||||
[] -> loop middleware remForest backup request respond
|
||||
(pathHead : pathTail) -> case Web.parseUrlPiece @t pathHead of
|
||||
Left _ -> loop middleware remForest backup request respond
|
||||
Right valueHead -> do
|
||||
key <- Vault.newKey @(NonEmpty.NonEmpty t)
|
||||
let valueTail = getValues @t pathTail
|
||||
nonEmptyPath = valueHead NonEmpty.:| valueTail
|
||||
newVault = Vault.insert key nonEmptyPath (Wai.vault request)
|
||||
newRequest = request {Wai.pathInfo = List.drop (List.length valueTail + 1) (Wai.pathInfo request), Wai.vault = newVault}
|
||||
loop middleware (growSubForest $ Secret.Secret key) backup newRequest respond
|
||||
where
|
||||
getValues :: forall ty. (Web.FromHttpApiData t) => [Text.Text] -> [t]
|
||||
getValues [] = []
|
||||
getValues (p : ps) = case Web.parseUrlPiece @t p of
|
||||
Left _ -> []
|
||||
Right v -> v : getValues @t ps
|
||||
Route @t route growSubForest -> do
|
||||
case Route.parse route $ Wai.pathInfo request of
|
||||
(Left _, _) -> loop middleware remForest backup request respond
|
||||
(Right value, newPathInfo) -> do
|
||||
key <- Vault.newKey @t
|
||||
let newVault = Vault.insert key value (Wai.vault request)
|
||||
newRequest = request {Wai.pathInfo = newPathInfo, Wai.vault = newVault}
|
||||
loop middleware (growSubForest $ Secret.Secret key) backup newRequest respond
|
||||
Method stdMethod transformation handler ->
|
||||
case HTTP.parseMethod $ Wai.requestMethod request of
|
||||
Left _ -> loop middleware remForest backup request respond
|
||||
Right stdMethod' ->
|
||||
if stdMethod == stdMethod' && List.null (Wai.pathInfo request)
|
||||
then
|
||||
middleware
|
||||
( \request' respond' -> do
|
||||
response <- transformation $ handler request'
|
||||
respond' response
|
||||
)
|
||||
request
|
||||
respond
|
||||
else loop middleware remForest backup request respond
|
||||
Apply middleware' tree ->
|
||||
loop
|
||||
(middleware' . middleware)
|
||||
(tree : [])
|
||||
(loop middleware remForest backup)
|
||||
request
|
||||
respond
|
||||
-}
|
||||
{-
|
||||
stringify :: Tree -> IO (Node.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)
|
||||
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)
|
||||
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)
|
||||
Splat @t growSubForest -> do
|
||||
secret <- Secret.new @(NonEmpty.NonEmpty ty)
|
||||
forest <- mapM $ produce secret
|
||||
return $ Tree.Node ("/*" <> 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
|
||||
(Method m _ _) = do
|
||||
return $ Tree.Node (show m) []
|
||||
(Apply _ api) = do
|
||||
(Tree.Node root subTrees) <- api
|
||||
return $ Tree.Node ("(" <> root <> ")") subTrees
|
||||
-}
|
||||
{-
|
||||
forest :: Tree -> IO (Tree.Node String)
|
||||
forest [] = return $ Tree.Node ":root:" []
|
||||
forest apis = do
|
||||
forest' <- mapM tree apis
|
||||
return $ Tree.Node "\ESC[31m:root:\ESC[0m" forest'
|
||||
where
|
||||
tree :: Node -> IO (Tree.Node String)
|
||||
tree (Match value apis) = do
|
||||
forest <- mapM tree apis
|
||||
return $ Tree.Node ("/" <> (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
|
||||
tree (Regex @ty regex produce) = do
|
||||
secret <- Secret.new @ty
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node ("/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
|
||||
tree (Route @ty route produce) = do
|
||||
secret <- Secret.new @ty
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node (Text.unpack (Route.rep route)) forest
|
||||
tree (Method m _ _) = do
|
||||
return $ Tree.Node (show m) []
|
||||
tree (Apply _ api) = do
|
||||
(Tree.Node root subTrees) <- tree api
|
||||
return $ Tree.Node ("(" <> root <> ")") subTrees
|
||||
|
||||
showType :: forall a. (Typeable.Typeable a) => String
|
||||
showType = show . Typeable.typeRep $ Typeable.Proxy @a
|
||||
|
||||
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)
|
||||
]
|
||||
-}
|
||||
-}
|
||||
26
lib/src/Okapi/Body.hs
Normal file
26
lib/src/Okapi/Body.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Okapi.Body where
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Data.Typeable qualified as Typeable
|
||||
import Text.Regex.TDFA qualified as Regex
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
data Parser a where
|
||||
FMap :: (a -> b) -> Parser a -> Parser b
|
||||
Pure :: a -> Parser a
|
||||
Apply :: Parser (a -> b) -> Parser a -> Parser b
|
||||
Match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
|
||||
Param :: forall a. (Typeable.Typeable a, Web.FromHttpApiData a) => Parser a
|
||||
Regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> Parser a
|
||||
|
||||
class From a where
|
||||
parser :: Parser a
|
||||
parse :: ()
|
||||
@ -2,54 +2,29 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- {-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Okapi.Headers where
|
||||
|
||||
import Data.Text
|
||||
import Data.Typeable
|
||||
import Data.Text qualified as Text
|
||||
import Data.Typeable qualified as Typeable
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
data Headers a where
|
||||
FMap :: (a -> b) -> Headers a -> Headers b
|
||||
Pure :: a -> Headers a
|
||||
Apply :: Headers (a -> b) -> Headers a -> Headers b
|
||||
Match :: Text -> Headers ()
|
||||
Param :: (Typeable a, Web.FromHttpApiData a) => Headers a
|
||||
data Parser a where
|
||||
FMap :: (a -> b) -> Parser a -> Parser b
|
||||
Pure :: a -> Parser a
|
||||
Apply :: Parser (a -> b) -> Parser a -> Parser b
|
||||
Match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
|
||||
Param :: forall a. (Typeable.Typeable a, Web.FromHttpApiData a) => Parser a
|
||||
|
||||
instance Functor Headers where
|
||||
instance Functor Parser where
|
||||
fmap = FMap
|
||||
|
||||
instance Applicative Headers where
|
||||
instance Applicative Parser where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
param :: (Typeable a, Web.FromHttpApiData a) => Headers a
|
||||
param = Param
|
||||
|
||||
match :: Text -> Headers ()
|
||||
match = Match
|
||||
|
||||
rep :: Headers a -> Text
|
||||
rep (FMap _ dsl) = rep dsl
|
||||
rep (Pure x) = ""
|
||||
rep (Apply aF aX) = rep aF <> rep aX
|
||||
rep (Match t) = "/" <> t
|
||||
rep (Param @p) = "/:" <> pack (show . typeRep $ Proxy @p)
|
||||
|
||||
-- equals :: Headers a -> Headers 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 (Static t) (Static t') = t == t'
|
||||
-- equals (Param @a) (Param @b) = case heqT @a @b of
|
||||
-- Nothing -> False
|
||||
-- Just HRefl -> True
|
||||
-- equals _ _ = False
|
||||
|
||||
data Error = Error
|
||||
|
||||
exec :: Headers a -> [Text] -> (Either Error a, [Text])
|
||||
exec = undefined
|
||||
class From a where
|
||||
parser :: Parser a
|
||||
parse :: ()
|
||||
|
||||
8
lib/src/Okapi/Middleware.hs
Normal file
8
lib/src/Okapi/Middleware.hs
Normal file
@ -0,0 +1,8 @@
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
|
||||
module Okapi.Middleware where
|
||||
|
||||
import Network.Wai qualified as Wai
|
||||
|
||||
class To a where
|
||||
to :: a -> Wai.Middleware
|
||||
33
lib/src/Okapi/Query.hs
Normal file
33
lib/src/Okapi/Query.hs
Normal file
@ -0,0 +1,33 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Okapi.Query where
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Data.Typeable qualified as Typeable
|
||||
import Text.Regex.TDFA qualified as Regex
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
data Parser a where
|
||||
FMap :: (a -> b) -> Parser a -> Parser b
|
||||
Pure :: a -> Parser a
|
||||
Apply :: Parser (a -> b) -> Parser a -> Parser b
|
||||
Match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
|
||||
Param :: forall a. (Typeable.Typeable a, Web.FromHttpApiData a) => Parser a
|
||||
Regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> Parser a
|
||||
|
||||
instance Functor Parser where
|
||||
fmap = FMap
|
||||
|
||||
instance Applicative Parser where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
class From a where
|
||||
parser :: Parser a
|
||||
parse :: ()
|
||||
@ -193,5 +193,6 @@ has = Has
|
||||
-- equals (Has _) (Has _) = undefined
|
||||
-- equals _ _ = False
|
||||
|
||||
build :: Builder a -> a
|
||||
build = undefined
|
||||
class To a where
|
||||
builder :: Builder a
|
||||
build :: ()
|
||||
|
||||
@ -28,6 +28,10 @@ instance Applicative Parser where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
class From a where
|
||||
parser :: Parser a
|
||||
parse :: ()
|
||||
|
||||
match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
|
||||
match = Match
|
||||
|
||||
@ -59,6 +63,3 @@ rep (Regex @ty regex) = "/r(" <> regex <> ")"
|
||||
-- equals _ _ = False
|
||||
|
||||
data Error = Error
|
||||
|
||||
parse :: Parser a -> [Text.Text] -> (Either Error a, [Text.Text])
|
||||
parse = undefined
|
||||
@ -1,74 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QualifiedDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Okapi.App where
|
||||
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Binary.Builder qualified as Builder
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Functor.Identity qualified as Identity
|
||||
import Data.Kind
|
||||
import Data.List qualified as List
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.Text qualified as Text
|
||||
import Data.Tree qualified as Tree
|
||||
import Data.Type.Equality qualified as Equality
|
||||
import Data.Typeable qualified as Typeable
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
import GHC.Exts qualified as Exts
|
||||
import GHC.Generics qualified as Generics
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as Wai
|
||||
import Okapi.Headers qualified as Headers
|
||||
import Okapi.Route qualified as Route
|
||||
import Okapi.Secret qualified as Secret
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
module Okapi.TypedAPI where
|
||||
|
||||
type MethodKind :: Type
|
||||
data MethodKind where
|
||||
GETType :: MethodKind
|
||||
POSTType :: MethodKind
|
||||
PUTType :: MethodKind
|
||||
DELETEType :: MethodKind
|
||||
|
||||
type OpTree :: Type
|
||||
data OpTree where
|
||||
MatchNode :: forall a. (Web.ToHttpApiData a) => a -> '[TypedAPI OpTree] -> OpTree
|
||||
ParamNode :: forall a. (Web.FromHttpApiData a) => '[TypedAPI OpTree] -> OpTree
|
||||
MethodLeaf :: MethodKind -> OpTree
|
||||
|
||||
-- type In :: TypedAPI OpTree -> [TypedAPI OpTree] -> Bool
|
||||
-- type family In (MatchNode ) (t :: [TypedAPI OpTree]) where
|
||||
-- Pop '[] =
|
||||
|
||||
type OpTreee :: OpTree -> Type
|
||||
data OpTreee where
|
||||
OpTreee :: OpTree -> OpTreee
|
||||
|
||||
data TypedAPI (t :: OpTreee) where
|
||||
Match' :: forall a t. (Web.ToHttpApiData a, t ~ [TypedAPI OpTreee]) => a -> t -> TypedAPI (OpTreee (MatchNode a t))
|
||||
Param' :: forall a t. (Web.FromHttpApiData a, Typeable.Typeable a, t ~ [TypedAPI OpTreee]) => (Secret.Secret a -> t) -> TypedAPI (OpTreee (ParamNode a t))
|
||||
Method' :: forall (m :: MethodKind) env. (env Natural.~> IO) -> Handler env -> TypedAPI (OpTreee (MethodLeaf m))
|
||||
Loading…
Reference in New Issue
Block a user