Add To/From classes and Parsers/Builders

lib/okapi.cabal

@@ -28,11 +28,13 @@ source-repository head
 library
   exposed-modules:
       Okapi
+      Okapi.Middleware
       Okapi.Route.Pattern
       Okapi.Headers
+      Okapi.Query
+      Okapi.Body
       Okapi.Secret
       Okapi.App
-      Okapi.App2
       Okapi.Route
       Okapi.Response
   other-modules:

lib/src/Okapi/App.hs

@@ -46,7 +46,10 @@ 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.Body qualified as Body
 import Okapi.Headers qualified as Headers
+import Okapi.Middleware qualified as Middleware
+import Okapi.Query qualified as Query
 import Okapi.Response qualified as Response
 import Okapi.Route qualified as Route
 import Okapi.Secret qualified as Secret
@@ -62,14 +65,14 @@ data Atom (r :: [Type]) where
   Match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> [Atom r] -> Atom r
   Param :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (r :> a)] -> Atom r
   Regex :: forall a (r :: [Type]). (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> [Atom (r :> a)] -> Atom r
-  Splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (NonEmpty.NonEmpty r :> a)] -> Atom r
+  Splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (r :> NonEmpty.NonEmpty a)] -> Atom r
-  Route :: forall a (r :: [Type]). Route.Parser a -> [Atom (r :> a)] -> Atom r
+  Route :: forall a (r :: [Type]). (Route.From a) => [Atom (r :> a)] -> Atom r
+  Query :: forall a (r :: [Type]). (Query.From a) => [Atom (r :> a)] -> Atom r
+  Headers :: forall a (r :: [Type]). (Headers.From a) => [Atom (r :> a)] -> Atom r
+  Body :: forall a (r :: [Type]). (Body.From a) => [Atom (r :> a)] -> Atom r
+  Apply :: forall a (r :: [Type]). (Middleware.To a) => Atom r -> Atom r
+  Respond :: forall a (r :: [Type]). (Response.To a) => [Atom (r :> a)] -> Atom r
   Method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Atom r
-  Headers :: forall a (r :: [Type]). Headers.Parser a -> [Atom (r :> a)] -> Atom r
-  Query :: forall a (r :: [Type]). Query.Parser a -> [Atom (r :> a)] -> Atom r
-  Body :: forall a (r :: [Type]). Body.Parser a -> [Atom (r :> a)] -> Atom r
-  Apply :: forall (r :: [Type]). Wai.Middleware -> Atom r -> Atom r
-  Respond :: forall a (r :: [Type]). Response.Builder a -> [Atom (r :> a)] -> Atom r
 
 type Handler :: [Type] -> (Type -> Type) -> Type
 type family Handler args env where
@@ -89,40 +92,55 @@ argsTest2 = \x -> \y -> \request -> do
   return $ Wai.responseLBS HTTP.status200 [] "world"
 
 match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> [Atom r] -> Atom r
-match = Match
+match = Match @a @r
 
 lit :: forall (r :: [Type]). Text.Text -> [Atom r] -> Atom r
 lit = match @Text.Text
 
 param :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (r :> a)] -> Atom r
-param = Param
+param = Param @a @r
 
 regex :: forall a (r :: [Type]). (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> [Atom (r :> a)] -> Atom r
-regex = Regex
+regex = Regex @a @r
 
-splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (NonEmpty.NonEmpty r :> a)] -> Atom r
+splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Atom (r :> NonEmpty.NonEmpty a)] -> Atom r
-splat = Splat
+splat = Splat @a @r
 
-route :: forall a (r :: [Type]). Route.Parser a -> [Atom (r :> a)] -> Atom r
+route :: forall a (r :: [Type]). (Route.From a) => [Atom (r :> a)] -> Atom r
-route = Route
+route = Route @a @r
+
+query :: forall a (r :: [Type]). (Query.From a) => [Atom (r :> a)] -> Atom r
+query = Query @a @r
+
+headers :: forall a (r :: [Type]). (Headers.From a) => [Atom (r :> a)] -> Atom r
+headers = Headers @a @r
+
+body :: forall a (r :: [Type]). (Body.From a) => [Atom (r :> a)] -> Atom r
+body = Body @a @r
+
+apply :: forall a (r :: [Type]). (Middleware.To a) => Atom r -> Atom r
+apply = Apply @a @r
+
+scope :: forall a m (r :: [Type]). (Route.From a, Middleware.To m) => Wai.Middleware -> [Atom (r :> a)] -> Atom r
+scope middleware children = apply @m @r $ route @a @r children
+
+respond :: forall a (r :: [Type]). (Response.To a) => [Atom (r :> a)] -> Atom r
+respond = Respond @a @r
 
 method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Atom r
