mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-22 00:51:34 +03:00
Clean up modules
This commit is contained in:
Rashad Gover
parent
90008469bb
commit
c582d29faf
@ -28,19 +28,9 @@ source-repository head
|
||||
library
|
||||
exposed-modules:
|
||||
Okapi
|
||||
Tree
|
||||
-- Okapi.DSL
|
||||
-- Okapi.DSL.Alternative
|
||||
-- Okapi.DSL.Applicative
|
||||
-- Okapi.Parser.Body
|
||||
-- Okapi.Parser.Headers
|
||||
Okapi.Parser.Path
|
||||
-- Okapi.Parser.Query
|
||||
-- Okapi.Parser.Request
|
||||
-- Okapi.Parser.Path
|
||||
Okapi.NewDSL
|
||||
Okapi.Pattern
|
||||
Okapi.Tree
|
||||
Okapi.Secret
|
||||
Okapi.App
|
||||
Okapi.Route
|
||||
other-modules:
|
||||
Paths_okapi
|
||||
|
||||
@ -18,7 +18,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Tree where
|
||||
module Okapi.App where
|
||||
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Functor.Identity qualified as Identity
|
||||
@ -30,40 +30,31 @@ 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
|
||||
|
||||
newtype Secret a = Secret (Vault.Key a)
|
||||
|
||||
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 a -> [App]) -> App
|
||||
Splat :: (Secret [Text.Text] -> [App]) -> App
|
||||
Router :: forall a. Route.Route a -> (Secret a -> [App]) -> App
|
||||
Capture :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [App]) -> App
|
||||
Splat :: (Secret.Secret [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
|
||||
|
||||
match :: Text.Text -> [App] -> App
|
||||
match = Match
|
||||
|
||||
(/?) = match
|
||||
|
||||
literal :: (Web.ToHttpApiData a) => a -> [App] -> App
|
||||
literal l = Match (Web.toUrlPiece l)
|
||||
|
||||
(/==) :: (Web.ToHttpApiData a) => a -> [App] -> App
|
||||
(/==) = literal
|
||||
|
||||
capture :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret a -> [App]) -> App
|
||||
capture :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [App]) -> App
|
||||
capture = Capture
|
||||
|
||||
(/:) :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret a -> [App]) -> App
|
||||
(/:) = capture
|
||||
|
||||
splat :: (Secret [Text.Text] -> [App]) -> App
|
||||
splat :: (Secret.Secret [Text.Text] -> [App]) -> App
|
||||
splat = Splat
|
||||
|
||||
router :: forall a. Route.Route a -> (Secret a -> [App]) -> App
|
||||
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
|
||||
@ -81,6 +72,128 @@ getPure = get (return . Identity.runIdentity)
|
||||
any :: forall env. (env Natural.~> IO) -> Handler env -> App
|
||||
any = Method (const True)
|
||||
|
||||
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' 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' (genApps $ Secret.Secret key) backup newReq resp
|
||||
Splat genApps -> do
|
||||
key <- Vault.newKey @[Text.Text]
|
||||
let newVault = Vault.insert key (Wai.pathInfo req) (Wai.vault req)
|
||||
newReq = req {Wai.pathInfo = [], Wai.vault = newVault}
|
||||
middleware' (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' (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
|
||||
|
||||
middleware' :: [App] -> Wai.Middleware
|
||||
middleware' [] backup req resp = backup req resp
|
||||
middleware' (appsHead : appsTail) backup req resp =
|
||||
case appsHead of
|
||||
Match text apps ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> middleware' appsTail backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == text
|
||||
then do
|
||||
let newReq = req {Wai.pathInfo = pathTail}
|
||||
middleware' apps backup newReq resp
|
||||
else middleware' appsTail backup req resp
|
||||
Capture @ty genApps ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> middleware' appsTail backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @ty pathHead of
|
||||
Left _ -> middleware' 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' (genApps $ Secret.Secret key) backup newReq resp
|
||||
Splat genApps -> do
|
||||
key <- Vault.newKey @[Text.Text]
|
||||
let newVault = Vault.insert key (Wai.pathInfo req) (Wai.vault req)
|
||||
newReq = req {Wai.pathInfo = [], Wai.vault = newVault}
|
||||
middleware' (genApps $ Secret.Secret key) backup newReq resp
|
||||
Router @ty route genApps -> do
|
||||
case Route.exec route $ Wai.pathInfo req of
|
||||
(Left _, _) -> middleware' 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' (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' appsTail backup req resp
|
||||
Right stdMethod ->
|
||||
if pred stdMethod
|
||||
then do
|
||||
res <- trans $ handler req
|
||||
resp res
|
||||
else middleware' appsTail backup req resp
|
||||
_ -> middleware' 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 @[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 ..])) []
|
||||
|
||||
showType :: forall a. (Typeable.Typeable a) => String
|
||||
showType = show . Typeable.typeRep $ Typeable.Proxy @a
|
||||
|
||||
myApp =
|
||||
match
|
||||
"app"
|
||||
@ -102,165 +215,3 @@ myApp =
|
||||
undefined
|
||||
]
|
||||
]
|
||||
|
||||
myApp' =
|
||||
"app"
|
||||
/? [ (/:) \(text :: Secret Text.Text) ->
|
||||
[ get id \req -> do
|
||||
undefined,
|
||||
capture @Int \age ->
|
||||
[ get id \req -> do
|
||||
let text' = release req text
|
||||
age' = release req age
|
||||
undefined
|
||||
]
|
||||
],
|
||||
(5 :: Int)
|
||||
/== [ getPure \req -> do
|
||||
undefined
|
||||
, splat \args ->
|
||||
[ method (HTTP.HEAD==) id \req -> undefined
|
||||
]
|
||||
],
|
||||
match
|
||||
"faq"
|
||||
[ get id \req -> do
|
||||
undefined,
|
||||
method (`elem` [HTTP.POST, HTTP.PUT, HTTP.PATCH]) id \req -> do
|
||||
undefined
|
||||
]
|
||||
]
|
||||
|
||||
release :: Wai.Request -> Secret a -> a
|
||||
release req (Secret key) = case Vault.lookup key $ Wai.vault req of
|
||||
Nothing -> error "IMPOSSIBLE"
|
||||
Just val -> val
|
||||
|
||||
toWaiApplication :: App -> Wai.Middleware
|
||||
toWaiApplication 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}
|
||||
toWaiApplication' 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}
|
||||
toWaiApplication' (genApps $ Secret key) backup newReq resp
|
||||
Splat genApps -> do
|
||||
key <- Vault.newKey @[Text.Text]
|
||||
let newVault = Vault.insert key (Wai.pathInfo req) (Wai.vault req)
|
||||
newReq = req {Wai.pathInfo = [], Wai.vault = newVault}
|
||||
toWaiApplication' (genApps $ 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}
|
||||
toWaiApplication' (genApps $ 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
|
||||
|
||||
toWaiApplication' :: [App] -> Wai.Middleware
|
||||
toWaiApplication' [] backup req resp = backup req resp
|
||||
toWaiApplication' (appsHead : appsTail) backup req resp =
|
||||
case appsHead of
|
||||
Match text apps ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> toWaiApplication' appsTail backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == text
|
||||
then do
|
||||
let newReq = req {Wai.pathInfo = pathTail}
|
||||
toWaiApplication' apps backup newReq resp
|
||||
else toWaiApplication' appsTail backup req resp
|
||||
Capture @ty genApps ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> toWaiApplication' appsTail backup req resp
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @ty pathHead of
|
||||
Left _ -> toWaiApplication' 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}
|
||||
toWaiApplication' (genApps $ Secret key) backup newReq resp
|
||||
Splat genApps -> do
|
||||
key <- Vault.newKey @[Text.Text]
|
||||
let newVault = Vault.insert key (Wai.pathInfo req) (Wai.vault req)
|
||||
newReq = req {Wai.pathInfo = [], Wai.vault = newVault}
|
||||
toWaiApplication' (genApps $ Secret key) backup newReq resp
|
||||
Router @ty route genApps -> do
|
||||
case Route.exec route $ Wai.pathInfo req of
|
||||
(Left _, _) -> toWaiApplication' 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}
|
||||
toWaiApplication' (genApps $ Secret key) backup newReq resp
|
||||
Method pred trans handler ->
|
||||
case Wai.pathInfo req of
|
||||
[] -> case HTTP.parseMethod $ Wai.requestMethod req of
|
||||
Left _ -> toWaiApplication' appsTail backup req resp
|
||||
Right stdMethod ->
|
||||
if pred stdMethod
|
||||
then do
|
||||
res <- trans $ handler req
|
||||
resp res
|
||||
else toWaiApplication' appsTail backup req resp
|
||||
_ -> toWaiApplication' appsTail backup req resp
|
||||
|
||||
toTree :: App -> IO (Tree.Tree String)
|
||||
toTree (Match text apps) = do
|
||||
forest <- mapM toTree apps
|
||||
return $ Tree.Node ("/" <> Text.unpack text) forest
|
||||
toTree (Capture @ty genApps) = do
|
||||
secret <- newSecret @ty
|
||||
forest <- mapM toTree $ genApps secret
|
||||
return $ Tree.Node ("/{:" <> showType @ty <> "}") forest
|
||||
toTree (Splat genApps) = do
|
||||
secret <- newSecret @[Text.Text]
|
||||
forest <- mapM toTree $ genApps secret
|
||||
return $ Tree.Node "/*" forest
|
||||
toTree (Router @ty route genApps) = do
|
||||
secret <- newSecret @ty
|
||||
forest <- mapM toTree $ genApps secret
|
||||
return $ Tree.Node (Text.unpack (Route.rep route)) forest
|
||||
toTree (Method pred _ _) = do
|
||||
return $ Tree.Node (List.intercalate " | " (map show $ filter pred [minBound ..])) []
|
||||
|
||||
showType :: forall a. (Typeable.Typeable a) => String
|
||||
showType = show . Typeable.typeRep $ Typeable.Proxy @a
|
||||
|
||||
newSecret :: forall a. IO (Secret a)
|
||||
newSecret = Secret <$> Vault.newKey
|
||||
|
||||
{-
|
||||
data App where
|
||||
Match :: Text.Text -> [App] -> App
|
||||
Capture :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret a -> [App]) -> App
|
||||
Splat :: (Secret [Text.Text] -> [App]) -> App
|
||||
Router :: forall a. Route.Route a -> (Secret a -> [App]) -> App
|
||||
Method :: forall env. (HTTP.StdMethod -> Bool) -> (env Natural.~> IO) -> Handler env -> App
|
||||
-}
|
||||
@ -1,9 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
|
||||
module Okapi.DSL where
|
||||
|
||||
class DSL expr input error output where
|
||||
eval :: expr -> input -> (Either error output, input)
|
||||
@ -1,51 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module Okapi.DSL.Alternative where
|
||||
|
||||
import Okapi.Tree
|
||||
import Okapi.DSL
|
||||
|
||||
-- 3 possibilities:
|
||||
-- 1. No errors. Just output. Means nothing went wrong.
|
||||
-- 2. Some errors. Just output. Means something went wrong, but program was able to recover.
|
||||
-- 3. Errors. Nothing output. Means everything went wrong.
|
||||
|
||||
-- exec :: DSL expr input error => Program expr input (Tree error) (Maybe output) -> input -> (Maybe output, (input, Tree error))
|
||||
-- exec (FMap f prog) input = case exec prog input of
|
||||
-- (Nothing, (input', eTree)) -> (Nothing, (input', eTree))
|
||||
-- (Just o, (input', eTree)) -> (Just o, (input', eTree))
|
||||
-- exec (Pure x) input = (Just x, (input, Nil))
|
||||
-- exec (Apply progF progX) input = case exec progF input of
|
||||
-- (Just f, (input', eTreeF)) -> case exec progX input of
|
||||
-- (Just x, (input'', eTreeX)) -> (Just $ f x, (input'', eTreeF :->: eTreeX ))
|
||||
-- (Nothing, (input'', eTreeX)) -> (Nothing, (input'', eTreeF :->: eTreeX))
|
||||
-- (Nothing, (input', eTreeF)) -> (Nothing, (input', eTreeF))
|
||||
-- eval Empty input = (Nothing, (input, Nil))
|
||||
-- eval (Or progA progB) input = case exec progA input of
|
||||
-- (Just a, (input', eTreeA)) -> (Just a, (input', eTreeA))
|
||||
-- (Nothing, (_, eTreeA)) -> case exec progB input of
|
||||
-- (Just b, (input', eTreeB)) -> (Just b, (input', eTreeA :<|>: eTreeB))
|
||||
-- (Nothing, (input', eTreeB)) -> (Nothing, (input', eTreeA :<|>: eTreeB))
|
||||
-- exec (Expr expr) input = case eval expr input of
|
||||
-- (Left error, input') -> (Nothing, (input', Leaf error))
|
||||
-- (Right x, input') -> (Just x, (input', Nil))
|
||||
|
||||
-- data Program expr input error output where
|
||||
-- FMap :: (output -> output') -> Program expr input error output -> Program expr input error output'
|
||||
-- Pure :: output -> Program expr input error output
|
||||
-- Apply :: Program expr input error (output -> output') -> Program expr input error output -> Program expr input error output'
|
||||
-- Empty :: Program expr input error output
|
||||
-- Or :: Program expr input error output -> Program expr input error output -> Program expr input error output
|
||||
-- Expr :: expr -> Program expr input error output
|
||||
|
||||
-- instance Functor (Program expr input error) where
|
||||
-- fmap = FMap
|
||||
|
||||
-- instance Applicative (Program expr input error) where
|
||||
-- pure = Pure
|
||||
-- (<*>) = Apply
|
||||
|
||||
-- instance Alternative (Program expr input error) where
|
||||
-- empty = Empty
|
||||
-- (<|>) = Or
|
||||
@ -1,31 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module Okapi.DSL.Applicative where
|
||||
|
||||
import Okapi.DSL
|
||||
|
||||
-- data Program expr input error output where
|
||||
-- FMap :: (output -> output') -> Program expr input error output -> Program expr input error output'
|
||||
-- Pure :: output -> Program expr input error output
|
||||
-- Apply :: Program expr input error (output -> output') -> Program expr input error output -> Program expr input error output'
|
||||
-- Expr :: expr -> Program expr input error output
|
||||
|
||||
-- exec :: forall expr input error output. DSL expr input error output => Program expr input error output -> input -> (Either error output, input)
|
||||
-- exec (FMap f prog) input = case exec @expr @input @error @output prog input of
|
||||
-- (Left e, input') -> (Left e, input')
|
||||
-- (Right o, input') -> (Right $ f o, input')
|
||||
-- exec (Pure x) input = (Right x, input)
|
||||
-- exec (Apply progF progX) input = case exec progF input of
|
||||
-- (Right f, input') -> case exec progX input' of
|
||||
-- (Right x, input'') -> (Right $ f x, input'')
|
||||
-- (Left e, input'') -> (Left e, input'')
|
||||
-- (Left e, input') -> (Left e, input')
|
||||
-- exec (Expr expr) input = eval expr input
|
||||
|
||||
-- instance Functor (Program expr input error) where
|
||||
-- fmap = FMap
|
||||
|
||||
-- instance Applicative (Program expr input error) where
|
||||
-- pure = Pure
|
||||
-- (<*>) = Apply
|
||||
@ -1,48 +0,0 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
module Okapi.NewDSL where
|
||||
import Data.Kind (Type)
|
||||
import Data.Typeable
|
||||
|
||||
-- type Interpreter (expr :: * -> *) state error a = state -> expr a -> (Either error a, state)
|
||||
|
||||
class Context (expr :: * -> *) state error where
|
||||
eval :: state -> expr a -> (Either error a, state)
|
||||
|
||||
data DSL (expr :: * -> *) state error a where
|
||||
FMap :: (a -> b) -> DSL expr state error a -> DSL expr state error b
|
||||
Pure :: a -> DSL expr state error a
|
||||
Apply :: DSL expr state error (a -> b) -> DSL expr state error a -> DSL expr state error b
|
||||
-- Eval :: Interpreter expr state error a -> expr a -> DSL expr state error a
|
||||
Expr :: Context expr state error => expr a -> DSL expr state error a -- Call Quote?
|
||||
-- Add constructor for Combinator??
|
||||
-- deriving (Typeable)
|
||||
|
||||
instance Functor (DSL expr state error) where
|
||||
fmap = FMap
|
||||
|
||||
instance Applicative (DSL expr state error) where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
exec :: Context expr state error => state -> DSL expr state error a -> (Either error a, state)
|
||||
exec state (FMap f expr) = case exec state expr of
|
||||
(Left e, state') -> (Left e, state')
|
||||
(Right o, state') -> (Right $ f o, state')
|
||||
exec state (Pure x) = (Right x, state)
|
||||
exec state (Apply progF progX) = case exec state progF of
|
||||
(Right f, state') -> case exec state' progX of
|
||||
(Right x, state'') -> (Right $ f x, state'')
|
||||
(Left e, state'') -> (Left e, state'')
|
||||
(Left e, state') -> (Left e, state')
|
||||
exec state (Expr expr) = eval state expr
|
||||
|
||||
-- expr :: Context expr state error => expr a -> DSL expr state error a
|
||||
-- expr = Expr
|
||||
@ -1 +0,0 @@
|
||||
module Okapi.Parser.Body where
|
||||
@ -1 +0,0 @@
|
||||
module Okapi.Parser.Headers where
|
||||
@ -1,119 +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.Parser.Path where
|
||||
|
||||
import Control.Natural
|
||||
import Data.Data (Typeable)
|
||||
import Data.Function ((&))
|
||||
import Data.Kind
|
||||
import Data.Map
|
||||
import Data.Text
|
||||
import Data.Typeable
|
||||
import GHC.Base (undefined)
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as Wai
|
||||
import Okapi.NewDSL
|
||||
import Okapi.Route qualified as Route
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
type Handler env = Wai.Request -> env Wai.Response
|
||||
|
||||
data API where
|
||||
Router :: forall a env. (env ~> IO) -> Route.Route a -> (a -> Handler env) -> API
|
||||
Endpoint :: forall a env. (env ~> IO) -> (HTTP.StdMethod -> Bool) -> Route.Route a -> (a -> Handler env) -> API
|
||||
MethodMap :: forall a env. (env ~> IO) -> Route.Route a -> Map HTTP.StdMethod (a -> Handler env) -> API
|
||||
Scope :: Wai.Middleware -> [Text] -> [API] -> API
|
||||
DynScope :: Wai.Middleware -> Route.Route a -> (a -> [API]) -> API
|
||||
|
||||
router :: forall a env. (env ~> IO) -> Route.Route a -> (a -> Handler env) -> API
|
||||
router = Router
|
||||
|
||||
endpoint :: forall a env. (env ~> IO) -> (HTTP.StdMethod -> Bool) -> Route.Route a -> (a -> Handler env) -> API
|
||||
endpoint = Endpoint @a @env
|
||||
|
||||
get_ :: Int -> Int -> Int
|
||||
get_ = undefined
|
||||
|
||||
methodMap :: forall a env. (env ~> IO) -> Route.Route a -> Map HTTP.StdMethod (a -> Handler env) -> API
|
||||
methodMap = MethodMap @a @env
|
||||
|
||||
scope :: Wai.Middleware -> [Text] -> [API] -> API
|
||||
scope = Scope
|
||||
|
||||
dynScope :: Wai.Middleware -> Route.Route a -> (a -> [API]) -> API
|
||||
dynScope = DynScope
|
||||
|
||||
helloWorld :: Route.Route (Text, Int)
|
||||
helloWorld = do
|
||||
_ <- Route.static "hello"
|
||||
_ <- Route.static "world"
|
||||
name <- Route.param @Text
|
||||
age <- Route.param @Int
|
||||
pure (name, age)
|
||||
|
||||
helloWorld' :: Route.Route (Text, Int)
|
||||
helloWorld' = do
|
||||
_ <- Route.static "helloz"
|
||||
_ <- Route.static "world"
|
||||
name <- Route.param @Text
|
||||
age <- Route.param @Int
|
||||
pure (name, age)
|
||||
|
||||
helloWorld'' :: Route.Route (Text, Int)
|
||||
helloWorld'' = do
|
||||
_ <- Route.static "hello"
|
||||
_ <- Route.static "world"
|
||||
age <- Route.param @Int
|
||||
name <- Route.param @Text
|
||||
pure (name, age)
|
||||
|
||||
data Person = Person {name :: Text, age :: Int, salary :: Float}
|
||||
|
||||
xRoute :: Route.Route Int
|
||||
xRoute = do
|
||||
_ <- Route.static "x"
|
||||
x <- Route.param @Int
|
||||
pure x
|
||||
|
||||
yRoute :: Route.Route Int
|
||||
yRoute = do
|
||||
_ <- Route.static "y"
|
||||
y <- Route.param @Int
|
||||
pure y
|
||||
|
||||
zRoute :: Route.Route Int
|
||||
zRoute = do
|
||||
_ <- Route.static "z"
|
||||
x <- xRoute
|
||||
y <- yRoute
|
||||
pure (x + y)
|
||||
|
||||
xyRoute :: Route.Route (Int, Int)
|
||||
xyRoute = do
|
||||
_ <- Route.static "xy"
|
||||
x <- xRoute
|
||||
y <- yRoute
|
||||
pure (x, y)
|
||||
|
||||
data Datum = Datum {foo :: Int, bar :: Int, baz :: Int}
|
||||
|
||||
convert :: forall a. Typeable a => String
|
||||
convert = show . typeRep $ Proxy @a
|
||||
@ -1 +0,0 @@
|
||||
module Okapi.Parser.Query where
|
||||
@ -1 +0,0 @@
|
||||
module Okapi.Parser.Request where
|
||||
@ -1,137 +1,19 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Okapi.Pattern where
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Network.Wai qualified as Wai
|
||||
import Data.Text
|
||||
import Data.Typeable
|
||||
import Web.HttpApiData qualified as Web
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Data.Tuple.Extra qualified as Extra
|
||||
import Network.Socket qualified as Socket
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
|
||||
pattern Match
|
||||
:: HTTP.Method
|
||||
-> HTTP.HttpVersion
|
||||
-> HTTP.RequestHeaders
|
||||
-> Bool
|
||||
-> Socket.SockAddr
|
||||
-> [Text.Text]
|
||||
-> HTTP.Query
|
||||
-> IO BS.ByteString
|
||||
-> Vault.Vault
|
||||
-> Wai.RequestBodyLength
|
||||
-> Maybe BS.ByteString
|
||||
-> Maybe BS.ByteString
|
||||
-> Maybe BS.ByteString
|
||||
-> Maybe BS.ByteString
|
||||
-> Wai.Request
|
||||
pattern Match
|
||||
{ method
|
||||
, version
|
||||
, headers
|
||||
, isSecure
|
||||
, host
|
||||
, path
|
||||
, query
|
||||
, bodyStream
|
||||
, vault
|
||||
, bodyLength
|
||||
, headerHost
|
||||
, headerRange
|
||||
, headerReferer
|
||||
, headerUserAgent
|
||||
} <-
|
||||
( match ->
|
||||
( method
|
||||
, version
|
||||
, headers
|
||||
, isSecure
|
||||
, host
|
||||
, path
|
||||
, query
|
||||
, bodyStream
|
||||
, vault
|
||||
, bodyLength
|
||||
, headerHost
|
||||
, headerRange
|
||||
, headerReferer
|
||||
, headerUserAgent
|
||||
)
|
||||
)
|
||||
|
||||
match
|
||||
:: Wai.Request
|
||||
-> ( HTTP.Method
|
||||
, HTTP.HttpVersion
|
||||
, HTTP.RequestHeaders
|
||||
, Bool
|
||||
, Socket.SockAddr
|
||||
, [Text.Text]
|
||||
, HTTP.Query
|
||||
, IO BS.ByteString
|
||||
, Vault.Vault
|
||||
, Wai.RequestBodyLength
|
||||
, Maybe BS.ByteString
|
||||
, Maybe BS.ByteString
|
||||
, Maybe BS.ByteString
|
||||
, Maybe BS.ByteString
|
||||
)
|
||||
match request =
|
||||
( Wai.requestMethod request
|
||||
, Wai.httpVersion request
|
||||
, Wai.requestHeaders request
|
||||
, Wai.isSecure request
|
||||
, Wai.remoteHost request
|
||||
, Wai.pathInfo request
|
||||
, Wai.queryString request
|
||||
, Wai.getRequestBodyChunk request
|
||||
, Wai.vault request
|
||||
, Wai.requestBodyLength request
|
||||
, Wai.requestHeaderHost request
|
||||
, Wai.requestHeaderRange request
|
||||
, Wai.requestHeaderReferer request
|
||||
, Wai.requestHeaderUserAgent request
|
||||
)
|
||||
{-
|
||||
pattern Endpoint :: HTTP.Method -> [Text.Text] -> Wai.Request
|
||||
pattern Endpoint method path <- Match { method, path }
|
||||
pattern Literal :: forall a. (Web.FromHttpApiData a, Web.ToHttpApiData a) => a -> Text
|
||||
pattern Literal x <- (Web.parseUrlPiece -> Right x)
|
||||
where
|
||||
Endpoint method path = Wai.defaultRequest { Wai.requestMethod = method, Wai.pathInfo = path }
|
||||
-}
|
||||
pattern Param :: (Web.FromHttpApiData a, Web.ToHttpApiData a) => a -> Text.Text
|
||||
pattern Param x <- (Web.parseUrlPiece -> Right x)
|
||||
where
|
||||
Param x = Web.toUrlPiece x
|
||||
|
||||
pattern GET :: HTTP.Method
|
||||
pattern GET = "GET"
|
||||
|
||||
pattern POST :: HTTP.Method
|
||||
pattern POST = "POST"
|
||||
|
||||
pattern PUT :: HTTP.Method
|
||||
pattern PUT = "PUT"
|
||||
|
||||
pattern HEAD :: HTTP.Method
|
||||
pattern HEAD = "HEAD"
|
||||
|
||||
pattern DELETE :: HTTP.Method
|
||||
pattern DELETE = "DELETE"
|
||||
|
||||
pattern TRACE :: HTTP.Method
|
||||
pattern TRACE = "TRACE"
|
||||
|
||||
pattern CONNECT :: HTTP.Method
|
||||
pattern CONNECT = "CONNECT"
|
||||
|
||||
pattern OPTIONS :: HTTP.Method
|
||||
pattern OPTIONS = "OPTIONS"
|
||||
|
||||
pattern PATCH :: HTTP.Method
|
||||
pattern PATCH = "PATCH"
|
||||
Literal x = Web.toUrlPiece x
|
||||
|
||||
@ -16,15 +16,9 @@ data Route a where
|
||||
FMap :: (a -> b) -> Route a -> Route b
|
||||
Pure :: a -> Route a
|
||||
Apply :: Route (a -> b) -> Route a -> Route b
|
||||
Static :: Text -> Route ()
|
||||
Match :: Text -> Route ()
|
||||
Param :: (Typeable a, Web.FromHttpApiData a) => Route a
|
||||
|
||||
param :: (Typeable a, Web.FromHttpApiData a) => Route a
|
||||
param = Param
|
||||
|
||||
static :: Text -> Route ()
|
||||
static = Static
|
||||
|
||||
instance Functor Route where
|
||||
fmap = FMap
|
||||
|
||||
@ -32,6 +26,19 @@ instance Applicative Route where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
param :: (Typeable a, Web.FromHttpApiData a) => Route a
|
||||
param = Param
|
||||
|
||||
match :: Text -> Route ()
|
||||
match = Match
|
||||
|
||||
rep :: Route 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 (FMap _ r) (FMap _ r') = equals r r'
|
||||
-- equals (Pure _) (Pure _) = True
|
||||
@ -42,13 +49,6 @@ instance Applicative Route where
|
||||
-- Just HRefl -> True
|
||||
-- equals _ _ = False
|
||||
|
||||
rep :: Route a -> Text
|
||||
rep (FMap _ dsl) = rep dsl
|
||||
rep (Pure x) = ""
|
||||
rep (Apply aF aX) = rep aF <> rep aX
|
||||
rep (Static t) = "/" <> t
|
||||
rep (Param @p) = "/{:" <> pack (show . typeRep $ Proxy @p) <> "}"
|
||||
|
||||
data Error = Error
|
||||
|
||||
exec :: Route a -> [Text] -> (Either Error a, [Text])
|
||||
|
||||
28
lib/src/Okapi/Secret.hs
Normal file
28
lib/src/Okapi/Secret.hs
Normal file
@ -0,0 +1,28 @@
|
||||
{-# 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.Secret where
|
||||
|
||||
import Data.Vault.Lazy qualified as Vault
|
||||
|
||||
newtype Secret a = Secret (Vault.Key a)
|
||||
|
||||
newSecret :: forall a. IO (Secret a)
|
||||
newSecret = Secret <$> Vault.newKey
|
||||
@ -1,7 +0,0 @@
|
||||
module Okapi.Tree where
|
||||
|
||||
data Tree a =
|
||||
Nil
|
||||
| Leaf a
|
||||
| Tree a :->: Tree a
|
||||
| Tree a :<|>: Tree a
|
||||
Loading…
Reference in New Issue
Block a user