mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-24 02:48:03 +03:00
Use heterogenous list instead of Secret keys to pass arguments to handlers
This commit is contained in:
parent
ccb3ca001d
commit
5b13261d30
@ -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
|
||||
|
@ -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
|
||||
-- ]
|
||||
|
@ -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
494
lib/src/Okapi/App.hs
Normal 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
2
lib/src/Okapi/Form.hs
Normal file
@ -0,0 +1,2 @@
|
||||
module Okapi.Form where
|
||||
|
@ -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
|
||||
|
@ -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
|
@ -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
|
@ -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
21
newdocs/.gitignore
vendored
Normal 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
4
newdocs/.vscode/extensions.json
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
{
|
||||
"recommendations": ["astro-build.astro-vscode"],
|
||||
"unwantedRecommendations": []
|
||||
}
|
11
newdocs/.vscode/launch.json
vendored
Normal file
11
newdocs/.vscode/launch.json
vendored
Normal 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
47
newdocs/README.md
Normal 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
4
newdocs/astro.config.mjs
Normal 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
6865
newdocs/package-lock.json
generated
Normal file
File diff suppressed because it is too large
Load Diff
17
newdocs/package.json
Normal file
17
newdocs/package.json
Normal 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"
|
||||
}
|
||||
}
|
9
newdocs/public/favicon.svg
Normal file
9
newdocs/public/favicon.svg
Normal 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
1
newdocs/src/env.d.ts
vendored
Normal file
@ -0,0 +1 @@
|
||||
/// <reference types="astro/client" />
|
76
newdocs/src/pages/docs.md
Normal file
76
newdocs/src/pages/docs.md
Normal 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
|
||||
...
|
||||
]
|
||||
]
|
||||
]
|
||||
```
|
16
newdocs/src/pages/index.astro
Normal file
16
newdocs/src/pages/index.astro
Normal 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
3
newdocs/tsconfig.json
Normal file
@ -0,0 +1,3 @@
|
||||
{
|
||||
"extends": "astro/tsconfigs/strict"
|
||||
}
|
Loading…
Reference in New Issue
Block a user