mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-22 08:54:32 +03:00
Fix names; fix Splat combinator; experiment with type-level Response, API, and other parts where it makes sense
This commit is contained in:
Rashad Gover
parent
917caadaec
commit
ccb3ca001d
@ -42,6 +42,7 @@ library
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, base64
|
||||
, binary
|
||||
, bytestring
|
||||
, case-insensitive
|
||||
, containers
|
||||
|
||||
@ -17,6 +17,8 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE QualifiedDo #-}
|
||||
-- {-# LANGUAGE RebindableSyntax #-}
|
||||
|
||||
module Okapi where
|
||||
|
||||
@ -34,7 +36,7 @@ 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 qualified as API
|
||||
import Okapi.API
|
||||
import Okapi.Headers qualified as Headers
|
||||
import Okapi.Route qualified as Route
|
||||
@ -52,21 +54,21 @@ test1 = do
|
||||
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match
|
||||
[ lit
|
||||
"" -- Won't be matched because you can't request http://localhost:1234/
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "The trailing slash"
|
||||
],
|
||||
match
|
||||
lit
|
||||
"hello"
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world",
|
||||
match
|
||||
lit
|
||||
""
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Trailing slash after \"hello\""
|
||||
],
|
||||
match
|
||||
lit
|
||||
"world"
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "!"
|
||||
@ -86,21 +88,21 @@ test2 = do
|
||||
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
match
|
||||
lit
|
||||
"" -- Won't be matched because you can't request http://localhost:1234/
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "The trailing slash"
|
||||
]
|
||||
: match
|
||||
: lit
|
||||
"hello"
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world",
|
||||
match
|
||||
lit
|
||||
""
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Trailing slash after \"hello\""
|
||||
],
|
||||
match
|
||||
lit
|
||||
"world"
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "!"
|
||||
@ -121,14 +123,14 @@ test3 = do
|
||||
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match
|
||||
[ lit
|
||||
"numbers"
|
||||
[ match
|
||||
[ lit
|
||||
"add"
|
||||
[ param @Int \xS ->
|
||||
[ param @Int \yS ->
|
||||
[ getIO_ \req -> do
|
||||
let magic = Secret.reveal req
|
||||
let magic = Secret.tell req
|
||||
x = magic xS
|
||||
y = magic yS
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x + y)
|
||||
@ -159,15 +161,15 @@ test4 = do
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match
|
||||
[ lit
|
||||
"numbers"
|
||||
[ param @Op \opS ->
|
||||
[ param @Int \xS ->
|
||||
[ param @Int \yS ->
|
||||
[ getIO_ \req -> do
|
||||
let x = Secret.reveal req xS
|
||||
y = Secret.reveal req yS
|
||||
answer = case Secret.reveal req opS of
|
||||
let x = Secret.tell req xS
|
||||
y = Secret.tell req yS
|
||||
answer = case Secret.tell req opS of
|
||||
Add -> x + y
|
||||
Sub -> x - y
|
||||
Mul -> x * y
|
||||
@ -175,7 +177,7 @@ test4 = do
|
||||
]
|
||||
],
|
||||
getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ case Secret.reveal req opS of
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ case Secret.tell req opS of
|
||||
Add -> "Add two numbers."
|
||||
Sub -> "Subtract one number from another."
|
||||
Mul -> "Multiply two numbers."
|
||||
@ -193,9 +195,9 @@ instance Web.ToHttpApiData Op where
|
||||
test5 :: IO ()
|
||||
test5 = do
|
||||
apiTreeRep <- forest testAPI
|
||||
apiEndpoints <- endpoints testAPI
|
||||
-- apiEndpoints <- endpoints testAPI
|
||||
putStrLn $ Tree.drawTree apiTreeRep
|
||||
Pretty.pPrint $ map curl $ List.reverse apiEndpoints
|
||||
-- Pretty.pPrint $ map curl $ List.reverse apiEndpoints
|
||||
where
|
||||
-- Warp.run 1234 $ build testAPI id backupWaiApp
|
||||
|
||||
@ -203,7 +205,7 @@ test5 = do
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match "numbers" $
|
||||
[ lit "numbers" $
|
||||
[ getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
|
||||
]
|
||||
@ -212,7 +214,7 @@ test5 = do
|
||||
|
||||
opAPI :: Op -> API
|
||||
opAPI op =
|
||||
lit
|
||||
match
|
||||
op
|
||||
[ getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ case op of
|
||||
@ -222,8 +224,8 @@ opAPI op =
|
||||
param @Int \xS ->
|
||||
[ param @Int \yS ->
|
||||
[ getIO_ \req -> do
|
||||
let x = Secret.reveal req xS
|
||||
y = Secret.reveal req yS
|
||||
let x = Secret.tell req xS
|
||||
y = Secret.tell req yS
|
||||
answer = case op of
|
||||
Add -> x + y
|
||||
Sub -> x - y
|
||||
@ -234,7 +236,7 @@ opAPI op =
|
||||
++ case op of
|
||||
Mul ->
|
||||
[ getIO_ \req -> do
|
||||
let x = Secret.reveal req xS
|
||||
let x = Secret.tell req xS
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x * x)
|
||||
]
|
||||
_ -> []
|
||||
|
||||
@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@ -15,24 +16,33 @@
|
||||
{-# 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
|
||||
@ -40,134 +50,62 @@ import Web.HttpApiData qualified as Web
|
||||
type Handler env = Wai.Request -> env Wai.Response
|
||||
|
||||
data API where
|
||||
Match :: Text.Text -> [API] -> API
|
||||
Match :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API
|
||||
Param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [API]) -> API
|
||||
Splat :: (Secret.Secret (NonEmpty.NonEmpty Text.Text) -> [API]) -> API
|
||||
Router :: forall a. Route.Route a -> (Secret.Secret a -> [API]) -> API
|
||||
Meta :: forall a. Headers.Headers a -> (Secret.Secret a -> [API]) -> API
|
||||
Method :: forall env. (HTTP.StdMethod -> Bool) -> (env Natural.~> IO) -> Handler env -> API
|
||||
Wrap :: Wai.Middleware -> 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 :: Text.Text -> [API] -> API
|
||||
match :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API
|
||||
match = Match
|
||||
|
||||
lit :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API
|
||||
lit l = Match (Web.toUrlPiece l)
|
||||
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 :: (Secret.Secret (NonEmpty.NonEmpty Text.Text) -> [API]) -> API
|
||||
splat :: forall a. (Web.FromHttpApiData a) => (Secret.Secret (NonEmpty.NonEmpty a) -> [API]) -> API
|
||||
splat = Splat
|
||||
|
||||
router :: forall a. Route.Route a -> (Secret.Secret a -> [API]) -> API
|
||||
router = Router
|
||||
route :: forall a. Route.Parser a -> (Secret.Secret a -> [API]) -> API
|
||||
route = Route
|
||||
|
||||
meta :: forall a. Headers.Headers a -> (Secret.Secret a -> [API]) -> API
|
||||
meta = Meta
|
||||
|
||||
wrap :: Wai.Middleware -> API -> API
|
||||
wrap = Wrap
|
||||
pipe :: Wai.Middleware -> API -> API
|
||||
pipe = Pipe
|
||||
|
||||
scope :: Wai.Middleware -> Text.Text -> [API] -> API
|
||||
scope mw t apps = wrap mw $ match t apps
|
||||
scope mw t apps = pipe mw $ lit t apps
|
||||
|
||||
method_ :: forall env. (HTTP.StdMethod -> Bool) -> (env Natural.~> IO) -> Handler env -> API
|
||||
method_ = Method
|
||||
method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> API
|
||||
method = Method
|
||||
|
||||
get_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
get_ = method_ (HTTP.GET ==)
|
||||
|
||||
getIO_ :: Handler IO -> API
|
||||
getIO_ = get_ id
|
||||
|
||||
getPure_ :: Handler Identity.Identity -> API
|
||||
getPure_ = get_ (return . Identity.runIdentity)
|
||||
|
||||
post_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
post_ = method_ (HTTP.POST ==)
|
||||
|
||||
postIO_ :: Handler IO -> API
|
||||
postIO_ = post_ id
|
||||
|
||||
postPure_ :: Handler Identity.Identity -> API
|
||||
postPure_ = post_ (return . Identity.runIdentity)
|
||||
|
||||
head_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
head_ = method_ (HTTP.HEAD ==)
|
||||
|
||||
headIO_ :: Handler IO -> API
|
||||
headIO_ = head_ id
|
||||
|
||||
headPure_ :: Handler Identity.Identity -> API
|
||||
headPure_ = head_ (return . Identity.runIdentity)
|
||||
|
||||
put_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
put_ = method_ (HTTP.PUT ==)
|
||||
|
||||
putIO_ :: Handler IO -> API
|
||||
putIO_ = put_ id
|
||||
|
||||
putPure_ :: Handler Identity.Identity -> API
|
||||
putPure_ = put_ (return . Identity.runIdentity)
|
||||
|
||||
delete_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
delete_ = method_ (HTTP.DELETE ==)
|
||||
|
||||
deleteIO_ :: Handler IO -> API
|
||||
deleteIO_ = delete_ id
|
||||
|
||||
deletePure_ :: Handler Identity.Identity -> API
|
||||
deletePure_ = delete_ (return . Identity.runIdentity)
|
||||
|
||||
trace_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
trace_ = method_ (HTTP.TRACE ==)
|
||||
|
||||
traceIO_ :: Handler IO -> API
|
||||
traceIO_ = trace_ id
|
||||
|
||||
tracePure_ :: Handler Identity.Identity -> API
|
||||
tracePure_ = trace_ (return . Identity.runIdentity)
|
||||
|
||||
connect_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
connect_ = method_ (HTTP.CONNECT ==)
|
||||
|
||||
connectIO_ :: Handler IO -> API
|
||||
connectIO_ = connect_ id
|
||||
|
||||
connectPure_ :: Handler Identity.Identity -> API
|
||||
connectPure_ = connect_ (return . Identity.runIdentity)
|
||||
|
||||
options_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
options_ = method_ (HTTP.OPTIONS ==)
|
||||
|
||||
optionsIO_ :: Handler IO -> API
|
||||
optionsIO_ = options_ id
|
||||
|
||||
optionsPure_ :: Handler Identity.Identity -> API
|
||||
optionsPure_ = options_ (return . Identity.runIdentity)
|
||||
|
||||
patch_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
patch_ = method_ (HTTP.PATCH ==)
|
||||
|
||||
patchIO_ :: Handler IO -> API
|
||||
patchIO_ = patch_ id
|
||||
|
||||
patchPure_ :: Handler Identity.Identity -> API
|
||||
patchPure_ = patch_ (return . Identity.runIdentity)
|
||||
|
||||
any_ :: forall env. (env Natural.~> IO) -> Handler env -> API
|
||||
any_ = method_ (const True)
|
||||
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 text children ->
|
||||
Match value children ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> build apis middlewareToApply backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == text
|
||||
if pathHead == Web.toUrlPiece value
|
||||
then do
|
||||
let newReq = req {Wai.pathInfo = pathTail}
|
||||
build children middlewareToApply backup newReq resp
|
||||
@ -183,16 +121,26 @@ build (api : apis) middlewareToApply backup req resp =
|
||||
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 produce -> do
|
||||
Splat @ty produce -> do
|
||||
case Wai.pathInfo req of
|
||||
[] -> build apis middlewareToApply backup req resp
|
||||
(pathHead : pathTail) -> do
|
||||
let nonEmptyPath = pathHead NonEmpty.:| pathTail
|
||||
key <- Vault.newKey @(NonEmpty.NonEmpty Text.Text)
|
||||
let newVault = Vault.insert key nonEmptyPath (Wai.vault req)
|
||||
newReq = req {Wai.pathInfo = [], Wai.vault = newVault}
|
||||
build (produce $ Secret.Secret key) middlewareToApply backup newReq resp
|
||||
Router @ty route produce -> do
|
||||
(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
|
||||
@ -200,11 +148,11 @@ build (api : apis) middlewareToApply backup req resp =
|
||||
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 pred trans handler ->
|
||||
Method m trans handler ->
|
||||
case HTTP.parseMethod $ Wai.requestMethod req of
|
||||
Left _ -> build apis middlewareToApply backup req resp
|
||||
Right stdMethod ->
|
||||
if pred stdMethod && List.null (Wai.pathInfo req)
|
||||
if m == stdMethod && List.null (Wai.pathInfo req)
|
||||
then
|
||||
middlewareToApply
|
||||
( \req' resp' -> do
|
||||
@ -214,7 +162,7 @@ build (api : apis) middlewareToApply backup req resp =
|
||||
req
|
||||
resp
|
||||
else build apis middlewareToApply backup req resp
|
||||
Wrap otherMiddlewareToApply app ->
|
||||
Pipe otherMiddlewareToApply app ->
|
||||
build
|
||||
(app : [])
|
||||
(otherMiddlewareToApply . middlewareToApply)
|
||||
@ -229,82 +177,30 @@ forest apis = do
|
||||
return $ Tree.Node "\ESC[31m:root:\ESC[0m" forest'
|
||||
where
|
||||
tree :: API -> IO (Tree.Tree String)
|
||||
tree (Match text apis) = do
|
||||
tree (Match value apis) = do
|
||||
forest <- mapM tree apis
|
||||
return $ Tree.Node ("/" <> Text.unpack text) forest
|
||||
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 produce) = do
|
||||
secret <- Secret.new @(NonEmpty.NonEmpty Text.Text)
|
||||
tree (Splat @ty produce) = do
|
||||
secret <- Secret.new @(NonEmpty.NonEmpty ty)
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node "/*" forest
|
||||
tree (Router @ty route produce) = do
|
||||
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 pred _ _) = do
|
||||
return $ Tree.Node (show $ filter pred [minBound ..]) []
|
||||
tree (Wrap _ api) = do
|
||||
tree (Method m _ _) = do
|
||||
return $ Tree.Node (show m) []
|
||||
tree (Pipe _ api) = do
|
||||
(Tree.Node root subTrees) <- tree api
|
||||
return $ Tree.Node ("(" <> root <> ")") subTrees
|
||||
|
||||
data Endpoint = Endpoint [Text.Text] HTTP.StdMethod
|
||||
deriving (Generics.Generic, Eq, Show)
|
||||
|
||||
curl :: Endpoint -> Text.Text
|
||||
curl (Endpoint [] method) = (Text.pack $ show method) <> " :root:"
|
||||
curl (Endpoint path method) = (Text.pack $ show method) <> " /" <> Text.intercalate "/" path
|
||||
|
||||
endpoints :: [API] -> IO [Endpoint]
|
||||
endpoints [] = pure []
|
||||
endpoints (api : apis) = case api of
|
||||
Match text children -> do
|
||||
childrenEndpoints <- map (\(Endpoint path methods) -> Endpoint (text : path) methods) <$> endpoints children
|
||||
siblingEndpoints <- endpoints apis
|
||||
pure $ siblingEndpoints <> childrenEndpoints
|
||||
Param @ty produce -> do
|
||||
secret <- Secret.new @ty
|
||||
childrenEndpoints <- map (\(Endpoint path methods) -> Endpoint (":" <> Text.pack (showType @ty) : path) methods) <$> (endpoints $ produce secret)
|
||||
siblingEndpoints <- endpoints apis
|
||||
pure $ siblingEndpoints <> childrenEndpoints
|
||||
Splat produce -> do
|
||||
secret <- Secret.new @(NonEmpty.NonEmpty Text.Text)
|
||||
childrenEndpoints <- map (\(Endpoint path methods) -> Endpoint ("*" : path) methods) <$> (endpoints $ produce secret)
|
||||
siblingEndpoints <- endpoints apis
|
||||
pure $ siblingEndpoints <> childrenEndpoints
|
||||
Router @ty route produce -> do
|
||||
secret <- Secret.new @ty
|
||||
let routeSegments = Text.split ('/' ==) $ Route.rep route
|
||||
childrenEndpoints <- map (\(Endpoint path methods) -> Endpoint (routeSegments <> path) methods) <$> (endpoints $ produce secret)
|
||||
siblingEndpoints <- endpoints apis
|
||||
pure $ siblingEndpoints <> childrenEndpoints
|
||||
Method pred _ _ -> do
|
||||
siblingEndpoints <- endpoints apis
|
||||
pure $ siblingEndpoints <> (map (Endpoint []) $ filter pred [minBound ..])
|
||||
Wrap _ wrappedAPI -> endpoint wrappedAPI
|
||||
where
|
||||
endpoint :: API -> IO [Endpoint]
|
||||
endpoint api = case api of
|
||||
Match text children -> do
|
||||
childrenEndpoints <- endpoints children
|
||||
pure $ map (\(Endpoint path methods) -> Endpoint (text : path) methods) childrenEndpoints
|
||||
Param @ty produce -> do
|
||||
secret <- Secret.new @ty
|
||||
childrenEndpoints <- endpoints $ produce secret
|
||||
pure $ map (\(Endpoint path methods) -> Endpoint (":" <> Text.pack (showType @ty) : path) methods) childrenEndpoints
|
||||
Splat produce -> do
|
||||
secret <- Secret.new @(NonEmpty.NonEmpty Text.Text)
|
||||
childrenEndpoints <- endpoints $ produce secret
|
||||
pure $ map (\(Endpoint path methods) -> Endpoint ("*" : path) methods) childrenEndpoints
|
||||
Router @ty route produce -> do
|
||||
secret <- Secret.new @ty
|
||||
childrenEndpoints <- endpoints $ produce secret
|
||||
let routeSegments = Text.split ('/' ==) $ Route.rep route
|
||||
pure $ map (\(Endpoint path methods) -> Endpoint (routeSegments <> path) methods) childrenEndpoints
|
||||
Method pred _ _ -> pure (map (Endpoint []) $ filter pred [minBound ..])
|
||||
Wrap _ wrappedAPI -> endpoint wrappedAPI
|
||||
|
||||
showType :: forall a. (Typeable.Typeable a) => String
|
||||
showType = show . Typeable.typeRep $ Typeable.Proxy @a
|
||||
|
||||
get_ = method HTTP.GET
|
||||
|
||||
getIO_ = method HTTP.GET id
|
||||
@ -2,8 +2,10 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@ -14,26 +16,136 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Okapi.Response 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.API qualified as API
|
||||
import Okapi.Headers qualified as Headers
|
||||
import Okapi.Route qualified as Route
|
||||
import Okapi.Secret qualified as Secret
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
class ToHeader a where
|
||||
toHeader :: a -> LBS.ByteString
|
||||
|
||||
type Elem :: Exts.Symbol -> [Exts.Symbol] -> Bool
|
||||
type family Elem x ys where
|
||||
Elem x '[] = 'False
|
||||
Elem x (x ': ys) = 'True
|
||||
Elem x (y ': ys) = Elem x ys
|
||||
|
||||
-- type Remove :: Exts.Symbol -> [Exts.Symbol] -> [Exts.Symbol]
|
||||
-- type family Remove (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]) where
|
||||
-- Remove _ '[] = '[]
|
||||
-- Remove headerKey (h : t) = If (headerKey Equality.== h) t (h : Remove headerKey t)
|
||||
|
||||
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 Headers (headerKeys :: [Exts.Symbol]) where
|
||||
NoHeaders :: Headers '[]
|
||||
InsertHeader ::
|
||||
forall (headerKey :: Exts.Symbol) headerValue (headerKeys :: [Exts.Symbol]).
|
||||
(ToHeader headerValue) =>
|
||||
headerValue ->
|
||||
Headers headerKeys ->
|
||||
Headers (headerKey : headerKeys)
|
||||
|
||||
insertHeader ::
|
||||
forall (headerKey :: Exts.Symbol) headerValue (headerKeys :: [Exts.Symbol]).
|
||||
(ToHeader headerValue) =>
|
||||
headerValue ->
|
||||
Headers headerKeys ->
|
||||
Headers (headerKey : headerKeys)
|
||||
insertHeader = InsertHeader
|
||||
|
||||
-- deleteHeader ::
|
||||
-- forall (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]).
|
||||
-- (Elem headerKey headerKeys ~ True) =>
|
||||
-- Headers headerKeys ->
|
||||
-- Headers (Remove headerKey headerKeys)
|
||||
-- deleteHeader NoHeaders = NoHeaders
|
||||
-- deleteHeader (InsertHeader @k v rest) =
|
||||
-- case Typeable.eqT @headerKey @k of
|
||||
-- Nothing -> (deleteHeader @headerKey rest)
|
||||
-- Just Typeable.Refl -> rest
|
||||
|
||||
data Key (k :: Exts.Symbol) = Key
|
||||
|
||||
-- instance Exts.KnownSymbol k => Show (Var k) where
|
||||
-- show = Exts.symbolVal
|
||||
|
||||
-- | 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
|
||||
|
||||
-- instance {-# OVERLAPS #-} IsMember v t ((v ':-> t) ': m) where
|
||||
-- lookp _ (Ext _ x _) = x
|
||||
|
||||
instance {-# OVERLAPS #-} IsMember headerKey (headerKey ': rest) where
|
||||
lookupHeader _ (InsertHeader v _) = toHeader v
|
||||
|
||||
-- instance {-# OVERLAPPABLE #-} IsMember v t m => IsMember v t (x ': m) where
|
||||
-- lookp v (Ext _ _ m) = lookp v m
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (IsMember headerKey headerKeys) => IsMember headerKey (otherHeaderKey ': headerKeys) where
|
||||
lookupHeader k (InsertHeader _ tail) = lookupHeader k tail
|
||||
|
||||
{-
|
||||
lookupHeader ::
|
||||
forall (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]).
|
||||
(Elem headerKey headerKeys ~ True) =>
|
||||
Headers headerKeys ->
|
||||
LBS.ByteString
|
||||
lookupHeader NoHeaders = undefined
|
||||
lookupHeader (InsertHeader @k v rest) =
|
||||
case Typeable.eqT @headerKey @k of
|
||||
Nothing -> lookupHeader @headerKey rest
|
||||
Just Typeable.Refl -> toHeader v
|
||||
-}
|
||||
|
||||
data Body
|
||||
= BodyStream Wai.StreamingBody
|
||||
| BodyBuilder Builder.Builder
|
||||
| BodyBytes LBS.ByteString
|
||||
| BodyFile FilePath Wai.FilePart
|
||||
|
||||
class ContentType a where
|
||||
contentTypeName :: LBS.ByteString
|
||||
contentTypeBody :: a -> Body
|
||||
|
||||
class (ContentType a) => ToContentType a b | b -> a where
|
||||
toContentType :: b -> a
|
||||
|
||||
data Response (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type) where
|
||||
Response ::
|
||||
forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
|
||||
(ContentType contentType, ToContentType contentType resultType) =>
|
||||
Headers headerKeys ->
|
||||
resultType ->
|
||||
Response status headerKeys contentType resultType
|
||||
|
||||
@ -12,34 +12,34 @@ import Data.Text
|
||||
import Data.Typeable
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
data Route a where
|
||||
FMap :: (a -> b) -> Route a -> Route b
|
||||
Pure :: a -> Route a
|
||||
Apply :: Route (a -> b) -> Route a -> Route b
|
||||
Match :: Text -> Route ()
|
||||
Param :: (Typeable a, Web.FromHttpApiData a) => Route 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 :: Text -> Parser ()
|
||||
Param :: (Typeable a, Web.FromHttpApiData a) => Parser a
|
||||
|
||||
instance Functor Route where
|
||||
instance Functor Parser where
|
||||
fmap = FMap
|
||||
|
||||
instance Applicative Route where
|
||||
instance Applicative Parser where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
param :: (Typeable a, Web.FromHttpApiData a) => Route a
|
||||
param :: (Typeable a, Web.FromHttpApiData a) => Parser a
|
||||
param = Param
|
||||
|
||||
match :: Text -> Route ()
|
||||
match :: Text -> Parser ()
|
||||
match = Match
|
||||
|
||||
rep :: Route a -> Text
|
||||
rep :: Parser 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 :: Route a -> Route b -> Bool
|
||||
-- equals :: Parser a -> Parser 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'
|
||||
@ -51,5 +51,5 @@ rep (Param @p) = "/:" <> pack (show . typeRep $ Proxy @p)
|
||||
|
||||
data Error = Error
|
||||
|
||||
exec :: Route a -> [Text] -> (Either Error a, [Text])
|
||||
exec :: Parser a -> [Text] -> (Either Error a, [Text])
|
||||
exec = undefined
|
||||
@ -28,7 +28,7 @@ newtype Secret a = Secret (Vault.Key a)
|
||||
new :: forall a. IO (Secret a)
|
||||
new = Secret <$> Vault.newKey @a
|
||||
|
||||
reveal :: Wai.Request -> Secret a -> a
|
||||
reveal req (Secret key) = case Vault.lookup key $ Wai.vault req of
|
||||
tell :: Wai.Request -> Secret a -> a
|
||||
tell req (Secret key) = case Vault.lookup key $ Wai.vault req of
|
||||
Nothing -> error "IMPOSSIBLE"
|
||||
Just val -> val
|
||||
|
||||
74
lib/src/Okapi/TypedAPI.hs
Normal file
74
lib/src/Okapi/TypedAPI.hs
Normal file
@ -0,0 +1,74 @@
|
||||
{-# 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 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