Use Tag class for Responses as well. May change

lib/okapi.cabal

@@ -33,7 +33,6 @@ library
       Okapi.Headers
       Okapi.Query
       Okapi.Body
-      Okapi.Secret
       Okapi.App
       Okapi.Route
       Okapi.Response

lib/src/Okapi.hs

@@ -38,7 +38,7 @@ import Okapi.App
 import Okapi.App qualified as App
 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
 

lib/src/Okapi/App.hs

@@ -55,20 +55,21 @@ 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
+
 import Text.Regex.TDFA qualified as Regex
 import Web.HttpApiData qualified as Web
 
-type (:>) :: [Type] -> Type -> [Type]
-type family (:>) (a :: [Type]) (b :: Type) where
-  (:>) '[] b = '[b]
-  (:>) (aa : aas) b = aa : (aas :> b)
+type (:->) :: [Type] -> Type -> [Type]
+type family (:->) (a :: [Type]) (b :: Type) where
+  (:->) '[] b = '[b]
+  (:->) (aa : aas) b = aa : (aas :-> b)
 
 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
 
+-- TODO: Potentially add type parameter to constrain middleware enum type
 data Atom (r :: [Type]) where
   Match ::
     forall a (r :: [Type]).
@@ -79,38 +80,38 @@ data Atom (r :: [Type]) where
   Param ::
     forall a (r :: [Type]).
     (Web.FromHttpApiData a, Typeable.Typeable a, Typeable.Typeable r) =>
-    [Atom (r :> a)] ->
+    [Atom (r :-> a)] ->
     Atom r
   Regex ::
     forall a (r :: [Type]).
     (Regex.RegexContext Regex.Regex Text.Text a, Typeable.Typeable a, Typeable.Typeable r) =>
     Text.Text ->
-    [Atom (r :> a)] ->
+    [Atom (r :-> a)] ->
     Atom r
   Splat ::
     forall a (r :: [Type]).
     (Web.FromHttpApiData a, Typeable.Typeable a, Typeable.Typeable r) =>
-    [Atom (r :> NonEmpty.NonEmpty a)] ->
+    [Atom (r :-> NonEmpty.NonEmpty a)] ->
     Atom r
   Route ::
     forall a (r :: [Type]).
     (Route.From a, Typeable.Typeable a, Typeable.Typeable r) =>
-    [Atom (r :> a)] ->
+    [Atom (r :-> a)] ->
     Atom r
   Query ::
     forall a (r :: [Type]).
     (Query.From a, Typeable.Typeable a, Typeable.Typeable r) =>
-    [Atom (r :> a)] ->
+    [Atom (r :-> a)] ->
     Atom r
   Headers ::
     forall a (r :: [Type]).
     (Headers.From a, Typeable.Typeable a, Typeable.Typeable r) =>
-    [Atom (r :> a)] ->
+    [Atom (r :-> a)] ->
     Atom r
   Body ::
     forall a (r :: [Type]).
     (Body.From a, Typeable.Typeable a, Typeable.Typeable r) =>
-    [Atom (r :> a)] ->
+    [Atom (r :-> a)] ->
     Atom r
   Apply ::
     forall t (r :: [Type]).
@@ -118,10 +119,15 @@ data Atom (r :: [Type]) where
     t ->
     Atom r ->
     Atom r
-  Respond ::
-    forall a (r :: [Type]).
-    (Response.To a, Typeable.Typeable a, Typeable.Typeable r) =>
-    [Atom (r :> a)] ->
+  -- Response ::
+  --   forall a (r :: [Type]).
+  --   (Response.To a, Typeable.Typeable a, Typeable.Typeable r) =>
+  --   [Atom (r :-> a)] ->
+  --   Atom r
+  Responses ::
+    forall t (r :: [Type]).
+    (Response.Tag t, Typeable.Typeable t, Typeable.Typeable r) =>
+    [Atom (r :-> (t -> Response.Response))] ->
     Atom r
   Method ::
     forall env (r :: [Type]).
