Use heterogenous list instead of Secret keys to pass arguments to handlers

This commit is contained in:
Rashad Gover 2023-11-06 19:42:42 -08:00
parent ccb3ca001d
commit 5b13261d30
21 changed files with 7638 additions and 244 deletions

View File

@ -28,10 +28,10 @@ source-repository head
library
exposed-modules:
Okapi
Okapi.Pattern
Okapi.Route.Pattern
Okapi.Headers
Okapi.Secret
Okapi.API
Okapi.App
Okapi.Route
Okapi.Response
other-modules:
@ -53,6 +53,8 @@ library
, natural-transformation
, network
, pretty-simple
, recursion-schemes
, regex-tdfa
, text
, vault
, wai

View File

@ -17,8 +17,6 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE QualifiedDo #-}
-- {-# LANGUAGE RebindableSyntax #-}
module Okapi where
@ -36,23 +34,25 @@ import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Middleware.RequestLogger qualified as Wai
import Okapi.API qualified as API
import Okapi.API
import Okapi.App
import Okapi.App qualified as App
import Okapi.Headers qualified as Headers
import Okapi.Route qualified as Route
import Okapi.Secret qualified as Secret
import Text.Pretty.Simple qualified as Pretty
import Web.HttpApiData qualified as Web
{-
test1 :: IO ()
test1 = do
apiTreeRep <- forest testAPI
putStrLn $ Tree.drawTree apiTreeRep
Warp.run 1234 $ (build testAPI id) backupWaiApp
where
-- Warp.run 1234 $ (build testAPI id) backupWaiApp
backupWaiApp = \req resp -> do
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
testAPI :: [API]
testAPI :: [App]
testAPI =
[ lit
"" -- Won't be matched because you can't request http://localhost:1234/
@ -82,11 +82,12 @@ test2 :: IO ()
test2 = do
apiTreeRep <- forest testAPI
putStrLn $ Tree.drawTree apiTreeRep
Warp.run 1234 $ (build testAPI id) backupWaiApp
where
-- Warp.run 1234 $ (build testAPI id) backupWaiApp
backupWaiApp = \req resp -> do
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
testAPI :: [API]
testAPI :: [App]
testAPI =
lit
"" -- Won't be matched because you can't request http://localhost:1234/
@ -117,11 +118,12 @@ test3 :: IO ()
test3 = do
apiTreeRep <- forest testAPI
putStrLn $ Tree.drawTree apiTreeRep
Warp.run 1234 $ (build testAPI id) backupWaiApp
where
-- Warp.run 1234 $ (build testAPI id) backupWaiApp
backupWaiApp = \_ resp -> do
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
testAPI :: [API]
testAPI :: [App]
testAPI =
[ lit
"numbers"
@ -159,7 +161,7 @@ test4 = do
backupWaiApp = \_ resp -> do
resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
testAPI :: [API]
testAPI :: [App]
testAPI =
[ lit
"numbers"
@ -197,13 +199,14 @@ test5 = do
apiTreeRep <- forest testAPI
-- apiEndpoints <- endpoints testAPI
putStrLn $ Tree.drawTree apiTreeRep
-- Pretty.pPrint $ map curl $ List.reverse apiEndpoints
where
-- Pretty.pPrint $ map curl $ List.reverse apiEndpoints
-- Warp.run 1234 $ build testAPI id backupWaiApp
backupWaiApp = \_ resp -> do
resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
testAPI :: [API]
testAPI :: [App]
testAPI =
[ lit "numbers" $
[ getIO_ \req -> do
@ -212,7 +215,7 @@ test5 = do
++ map opAPI [Add, Sub, Mul]
]
opAPI :: Op -> API
opAPI :: Op -> App
opAPI op =
match
op
@ -241,3 +244,19 @@ opAPI op =
]
_ -> []
]
-}
-- test6 :: IO ()
-- test6 = do
-- apiTreeRep <- forest testAPI
-- putStrLn $ Tree.drawTree apiTreeRep
-- where
-- backupWaiApp = \req resp -> do
-- resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
-- testAPI :: [App]
-- testAPI =
-- [ endpoint HTTP.GET (do Route.lit "user";) id \_ req -> do
-- undefined
-- , endpoint HTTP.POST (do Route.lit "user"; id' <- Route.param @Int; return id') id \userIDS req -> do
-- let userID = Secret.tell req userIDS
-- undefined
-- ]

View File

@ -1,206 +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.API 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 GHC.Natural qualified as Natural
import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as Wai
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 Web.HttpApiData qualified as Web
type Handler env = Wai.Request -> env Wai.Response
data API where
Match :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API
Param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [API]) -> API
Regex :: API
Splat :: forall a. (Web.FromHttpApiData a) => (Secret.Secret (NonEmpty.NonEmpty a) -> [API]) -> API
Route :: forall a. Route.Parser a -> (Secret.Secret a -> [API]) -> API
Method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> API
-- Query :: forall a. Query.Parser a -> (Secret.Secret a -> [API]) -> API
-- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> [API]) -> API
-- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> [API]) -> API
Pipe :: Wai.Middleware -> API -> API
Respond ::
forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
(Response.ToContentType contentType resultType) =>
((Response.Headers headerKeys -> resultType -> Wai.Response) -> [API]) ->
API
match :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API
match = Match
lit :: Text.Text -> [API] -> API
lit = match @Text.Text
param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [API]) -> API
param = Param
splat :: forall a. (Web.FromHttpApiData a) => (Secret.Secret (NonEmpty.NonEmpty a) -> [API]) -> API
splat = Splat
route :: forall a. Route.Parser a -> (Secret.Secret a -> [API]) -> API
route = Route
pipe :: Wai.Middleware -> API -> API
pipe = Pipe
scope :: Wai.Middleware -> Text.Text -> [API] -> API
scope mw t apps = pipe mw $ lit t apps
method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> API
method = Method
respond ::
forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
(Response.ToContentType contentType resultType) =>
((Response.Headers headerKeys -> resultType -> Wai.Response) -> [API]) ->
API
respond = Respond
build :: [API] -> Wai.Middleware -> Wai.Middleware
build [] _ backup req resp = backup req resp
build (api : apis) middlewareToApply backup req resp =
case api of
Match value children ->
case Wai.pathInfo req of
[] -> build apis middlewareToApply backup req resp
(pathHead : pathTail) ->
if pathHead == Web.toUrlPiece value
then do
let newReq = req {Wai.pathInfo = pathTail}
build children middlewareToApply backup newReq resp
else build apis middlewareToApply backup req resp
Param @ty produce ->
case Wai.pathInfo req of
[] -> build apis middlewareToApply backup req resp
(pathHead : pathTail) ->
case Web.parseUrlPiece @ty pathHead of
Left _ -> build apis middlewareToApply backup req resp
Right value -> do
key <- Vault.newKey @ty
let newVault = Vault.insert key value (Wai.vault req)
newReq = req {Wai.pathInfo = pathTail, Wai.vault = newVault}
build (produce $ Secret.Secret key) middlewareToApply backup newReq resp
Splat @ty produce -> do
case Wai.pathInfo req of
[] -> build apis middlewareToApply backup req resp
(pathHead : pathTail) -> case Web.parseUrlPiece @ty pathHead of
Left _ -> build apis middlewareToApply backup req resp
Right valueHead -> do
-- TODO: FIX ALGORITHM!
let valueTail = loop @ty pathTail
nonEmptyPath = valueHead NonEmpty.:| valueTail
key <- Vault.newKey @(NonEmpty.NonEmpty ty)
let newVault = Vault.insert key nonEmptyPath (Wai.vault req)
newReq = req {Wai.pathInfo = List.drop (List.length valueTail + 1) (Wai.pathInfo req), Wai.vault = newVault}
build (produce $ Secret.Secret key) middlewareToApply backup newReq resp
where
loop :: forall ty. (Web.FromHttpApiData ty) => [Text.Text] -> [ty]
loop [] = []
loop (t : ts) = case Web.parseUrlPiece @ty t of
Left _ -> []
Right v -> v : loop @ty ts
Route @ty route produce -> do
case Route.exec route $ Wai.pathInfo req of
(Left _, _) -> build apis middlewareToApply backup req resp
(Right value, newPathInfo) -> do
key <- Vault.newKey @ty
let newVault = Vault.insert key value (Wai.vault req)
newReq = req {Wai.pathInfo = newPathInfo, Wai.vault = newVault}
build (produce $ Secret.Secret key) middlewareToApply backup newReq resp
Method m trans handler ->
case HTTP.parseMethod $ Wai.requestMethod req of
Left _ -> build apis middlewareToApply backup req resp
Right stdMethod ->
if m == stdMethod && List.null (Wai.pathInfo req)
then
middlewareToApply
( \req' resp' -> do
res <- trans $ handler req'
resp' res
)
req
resp
else build apis middlewareToApply backup req resp
Pipe otherMiddlewareToApply app ->
build
(app : [])
(otherMiddlewareToApply . middlewareToApply)
(build apis middlewareToApply backup)
req
resp
forest :: [API] -> IO (Tree.Tree String)
forest [] = return $ Tree.Node ":root:" []
forest apis = do
forest' <- mapM tree apis
return $ Tree.Node "\ESC[31m:root:\ESC[0m" forest'
where
tree :: API -> IO (Tree.Tree 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 (Splat @ty produce) = do
secret <- Secret.new @(NonEmpty.NonEmpty ty)
forest <- mapM tree $ produce secret
return $ Tree.Node "/*" 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 (Pipe _ 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

494
lib/src/Okapi/App.hs Normal file
View File

@ -0,0 +1,494 @@
{-# 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.App 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 = [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
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
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
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 HTTP.GET id testHandler1,
param @Int
[ method HTTP.GET id testHandler2,
lit
"foo"
[ method HTTP.POST id testHandler2
],
param @Float
[ method 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
{-
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)
]
-}

2
lib/src/Okapi/Form.hs Normal file
View File

@ -0,0 +1,2 @@
module Okapi.Form where

View File

@ -94,7 +94,7 @@ insertHeader = InsertHeader
-- Nothing -> (deleteHeader @headerKey rest)
-- Just Typeable.Refl -> rest
data Key (k :: Exts.Symbol) = Key
data HeaderKey (k :: Exts.Symbol) = HeaderKey
-- instance Exts.KnownSymbol k => Show (Var k) where
-- show = Exts.symbolVal
@ -102,7 +102,7 @@ data Key (k :: Exts.Symbol) = Key
-- | Membership test a type class (predicate)
class IsMember (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]) where
-- | Value-level lookup of elements from a map, via type class predicate
lookupHeader :: Key headerKey -> Headers headerKeys -> LBS.ByteString
lookupHeader :: HeaderKey headerKey -> Headers headerKeys -> LBS.ByteString
-- instance {-# OVERLAPS #-} IsMember v t ((v ':-> t) ': m) where
-- lookp _ (Ext _ x _) = x

View File

@ -1,23 +1,25 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Okapi.Route where
import Data.Text
import Data.Typeable
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 :: Text -> Parser ()
Param :: (Typeable a, Web.FromHttpApiData a) => Parser a
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
@ -26,18 +28,25 @@ instance Applicative Parser where
pure = Pure
(<*>) = Apply
param :: (Typeable a, Web.FromHttpApiData a) => Parser a
param = Param
match :: Text -> Parser ()
match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
match = Match
rep :: Parser a -> Text
lit :: Text.Text -> Parser ()
lit = Match @Text.Text
param :: (Typeable.Typeable a, Web.FromHttpApiData a) => Parser a
param = Param
regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> Parser a
regex = Regex
rep :: Parser a -> Text.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)
rep (Match t) = "/" <> Web.toUrlPiece t
rep (Param @p) = "/:" <> Text.pack (show . Typeable.typeRep $ Typeable.Proxy @p)
rep (Regex @ty regex) = "/r(" <> regex <> ")"
-- equals :: Parser a -> Parser b -> Bool
-- equals (FMap _ r) (FMap _ r') = equals r r'
@ -51,5 +60,5 @@ rep (Param @p) = "/:" <> pack (show . typeRep $ Proxy @p)
data Error = Error
exec :: Parser a -> [Text] -> (Either Error a, [Text])
exec = undefined
parse :: Parser a -> [Text.Text] -> (Either Error a, [Text.Text])
parse = undefined

View File

@ -2,18 +2,18 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Okapi.Pattern where
module Okapi.Route.Pattern where
import Data.Text
import Data.Typeable
import Web.HttpApiData qualified as Web
pattern Literal :: forall a. (Web.FromHttpApiData a, Web.ToHttpApiData a) => a -> Text
pattern Literal x <- (Web.parseUrlPiece -> Right x)
pattern Part :: forall a. (Web.FromHttpApiData a, Web.ToHttpApiData a) => a -> Text
pattern Part x <- (Web.parseUrlPiece -> Right x)
where
Literal x = Web.toUrlPiece x
Part x = Web.toUrlPiece x

View File

@ -22,7 +22,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Okapi.API where
module Okapi.App where
import Control.Natural qualified as Natural
import Data.Binary.Builder qualified as Builder

21
newdocs/.gitignore vendored Normal file
View File

@ -0,0 +1,21 @@
# build output
dist/
# generated types
.astro/
# dependencies
node_modules/
# logs
npm-debug.log*
yarn-debug.log*
yarn-error.log*
pnpm-debug.log*
# environment variables
.env
.env.production
# macOS-specific files
.DS_Store

4
newdocs/.vscode/extensions.json vendored Normal file
View File

@ -0,0 +1,4 @@
{
"recommendations": ["astro-build.astro-vscode"],
"unwantedRecommendations": []
}

11
newdocs/.vscode/launch.json vendored Normal file
View File

@ -0,0 +1,11 @@
{
"version": "0.2.0",
"configurations": [
{
"command": "./node_modules/.bin/astro dev",
"name": "Development server",
"request": "launch",
"type": "node-terminal"
}
]
}

47
newdocs/README.md Normal file
View File

@ -0,0 +1,47 @@
# Astro Starter Kit: Minimal
```sh
npm create astro@latest -- --template minimal
```
[![Open in StackBlitz](https://developer.stackblitz.com/img/open_in_stackblitz.svg)](https://stackblitz.com/github/withastro/astro/tree/latest/examples/minimal)
[![Open with CodeSandbox](https://assets.codesandbox.io/github/button-edit-lime.svg)](https://codesandbox.io/p/sandbox/github/withastro/astro/tree/latest/examples/minimal)
[![Open in GitHub Codespaces](https://github.com/codespaces/badge.svg)](https://codespaces.new/withastro/astro?devcontainer_path=.devcontainer/minimal/devcontainer.json)
> 🧑‍🚀 **Seasoned astronaut?** Delete this file. Have fun!
## 🚀 Project Structure
Inside of your Astro project, you'll see the following folders and files:
```text
/
├── public/
├── src/
│ └── pages/
│ └── index.astro
└── package.json
```
Astro looks for `.astro` or `.md` files in the `src/pages/` directory. Each page is exposed as a route based on its file name.
There's nothing special about `src/components/`, but that's where we like to put any Astro/React/Vue/Svelte/Preact components.
Any static assets, like images, can be placed in the `public/` directory.
## 🧞 Commands
All commands are run from the root of the project, from a terminal:
| Command | Action |
| :------------------------ | :----------------------------------------------- |
| `npm install` | Installs dependencies |
| `npm run dev` | Starts local dev server at `localhost:4321` |
| `npm run build` | Build your production site to `./dist/` |
| `npm run preview` | Preview your build locally, before deploying |
| `npm run astro ...` | Run CLI commands like `astro add`, `astro check` |
| `npm run astro -- --help` | Get help using the Astro CLI |
## 👀 Want to learn more?
Feel free to check [our documentation](https://docs.astro.build) or jump into our [Discord server](https://astro.build/chat).

4
newdocs/astro.config.mjs Normal file
View File

@ -0,0 +1,4 @@
import { defineConfig } from 'astro/config';
// https://astro.build/config
export default defineConfig({});

6865
newdocs/package-lock.json generated Normal file

File diff suppressed because it is too large Load Diff

17
newdocs/package.json Normal file
View File

@ -0,0 +1,17 @@
{
"name": "newdocs",
"type": "module",
"version": "0.0.1",
"scripts": {
"dev": "astro dev",
"start": "astro dev",
"build": "astro check && astro build",
"preview": "astro preview",
"astro": "astro"
},
"dependencies": {
"@astrojs/check": "^0.3.0",
"astro": "^3.4.0",
"typescript": "^5.2.2"
}
}

View File

@ -0,0 +1,9 @@
<svg xmlns="http://www.w3.org/2000/svg" fill="none" viewBox="0 0 128 128">
<path d="M50.4 78.5a75.1 75.1 0 0 0-28.5 6.9l24.2-65.7c.7-2 1.9-3.2 3.4-3.2h29c1.5 0 2.7 1.2 3.4 3.2l24.2 65.7s-11.6-7-28.5-7L67 45.5c-.4-1.7-1.6-2.8-2.9-2.8-1.3 0-2.5 1.1-2.9 2.7L50.4 78.5Zm-1.1 28.2Zm-4.2-20.2c-2 6.6-.6 15.8 4.2 20.2a17.5 17.5 0 0 1 .2-.7 5.5 5.5 0 0 1 5.7-4.5c2.8.1 4.3 1.5 4.7 4.7.2 1.1.2 2.3.2 3.5v.4c0 2.7.7 5.2 2.2 7.4a13 13 0 0 0 5.7 4.9v-.3l-.2-.3c-1.8-5.6-.5-9.5 4.4-12.8l1.5-1a73 73 0 0 0 3.2-2.2 16 16 0 0 0 6.8-11.4c.3-2 .1-4-.6-6l-.8.6-1.6 1a37 37 0 0 1-22.4 2.7c-5-.7-9.7-2-13.2-6.2Z" />
<style>
path { fill: #000; }
@media (prefers-color-scheme: dark) {
path { fill: #FFF; }
}
</style>
</svg>

After

Width:  |  Height:  |  Size: 749 B

1
newdocs/src/env.d.ts vendored Normal file
View File

@ -0,0 +1 @@
/// <reference types="astro/client" />

76
newdocs/src/pages/docs.md Normal file
View File

@ -0,0 +1,76 @@
---
---
# Okapi
```haskell
data App where
Match :: forall a. (Web.ToHttpApiData a) => a -> [App] -> App
Param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [App]) -> App
Regex :: forall a. Text -> (Secret.Secret a -> [App]) -> App
Splat :: forall a. (Web.FromHttpApiData a) => (Secret.Secret (NonEmpty.NonEmpty a) -> [App]) -> App
Route :: forall a. Route.Parser a -> (Secret.Secret a -> [App]) -> App
Method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> App
Query :: forall a. Query.Parser a -> (Secret.Secret a -> [App]) -> App
Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> [App]) -> App
-- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> [App]) -> App
Pipe :: Wai.Middleware -> App -> App
Respond ::
forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
(Response.ToContentType contentType resultType) =>
((Response.Headers headerKeys -> resultType -> Wai.Response) -> [App]) ->
App
-- Endpoint :: HTTP.StdMethod -> Route.Parser a -> (env Natural.~> IO) -> App
```
## `endpoint` function
```haskell
endpoint
:: HTTP.StdMethod
-> Route.Parser a
-> (env Natural.~> IO)
-> (Secret.Secret a -> Handler env)
-> App
endpoint stdMethod routeP trans handlerWithSecret = route routeP \routeS ->
[ method stdMethod trans (handlerWithSecret routeS)
]
myAPI :: [App]
myAPI =
[ endpoint GET (do Route.lit "user";) id \_ req -> do
...
, endpoint POST (do Route.lit "user"; Route.param @UserID;) id \userIDS req -> do
let userID = Secret.tell req userIDs
...
]
```
## `on` function
```haskell
on :: Operation a -> (Secret.Secret a -> [App]) -> App
on op ... =
myAPI =
[on|/api|]
[ [on|/v2|]
[ [on|?name:Text|] \nameS ->
[ getIO \req -> do
...
]
, [on|/:Text|] \nameS ->
[ getIO \req -> do
...
]
, [on|/*Int|] \intsS ->
[ method GET id \req -> do
...
]
, [on|{ Accept:Text, XSRF-Token:XSRFToken }|] \headersS ->
[ [on|POST /new/:Int|] id \intS req -> do
...
]
]
]
```

View File

@ -0,0 +1,16 @@
---
---
<html lang="en">
<head>
<meta charset="utf-8" />
<link rel="icon" type="image/svg+xml" href="/favicon.svg" />
<meta name="viewport" content="width=device-width" />
<meta name="generator" content={Astro.generator} />
<title>Astro</title>
</head>
<body>
<h1>Astro</h1>
</body>
</html>

3
newdocs/tsconfig.json Normal file
View File

@ -0,0 +1,3 @@
{
"extends": "astro/tsconfigs/strict"
}