Add working calculator API example

2024-11-22 00:51:34 +03:00 · 2023-11-12 20:19:39 -08:00 · 2023-11-12 20:19:39 -08:00 · 44c5c713c1
commit 44c5c713c1
parent d35f0d359d
4 changed files with 333 additions and 48 deletions
--- a/lib/okapi.cabal
+++ b/lib/okapi.cabal
@ -36,6 +36,7 @@ library
      Okapi.App
      Okapi.Route
      Okapi.Response
+      Example
  other-modules:
      Paths_okapi
  hs-source-dirs:
--- a/lib/src/Example.hs
+++ b/lib/src/Example.hs
@ -0,0 +1,106 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use if" #-}
+
+module Example where
+
+import Control.Natural qualified as Natural
+import Data.Binary.Builder qualified as Builder
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBSChar8
+import Data.Kind
+import Data.List qualified as List
+import Data.Text qualified as Text
+import Data.Type.Equality qualified as Equality
+import Data.Typeable qualified as Typeable
+import Data.Vault.Lazy qualified as Vault
+import GHC.Exts qualified as Exts
+import GHC.Generics qualified as Generics
+import GHC.Natural qualified as Natural
+import Network.HTTP.Types qualified as HTTP
+import Network.Wai qualified as Wai
+import Network.Wai.Handler.Warp qualified as Warp
+import Okapi.App {- qualified as App -}
+import Okapi.Response {- qualified as Response -}
+import Web.HttpApiData qualified as Web
+
+data Operator = Add | Sub | Mul | Div | Sq | Neg deriving (Show)
+
+isUnary :: Operator -> Bool
+isUnary Sq = True
+isUnary Neg = True
+isUnary _ = False
+
+instance Web.FromHttpApiData Operator where
+    parseUrlPiece "add" = Right Add
+    parseUrlPiece "sub" = Right Sub
+    parseUrlPiece "minus" = Right Sub
+    parseUrlPiece "mul" = Right Mul
+    parseUrlPiece "div" = Right Div
+    parseUrlPiece "neg" = Right Neg
+    parseUrlPiece "sq" = Right Sq
+    parseUrlPiece "square" = Right Sq
+    parseUrlPiece _ = Left "Can't parse operator..."
+
+unaryF =
+    responder @200 @'[] @Text.Text @Int
+        . responder @500 @'[] @Text.Text @Text.Text
+        . method HTTP.GET id
+
+binaryF =
+    param @Int
+        . responder @200 @'[] @Text.Text @Int
+        . responder @500 @'[] @Text.Text @Text.Text
+        . responder @403 @'[] @Text.Text @Text.Text
+        . method HTTP.GET id
+
+calc =
+    lit "calc"
+        . param @Operator
+        . param @Int
+        $ choice
+            [ unaryF \operator x ok wrongArgs _req -> return
+                $ case operator of
+                    Sq -> ok noHeaders (x * x)
+                    Neg -> ok noHeaders (x * (-1))
+                    _ -> wrongArgs noHeaders $ (Text.pack $ show operator) <> " needs two arguments."
+            , binaryF \operator x y ok wrongArgs divByZeroErr _req -> do
+                return
+                    $ case operator of
+                        Add -> ok noHeaders (x + y)
+                        Sub -> ok noHeaders (x - y)
+                        Mul -> ok noHeaders (x * y)
+                        Div ->
+                            if y == 0
+                                then divByZeroErr noHeaders "You can't divide by 0."
+                                else ok noHeaders (div x y)
+                        _ -> wrongArgs noHeaders $ (Text.pack $ show operator) <> " needs one argument."
+            ]
+
+main =
+    Warp.run 8003 $ calc `withDefault` \_ resp ->
+        resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
--- a/lib/src/Okapi/App.hs
+++ b/lib/src/Okapi/App.hs
@ -45,7 +45,7 @@ import Data.Typeable qualified as Typeable
 import Data.Vault.Lazy qualified as Vault
 import GHC.Exts qualified as Exts
 import GHC.Generics qualified as Generics
