From d55a09da63ad20de069bf6f69895d0af65d5e642 Mon Sep 17 00:00:00 2001 From: Rashad Gover Date: Thu, 9 Nov 2023 08:54:09 -0800 Subject: [PATCH] Use Tag class for Responses as well. May change --- lib/okapi.cabal | 1 - lib/src/Okapi.hs | 2 +- lib/src/Okapi/App.hs | 92 +++++++++++++++------------ lib/src/Okapi/Response.hs | 100 ++++++++++++------------------ lib/src/Okapi/Response/Headers.hs | 1 + lib/src/Okapi/Response/Raw.hs | 1 + lib/src/Okapi/Secret.hs | 34 ---------- 7 files changed, 96 insertions(+), 135 deletions(-) create mode 100644 lib/src/Okapi/Response/Headers.hs create mode 100644 lib/src/Okapi/Response/Raw.hs delete mode 100644 lib/src/Okapi/Secret.hs diff --git a/lib/okapi.cabal b/lib/okapi.cabal index b51b1fd..6293139 100644 --- a/lib/okapi.cabal +++ b/lib/okapi.cabal @@ -33,7 +33,6 @@ library Okapi.Headers Okapi.Query Okapi.Body - Okapi.Secret Okapi.App Okapi.Route Okapi.Response diff --git a/lib/src/Okapi.hs b/lib/src/Okapi.hs index 08c2d3d..5e761ae 100644 --- a/lib/src/Okapi.hs +++ b/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 diff --git a/lib/src/Okapi/App.hs b/lib/src/Okapi/App.hs index 18d227b..663947a 100644 --- a/lib/src/Okapi/App.hs +++ b/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 diff --git a/lib/src/Okapi/Response.hs b/lib/src/Okapi/Response.hs index cdd3568..bc66c8f 100644 --- a/lib/src/Okapi/Response.hs +++ b/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 diff --git a/lib/src/Okapi/Response/Headers.hs b/lib/src/Okapi/Response/Headers.hs new file mode 100644 index 0000000..01ce7d6 --- /dev/null +++ b/lib/src/Okapi/Response/Headers.hs @@ -0,0 +1 @@ +module Okapi.Response.Headers where diff --git a/lib/src/Okapi/Response/Raw.hs b/lib/src/Okapi/Response/Raw.hs new file mode 100644 index 0000000..9a6d02b --- /dev/null +++ b/lib/src/Okapi/Response/Raw.hs @@ -0,0 +1 @@ +module Okapi.Response.Raw where diff --git a/lib/src/Okapi/Secret.hs b/lib/src/Okapi/Secret.hs deleted file mode 100644 index 6fb4917..0000000 --- a/lib/src/Okapi/Secret.hs +++ /dev/null @@ -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