-method = Method
+method = Method @env @r
 
-headers :: forall a (r :: [Type]). Headers.Parser a -> [Atom (r :> a)] -> Atom r
+endpoint ::
-headers = Headers
+  forall a env (r :: [Type]).
-
+  (Route.From a) =>
-query :: forall a (r :: [Type]). Query.Parser a -> [Atom (r :> a)] -> Atom r
+  HTTP.StdMethod ->
-query = Query
+  (env Natural.~> IO) ->
-
+  Handler (r :> a) env ->
-body :: forall a (r :: [Type]). Body.Parser a -> [Atom (r :> a)] -> Atom r
+  Atom r
-body = Body
+endpoint stdMethod transformation handler =
-
+  route @a
-apply :: forall (r :: [Type]). Wai.Middleware -> Atom r -> Atom r
+    [ method stdMethod transformation handler
-apply = Apply
+    ]
-
-respond :: forall a (r :: [Type]). Response.Builder a -> [Atom (r :> a)] -> Atom r
-respond = Respond
 
 myTest = Warp.run 8080 $ test `withDefault` \_ resp -> resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
 

lib/src/Okapi/App2.hs

@@ -1,571 +0,0 @@
-{-# 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 #-}
-
-module Okapi.App2 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.Base qualified as Base
-import Data.Functor.Foldable qualified as Foldable
-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.Tree qualified as Tree
-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.Headers qualified as Headers
-import Okapi.Response qualified as Response
-import Okapi.Route qualified as Route
-import Okapi.Secret qualified as Secret
-import Text.Regex.TDFA qualified as Regex
-import Web.HttpApiData qualified as Web
-
--- type Tree r s = [Node r s]
-
-type (:>) :: [Type] -> Type -> [Type]
-type family (:>) (a :: [Type]) (b :: Type) where
-  (:>) '[] b = '[b]
-  (:>) (aa : aas) b = aa : (aas :> b)
-
-type (:>>) :: [Datum] -> Datum -> [Datum]
-type family (:>>) (a :: [Datum]) (b :: Datum) where
-  (:>>) '[] b = '[b]
-  (:>>) (aa : aas) b = aa : (aas :>> b)
-
-type Null :: [Type] -> Bool
-type family Null (a :: [Type]) where
-  Null '[] = 'False
-  Null _   = 'True
-
-type Datum :: Type
-data Datum where
-  Seg :: Exts.Symbol -> Datum
-  Arg :: a -> Datum
-
-type NODE :: Type
-data NODE where
---   ROOT :: [NODE] -> NODE
-  MATCH :: a -> [NODE] -> NODE
-  PARAM :: a -> [NODE] -> NODE
-  GET :: NODE
-  POST :: NODE
-  PUT :: NODE
-  DELETE :: NODE
-
-data Node (r :: [Type]) (p :: [Datum]) where -- r for args, p for path
---   Root :: forall (r :: [Type]) (s :: [NODE]). [Node r s] -> Node '[] s
-  Match :: forall a (r :: [Type]) (p :: [Datum]). (Web.ToHttpApiData a) => a -> [Node r p] -> Node r (p :>> Arg a)
-  Param :: forall a (r :: [Type]) (p :: [Datum]). (Web.FromHttpApiData a, Typeable.Typeable a) => [Node (r :> a) p] -> Node r (p :>> Arg a)
-  -- Regex :: forall a (r :: [Type]). (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> Tree (a : r) -> Node (a : r)
-  -- Splat :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => Tree (NonEmpty.NonEmpty a : r) -> Node (NonEmpty.NonEmpty a : r)
-  -- Route :: forall a (r :: [Type]). Route.Parser a -> Tree (a : r) -> Node (a : r)
-  -- Method :: forall (env :: Type -> Type) (r :: [Type]) (s :: NODE). (env Natural.~> IO) -> Handler r env -> Node r ()
---   Get :: forall (env :: Type -> Type) (r :: [Type]). (env Natural.~> IO) -> Handler r env -> Node r
---   Post :: forall (env :: Type -> Type) (r :: [Type]). (env Natural.~> IO) -> Handler r env -> Node r
-
--- Query :: forall a. Query.Parser a -> (Secret.Secret a -> Tree) -> Node
--- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> Tree) -> Node
--- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> Tree) -> Node
--- Apply :: forall (r :: [Type]). Wai.Middleware -> Node r -> Node r
-
-type Handler :: [Type] -> (Type -> Type) -> Type
-type family Handler args env where
-  Handler '[] env = Wai.Request -> env Wai.Response
-  Handler (arg : args) env = arg -> Handler args env
-
-typeTest = [Match @Int 5
-  [ Match @Float 6.9
-      []
-  , Param @Int
-      []
-  ]
- ]
-{-
-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"
-
-match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> Tree r -> Node r
-match = Match
-
-lit :: forall (r :: [Type]). Text.Text -> Tree r -> Node r
-lit = match @Text.Text
-
-param :: forall a (r :: [Type]). (Web.FromHttpApiData a, Typeable.Typeable a) => Tree (r :> a) -> Node r
-param = Param @a @r
-
-
--- TODO: Add type level method to node???
-method :: forall env (r :: [Type]). HTTP.StdMethod -> (env Natural.~> IO) -> Handler r env -> Node r
-method = Method
--}
-{-
-type Root = '[]
-
-myTest = Warp.run 8080 $ test `withDefault` \_ resp -> resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
-
-test :: Tree Root
-test =
-  [ lit @'[] "hello"
-      [ lit @'[] "world"
-          [ param @Bool @'[]
-              [ method @IO @'[Bool] HTTP.GET id testHandler1
-              , param @Int @'[Bool]
-                  [ method @IO @'[Bool, Int] HTTP.GET id testHandler2
-                  , lit @'[Bool, Int] "foo"
-                      [ method @IO @'[Bool, Int] HTTP.POST id testHandler2
-                      ]
-                  , param @Float @'[Bool, Int]
-                      [ method @IO @'[Bool, Int, Float] HTTP.PUT id \bool1 -> \int2 -> \f3 -> \req -> do
-                          return $ Wai.responseLBS HTTP.status200 [] "many args"
-                      ]
-                  ]
-              ]
-          ]
-      ]
-  , lit "world"
-      [ method HTTP.GET id \req -> do
-          return $ Wai.responseLBS HTTP.status200 [] "world"
-      , method HTTP.HEAD id \req -> do
-          return $ Wai.responseLBS HTTP.status200 [] "dub"
-      ]
-  , method HTTP.GET id \req -> do
-      return $ Wai.responseLBS HTTP.status200 [] "What's up??"
-  ]
-
-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)
-
-snoc :: forall (l :: [Type]) (e :: Type). HList l -> e -> HList (l :> e)
-snoc HNil x = HCons x HNil
-snoc (HCons h t) x = HCons h (snoc t x)
-
--- type Reverse :: [Type] -> [Type]
--- type family Reverse l where
---   Reverse '[] = '[]
---   Reverse (h : t) = Reverse t :> h
-
-fillHandler :: Handler args env -> HList args -> (Wai.Request -> env Wai.Response)
-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 :: Tree Root -> Wai.Middleware
-withDefault = withDefaultLoop id HNil
-
-withDefaultLoop :: Wai.Middleware -> HList args -> Tree args -> Wai.Middleware
-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
--}
-{-
-url :: forall (args :: [Type]). HList args -> Tree args -> Text
-url a tree = case tree of
-  [] -> ""
-  (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
--}
-{-
-type Remove :: Exts.Symbol -> [Exts.Symbol] -> [Exts.Symbol]
-type family Remove x ys where
-  Remove a '[] = '[]
-  Remove a (a ': ys) = ys
-  Remove a (y ': ys) = y ': (Remove a ys)
--}
-
-{-
-data Node (r :: [Type]) where
-  Match :: forall a (r :: [Type]). (Web.ToHttpApiData a) => a -> Tree r -> Node r
-  Param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> Tree) -> Node
-  Regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> (Secret.Secret a -> Tree) -> Node
-  Splat :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret (NonEmpty.NonEmpty a) -> Tree) -> Node
-  Route :: forall a. Route.Parser a -> (Secret.Secret a -> Tree) -> Node
-  Method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> Node
-  -- Query :: forall a. Query.Parser a -> (Secret.Secret a -> Tree) -> Node
-  -- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> Tree) -> Node
-  -- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> Tree) -> Node
-  Apply :: Wai.Middleware -> Node -> Node
--}
-
--- Respond ::
---   forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
---   (Response.ToContentType contentType resultType) =>
---   ((Response.Headers headerKeys -> resultType -> Wai.Response) -> Tree) ->
---   Node
-
-{-
-regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> (Secret.Secret a -> Tree) -> Node
-regex = Regex
-
-splat :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret (NonEmpty.NonEmpty a) -> Tree) -> Node
-splat = Splat
-
-route :: forall a. Route.Parser a -> (Secret.Secret a -> Tree) -> Node
-route = Route
-
-apply :: Wai.Middleware -> Node -> Node
-apply = Apply
-
-scope :: Wai.Middleware -> Text.Text -> Tree -> Node
-scope mw t forest = apply mw $ lit t forest
--}
-
-{-
--- respond ::
---   forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
---   (Response.ToContentType contentType resultType) =>
---   ((Response.Headers headerKeys -> resultType -> Wai.Response) -> Tree) ->
---   Node
--- respond = Respond
-
-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 []
-stringify (tree:remForest) = case tree of
-  Match value subForest -> do
-    stringSubForest <- stringify subForest
-    stringRemForest <- stringify remForest
-    let string = "/" <> (Text.unpack $ Web.toUrlPiece value)
-    return ((Tree.Node string stringSubForest) : stringRemForest)
-  Param @t growSubForest -> do
-    secret <- Secret.new @t
-    stringSubForest <- stringify $ growSubForest secret
-    stringRemForest <- stringify remForest
-    let string = "/:" <> showType @t
-    return ((Tree.Node string stringSubForest) : stringRemForest)
-  Regex @t regex growSubForest -> do
-    secret <- Secret.new @t
-    stringSubForest <- stringify $ growSubForest secret
-    stringRemForest <- stringify remForest
-    let string = "/<" <> Text.unpack regex <> ">"
-    return ((Tree.Node string stringSubForest) : stringRemForest)
-  Splat @t growSubForest -> do
-    secret <- Secret.new @(NonEmpty.NonEmpty ty)
-    forest <- mapM $ produce secret
-    return $ Tree.Node ("/*" <> showType @ty) forest
-  (Route @ty route produce) = do
-    secret <- Secret.new @ty
-    forest <- mapM $ produce secret
-    return $ Tree.Node (Text.unpack (Route.rep route)) forest
-  (Method m _ _) = do
-    return $ Tree.Node (show m) []
-  (Apply _ api) = do
-    (Tree.Node root subTrees) <- api
-    return $ Tree.Node ("(" <> root <> ")") subTrees
--}
-{-
-forest :: Tree -> IO (Tree.Node String)
-forest [] = return $ Tree.Node ":root:" []
-forest apis = do
-  forest' <- mapM tree apis
-  return $ Tree.Node "\ESC[31m:root:\ESC[0m" forest'
-  where
-    tree :: Node -> IO (Tree.Node String)
-    tree (Match value apis) = do
-      forest <- mapM tree apis
-      return $ Tree.Node ("/" <> (Text.unpack $ Web.toUrlPiece value)) forest
-    tree (Param @ty produce) = do
-      secret <- Secret.new @ty
-      forest <- mapM tree $ produce secret
-      return $ Tree.Node ("/:" <> showType @ty) forest
-    tree (Regex @ty regex produce) = do
-      secret <- Secret.new @ty
-      forest <- mapM tree $ produce secret
-      return $ Tree.Node ("/r<" <> Text.unpack regex <> ">") forest
-    tree (Splat @ty produce) = do
-      secret <- Secret.new @(NonEmpty.NonEmpty ty)
-      forest <- mapM tree $ produce secret
-      return $ Tree.Node ("/*" <> showType @ty) forest
-    tree (Route @ty route produce) = do
-      secret <- Secret.new @ty
-      forest <- mapM tree $ produce secret
-      return $ Tree.Node (Text.unpack (Route.rep route)) forest
-    tree (Method m _ _) = do
-      return $ Tree.Node (show m) []
-    tree (Apply _ api) = do
-      (Tree.Node root subTrees) <- tree api
-      return $ Tree.Node ("(" <> root <> ")") subTrees
-
-showType :: forall a. (Typeable.Typeable a) => String
-showType = show . Typeable.typeRep $ Typeable.Proxy @a
-
-get_ = method HTTP.GET
-
-getIO_ = method HTTP.GET id
--}
-{-
-data Node where
-  Match :: forall a. (Web.ToHttpApiData a) => a -> Tree -> Node
-  Param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> Tree) -> Node
-  Regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> (Secret.Secret a -> Tree) -> Node
-  Splat :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret (NonEmpty.NonEmpty a) -> Tree) -> Node
-  Route :: forall a. Route.Parser a -> (Secret.Secret a -> Tree) -> Node
-  Method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> Node
-  -- Query :: forall a. Query.Parser a -> (Secret.Secret a -> Tree) -> Node
-  -- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> Tree) -> Node
-  -- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> Tree) -> Node
-  Pipe :: Wai.Middleware -> Node -> Node
-  Respond ::
-    forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
-    (Response.ToContentType contentType resultType) =>
-    ((Response.Headers headerKeys -> resultType -> Wai.Response) -> Tree) ->
-    Node
-
--- data AppF a where
---   MatchF :: forall a b. (Web.ToHttpApiData b) => b -> [a] -> AppF a
---   ParamF :: forall a b. (Web.FromHttpApiData b, Typeable.Typeable b) => (Secret.Secret b -> [a]) -> AppF a
---   RegexF :: forall a b. (Regex.RegexContext Regex.Regex Text.Text b) => Text.Text -> (Secret.Secret b -> [a]) -> AppF a
---   SplatF :: forall a b. (Web.FromHttpApiData b, Typeable.Typeable b) => (Secret.Secret (NonEmpty.NonEmpty b) -> [a]) -> AppF a
---   RouteF :: forall a b. Route.Parser b -> (Secret.Secret b -> [a]) -> AppF a
---   MethodF :: forall a env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> AppF a
---   -- Query :: forall a. Query.Parser a -> (Secret.Secret a -> [AppF]) -> AppF
---   -- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> [AppF]) -> AppF
---   -- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> [AppF]) -> AppF
---   PipeF :: forall a. Wai.Middleware -> a -> AppF a
-  -- RespondF ::
-  --   forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
-  --   (Response.ToContentType contentType resultType) =>
-  --   ((Response.Headers headerKeys -> resultType -> Wai.Response) -> [a]) ->
-  --   AppF a
-
-build' :: Tree -> Wai.Middleware -> Wai.Middleware
-build' root middleware backup request respond = Foldable.fold
-  (\case
-      Base.Nil -> backup request respond
-      Base.Cons api (apis :: _) -> case api of
-        Match value children ->
-          case Wai.pathInfo request of
-            [] -> build' apis middleware backup request respond
-            (pathHead : pathTail) ->
-              if pathHead == Web.toUrlPiece value
-                then do
-                  let newReq = request {Wai.pathInfo = pathTail}
-                  build' children middleware backup newReq respond
-                else build' apis middleware backup request respond
-  )
-  root
-
-endpoint ::
-  HTTP.StdMethod ->
-  Route.Parser a ->
-  (env Natural.~> IO) ->
-  (Secret.Secret a -> Handler env) ->
-  Node
-endpoint stdMethod routeP trans handlerWithSecret = route routeP \routeS ->
-  [ method stdMethod trans (handlerWithSecret routeS)
-  ]
--}
--}