-import GHC.Natural qualified as Natural
+import GHC.TypeNats qualified as Nat
 import Network.HTTP.Types qualified as HTTP
 import Network.Wai qualified as Wai
 import Network.Wai.Handler.Warp qualified as Warp
@ -125,9 +125,10 @@ data Node (r :: [Type]) where
    Node r ->
    Node r
  Responder ::
-    forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type) (r :: [Type]).
+    forall (status :: Nat.Nat) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type) (r :: [Type]).
    ( Response.ContentType contentType
    , Response.ToContentType contentType resultType
+    , Nat.KnownNat status
    , Typeable.Typeable status
    , Typeable.Typeable headerKeys
    , Typeable.Typeable contentType
@ -144,14 +145,13 @@ data Node (r :: [Type]) where
    Handler r env ->
    Node r

-{-
-smush ::
+combine ::
  forall (r :: [Type]).
  (Typeable.Typeable r) =>
  Node r ->
  Node r ->
  Maybe (Node r)
-smush a1 a2 = case (a1, a2) of
+combine n1 n2 = case (n1, n2) of
  (Choice @r1 children1, Choice @r2 children2) -> case (Typeable.eqT @r1 @r2) of
    Just Typeable.Refl -> Just $ choice @r1 (children1 <> children2)
    _ -> Nothing
@ -179,9 +179,9 @@ smush a1 a2 = case (a1, a2) of
  (Body @a1 @r1 child1, Body @a2 @r2 child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
    (Just Typeable.Refl, Just Typeable.Refl) -> Just $ body @a1 @r1 $ choice @(r1 :-> a1) [child1, child2]
    (_, _) -> Nothing
-  (Apply @t1 @r1 tag1 atom1, Apply @t2 @r2 tag2 atom2) -> case (Typeable.eqT @t1 @t2, Typeable.eqT @r1 @r2) of
+  (Apply @t1 @r1 tag1 node1, Apply @t2 @r2 tag2 node2) -> case (Typeable.eqT @t1 @t2, Typeable.eqT @r1 @r2) of
    (Just Typeable.Refl, Just Typeable.Refl) -> case tag1 == tag2 of
-      True -> Just $ apply @t1 @r1 tag1 $ choice @r1 [atom1, atom2]
+      True -> Just $ apply @t1 @r1 tag1 $ choice @r1 [node1, node2]
      False -> Nothing
    (_, _) -> Nothing
  (Responder @s1 @hk1 @ct1 @rt1 @r1 child1, Responder @s2 @hk2 @ct2 @rt2 @r2 child2) -> case (Typeable.eqT @s1 @s2, Typeable.eqT @hk1 @hk2, Typeable.eqT @ct1 @ct2, Typeable.eqT @rt1 @rt2, Typeable.eqT @r1 @r2) of
@ -191,19 +191,18 @@ smush a1 a2 = case (a1, a2) of
  (a1', Choice @r2 children) -> Just $ choice @r2 (a1' : children)
  -- Method is not comparable
  (_, _) -> Nothing
-}
-- smushes :: Node r -> Node r
-- smushes (Choice []) = Choice []
-- smushes (Choice singleton@[atom]) = Choice singleton
-- smushes (Choice (atom1 : atom2 : atoms)) = case atom1 `smush` atom2 of
--   Just newAtom -> smushes $ Choice (newAtom : atoms)
--   Nothing ->
--     List.concat
--       [ smushes (atom1 : atoms)
--       , smushes (atom2 : atoms)
--       , smushes atoms
--       ]
-- smushes atom = atom
+
+flatten :: (Typeable.Typeable r) => Node r -> Node r
+flatten (Choice [node]) = node
+flatten (Choice (node1 : node2 : nodes)) = case node1 `combine` node2 of
+  Just newNode -> flatten $ choice (newNode : nodes)
+  Nothing ->
+    choice
+      [ flatten $ choice (node1 : nodes)
+      , flatten $ choice (node2 : nodes)
+      , flatten $ choice nodes
+      ]
+flatten node = node

 argsTest :: Handler '[] IO
 argsTest = \request -> do
@ -307,9 +306,10 @@ scope ::
 scope tag children = apply @t @r tag $ route @a @r children

 responder ::
-  forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type) (r :: [Type]).
+  forall (status :: Nat.Nat) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type) (r :: [Type]).
  ( Response.ContentType contentType
  , Response.ToContentType contentType resultType
+  , Nat.KnownNat status
  , Typeable.Typeable status
  , Typeable.Typeable headerKeys
  , Typeable.Typeable contentType
@ -351,13 +351,6 @@ data HelloWorldBody = HelloWorldBody deriving (Typeable.Typeable)

 data ByeWorldBody = ByeWorldBody {error :: Text.Text, randomN :: Int} deriving (Typeable.Typeable)

-textToBytes :: Text.Text -> LBSChar8.ByteString
-textToBytes = undefined
-
-instance Response.ContentType Text.Text where
-  contentTypeName = "text/plain"
-  contentTypeBody text = Response.BodyBytes $ textToBytes text
-
 instance Response.ToContentType Text.Text HelloWorldBody where
  toContentType HelloWorldBody = "Hello World! :)"

@ -366,15 +359,18 @@ instance Response.ToContentType Text.Text ByeWorldBody where

 -- test :: _
 test =
-  myResponders
-    . lit "some"
+  lit "some"
+    . myOtherResponders
    . lit "world"
    . param @Float
    $ method
      HTTP.GET
      id
-      \helloWorld byeWorld float req -> do
-        undefined
+      testHandle
+
+-- testHandle :: _
+testHandle = \helloWorld byeWorld watWorld float (req :: Wai.Request) -> do
+  undefined

 test2 =
  choice
@ -387,18 +383,15 @@ test2 =
              undefined
          ]
    , param @Float