@@ -161,10 +167,10 @@ instance Eq (Atom r) where
     (Apply @t1 @r1 tag1 atom1, Apply @t2 @r2 tag2 atom2) -> case (Typeable.eqT @t1 @t2, Typeable.eqT @r1 @r2) of
       (Just Typeable.Refl, Just Typeable.Refl) -> tag1 == tag2 && atom1 == atom2
       (_, _) -> False
-    (Respond @a1 @r1 _, Respond @a2 @r2 _) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
+    (Response @a1 @r1 _, Response @a2 @r2 _) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
       (Just Typeable.Refl, Just Typeable.Refl) -> True
       (_, _) -> False
-    -- Method is not comparable TODO: ACTUALLY IT MAY BE POSSIBLE
+    -- Method is not comparable TODO: ACTUALLY IT MAY BE POSSIBLE. AT LEAST PARTIALLY
     (_, _) -> False
 -}
 
@@ -201,8 +207,8 @@ smush a1 a2 = case (a1, a2) of
         Nothing -> Nothing
       False -> Nothing
     (_, _) -> Nothing
-  (Respond @a1 @r1 children1, Respond @a2 @r2 children2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
-    (Just Typeable.Refl, Just Typeable.Refl) -> Just $ respond @a1 @r1 $ smushes (children1 <> children2)
+  (Responses @t1 @r1 children1, Responses @t2 @r2 children2) -> case (Typeable.eqT @t1 @t2, Typeable.eqT @r1 @r2) of
+    (Just Typeable.Refl, Just Typeable.Refl) -> Just $ responses @t1 @r1 $ smushes (children1 <> children2)
     (_, _) -> Nothing
   -- Method is not comparable
   (_, _) -> Nothing
@@ -250,7 +256,7 @@ lit = match @Text.Text
 param ::
   forall a (r :: [Type]).
   (Web.FromHttpApiData a, Typeable.Typeable a, Typeable.Typeable r) =>
-  [Atom (r :> a)] ->
+  [Atom (r :-> a)] ->
   Atom r
 param = Param @a @r
 
@@ -258,42 +264,42 @@ regex ::
   forall a (r :: [Type]).
   (Regex.RegexContext Regex.Regex Text.Text a, Typeable.Typeable a, Typeable.Typeable r) =>
   Text.Text ->
-  [Atom (r :> a)] ->
+  [Atom (r :-> a)] ->
   Atom r
 regex = Regex @a @r
 
 splat ::
   forall a (r :: [Type]).
   (Web.FromHttpApiData a, Typeable.Typeable a, Typeable.Typeable r) =>
-  [Atom (r :> NonEmpty.NonEmpty a)] ->
+  [Atom (r :-> NonEmpty.NonEmpty a)] ->
   Atom r
 splat = Splat @a @r
 
 route ::
   forall a (r :: [Type]).
   (Route.From a, Typeable.Typeable a, Typeable.Typeable r) =>
-  [Atom (r :> a)] ->
+  [Atom (r :-> a)] ->
   Atom r
 route = Route @a @r
 
 query ::
   forall a (r :: [Type]).
   (Query.From a, Typeable.Typeable a, Typeable.Typeable r) =>
-  [Atom (r :> a)] ->
+  [Atom (r :-> a)] ->
   Atom r
 query = Query @a @r
 
 headers ::
   forall a (r :: [Type]).
   (Headers.From a, Typeable.Typeable a, Typeable.Typeable r) =>
-  [Atom (r :> a)] ->
+  [Atom (r :-> a)] ->
   Atom r
 headers = Headers @a @r
 
 body ::
   forall a (r :: [Type]).
   (Body.From a, Typeable.Typeable a, Typeable.Typeable r) =>
-  [Atom (r :> a)] ->
+  [Atom (r :-> a)] ->
   Atom r
 body = Body @a @r
 
@@ -309,16 +315,16 @@ scope ::
   forall a t (r :: [Type]).
   (Route.From a, Typeable.Typeable a, Middleware.Tag t, Eq t, Typeable.Typeable t, Typeable.Typeable r) =>
   t ->
-  [Atom (r :> a)] ->
+  [Atom (r :-> a)] ->
   Atom r
 scope tag children = apply @t @r tag $ route @a @r children
 
-respond ::
-  forall a (r :: [Type]).
-  (Response.To a, Typeable.Typeable a, Typeable.Typeable r) =>
-  [Atom (r :> a)] ->
+responses ::
+  forall t (r :: [Type]).
+  (Response.Tag t, Typeable.Typeable t, Typeable.Typeable r) =>
+  [Atom (r :-> (t -> Response.Response))] ->
   Atom r
-respond = Respond @a @r
+responses = Responses @t @r
 
 method ::
   forall env (r :: [Type]).
@@ -331,17 +337,19 @@ method = Method @env @r
 
 endpoint ::
   forall a env (r :: [Type]).
-  (Route.From a, Typeable.Typeable a, Typeable.Typeable r, Typeable.Typeable (r :> a)) =>
+  (Route.From a, Typeable.Typeable a, Typeable.Typeable r, Typeable.Typeable (r :-> a)) =>
   HTTP.StdMethod ->
   (env Natural.~> IO) ->
-  Handler (r :> a) env ->
+  Handler (r :-> a) env ->
   Atom r
 endpoint stdMethod transformation handler =
   route @a
-    [ method @env @(r :> a) stdMethod transformation handler
+    [ method @env @(r :-> a) stdMethod transformation handler
     ]
 
-myTest = Warp.run 8080 $ test `withDefault` \_ resp -> resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
+myTest =
+  Warp.run 8080 $ test `withDefault` \_ resp ->
+    resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
 
 test =
   [ lit
@@ -357,7 +365,7 @@ test =
                       [ method HTTP.POST id testHandler2
                       ]
                   , param @Float
-                      [ method HTTP.PUT id \bool1 -> \int2 -> \f3 -> \req -> do
+                      [ method HTTP.PUT id \bool1 int2 f3 req -> do
                           return $ Wai.responseLBS HTTP.status200 [] "many args"
                       ]
                   ]
@@ -371,6 +379,11 @@ test =
       , method HTTP.HEAD id \req -> do
           return $ Wai.responseLBS HTTP.status200 [] "dub"
       ]
+  , lit
+      "world"
+      [ method HTTP.POST id \req -> do
+          return $ Wai.responseLBS HTTP.status200 [] "dub"
+      ]
   , method HTTP.GET id \req -> do
       return $ Wai.responseLBS HTTP.status200 [] "What's up??"
   ]
@@ -387,7 +400,7 @@ 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 :: 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)
 
