From ccb3ca001d2c3514fc83a8c8decbfbdf6952c932 Mon Sep 17 00:00:00 2001 From: Rashad Gover Date: Mon, 30 Oct 2023 05:21:19 -0700 Subject: [PATCH] Fix names; fix Splat combinator; experiment with type-level Response, API, and other parts where it makes sense --- lib/okapi.cabal | 1 + lib/src/Okapi.hs | 50 ++++---- lib/src/Okapi/API.hs | 256 +++++++++++--------------------------- lib/src/Okapi/Response.hs | 114 ++++++++++++++++- lib/src/Okapi/Route.hs | 26 ++-- lib/src/Okapi/Secret.hs | 4 +- lib/src/Okapi/TypedAPI.hs | 74 +++++++++++ 7 files changed, 305 insertions(+), 220 deletions(-) create mode 100644 lib/src/Okapi/TypedAPI.hs diff --git a/lib/okapi.cabal b/lib/okapi.cabal index f4544fc..5aa4327 100644 --- a/lib/okapi.cabal +++ b/lib/okapi.cabal @@ -42,6 +42,7 @@ library aeson , base >=4.7 && <5 , base64 + , binary , bytestring , case-insensitive , containers diff --git a/lib/src/Okapi.hs b/lib/src/Okapi.hs index 1afbda2..31d3cc4 100644 --- a/lib/src/Okapi.hs +++ b/lib/src/Okapi.hs @@ -17,6 +17,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE QualifiedDo #-} +-- {-# LANGUAGE RebindableSyntax #-} module Okapi where @@ -34,7 +36,7 @@ import Network.HTTP.Types qualified as HTTP import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Middleware.RequestLogger qualified as Wai --- import Okapi.API qualified as API +import Okapi.API qualified as API import Okapi.API import Okapi.Headers qualified as Headers import Okapi.Route qualified as Route @@ -52,21 +54,21 @@ test1 = do resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..." testAPI :: [API] testAPI = - [ match + [ lit "" -- Won't be matched because you can't request http://localhost:1234/ [ get_ id \req -> do return $ Wai.responseLBS HTTP.status200 [] "The trailing slash" ], - match + lit "hello" [ get_ id \req -> do return $ Wai.responseLBS HTTP.status200 [] "world", - match + lit "" [ get_ id \req -> do return $ Wai.responseLBS HTTP.status200 [] "Trailing slash after \"hello\"" ], - match + lit "world" [ get_ id \req -> do return $ Wai.responseLBS HTTP.status200 [] "!" @@ -86,21 +88,21 @@ test2 = do resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..." testAPI :: [API] testAPI = - match + lit "" -- Won't be matched because you can't request http://localhost:1234/ [ get_ id \req -> do return $ Wai.responseLBS HTTP.status200 [] "The trailing slash" ] - : match + : lit "hello" [ get_ id \req -> do return $ Wai.responseLBS HTTP.status200 [] "world", - match + lit "" [ get_ id \req -> do return $ Wai.responseLBS HTTP.status200 [] "Trailing slash after \"hello\"" ], - match + lit "world" [ get_ id \req -> do return $ Wai.responseLBS HTTP.status200 [] "!" @@ -121,14 +123,14 @@ test3 = do resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..." testAPI :: [API] testAPI = - [ match + [ lit "numbers" - [ match + [ lit "add" [ param @Int \xS -> [ param @Int \yS -> [ getIO_ \req -> do - let magic = Secret.reveal req + let magic = Secret.tell req x = magic xS y = magic yS return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x + y) @@ -159,15 +161,15 @@ test4 = do resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..." testAPI :: [API] testAPI = - [ match + [ lit "numbers" [ param @Op \opS -> [ param @Int \xS -> [ param @Int \yS -> [ getIO_ \req -> do - let x = Secret.reveal req xS - y = Secret.reveal req yS - answer = case Secret.reveal req opS of + let x = Secret.tell req xS + y = Secret.tell req yS + answer = case Secret.tell req opS of Add -> x + y Sub -> x - y Mul -> x * y @@ -175,7 +177,7 @@ test4 = do ] ], getIO_ \req -> do - return $ Wai.responseLBS HTTP.status200 [] $ case Secret.reveal req opS of + return $ Wai.responseLBS HTTP.status200 [] $ case Secret.tell req opS of Add -> "Add two numbers." Sub -> "Subtract one number from another." Mul -> "Multiply two numbers." @@ -193,9 +195,9 @@ instance Web.ToHttpApiData Op where test5 :: IO () test5 = do apiTreeRep <- forest testAPI - apiEndpoints <- endpoints testAPI + -- apiEndpoints <- endpoints testAPI putStrLn $ Tree.drawTree apiTreeRep - Pretty.pPrint $ map curl $ List.reverse apiEndpoints + -- Pretty.pPrint $ map curl $ List.reverse apiEndpoints where -- Warp.run 1234 $ build testAPI id backupWaiApp @@ -203,7 +205,7 @@ test5 = do resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..." testAPI :: [API] testAPI = - [ match "numbers" $ + [ lit "numbers" $ [ getIO_ \req -> do return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul" ] @@ -212,7 +214,7 @@ test5 = do opAPI :: Op -> API opAPI op = - lit + match op [ getIO_ \req -> do return $ Wai.responseLBS HTTP.status200 [] $ case op of @@ -222,8 +224,8 @@ opAPI op = param @Int \xS -> [ param @Int \yS -> [ getIO_ \req -> do - let x = Secret.reveal req xS - y = Secret.reveal req yS + let x = Secret.tell req xS + y = Secret.tell req yS answer = case op of Add -> x + y Sub -> x - y @@ -234,7 +236,7 @@ opAPI op = ++ case op of Mul -> [ getIO_ \req -> do - let x = Secret.reveal req xS + let x = Secret.tell req xS return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x * x) ] _ -> [] diff --git a/lib/src/Okapi/API.hs b/lib/src/Okapi/API.hs index 0d9b4e5..6174898 100644 --- a/lib/src/Okapi/API.hs +++ b/lib/src/Okapi/API.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} @@ -15,24 +16,33 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Okapi.API 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 GHC.Natural qualified as Natural import Network.HTTP.Types qualified as HTTP import Network.Wai qualified as Wai 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 Web.HttpApiData qualified as Web @@ -40,134 +50,62 @@ import Web.HttpApiData qualified as Web type Handler env = Wai.Request -> env Wai.Response data API where - Match :: Text.Text -> [API] -> API + Match :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API Param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [API]) -> API - Splat :: (Secret.Secret (NonEmpty.NonEmpty Text.Text) -> [API]) -> API - Router :: forall a. Route.Route a -> (Secret.Secret a -> [API]) -> API - Meta :: forall a. Headers.Headers a -> (Secret.Secret a -> [API]) -> API - Method :: forall env. (HTTP.StdMethod -> Bool) -> (env Natural.~> IO) -> Handler env -> API - Wrap :: Wai.Middleware -> API -> API + Regex :: API + Splat :: forall a. (Web.FromHttpApiData a) => (Secret.Secret (NonEmpty.NonEmpty a) -> [API]) -> API + Route :: forall a. Route.Parser a -> (Secret.Secret a -> [API]) -> API + Method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> API + -- Query :: forall a. Query.Parser a -> (Secret.Secret a -> [API]) -> API + -- Headers :: forall a. RequestHeaders.Parser a -> (Secret.Secret a -> [API]) -> API + -- Body :: forall a. RequestBody.Parser a -> (Secret.Secret a -> [API]) -> API + Pipe :: Wai.Middleware -> API -> API + Respond :: + forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type). + (Response.ToContentType contentType resultType) => + ((Response.Headers headerKeys -> resultType -> Wai.Response) -> [API]) -> + API -match :: Text.Text -> [API] -> API +match :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API match = Match -lit :: forall a. (Web.ToHttpApiData a) => a -> [API] -> API -lit l = Match (Web.toUrlPiece l) +lit :: Text.Text -> [API] -> API +lit = match @Text.Text param :: forall a. (Web.FromHttpApiData a, Typeable.Typeable a) => (Secret.Secret a -> [API]) -> API param = Param -splat :: (Secret.Secret (NonEmpty.NonEmpty Text.Text) -> [API]) -> API +splat :: forall a. (Web.FromHttpApiData a) => (Secret.Secret (NonEmpty.NonEmpty a) -> [API]) -> API splat = Splat -router :: forall a. Route.Route a -> (Secret.Secret a -> [API]) -> API -router = Router +route :: forall a. Route.Parser a -> (Secret.Secret a -> [API]) -> API +route = Route -meta :: forall a. Headers.Headers a -> (Secret.Secret a -> [API]) -> API -meta = Meta - -wrap :: Wai.Middleware -> API -> API -wrap = Wrap +pipe :: Wai.Middleware -> API -> API +pipe = Pipe scope :: Wai.Middleware -> Text.Text -> [API] -> API -scope mw t apps = wrap mw $ match t apps +scope mw t apps = pipe mw $ lit t apps -method_ :: forall env. (HTTP.StdMethod -> Bool) -> (env Natural.~> IO) -> Handler env -> API -method_ = Method +method :: forall env. HTTP.StdMethod -> (env Natural.~> IO) -> Handler env -> API +method = Method -get_ :: forall env. (env Natural.~> IO) -> Handler env -> API -get_ = method_ (HTTP.GET ==) - -getIO_ :: Handler IO -> API -getIO_ = get_ id - -getPure_ :: Handler Identity.Identity -> API -getPure_ = get_ (return . Identity.runIdentity) - -post_ :: forall env. (env Natural.~> IO) -> Handler env -> API -post_ = method_ (HTTP.POST ==) - -postIO_ :: Handler IO -> API -postIO_ = post_ id - -postPure_ :: Handler Identity.Identity -> API -postPure_ = post_ (return . Identity.runIdentity) - -head_ :: forall env. (env Natural.~> IO) -> Handler env -> API -head_ = method_ (HTTP.HEAD ==) - -headIO_ :: Handler IO -> API -headIO_ = head_ id - -headPure_ :: Handler Identity.Identity -> API -headPure_ = head_ (return . Identity.runIdentity) - -put_ :: forall env. (env Natural.~> IO) -> Handler env -> API -put_ = method_ (HTTP.PUT ==) - -putIO_ :: Handler IO -> API -putIO_ = put_ id - -putPure_ :: Handler Identity.Identity -> API -putPure_ = put_ (return . Identity.runIdentity) - -delete_ :: forall env. (env Natural.~> IO) -> Handler env -> API -delete_ = method_ (HTTP.DELETE ==) - -deleteIO_ :: Handler IO -> API -deleteIO_ = delete_ id - -deletePure_ :: Handler Identity.Identity -> API -deletePure_ = delete_ (return . Identity.runIdentity) - -trace_ :: forall env. (env Natural.~> IO) -> Handler env -> API -trace_ = method_ (HTTP.TRACE ==) - -traceIO_ :: Handler IO -> API -traceIO_ = trace_ id - -tracePure_ :: Handler Identity.Identity -> API -tracePure_ = trace_ (return . Identity.runIdentity) - -connect_ :: forall env. (env Natural.~> IO) -> Handler env -> API -connect_ = method_ (HTTP.CONNECT ==) - -connectIO_ :: Handler IO -> API -connectIO_ = connect_ id - -connectPure_ :: Handler Identity.Identity -> API -connectPure_ = connect_ (return . Identity.runIdentity) - -options_ :: forall env. (env Natural.~> IO) -> Handler env -> API -options_ = method_ (HTTP.OPTIONS ==) - -optionsIO_ :: Handler IO -> API -optionsIO_ = options_ id - -optionsPure_ :: Handler Identity.Identity -> API -optionsPure_ = options_ (return . Identity.runIdentity) - -patch_ :: forall env. (env Natural.~> IO) -> Handler env -> API -patch_ = method_ (HTTP.PATCH ==) - -patchIO_ :: Handler IO -> API -patchIO_ = patch_ id - -patchPure_ :: Handler Identity.Identity -> API -patchPure_ = patch_ (return . Identity.runIdentity) - -any_ :: forall env. (env Natural.~> IO) -> Handler env -> API -any_ = method_ (const True) +respond :: + forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type). + (Response.ToContentType contentType resultType) => + ((Response.Headers headerKeys -> resultType -> Wai.Response) -> [API]) -> + API +respond = Respond build :: [API] -> Wai.Middleware -> Wai.Middleware build [] _ backup req resp = backup req resp build (api : apis) middlewareToApply backup req resp = case api of - Match text children -> + Match value children -> case Wai.pathInfo req of [] -> build apis middlewareToApply backup req resp (pathHead : pathTail) -> - if pathHead == text + if pathHead == Web.toUrlPiece value then do let newReq = req {Wai.pathInfo = pathTail} build children middlewareToApply backup newReq resp @@ -183,16 +121,26 @@ build (api : apis) middlewareToApply backup req resp = let newVault = Vault.insert key value (Wai.vault req) newReq = req {Wai.pathInfo = pathTail, Wai.vault = newVault} build (produce $ Secret.Secret key) middlewareToApply backup newReq resp - Splat produce -> do + Splat @ty produce -> do case Wai.pathInfo req of [] -> build apis middlewareToApply backup req resp - (pathHead : pathTail) -> do - let nonEmptyPath = pathHead NonEmpty.:| pathTail - key <- Vault.newKey @(NonEmpty.NonEmpty Text.Text) - let newVault = Vault.insert key nonEmptyPath (Wai.vault req) - newReq = req {Wai.pathInfo = [], Wai.vault = newVault} - build (produce $ Secret.Secret key) middlewareToApply backup newReq resp - Router @ty route produce -> do + (pathHead : pathTail) -> case Web.parseUrlPiece @ty pathHead of + Left _ -> build apis middlewareToApply backup req resp + Right valueHead -> do + -- TODO: FIX ALGORITHM! + let valueTail = loop @ty pathTail + nonEmptyPath = valueHead NonEmpty.:| valueTail + key <- Vault.newKey @(NonEmpty.NonEmpty ty) + let newVault = Vault.insert key nonEmptyPath (Wai.vault req) + newReq = req {Wai.pathInfo = List.drop (List.length valueTail + 1) (Wai.pathInfo req), Wai.vault = newVault} + build (produce $ Secret.Secret key) middlewareToApply backup newReq resp + where + loop :: forall ty. (Web.FromHttpApiData ty) => [Text.Text] -> [ty] + loop [] = [] + loop (t : ts) = case Web.parseUrlPiece @ty t of + Left _ -> [] + Right v -> v : loop @ty ts + Route @ty route produce -> do case Route.exec route $ Wai.pathInfo req of (Left _, _) -> build apis middlewareToApply backup req resp (Right value, newPathInfo) -> do @@ -200,11 +148,11 @@ build (api : apis) middlewareToApply backup req resp = let newVault = Vault.insert key value (Wai.vault req) newReq = req {Wai.pathInfo = newPathInfo, Wai.vault = newVault} build (produce $ Secret.Secret key) middlewareToApply backup newReq resp - Method pred trans handler -> + Method m trans handler -> case HTTP.parseMethod $ Wai.requestMethod req of Left _ -> build apis middlewareToApply backup req resp Right stdMethod -> - if pred stdMethod && List.null (Wai.pathInfo req) + if m == stdMethod && List.null (Wai.pathInfo req) then middlewareToApply ( \req' resp' -> do @@ -214,7 +162,7 @@ build (api : apis) middlewareToApply backup req resp = req resp else build apis middlewareToApply backup req resp - Wrap otherMiddlewareToApply app -> + Pipe otherMiddlewareToApply app -> build (app : []) (otherMiddlewareToApply . middlewareToApply) @@ -229,82 +177,30 @@ forest apis = do return $ Tree.Node "\ESC[31m:root:\ESC[0m" forest' where tree :: API -> IO (Tree.Tree String) - tree (Match text apis) = do + tree (Match value apis) = do forest <- mapM tree apis - return $ Tree.Node ("/" <> Text.unpack text) forest + 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 (Splat produce) = do - secret <- Secret.new @(NonEmpty.NonEmpty Text.Text) + tree (Splat @ty produce) = do + secret <- Secret.new @(NonEmpty.NonEmpty ty) forest <- mapM tree $ produce secret return $ Tree.Node "/*" forest - tree (Router @ty route produce) = do + 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 pred _ _) = do - return $ Tree.Node (show $ filter pred [minBound ..]) [] - tree (Wrap _ api) = do + tree (Method m _ _) = do + return $ Tree.Node (show m) [] + tree (Pipe _ api) = do (Tree.Node root subTrees) <- tree api return $ Tree.Node ("(" <> root <> ")") subTrees -data Endpoint = Endpoint [Text.Text] HTTP.StdMethod - deriving (Generics.Generic, Eq, Show) - -curl :: Endpoint -> Text.Text -curl (Endpoint [] method) = (Text.pack $ show method) <> " :root:" -curl (Endpoint path method) = (Text.pack $ show method) <> " /" <> Text.intercalate "/" path - -endpoints :: [API] -> IO [Endpoint] -endpoints [] = pure [] -endpoints (api : apis) = case api of - Match text children -> do - childrenEndpoints <- map (\(Endpoint path methods) -> Endpoint (text : path) methods) <$> endpoints children - siblingEndpoints <- endpoints apis - pure $ siblingEndpoints <> childrenEndpoints - Param @ty produce -> do - secret <- Secret.new @ty - childrenEndpoints <- map (\(Endpoint path methods) -> Endpoint (":" <> Text.pack (showType @ty) : path) methods) <$> (endpoints $ produce secret) - siblingEndpoints <- endpoints apis - pure $ siblingEndpoints <> childrenEndpoints - Splat produce -> do - secret <- Secret.new @(NonEmpty.NonEmpty Text.Text) - childrenEndpoints <- map (\(Endpoint path methods) -> Endpoint ("*" : path) methods) <$> (endpoints $ produce secret) - siblingEndpoints <- endpoints apis - pure $ siblingEndpoints <> childrenEndpoints - Router @ty route produce -> do - secret <- Secret.new @ty - let routeSegments = Text.split ('/' ==) $ Route.rep route - childrenEndpoints <- map (\(Endpoint path methods) -> Endpoint (routeSegments <> path) methods) <$> (endpoints $ produce secret) - siblingEndpoints <- endpoints apis - pure $ siblingEndpoints <> childrenEndpoints - Method pred _ _ -> do - siblingEndpoints <- endpoints apis - pure $ siblingEndpoints <> (map (Endpoint []) $ filter pred [minBound ..]) - Wrap _ wrappedAPI -> endpoint wrappedAPI - where - endpoint :: API -> IO [Endpoint] - endpoint api = case api of - Match text children -> do - childrenEndpoints <- endpoints children - pure $ map (\(Endpoint path methods) -> Endpoint (text : path) methods) childrenEndpoints - Param @ty produce -> do - secret <- Secret.new @ty - childrenEndpoints <- endpoints $ produce secret - pure $ map (\(Endpoint path methods) -> Endpoint (":" <> Text.pack (showType @ty) : path) methods) childrenEndpoints - Splat produce -> do - secret <- Secret.new @(NonEmpty.NonEmpty Text.Text) - childrenEndpoints <- endpoints $ produce secret - pure $ map (\(Endpoint path methods) -> Endpoint ("*" : path) methods) childrenEndpoints - Router @ty route produce -> do - secret <- Secret.new @ty - childrenEndpoints <- endpoints $ produce secret - let routeSegments = Text.split ('/' ==) $ Route.rep route - pure $ map (\(Endpoint path methods) -> Endpoint (routeSegments <> path) methods) childrenEndpoints - Method pred _ _ -> pure (map (Endpoint []) $ filter pred [minBound ..]) - Wrap _ wrappedAPI -> endpoint wrappedAPI - showType :: forall a. (Typeable.Typeable a) => String showType = show . Typeable.typeRep $ Typeable.Proxy @a + +get_ = method HTTP.GET + +getIO_ = method HTTP.GET id \ No newline at end of file diff --git a/lib/src/Okapi/Response.hs b/lib/src/Okapi/Response.hs index a327fab..d127f7c 100644 --- a/lib/src/Okapi/Response.hs +++ b/lib/src/Okapi/Response.hs @@ -2,8 +2,10 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} @@ -14,26 +16,136 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} 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.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 Okapi.API qualified as API 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 + toHeader :: a -> LBS.ByteString +type Elem :: Exts.Symbol -> [Exts.Symbol] -> Bool +type family Elem x ys where + Elem x '[] = 'False + 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 :: + forall (headerKey :: Exts.Symbol) headerValue (headerKeys :: [Exts.Symbol]). + (ToHeader headerValue) => + headerValue -> + Headers headerKeys -> + Headers (headerKey : headerKeys) + +insertHeader :: + forall (headerKey :: Exts.Symbol) headerValue (headerKeys :: [Exts.Symbol]). + (ToHeader headerValue) => + headerValue -> + Headers headerKeys -> + 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 Key (k :: Exts.Symbol) = Key + +-- instance Exts.KnownSymbol k => Show (Var k) where +-- show = Exts.symbolVal + +-- | Membership test a type class (predicate) +class IsMember (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]) where + -- | Value-level lookup of elements from a map, via type class predicate + lookupHeader :: Key headerKey -> Headers headerKeys -> LBS.ByteString + +-- instance {-# OVERLAPS #-} IsMember v t ((v ':-> t) ': m) where +-- lookp _ (Ext _ x _) = x + +instance {-# OVERLAPS #-} IsMember headerKey (headerKey ': rest) where + lookupHeader _ (InsertHeader v _) = toHeader v + +-- instance {-# OVERLAPPABLE #-} IsMember v t m => IsMember v t (x ': m) where +-- lookp v (Ext _ _ m) = lookp v m + +instance {-# OVERLAPPABLE #-} (IsMember headerKey headerKeys) => IsMember headerKey (otherHeaderKey ': headerKeys) where + lookupHeader k (InsertHeader _ tail) = lookupHeader k tail + +{- +lookupHeader :: + forall (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]). + (Elem headerKey headerKeys ~ True) => + Headers headerKeys -> + LBS.ByteString +lookupHeader NoHeaders = undefined +lookupHeader (InsertHeader @k v rest) = + case Typeable.eqT @headerKey @k of + Nothing -> lookupHeader @headerKey rest + Just Typeable.Refl -> toHeader v +-} + +data Body + = BodyStream Wai.StreamingBody + | BodyBuilder Builder.Builder + | BodyBytes LBS.ByteString + | BodyFile FilePath Wai.FilePart + +class ContentType a where + contentTypeName :: LBS.ByteString + contentTypeBody :: a -> Body + +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 + 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 diff --git a/lib/src/Okapi/Route.hs b/lib/src/Okapi/Route.hs index 6caad36..3e476b9 100644 --- a/lib/src/Okapi/Route.hs +++ b/lib/src/Okapi/Route.hs @@ -12,34 +12,34 @@ import Data.Text import Data.Typeable import Web.HttpApiData qualified as Web -data Route a where - FMap :: (a -> b) -> Route a -> Route b - Pure :: a -> Route a - Apply :: Route (a -> b) -> Route a -> Route b - Match :: Text -> Route () - Param :: (Typeable a, Web.FromHttpApiData a) => Route a +data Parser a where + FMap :: (a -> b) -> Parser a -> Parser b + Pure :: a -> Parser a + Apply :: Parser (a -> b) -> Parser a -> Parser b + Match :: Text -> Parser () + Param :: (Typeable a, Web.FromHttpApiData a) => Parser a -instance Functor Route where +instance Functor Parser where fmap = FMap -instance Applicative Route where +instance Applicative Parser where pure = Pure (<*>) = Apply -param :: (Typeable a, Web.FromHttpApiData a) => Route a +param :: (Typeable a, Web.FromHttpApiData a) => Parser a param = Param -match :: Text -> Route () +match :: Text -> Parser () match = Match -rep :: Route a -> Text +rep :: Parser 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 :: Route a -> Route b -> Bool +-- equals :: Parser a -> Parser 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' @@ -51,5 +51,5 @@ rep (Param @p) = "/:" <> pack (show . typeRep $ Proxy @p) data Error = Error -exec :: Route a -> [Text] -> (Either Error a, [Text]) +exec :: Parser a -> [Text] -> (Either Error a, [Text]) exec = undefined \ No newline at end of file diff --git a/lib/src/Okapi/Secret.hs b/lib/src/Okapi/Secret.hs index d024ad5..6fb4917 100644 --- a/lib/src/Okapi/Secret.hs +++ b/lib/src/Okapi/Secret.hs @@ -28,7 +28,7 @@ newtype Secret a = Secret (Vault.Key a) new :: forall a. IO (Secret a) new = Secret <$> Vault.newKey @a -reveal :: Wai.Request -> Secret a -> a -reveal req (Secret key) = case Vault.lookup key $ Wai.vault req of +tell :: Wai.Request -> Secret a -> a +tell req (Secret key) = case Vault.lookup key $ Wai.vault req of Nothing -> error "IMPOSSIBLE" Just val -> val diff --git a/lib/src/Okapi/TypedAPI.hs b/lib/src/Okapi/TypedAPI.hs new file mode 100644 index 0000000..5dceecb --- /dev/null +++ b/lib/src/Okapi/TypedAPI.hs @@ -0,0 +1,74 @@ +{-# 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.API 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)) \ No newline at end of file