-        $ method HTTP.PUT id \req -> do
+        $ method HTTP.PUT id \float req -> do
          undefined
    , choice
-        [ lit "lol"
-            . lit "foo"
-            . param @Int
-            $ method HTTP.GET id \n req -> do
-              undefined
+        [ somePath $ method HTTP.GET id \helloWorld byeWorld n -> do
+            undefined
        , lit "bar"
            . match @Int 10
-            $ method HTTP.PATCH id \req -> do
-              undefined
+            . somePath
+            $ method HTTP.PATCH id undefined
        , lit "baz"
            $ choice
              [ method HTTP.GET id \req -> do
@ -408,11 +401,73 @@ test2 =
              ]
        ]
    ]
+ 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
@ -444,13 +499,98 @@ myFunc = fillHandler handlerTest argsTest
  argsTest = HCons True (HCons 5 (HCons 5.8 HNil))

 withDefault :: Node '[] -> Wai.Middleware
-withDefault = undefined
-
-- withDefaultLoop id HNil
+withDefault = withDefaultLoop id HNil

 withDefaultLoop :: Wai.Middleware -> HList args -> Node args -> Wai.Middleware
-withDefaultLoop = undefined
-
+withDefaultLoop middleware args root backup request respond = case root of
+  Choice [] -> backup request respond
+  Choice (node : nodes) -> case node of
+    Choice subNodes -> withDefaultLoop middleware args (choice (subNodes <> nodes)) 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
+  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
--- a/lib/src/Okapi/Response.hs
+++ b/lib/src/Okapi/Response.hs
@ -27,11 +27,14 @@ module Okapi.Response where
 import Control.Natural qualified as Natural
 import Data.Binary.Builder qualified as Builder
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBSChar8
 import Data.Functor.Identity qualified as Identity
 import Data.Kind
 import Data.List qualified as List
 import Data.List.NonEmpty qualified as NonEmpty
 import Data.Text qualified as Text
