mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-22 00:51:34 +03:00
Add example APIs for testing potential API; add pretty printers
This commit is contained in:
Rashad Gover
parent
a3caeb9ffb
commit
917caadaec
@ -21,6 +21,8 @@
|
||||
module Okapi where
|
||||
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBSChar8
|
||||
import Data.Functor.Identity qualified as Identity
|
||||
import Data.List qualified as List
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
@ -28,17 +30,16 @@ 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 Network.Wai.Middleware.RequestLogger qualified as Wai
|
||||
-- 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 Text.Pretty.Simple qualified as Pretty
|
||||
import Web.HttpApiData qualified as Web
|
||||
|
||||
test1 :: IO ()
|
||||
@ -120,8 +121,10 @@ test3 = do
|
||||
resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match "numbers"
|
||||
[ match "add"
|
||||
[ match
|
||||
"numbers"
|
||||
[ match
|
||||
"add"
|
||||
[ param @Int \xS ->
|
||||
[ param @Int \yS ->
|
||||
[ getIO_ \req -> do
|
||||
@ -131,8 +134,8 @@ test3 = do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x + y)
|
||||
]
|
||||
]
|
||||
]
|
||||
, getIO_ \req -> do
|
||||
],
|
||||
getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
|
||||
]
|
||||
]
|
||||
@ -143,19 +146,21 @@ instance Web.FromHttpApiData Op where
|
||||
parseUrlPiece "add" = Right Add
|
||||
parseUrlPiece "sub" = Right Sub
|
||||
parseUrlPiece "mul" = Right Mul
|
||||
parseUrlPiece _ = Left undefined
|
||||
parseUrlPiece _ = Left undefined
|
||||
|
||||
test4 :: IO ()
|
||||
test4 = do
|
||||
apiTreeRep <- forest testAPI
|
||||
putStrLn $ Tree.drawTree apiTreeRep
|
||||
Warp.run 1234 $ Wai.logStdoutDev $ build testAPI id backupWaiApp
|
||||
where
|
||||
-- Warp.run 1234 $ Wai.logStdoutDev $ build testAPI id backupWaiApp
|
||||
|
||||
backupWaiApp = \_ resp -> do
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
|
||||
testAPI :: [API]
|
||||
testAPI =
|
||||
[ match "numbers"
|
||||
[ match
|
||||
"numbers"
|
||||
[ param @Op \opS ->
|
||||
[ param @Int \xS ->
|
||||
[ param @Int \yS ->
|
||||
@ -168,14 +173,14 @@ test4 = do
|
||||
Mul -> x * y
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show answer
|
||||
]
|
||||
]
|
||||
, getIO_ \req -> do
|
||||
],
|
||||
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
|
||||
],
|
||||
getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
|
||||
]
|
||||
]
|
||||
@ -188,39 +193,49 @@ instance Web.ToHttpApiData Op where
|
||||
test5 :: IO ()
|
||||
test5 = do
|
||||
apiTreeRep <- forest testAPI
|
||||
apiEndpoints <- endpoints testAPI
|
||||
putStrLn $ Tree.drawTree apiTreeRep
|
||||
Warp.run 1234 $ build testAPI id backupWaiApp
|
||||
Pretty.pPrint $ map curl $ List.reverse apiEndpoints
|
||||
where
|
||||
-- Warp.run 1234 $ build testAPI id backupWaiApp
|
||||
|
||||
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
|
||||
[ match "numbers" $
|
||||
[ getIO_ \req -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
|
||||
]
|
||||
++ map opAPI [Add, Sub, 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
|
||||
]
|
||||
]
|
||||
]
|
||||
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
|
||||
]
|
||||
]
|
||||
++ case op of
|
||||
Mul ->
|
||||
[ getIO_ \req -> do
|
||||
let x = Secret.reveal req xS
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x * x)
|
||||
]
|
||||
_ -> []
|
||||
]
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
@ -28,6 +29,7 @@ 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 GHC.Generics qualified as Generics
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as Wai
|
||||
import Okapi.Headers qualified as Headers
|
||||
@ -42,7 +44,7 @@ data API where
|
||||
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
|
||||
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
|
||||
|
||||
@ -224,29 +226,85 @@ 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
|
||||
return $ Tree.Node "\ESC[31m:root:\ESC[0m" 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
|
||||
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
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user