@@ -445,6 +458,7 @@ withDefaultLoop middleware args tree backup request respond = case tree of
                   request
                   respond
               else withDefaultLoop middleware args remTree backup request respond
+      Responses @t subTree -> undefined
 
 {-
 withDefault :: Tree -> Wai.Middleware

lib/src/Okapi/Response.hs

@@ -43,7 +43,7 @@ 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
 
 class ToHeader a where
@@ -55,17 +55,6 @@ type family Elem x ys where
   Elem x (x ': ys) = 'True
   Elem x (y ': ys) = Elem x ys
 
--- type Remove :: Exts.Symbol -> [Exts.Symbol] -> [Exts.Symbol]
--- type family Remove (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]) where
---   Remove _ '[] = '[]
---   Remove headerKey (h : t) = If (headerKey Equality.== h) t (h : Remove headerKey t)
-
-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 Headers (headerKeys :: [Exts.Symbol]) where
   NoHeaders :: Headers '[]
   InsertHeader ::
@@ -83,17 +72,6 @@ insertHeader ::
   Headers (headerKey : headerKeys)
 insertHeader = InsertHeader
 
--- deleteHeader ::
---   forall (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]).
---   (Elem headerKey headerKeys ~ True) =>
---   Headers headerKeys ->
---   Headers (Remove headerKey headerKeys)
--- deleteHeader NoHeaders = NoHeaders
--- deleteHeader (InsertHeader @k v rest) =
---   case Typeable.eqT @headerKey @k of
---     Nothing -> (deleteHeader @headerKey rest)
---     Just Typeable.Refl -> rest
-
 data HeaderKey (k :: Exts.Symbol) = HeaderKey
 
 -- instance Exts.KnownSymbol k => Show (Var k) where
@@ -142,49 +120,52 @@ class ContentType a where
 class (ContentType a) => ToContentType a b | b -> a where
   toContentType :: b -> a
 
-data Response (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type) where
+data Response where
   Response ::
     forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
     (ContentType contentType, ToContentType contentType resultType) =>
     Headers headerKeys ->
     resultType ->
-    Response status headerKeys contentType resultType
+    Response
 
-data Builder a where
-  FMap :: (a -> b) -> Builder a -> Builder b
-  Pure :: a -> Builder a
-  Apply :: Builder (a -> b) -> Builder a -> Builder b
-  Has ::
-    forall
-      (status :: Natural.Natural)
-      (headerKeys :: [Exts.Symbol])
-      (contentType :: Type)
-      (resultType :: Type).
-    Builder
-      ( Headers headerKeys ->
-        resultType ->
-        Response status headerKeys contentType resultType
-      )
+class (Enum a) => Tag a where
+  fromTag :: a -> Response
 
-instance Functor Builder where
-  fmap = FMap
+-- data Builder a where
+--   FMap :: (a -> b) -> Builder a -> Builder b
+--   Pure :: a -> Builder a
+--   Apply :: Builder (a -> b) -> Builder a -> Builder b
+--   With ::
+--     forall
+--       (status :: Natural.Natural)
+--       (headerKeys :: [Exts.Symbol])
+--       (contentType :: Type)
+--       (resultType :: Type).
+--     Builder
+--       ( Headers headerKeys ->
+--         resultType ->
+--         Wai.Response
+--       )
 
-instance Applicative Builder where
-  pure = Pure
-  (<*>) = Apply
+-- instance Functor Builder where
+--   fmap = FMap
 
-has ::
-  forall
-    (status :: Natural.Natural)
-    (headerKeys :: [Exts.Symbol])
-    (contentType :: Type)
-    (resultType :: Type).
-  Builder
-    ( Headers headerKeys ->
-      resultType ->
-      Response status headerKeys contentType resultType
-    )
-has = Has
+-- instance Applicative Builder where
+--   pure = Pure
+--   (<*>) = Apply
+
+-- with ::
+--   forall
+--     (status :: Natural.Natural)
+--     (headerKeys :: [Exts.Symbol])
+--     (contentType :: Type)
+--     (resultType :: Type).
+--   Builder
+--     ( Headers headerKeys ->
+--       resultType ->
+--       Wai.Response
+--     )
+-- with = With
 
 -- equals :: Builder a -> Builder b -> Bool
 -- equals (FMap _ r) (FMap _ r') = equals r r'
@@ -193,6 +174,5 @@ has = Has
 -- equals (Has _) (Has _) = undefined
 -- equals _ _ = False
 
-class To a where
-  builder :: Builder a
-  build :: ()
+-- class To a where
+--   builder :: Builder a

lib/src/Okapi/Response/Headers.hs

@@ -0,0 +1 @@
+module Okapi.Response.Headers where

lib/src/Okapi/Response/Raw.hs

@@ -0,0 +1 @@
+module Okapi.Response.Raw where

lib/src/Okapi/Secret.hs

@@ -1,34 +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.Secret where
-
-import Data.Vault.Lazy qualified as Vault
-import Network.Wai qualified as Wai
-
-newtype Secret a = Secret (Vault.Key a)
-
-new :: forall a. IO (Secret a)
-new = Secret <$> Vault.newKey @a
-
-tell :: Wai.Request -> Secret a -> a
-tell req (Secret key) = case Vault.lookup key $ Wai.vault req of
-  Nothing -> error "IMPOSSIBLE"
-  Just val -> val