mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-22 00:51:34 +03:00
New trie based routing algorithm; helpers for testing, logging, etc.
This commit is contained in:
Rashad Gover
parent
90225e6330
commit
a3caeb9ffb
@ -29,9 +29,11 @@ library
|
||||
exposed-modules:
|
||||
Okapi
|
||||
Okapi.Pattern
|
||||
Okapi.Headers
|
||||
Okapi.Secret
|
||||
Okapi.App
|
||||
Okapi.API
|
||||
Okapi.Route
|
||||
Okapi.Response
|
||||
other-modules:
|
||||
Paths_okapi
|
||||
hs-source-dirs:
|
||||
@ -53,7 +55,8 @@ library
|
||||
, text
|
||||
, vault
|
||||
, wai
|
||||
-- , wai-extra
|
||||
, wai-extra
|
||||
, wai-logger
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
|
||||
|
||||
224
lib/src/Okapi.hs
224
lib/src/Okapi.hs
@ -1,2 +1,226 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QualifiedDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Okapi where
|
||||
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Functor.Identity qualified as Identity
|
||||
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.Typeable qualified as Typeable
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBSChar8
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as Wai
|
||||
import Network.Wai.Middleware.RequestLogger qualified as Wai
|
||||
import Network.Wai.Handler.Warp qualified as Warp
|
||||
-- import Okapi.API qualified as API
|
||||
import Okapi.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
|
||||
|
||||
test1 :: IO ()
|
||||
test1 = do
|
||||
apiTreeRep <- forest testAPI
|
||||
putStrLn $ Tree.drawTree apiTreeRep
|
||||
Warp.run 1234 $ (build testAPI id) backupWaiApp
|
||||
where
|
||||
backupWaiApp = \req resp -> do
|
||||
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match
|
||||
"" -- 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
|
||||
"hello"
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world",
|
||||
match
|
||||
""
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Trailing slash after \"hello\""
|
||||
],
|
||||
match
|
||||
"world"
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "!"
|
||||
]
|
||||
],
|
||||
get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "You made a GET request to :ROOT:"
|
||||
]
|
||||
|
||||
test2 :: IO ()
|
||||
test2 = do
|
||||
apiTreeRep <- forest testAPI
|
||||
putStrLn $ Tree.drawTree apiTreeRep
|
||||
Warp.run 1234 $ (build testAPI id) backupWaiApp
|
||||
where
|
||||
backupWaiApp = \req resp -> do
|
||||
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
match
|
||||
"" -- 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
|
||||
"hello"
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world",
|
||||
match
|
||||
""
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Trailing slash after \"hello\""
|
||||
],
|
||||
match
|
||||
"world"
|
||||
[ get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "!"
|
||||
]
|
||||
]
|
||||
: ( get_ id \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "You made a GET request to :ROOT:"
|
||||
)
|
||||
: []
|
||||
|
||||
test3 :: IO ()
|
||||
test3 = do
|
||||
apiTreeRep <- forest testAPI
|
||||
putStrLn $ Tree.drawTree apiTreeRep
|
||||
Warp.run 1234 $ (build testAPI id) backupWaiApp
|
||||
where
|
||||
backupWaiApp = \_ resp -> do
|
||||
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match "numbers"
|
||||
[ match "add"
|
||||
[ param @Int \xS ->
|
||||
[ param @Int \yS ->
|
||||
[ getIO_ \req -> do
|
||||
let magic = Secret.reveal req
|
||||
x = magic xS
|
||||
y = magic yS
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x + y)
|
||||
]
|
||||
]
|
||||
]
|
||||
, getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
|
||||
]
|
||||
]
|
||||
|
||||
data Op = Add | Sub | Mul
|
||||
|
||||
instance Web.FromHttpApiData Op where
|
||||
parseUrlPiece "add" = Right Add
|
||||
parseUrlPiece "sub" = Right Sub
|
||||
parseUrlPiece "mul" = Right Mul
|
||||
parseUrlPiece _ = Left undefined
|
||||
|
||||
test4 :: IO ()
|
||||
test4 = do
|
||||
apiTreeRep <- forest testAPI
|
||||
putStrLn $ Tree.drawTree apiTreeRep
|
||||
Warp.run 1234 $ Wai.logStdoutDev $ build testAPI id backupWaiApp
|
||||
where
|
||||
backupWaiApp = \_ resp -> do
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match "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
|
||||
Add -> x + y
|
||||
Sub -> x - y
|
||||
Mul -> x * y
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show answer
|
||||
]
|
||||
]
|
||||
, getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ case Secret.reveal req opS of
|
||||
Add -> "Add two numbers."
|
||||
Sub -> "Subtract one number from another."
|
||||
Mul -> "Multiply two numbers."
|
||||
]
|
||||
, getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
|
||||
]
|
||||
]
|
||||
|
||||
instance Web.ToHttpApiData Op where
|
||||
toUrlPiece Add = "add"
|
||||
toUrlPiece Sub = "sub"
|
||||
toUrlPiece Mul = "mul"
|
||||
|
||||
test5 :: IO ()
|
||||
test5 = do
|
||||
apiTreeRep <- forest testAPI
|
||||
putStrLn $ Tree.drawTree apiTreeRep
|
||||
Warp.run 1234 $ build testAPI id backupWaiApp
|
||||
where
|
||||
backupWaiApp = \_ resp -> do
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match "numbers"
|
||||
[ opAPI Add
|
||||
, wrap Wai.logStdoutDev $ opAPI Sub
|
||||
, opAPI Mul
|
||||
, getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
|
||||
]
|
||||
]
|
||||
|
||||
opAPI :: Op -> API
|
||||
opAPI op = lit op
|
||||
[ getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ case op of
|
||||
Add -> "Add two numbers."
|
||||
Sub -> "Subtract one number from another."
|
||||
Mul -> "Multiply two numbers."
|
||||
, param @Int \xS ->
|
||||
[ param @Int \yS ->
|
||||
[ getIO_ \req -> do
|
||||
let x = Secret.reveal req xS
|
||||
y = Secret.reveal req yS
|
||||
answer = case op of
|
||||
Add -> x + y
|
||||
Sub -> x - y
|
||||
Mul -> x * y
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show answer
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
252
lib/src/Okapi/API.hs
Normal file
252
lib/src/Okapi/API.hs
Normal file
@ -0,0 +1,252 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QualifiedDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Okapi.API where
|
||||
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Functor.Identity qualified as Identity
|
||||
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.Typeable qualified as Typeable
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
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
|
||||
|
||||
type Handler env = Wai.Request -> env Wai.Response
|
||||
|
||||
data API where
|
||||
Match :: Text.Text -> [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 :: 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
|
||||
|
||||
match :: Text.Text -> [API] -> API
|
||||
match = Match
|
||||
|
||||
lit :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API
|
||||
lit l = Match (Web.toUrlPiece l)
|
||||
|
||||
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 = Splat
|
||||
|
||||
router :: forall a. Route.Route a -> (Secret.Secret a -> [API]) -> API
|
||||
router = Router
|
||||
|
||||
meta :: forall a. Headers.Headers a -> (Secret.Secret a -> [API]) -> API
|
||||
meta = Meta
|
||||
|
||||
wrap :: Wai.Middleware -> API -> API
|
||||
wrap = Wrap
|
||||
|
||||
scope :: Wai.Middleware -> Text.Text -> [API] -> API
|
||||
scope mw t apps = wrap mw $ match t apps
|
||||
|
||||
method_ :: forall env. (HTTP.StdMethod -> Bool) -> (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)
|
||||
|
||||
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 ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> build apis middlewareToApply backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == text
|
||||
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 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
|
||||
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 pred 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)
|
||||
then
|
||||
middlewareToApply
|
||||
( \req' resp' -> do
|
||||
res <- trans $ handler req'
|
||||
resp' res
|
||||
)
|
||||
req
|
||||
resp
|
||||
else build apis middlewareToApply backup req resp
|
||||
Wrap 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 ":root:" forest'
|
||||
|
||||
tree :: API -> IO (Tree.Tree String)
|
||||
tree (Match text apis) = do
|
||||
forest <- mapM tree apis
|
||||
return $ Tree.Node ("/" <> Text.unpack text) forest
|
||||
tree (Param @ty produce) = do
|
||||
secret <- Secret.new @ty
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node ("/:" <> showType @ty) forest
|
||||
where
|
||||
showType :: forall a. (Typeable.Typeable a) => String
|
||||
showType = show . Typeable.typeRep $ Typeable.Proxy @a
|
||||
tree (Splat produce) = do
|
||||
secret <- Secret.new @(NonEmpty.NonEmpty Text.Text)
|
||||
forest <- mapM tree $ produce secret
|
||||
return $ Tree.Node "/*" forest
|
||||
tree (Router @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.Node root subTrees) <- tree api
|
||||
return $ Tree.Node ("---" <> root <> "->>") subTrees
|
||||
@ -1,254 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QualifiedDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Okapi.App where
|
||||
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Functor.Identity qualified as Identity
|
||||
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.Typeable qualified as Typeable
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as Wai
|
||||
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 App where
|
||||
Match :: Text.Text -> [App] -> App
|
||||
Capture :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [App]) -> App
|
||||
Splat :: (Secret.Secret (NonEmpty.NonEmpty Text.Text) -> [App]) -> App
|
||||
Router :: forall a. Route.Route a -> (Secret.Secret a -> [App]) -> App
|
||||
Method :: forall env. (HTTP.StdMethod -> Bool) -> (env Natural.~> IO) -> Handler env -> App
|
||||
Scope :: Wai.Middleware -> [Text.Text] -> [App] -> App
|
||||
|
||||
match :: Text.Text -> [App] -> App
|
||||
match = Match
|
||||
|
||||
literal :: (Web.ToHttpApiData a) => a -> [App] -> App
|
||||
literal l = Match (Web.toUrlPiece l)
|
||||
|
||||
capture :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [App]) -> App
|
||||
capture = Capture
|
||||
|
||||
splat :: (Secret.Secret (NonEmpty.NonEmpty Text.Text) -> [App]) -> App
|
||||
splat = Splat
|
||||
|
||||
router :: forall a. Route.Route a -> (Secret.Secret a -> [App]) -> App
|
||||
router = Router
|
||||
|
||||
method :: forall env. (HTTP.StdMethod -> Bool) -> (env Natural.~> IO) -> Handler env -> App
|
||||
method = Method
|
||||
|
||||
get :: forall env. (env Natural.~> IO) -> Handler env -> App
|
||||
get = Method (HTTP.GET ==)
|
||||
|
||||
getIO :: Handler IO -> App
|
||||
getIO = get id
|
||||
|
||||
getPure :: Handler Identity.Identity -> App
|
||||
getPure = get (return . Identity.runIdentity)
|
||||
|
||||
any :: forall env. (env Natural.~> IO) -> Handler env -> App
|
||||
any = Method (const True)
|
||||
|
||||
scope :: Wai.Middleware -> [Text.Text] -> [App] -> App
|
||||
scope = Scope
|
||||
|
||||
release :: Wai.Request -> Secret.Secret a -> a
|
||||
release req (Secret.Secret key) = case Vault.lookup key $ Wai.vault req of
|
||||
Nothing -> error "IMPOSSIBLE"
|
||||
Just val -> val
|
||||
|
||||
middleware :: App -> Wai.Middleware
|
||||
middleware app backup req resp = do
|
||||
case app of
|
||||
Match text apps ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == text
|
||||
then do
|
||||
let newReq = req {Wai.pathInfo = pathTail}
|
||||
middleware' id apps backup newReq resp
|
||||
else backup req resp
|
||||
Capture @ty genApps ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @ty pathHead of
|
||||
Left _ -> 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}
|
||||
middleware' id (genApps $ Secret.Secret key) backup newReq resp
|
||||
Splat genApps -> do
|
||||
case Wai.pathInfo req of
|
||||
[] -> 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}
|
||||
middleware' id (genApps $ Secret.Secret key) backup newReq resp
|
||||
Router @ty route genApps -> do
|
||||
case Route.exec route $ Wai.pathInfo req of
|
||||
(Left _, _) -> 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}
|
||||
middleware' id (genApps $ Secret.Secret key) backup newReq resp
|
||||
Method pred trans handler ->
|
||||
case HTTP.parseMethod $ Wai.requestMethod req of
|
||||
Left _ -> backup req resp
|
||||
Right stdMethod ->
|
||||
if pred stdMethod
|
||||
then do
|
||||
res <- trans $ handler req
|
||||
resp res
|
||||
else backup req resp
|
||||
Scope middlewareToApply prefix apps ->
|
||||
if prefix `List.isPrefixOf` Wai.pathInfo req
|
||||
then do
|
||||
let newReq = req {Wai.pathInfo = drop (length prefix) (Wai.pathInfo req)}
|
||||
middleware' middlewareToApply apps backup newReq resp
|
||||
else backup req resp
|
||||
|
||||
middleware' :: Wai.Middleware -> [App] -> Wai.Middleware
|
||||
middleware' _ [] backup req resp = backup req resp
|
||||
middleware' middlewareToApply (appsHead : appsTail) backup req resp =
|
||||
case appsHead of
|
||||
Match text apps ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> middleware' middlewareToApply appsTail backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == text
|
||||
then do
|
||||
let newReq = req {Wai.pathInfo = pathTail}
|
||||
middleware' middlewareToApply apps backup newReq resp
|
||||
else middleware' middlewareToApply appsTail backup req resp
|
||||
Capture @ty genApps ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> middleware' middlewareToApply appsTail backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @ty pathHead of
|
||||
Left _ -> middleware' middlewareToApply appsTail 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}
|
||||
middleware' middlewareToApply (genApps $ Secret.Secret key) backup newReq resp
|
||||
Splat genApps -> do
|
||||
case Wai.pathInfo req of
|
||||
[] -> middleware' middlewareToApply appsTail 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}
|
||||
middleware' middlewareToApply (genApps $ Secret.Secret key) backup newReq resp
|
||||
Router @ty route genApps -> do
|
||||
case Route.exec route $ Wai.pathInfo req of
|
||||
(Left _, _) -> middleware' middlewareToApply appsTail 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}
|
||||
middleware' middlewareToApply (genApps $ Secret.Secret key) backup newReq resp
|
||||
Method pred trans handler ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> case HTTP.parseMethod $ Wai.requestMethod req of
|
||||
Left _ -> middleware' middlewareToApply appsTail backup req resp
|
||||
Right stdMethod ->
|
||||
if pred stdMethod
|
||||
then middlewareToApply (\req' resp' -> do res <- trans $ handler req'; resp' res) req resp
|
||||
else middleware' middlewareToApply appsTail backup req resp
|
||||
_ -> middleware' middlewareToApply appsTail backup req resp
|
||||
Scope otherMiddlewareToApply prefix apps ->
|
||||
if prefix `List.isPrefixOf` Wai.pathInfo req
|
||||
then do
|
||||
let newReq = req {Wai.pathInfo = drop (length prefix) (Wai.pathInfo req)}
|
||||
middleware' (otherMiddlewareToApply . middlewareToApply) apps backup newReq resp
|
||||
else middleware' middlewareToApply appsTail backup req resp
|
||||
|
||||
tree :: App -> IO (Tree.Tree String)
|
||||
tree (Match text apps) = do
|
||||
forest <- mapM tree apps
|
||||
return $ Tree.Node ("/" <> Text.unpack text) forest
|
||||
tree (Capture @ty genApps) = do
|
||||
secret <- Secret.newSecret @ty
|
||||
forest <- mapM tree $ genApps secret
|
||||
return $ Tree.Node ("/:" <> showType @ty) forest
|
||||
tree (Splat genApps) = do
|
||||
secret <- Secret.newSecret @(NonEmpty.NonEmpty Text.Text)
|
||||
forest <- mapM tree $ genApps secret
|
||||
return $ Tree.Node "/*" forest
|
||||
tree (Router @ty route genApps) = do
|
||||
secret <- Secret.newSecret @ty
|
||||
forest <- mapM tree $ genApps secret
|
||||
return $ Tree.Node (Text.unpack (Route.rep route)) forest
|
||||
tree (Method pred _ _) = do
|
||||
return $ Tree.Node (List.intercalate " | " (map show $ filter pred [minBound ..])) []
|
||||
tree (Scope _ prefix apps) = do
|
||||
forest <- mapM tree apps
|
||||
return $ Tree.Node ("/(" <> List.intercalate "/" (map Text.unpack prefix) <> ")") forest
|
||||
|
||||
showType :: forall a. (Typeable.Typeable a) => String
|
||||
showType = show . Typeable.typeRep $ Typeable.Proxy @a
|
||||
|
||||
myApp =
|
||||
match
|
||||
"app"
|
||||
[ capture @Text.Text \text ->
|
||||
[ get id \req -> do
|
||||
undefined,
|
||||
capture @Int \age ->
|
||||
[ get id \req -> do
|
||||
let text' = release req text
|
||||
age' = release req age
|
||||
undefined
|
||||
],
|
||||
scope
|
||||
id
|
||||
["lol", "hello"]
|
||||
[ get id \req -> do
|
||||
undefined,
|
||||
match
|
||||
"null"
|
||||
[ get id \req -> do
|
||||
undefined
|
||||
]
|
||||
]
|
||||
],
|
||||
match
|
||||
"faq"
|
||||
[ get id \req -> do
|
||||
undefined,
|
||||
method (`elem` [HTTP.POST, HTTP.PUT, HTTP.PATCH]) id \req -> do
|
||||
undefined
|
||||
]
|
||||
]
|
||||
55
lib/src/Okapi/Headers.hs
Normal file
55
lib/src/Okapi/Headers.hs
Normal file
@ -0,0 +1,55 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- {-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Okapi.Headers where
|
||||
|
||||
import Data.Text
|
||||
import Data.Typeable
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
data Headers a where
|
||||
FMap :: (a -> b) -> Headers a -> Headers b
|
||||
Pure :: a -> Headers a
|
||||
Apply :: Headers (a -> b) -> Headers a -> Headers b
|
||||
Match :: Text -> Headers ()
|
||||
Param :: (Typeable a, Web.FromHttpApiData a) => Headers a
|
||||
|
||||
instance Functor Headers where
|
||||
fmap = FMap
|
||||
|
||||
instance Applicative Headers where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
param :: (Typeable a, Web.FromHttpApiData a) => Headers a
|
||||
param = Param
|
||||
|
||||
match :: Text -> Headers ()
|
||||
match = Match
|
||||
|
||||
rep :: Headers a -> Text
|
||||
rep (FMap _ dsl) = rep dsl
|
||||
rep (Pure x) = ""
|
||||
rep (Apply aF aX) = rep aF <> rep aX
|
||||
rep (Match t) = "/" <> t
|
||||
rep (Param @p) = "/:" <> pack (show . typeRep $ Proxy @p)
|
||||
|
||||
-- equals :: Headers a -> Headers b -> Bool
|
||||
-- equals (FMap _ r) (FMap _ r') = equals r r'
|
||||
-- equals (Pure _) (Pure _) = True
|
||||
-- equals (Apply af ap) (Apply af' ap') = equals af af' && equals ap ap'
|
||||
-- equals (Static t) (Static t') = t == t'
|
||||
-- equals (Param @a) (Param @b) = case heqT @a @b of
|
||||
-- Nothing -> False
|
||||
-- Just HRefl -> True
|
||||
-- equals _ _ = False
|
||||
|
||||
data Error = Error
|
||||
|
||||
exec :: Headers a -> [Text] -> (Either Error a, [Text])
|
||||
exec = undefined
|
||||
39
lib/src/Okapi/Response.hs
Normal file
39
lib/src/Okapi/Response.hs
Normal file
@ -0,0 +1,39 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QualifiedDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Okapi.Response where
|
||||
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Functor.Identity qualified as Identity
|
||||
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.Typeable qualified as Typeable
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
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
|
||||
|
||||
|
||||
@ -21,8 +21,14 @@
|
||||
module Okapi.Secret where
|
||||
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
import Network.Wai qualified as Wai
|
||||
|
||||
newtype Secret a = Secret (Vault.Key a)
|
||||
|
||||
newSecret :: forall a. IO (Secret a)
|
||||
newSecret = Secret <$> Vault.newKey
|
||||
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
|
||||
Nothing -> error "IMPOSSIBLE"
|
||||
Just val -> val
|
||||
|
||||
Loading…
Reference in New Issue
Block a user