mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-22 08:54:32 +03:00
Separate examples
This commit is contained in:
Rashad Gover
parent
9e578bad59
commit
9eef8d3a74
@ -36,7 +36,7 @@ library
|
||||
Okapi.App
|
||||
Okapi.Route
|
||||
Okapi.Response
|
||||
Example
|
||||
Example.Calculator
|
||||
other-modules:
|
||||
Paths_okapi
|
||||
hs-source-dirs:
|
||||
|
||||
@ -26,7 +26,7 @@
|
||||
|
||||
{-# HLINT ignore "Use if" #-}
|
||||
|
||||
module Example where
|
||||
module Example.Calculator where
|
||||
|
||||
import Control.Natural qualified as Natural
|
||||
import Data.Binary.Builder qualified as Builder
|
||||
@ -204,18 +204,6 @@ flatten (Choice (node1 : node2 : nodes)) = case node1 `combine` node2 of
|
||||
]
|
||||
flatten node = node
|
||||
|
||||
argsTest :: Handler '[] IO
|
||||
argsTest = \request -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
|
||||
argsTest1 :: Handler '[Int] IO
|
||||
argsTest1 = \x -> \request -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
|
||||
argsTest2 :: Handler '[Int, Int] IO
|
||||
argsTest2 = \x -> \y -> \request -> do
|
||||
return $ Wai.responseLBS HTTP.status200 [] "world"
|
||||
|
||||
choice ::
|
||||
forall (r :: [Type]).
|
||||
-- (Typeable.Typeable r) =>
|
||||
@ -339,143 +327,6 @@ endpoint ::
|
||||
endpoint stdMethod transformation handler =
|
||||
route @a $ method @env @(r :-> a) stdMethod transformation handler
|
||||
|
||||
myTest =
|
||||
Warp.run 8081 $ test `withDefault` \_ resp ->
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
myTest2 =
|
||||
Warp.run 8082 $ test2 `withDefault` \_ resp ->
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
data HelloWorldBody = HelloWorldBody deriving (Typeable.Typeable)
|
||||
|
||||
data ByeWorldBody = ByeWorldBody {error :: Text.Text, randomN :: Int} deriving (Typeable.Typeable)
|
||||
|
||||
instance Response.ToContentType Text.Text HelloWorldBody where
|
||||
toContentType HelloWorldBody = "Hello World! :)"
|
||||
|
||||
instance Response.ToContentType Text.Text ByeWorldBody where
|
||||
toContentType (ByeWorldBody _error _randomN) = "Bye World... :("
|
||||
|
||||
-- test :: _
|
||||
test =
|
||||
lit "some"
|
||||
. myOtherResponders
|
||||
. lit "world"
|
||||
. param @Float
|
||||
$ method
|
||||
HTTP.GET
|
||||
id
|
||||
testHandle
|
||||
|
||||
-- testHandle :: _
|
||||
testHandle = \helloWorld byeWorld watWorld float (req :: Wai.Request) -> do
|
||||
undefined
|
||||
|
||||
test2 =
|
||||
choice
|
||||
[ lit "some"
|
||||
. lit "path"
|
||||
$ choice
|
||||
[ method HTTP.GET id \req -> do
|
||||
undefined
|
||||
, method HTTP.POST id \req -> do
|
||||
undefined
|
||||
]
|
||||
, param @Float
|
||||
$ method HTTP.PUT id \float req -> do
|
||||
undefined
|
||||
, choice
|
||||
[ somePath $ method HTTP.GET id \helloWorld byeWorld n -> do
|
||||
undefined
|
||||
, lit "bar"
|
||||
. match @Int 10
|
||||
. somePath
|
||||
$ method HTTP.PATCH id undefined
|
||||
, lit "baz"
|
||||
$ choice
|
||||
[ method HTTP.GET id \req -> do
|
||||
undefined
|
||||
, param @Float $ method HTTP.PUT id \f req -> do
|
||||
undefined
|
||||
]
|
||||
]
|
||||
]
|
||||
where
|
||||
somePath =
|
||||
lit "lol"
|
||||
. lit "foo"
|
||||
. myResponders
|
||||
. param @Int
|
||||
|
||||
myResponders =
|
||||
responder @200 @'["HELLO-HEADER"] @Text.Text @HelloWorldBody
|
||||
. responder @204 @'["BYE-HEADER"] @Text.Text @ByeWorldBody
|
||||
|
||||
myOtherResponders =
|
||||
responder @200 @'["HELLO-HEADER"] @Text.Text @HelloWorldBody
|
||||
. responder @500 @'["BYE-HEADER"] @Text.Text @ByeWorldBody
|
||||
. responder @404 @'["WAT-HEADER"] @Text.Text @HelloWorldBody
|
||||
|
||||
helloWorldApp =
|
||||
helloWorld `withDefault` \_ resp ->
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
helloWorld = (lit "hello" . lit "world" . responder @200 @'[] @Text.Text @Text.Text . method HTTP.GET id) \greeting req -> undefined
|
||||
|
||||
helloWorldApp' =
|
||||
helloWorld' `withDefault` \_ resp ->
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
helloWorld' =
|
||||
(responder @200 @'[] @Text.Text @Text.Text . method HTTP.GET id) \greet _req -> do
|
||||
return $ greet Response.NoHeaders "Hello World!"
|
||||
|
||||
helloWorldApp'' =
|
||||
helloWorld'' `withDefault` \_ resp ->
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
helloWorldPath'' =
|
||||
lit "hello"
|
||||
. lit "world"
|
||||
. responder @200 @'[] @Text.Text @Text.Text
|
||||
. method HTTP.GET id
|
||||
|
||||
helloWorld'' = helloWorldPath'' \greeting _req -> do
|
||||
return $ greeting Response.NoHeaders "Hello World!"
|
||||
|
||||
worldApp =
|
||||
world `withDefault` \_ resp ->
|
||||
resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
|
||||
|
||||
world =
|
||||
choice
|
||||
[ helloWorldPathz \hi _req -> do
|
||||
return $ hi Response.NoHeaders "Hello World!"
|
||||
, byeWorldPathz \bye _req -> do
|
||||
return $ bye Response.NoHeaders "Bye World..."
|
||||
]
|
||||
|
||||
helloWorldPathz =
|
||||
lit "hello"
|
||||
. lit "world"
|
||||
. responder @200 @'[] @Text.Text @Text.Text
|
||||
. method HTTP.GET id
|
||||
|
||||
byeWorldPathz =
|
||||
lit "bye"
|
||||
. lit "world"
|
||||
. responder @500 @'[] @Text.Text @Text.Text
|
||||
. method HTTP.GET id
|
||||
|
||||
testHandler1 :: Bool -> Wai.Request -> IO Wai.Response
|
||||
testHandler1 x request = do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show x
|
||||
|
||||
testHandler2 :: Bool -> Int -> Wai.Request -> IO Wai.Response
|
||||
testHandler2 x y request = do
|
||||
return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show x <> show y
|
||||
|
||||
data HList (l :: [Type]) where
|
||||
HNil :: HList '[]
|
||||
HCons :: e -> HList l -> HList (e ': l)
|
||||
@ -488,16 +339,6 @@ fillHandler :: Handler args env -> HList args -> (Wai.Request -> env Wai.Respons
|
||||
fillHandler handler HNil = handler
|
||||
fillHandler handler (HCons x xs) = fillHandler (handler x) xs
|
||||
|
||||
myFunc :: Wai.Request -> IO Wai.Response
|
||||
myFunc = fillHandler handlerTest argsTest
|
||||
where
|
||||
handlerTest :: Handler [Bool, Int, Float] IO
|
||||
handlerTest = \b -> \i -> \f -> \req -> do
|
||||
undefined
|
||||
|
||||
argsTest :: HList [Bool, Int, Float]
|
||||
argsTest = HCons True (HCons 5 (HCons 5.8 HNil))
|
||||
|
||||
withDefault :: Node '[] -> Wai.Middleware
|
||||
withDefault = withDefaultLoop id HNil
|
||||
|
||||
@ -548,188 +389,11 @@ withDefaultLoop middleware args root backup request respond = case root of
|
||||
respond
|
||||
else withDefaultLoop middleware args (choice nodes) backup request respond
|
||||
root' -> withDefaultLoop middleware args (choice [root']) backup request respond
|
||||
{-
|
||||
Match value subNode ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> withDefaultLoop middleware args (choice nodes) backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == Web.toUrlPiece value
|
||||
then do
|
||||
let newRequest = request{Wai.pathInfo = pathTail}
|
||||
withDefaultLoop middleware args subNode backup newRequest respond
|
||||
else withDefaultLoop middleware args (choice nodes) backup request respond
|
||||
Param @p subNode ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> withDefaultLoop middleware args (choice nodes) backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @p pathHead of
|
||||
Left _ -> withDefaultLoop middleware args (choice nodes) backup request respond
|
||||
Right value -> do
|
||||
let newRequest = request{Wai.pathInfo = pathTail}
|
||||
withDefaultLoop middleware (snoc args value) subNode backup newRequest respond
|
||||
Responder @s @hk @ct @rt @r subNode ->
|
||||
let callback = Response.makeResponder @s @hk @ct @rt
|
||||
in withDefaultLoop
|
||||
middleware
|
||||
(snoc args callback)
|
||||
(choice [subNode])
|
||||
(withDefaultLoop middleware args (choice nodes) backup)
|
||||
request
|
||||
respond
|
||||
Method stdMethod transformation handler ->
|
||||
case HTTP.parseMethod $ Wai.requestMethod request of
|
||||
Left _ -> withDefaultLoop middleware args (choice nodes) backup request respond
|
||||
Right stdMethod' ->
|
||||
if stdMethod == stdMethod' && List.null (Wai.pathInfo request)
|
||||
then
|
||||
middleware
|
||||
( \request' respond' -> do
|
||||
response <- transformation $ fillHandler handler args request'
|
||||
respond' response
|
||||
)
|
||||
request
|
||||
respond
|
||||
else withDefaultLoop middleware args (choice nodes) backup request respond
|
||||
-}
|
||||
{-
|
||||
withDefaultLoop middleware args tree backup request respond = case tree of
|
||||
[] -> backup request respond
|
||||
(node : remTree) ->
|
||||
case node of
|
||||
Match value subTree ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> withDefaultLoop middleware args remTree backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == Web.toUrlPiece value
|
||||
then do
|
||||
let newRequest = request{Wai.pathInfo = pathTail}
|
||||
withDefaultLoop middleware args subTree backup newRequest respond
|
||||
else withDefaultLoop middleware args remTree backup request respond
|
||||
Param @t subTree ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> withDefaultLoop middleware args remTree backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @t pathHead of
|
||||
Left _ -> withDefaultLoop middleware args remTree backup request respond
|
||||
Right value -> do
|
||||
let newRequest = request{Wai.pathInfo = pathTail}
|
||||
withDefaultLoop middleware (snoc args value) subTree backup newRequest respond
|
||||
Method stdMethod transformation handler ->
|
||||
case HTTP.parseMethod $ Wai.requestMethod request of
|
||||
Left _ -> withDefaultLoop middleware args remTree backup request respond
|
||||
Right stdMethod' ->
|
||||
if stdMethod == stdMethod' && List.null (Wai.pathInfo request)
|
||||
then
|
||||
middleware
|
||||
( \request' respond' -> do
|
||||
response <- transformation $ fillHandler handler args request'
|
||||
respond' response
|
||||
)
|
||||
request
|
||||
respond
|
||||
else withDefaultLoop middleware args remTree backup request respond
|
||||
Responder @s @hk @ct @rt @r child ->
|
||||
let callback = Response.makeResponder @s @hk @ct @rt
|
||||
in withDefaultLoop
|
||||
middleware
|
||||
(snoc args callback)
|
||||
(child : [])
|
||||
(withDefaultLoop middleware args remTree backup)
|
||||
request
|
||||
respond
|
||||
-}
|
||||
|
||||
---- TODO: May need system for content-type negotiation???
|
||||
---- The accepted content types can be the same or more
|
||||
---- If Accept is less than the responseses content types, then I can't go down that tree
|
||||
|
||||
{-
|
||||
withDefault :: Tree -> Wai.Middleware
|
||||
withDefault = loop id
|
||||
where
|
||||
loop :: Wai.Middleware -> Tree -> Wai.Middleware
|
||||
loop middleware forest backup request respond = case forest of
|
||||
[] -> backup request respond
|
||||
(tree : remForest) ->
|
||||
case tree of
|
||||
Match value subForest ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> loop middleware remForest backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
if pathHead == Web.toUrlPiece value
|
||||
then do
|
||||
let newRequest = request {Wai.pathInfo = pathTail}
|
||||
loop middleware subForest backup newRequest respond
|
||||
else loop middleware remForest backup request respond
|
||||
Param @t growSubForest ->
|
||||
case Wai.pathInfo request of
|
||||
[] -> loop middleware remForest backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
case Web.parseUrlPiece @t pathHead of
|
||||
Left _ -> loop middleware remForest backup request respond
|
||||
Right value -> do
|
||||
key <- Vault.newKey @t
|
||||
let newVault = Vault.insert key value (Wai.vault request)
|
||||
newRequest = request {Wai.pathInfo = pathTail, Wai.vault = newVault}
|
||||
loop middleware (growSubForest $ Secret.Secret key) backup newRequest respond
|
||||
Regex @t regex growSubForest -> do
|
||||
case Wai.pathInfo request of
|
||||
[] -> loop middleware remForest backup request respond
|
||||
(pathHead : pathTail) ->
|
||||
case pathHead Regex.=~~ regex of
|
||||
Nothing -> loop middleware remForest backup request respond
|
||||
Just value -> do
|
||||
key <- Vault.newKey @t
|
||||
let newVault = Vault.insert key value (Wai.vault request)
|
||||
newRequest = request {Wai.pathInfo = pathTail, Wai.vault = newVault}
|
||||
loop middleware (growSubForest $ Secret.Secret key) backup newRequest respond
|
||||
Splat @t growSubForest -> do
|
||||
case Wai.pathInfo request of
|
||||
[] -> loop middleware remForest backup request respond
|
||||
(pathHead : pathTail) -> case Web.parseUrlPiece @t pathHead of
|
||||
Left _ -> loop middleware remForest backup request respond
|
||||
Right valueHead -> do
|
||||
key <- Vault.newKey @(NonEmpty.NonEmpty t)
|
||||
let valueTail = getValues @t pathTail
|
||||
nonEmptyPath = valueHead NonEmpty.:| valueTail
|
||||
newVault = Vault.insert key nonEmptyPath (Wai.vault request)
|
||||
newRequest = request {Wai.pathInfo = List.drop (List.length valueTail + 1) (Wai.pathInfo request), Wai.vault = newVault}
|
||||
loop middleware (growSubForest $ Secret.Secret key) backup newRequest respond
|
||||
where
|
||||
getValues :: forall ty. (Web.FromHttpApiData t) => [Text.Text] -> [t]
|
||||
getValues [] = []
|
||||
getValues (p : ps) = case Web.parseUrlPiece @t p of
|
||||
Left _ -> []
|
||||
Right v -> v : getValues @t ps
|
||||
Route @t route growSubForest -> do
|
||||
case Route.parse route $ Wai.pathInfo request of
|
||||
(Left _, _) -> loop middleware remForest backup request respond
|
||||
(Right value, newPathInfo) -> do
|
||||
key <- Vault.newKey @t
|
||||
let newVault = Vault.insert key value (Wai.vault request)
|
||||
newRequest = request {Wai.pathInfo = newPathInfo, Wai.vault = newVault}
|
||||
loop middleware (growSubForest $ Secret.Secret key) backup newRequest respond
|
||||
Method stdMethod transformation handler ->
|
||||
case HTTP.parseMethod $ Wai.requestMethod request of
|
||||
Left _ -> loop middleware remForest backup request respond
|
||||
Right stdMethod' ->
|
||||
if stdMethod == stdMethod' && List.null (Wai.pathInfo request)
|
||||
then
|
||||
middleware
|
||||
( \request' respond' -> do
|
||||
response <- transformation $ handler request'
|
||||
respond' response
|
||||
)
|
||||
request
|
||||
respond
|
||||
else loop middleware remForest backup request respond
|
||||
Apply middleware' tree ->
|
||||
loop
|
||||
(middleware' . middleware)
|
||||
(tree : [])
|
||||
(loop middleware remForest backup)
|
||||
request
|
||||
respond
|
||||
-}
|
||||
{-
|
||||
stringify :: Tree -> IO (Node.Tree String)
|
||||
stringify [] = return []
|
||||
@ -765,6 +429,7 @@ stringify (tree:remForest) = case tree of
|
||||
(Tree.Node root subTrees) <- api
|
||||
return $ Tree.Node ("(" <> root <> ")") subTrees
|
||||
-}
|
||||
|
||||
{-
|
||||
forest :: Tree -> IO (Tree.Node String)
|
||||
forest [] = return $ Tree.Node ":root:" []
|
||||
|
||||
Loading…
Reference in New Issue
Block a user