lib/src/Okapi/Body.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Okapi.Body where
+
+import Data.Text qualified as Text
+import Data.Typeable qualified as Typeable
+import Text.Regex.TDFA qualified as Regex
+import Web.HttpApiData qualified as Web
+
+data Parser a where
+    FMap :: (a -> b) -> Parser a -> Parser b
+    Pure :: a -> Parser a
+    Apply :: Parser (a -> b) -> Parser a -> Parser b
+    Match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
+    Param :: forall a. (Typeable.Typeable a, Web.FromHttpApiData a) => Parser a
+    Regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> Parser a
+
+class From a where
+    parser :: Parser a
+    parse :: ()

lib/src/Okapi/Headers.hs

@@ -2,54 +2,29 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
--- {-# LANGUAGE RebindableSyntax #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Okapi.Headers where
 
-import Data.Text
+import Data.Text qualified as Text
-import Data.Typeable
+import Data.Typeable qualified as Typeable
 import Web.HttpApiData qualified as Web
 
-data Headers a where
+data Parser a where
-  FMap :: (a -> b) -> Headers a -> Headers b
+  FMap :: (a -> b) -> Parser a -> Parser b
-  Pure :: a -> Headers a
+  Pure :: a -> Parser a
-  Apply :: Headers (a -> b) -> Headers a -> Headers b
+  Apply :: Parser (a -> b) -> Parser a -> Parser b
-  Match :: Text -> Headers ()
+  Match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
-  Param :: (Typeable a, Web.FromHttpApiData a) => Headers a
+  Param :: forall a. (Typeable.Typeable a, Web.FromHttpApiData a) => Parser a
 
-instance Functor Headers where
+instance Functor Parser where
   fmap = FMap
 
-instance Applicative Headers where
+instance Applicative Parser where
   pure = Pure
   (<*>) = Apply
 
-param :: (Typeable a, Web.FromHttpApiData a) => Headers a
+class From a where
-param = Param
+  parser :: Parser a
-
+  parse :: ()
-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

lib/src/Okapi/Middleware.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Okapi.Middleware where
+
+import Network.Wai qualified as Wai
+
+class To a where
+  to :: a -> Wai.Middleware

lib/src/Okapi/Query.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Okapi.Query where
+
+import Data.Text qualified as Text
+import Data.Typeable qualified as Typeable
+import Text.Regex.TDFA qualified as Regex
+import Web.HttpApiData qualified as Web
+
+data Parser a where
+    FMap :: (a -> b) -> Parser a -> Parser b
+    Pure :: a -> Parser a
+    Apply :: Parser (a -> b) -> Parser a -> Parser b
+    Match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
+    Param :: forall a. (Typeable.Typeable a, Web.FromHttpApiData a) => Parser a
+    Regex :: forall a. (Regex.RegexContext Regex.Regex Text.Text a) => Text.Text -> Parser a
+
+instance Functor Parser where
+  fmap = FMap
+
+instance Applicative Parser where
+  pure = Pure
+  (<*>) = Apply
+
+class From a where
+  parser :: Parser a
+  parse :: ()

lib/src/Okapi/Response.hs

@@ -193,5 +193,6 @@ has = Has
 -- equals (Has _) (Has _) = undefined
 -- equals _ _ = False
 
-build :: Builder a -> a
+class To a where
-build = undefined
+  builder :: Builder a
+  build :: ()

lib/src/Okapi/Route.hs

@@ -28,6 +28,10 @@ instance Applicative Parser where
   pure = Pure
   (<*>) = Apply
 
+class From a where
+  parser :: Parser a
+  parse :: ()
+
 match :: forall a. (Web.ToHttpApiData a) => a -> Parser ()
 match = Match
 
@@ -59,6 +63,3 @@ rep (Regex @ty regex) = "/r(" <> regex <> ")"
 -- equals _ _ = False
 
 data Error = Error
-
-parse :: Parser a -> [Text.Text] -> (Either Error a, [Text.Text])
-parse = undefined

lib/src/Okapi/TypedAPI.hs

@@ -1,74 +0,0 @@
-{-# 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 OverloadedStrings #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE QualifiedDo #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Okapi.App where
-
-import Control.Natural qualified as Natural
-import Data.Binary.Builder qualified as Builder
-import Data.ByteString.Lazy qualified as LBS
-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.Tree qualified as Tree
-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 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
-
-module Okapi.TypedAPI where
-
-type MethodKind :: Type
-data MethodKind where
-  GETType :: MethodKind
-  POSTType :: MethodKind
-  PUTType :: MethodKind
-  DELETEType :: MethodKind
-
-type OpTree :: Type
-data OpTree where
-  MatchNode :: forall a. (Web.ToHttpApiData a) => a -> '[TypedAPI OpTree] -> OpTree
-  ParamNode :: forall a. (Web.FromHttpApiData a) => '[TypedAPI OpTree] -> OpTree
-  MethodLeaf :: MethodKind -> OpTree
-
--- type In :: TypedAPI OpTree -> [TypedAPI OpTree] -> Bool
--- type family In (MatchNode ) (t :: [TypedAPI OpTree]) where
---   Pop '[] =
-
-type OpTreee :: OpTree -> Type
-data OpTreee where
-  OpTreee :: OpTree -> OpTreee
-
-data TypedAPI (t :: OpTreee) where
-  Match' :: forall a t. (Web.ToHttpApiData a, t ~ [TypedAPI OpTreee]) => a -> t -> TypedAPI (OpTreee (MatchNode a t))
-  Param' :: forall a t. (Web.FromHttpApiData a, Typeable.Typeable a, t ~ [TypedAPI OpTreee]) => (Secret.Secret a -> t) -> TypedAPI (OpTreee (ParamNode a t))
-  Method' :: forall (m :: MethodKind) env. (env Natural.~> IO) -> Handler env -> TypedAPI (OpTreee (MethodLeaf m))