+import Data.Text.Lazy qualified as LText
+import Data.Text.Lazy.Encoding qualified as Text
 import Data.Tree qualified as Tree
 import Data.Type.Equality qualified as Equality
 import Data.Typeable qualified as Typeable
@ -39,6 +42,7 @@ import Data.Vault.Lazy qualified as Vault
 import GHC.Exts qualified as Exts
 import GHC.Generics qualified as Generics
 import GHC.Natural qualified as Natural
+import GHC.TypeNats qualified as Nat
 import Network.HTTP.Types qualified as HTTP
 import Network.Wai qualified as Wai
 import Okapi.Headers qualified as Headers
@ -49,6 +53,9 @@ import Web.HttpApiData qualified as Web
 class ToHeader a where
  toHeader :: a -> LBS.ByteString

+instance ToHeader LBS.ByteString where
+  toHeader = id
+
 type Elem :: Exts.Symbol -> [Exts.Symbol] -> Bool
 type family Elem x ys where
  Elem x '[] = 'False
@ -64,6 +71,9 @@ data Headers (headerKeys :: [Exts.Symbol]) where
    Headers headerKeys ->
    Headers (headerKey : headerKeys)

+noHeaders :: Headers '[]
+noHeaders = NoHeaders
+
 insertHeader ::
  forall (headerKey :: Exts.Symbol) headerValue (headerKeys :: [Exts.Symbol]).
  (ToHeader headerValue) =>
@ -111,23 +121,51 @@ data Body
  = BodyStream Wai.StreamingBody
  | BodyBuilder Builder.Builder
  | BodyBytes LBS.ByteString
-  | BodyFile FilePath Wai.FilePart
+  | BodyFile FilePath (Maybe Wai.FilePart)

 class ContentType a where
  contentTypeName :: LBS.ByteString
  contentTypeBody :: a -> Body

+instance ContentType Text.Text where
+  contentTypeName = "text/plain"
+  contentTypeBody = BodyBytes . Text.encodeUtf8 . LText.fromStrict
+
 class (ContentType a) => ToContentType a b | b -> a where
  toContentType :: b -> a

+instance ToContentType Text.Text Text.Text where
+  toContentType = id
+
+instance ToContentType Text.Text Int where
+  toContentType = Text.pack . show
+
 data Response where
  Response ::
    forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
    (ContentType contentType, ToContentType contentType resultType, Typeable.Typeable headerKeys, Typeable.Typeable resultType) =>
    Response

+toWaiResponseHeaders ::
+  forall (headerKeys :: [Exts.Symbol]).
+  Headers headerKeys ->
+  HTTP.ResponseHeaders
+toWaiResponseHeaders headers = []
+
+natToStatus :: Nat.Nat -> HTTP.Status
+natToStatus n = toEnum $ fromEnum n
+
 makeResponder ::
  forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
-  (ContentType contentType, ToContentType contentType resultType, Typeable.Typeable headerKeys, Typeable.Typeable resultType) => 
+  (Nat.KnownNat status, ContentType contentType, ToContentType contentType resultType, Typeable.Typeable headerKeys, Typeable.Typeable resultType) =>
  (Headers headerKeys -> resultType -> Wai.Response)
-makeResponder = undefined
+makeResponder = \_ result ->
+  let status = natToStatus $ Nat.natVal @status Typeable.Proxy
+      contentType = toContentType result
+      bodyType = contentTypeBody contentType
+      name = contentTypeName @contentType
+   in case bodyType of
+        BodyBytes bytes -> Wai.responseLBS status [] bytes
+        BodyBuilder builder -> Wai.responseBuilder status [] builder
+        BodyStream stream -> Wai.responseStream status [] stream
+        BodyFile path part -> Wai.responseFile status [] path part