From ce4e6aedf105d19c4f64f01e785a101fc3ff26a0 Mon Sep 17 00:00:00 2001 From: Rashad Gover Date: Thu, 20 Jul 2023 14:36:54 +0900 Subject: [PATCH] Add parsers for Headers --- lib/okapi.cabal | 5 +- lib/src/Okapi/Parser/Headers/Alt.hs | 96 +++++++++++++++++++++++ lib/src/Okapi/Parser/Headers/Ap.hs | 81 +++++++++++++++++++ lib/src/Okapi/Parser/Headers/Operation.hs | 54 +++++++++++++ lib/src/Okapi/Parser/Query/Alt.hs | 4 +- lib/src/Okapi/Parser/Query/Ap.hs | 2 +- lib/src/Okapi/Tree.hs | 1 - 7 files changed, 238 insertions(+), 5 deletions(-) create mode 100644 lib/src/Okapi/Parser/Headers/Alt.hs create mode 100644 lib/src/Okapi/Parser/Headers/Ap.hs create mode 100644 lib/src/Okapi/Parser/Headers/Operation.hs diff --git a/lib/okapi.cabal b/lib/okapi.cabal index b5cf693..485a193 100644 --- a/lib/okapi.cabal +++ b/lib/okapi.cabal @@ -28,11 +28,14 @@ source-repository head library exposed-modules: Okapi - Okapi.Tree + Okapi.Parser.Headers.Alt + Okapi.Parser.Headers.Ap + Okapi.Parser.Headers.Operation Okapi.Parser.Query.Alt Okapi.Parser.Query.Ap Okapi.Parser.Query.Operation Okapi.Pattern + Okapi.Tree other-modules: Paths_okapi hs-source-dirs: diff --git a/lib/src/Okapi/Parser/Headers/Alt.hs b/lib/src/Okapi/Parser/Headers/Alt.hs new file mode 100644 index 0000000..fd5a8dd --- /dev/null +++ b/lib/src/Okapi/Parser/Headers/Alt.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Okapi.Parser.Headers.Alt where + +import Data.Bifunctor qualified as Bifunctor +import Data.ByteString qualified as BS +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Network.HTTP.Types qualified as HTTP +import Web.HttpApiData qualified as Web +import Network.Wai qualified as Wai +import Network.Wai.Internal qualified as Wai +import Okapi.Parser.Headers.Operation qualified as Operation +import Control.Applicative (Alternative(..)) +import Okapi.Tree qualified as Tree + +data Parser a where + FMap :: (a -> b) -> Parser a -> Parser b + Pure :: a -> Parser a + Apply :: Parser (a -> b) -> Parser a -> Parser b + Empty :: Parser a + Or :: Parser a -> Parser a -> Parser a + Optional :: Parser a -> Parser (Maybe a) + Option :: a -> Parser a -> Parser a + Operation :: Operation.Parser a -> Parser a + +instance Functor Parser where + fmap = FMap + +instance Applicative Parser where + pure = Pure + (<*>) = Apply + +instance Alternative Parser where + empty = Empty + (<|>) = Or + +param :: Web.FromHttpApiData a => HTTP.HeaderName -> Parser a +param = Operation . Operation.Param + +cookie :: BS.ByteString -> Parser () +cookie = Operation . Operation.Cookie + +optional :: Web.FromHttpApiData a => Parser a -> Parser (Maybe a) +optional = Optional + +option :: Web.FromHttpApiData a => a -> Parser a -> Parser a +option = Option + +eval :: + Parser a -> + Wai.Request -> + (Either (Tree.Tree Operation.Error) a, Wai.Request) +eval (FMap f opX) state = case eval opX state of + (Left e, state') -> (Left e, state') + (Right x, state') -> (Right $ f x, state') +eval (Pure x) state = (Right x, state) +eval (Apply opF opX) state = case eval opF state of + (Right f, state') -> case eval opX state' of + (Right x, state'') -> (Right $ f x, state'') + (Left e, state'') -> (Left e, state'') + (Left e, state') -> (Left e, state') +eval Empty state = (Left Tree.Nil, state) +eval (Or opA opB) state = case eval opA state of + (Right a, state') -> (Right a, state') + (Left l, state') -> case eval opB state' of + (Right b, state'') -> (Right b, state'') + (Left r, state'') -> (Left (l Tree.:|: r), state'') +eval (Optional op) state = case op of + Operation param@(Operation.Param _) -> case Operation.eval param state of + (Right result, state') -> (Right $ Just result, state') + (_, state') -> (Right Nothing, state') + Operation cookie@(Operation.Cookie _) -> case Operation.eval cookie state of + (Right result, state') -> (Right $ Just result, state') + (_, state') -> (Right Nothing, state') + _ -> case eval op state of + (Right result, state') -> (Right $ Just result, state') + (Left err, state') -> (Left err, state') +eval (Option def op) state = case op of + Operation param@(Operation.Param _) -> case Operation.eval param state of + (Right result, state') -> (Right result, state') + (_, state') -> (Right def, state') + Operation cookie@(Operation.Cookie _) -> case Operation.eval cookie state of + (Right result, state') -> (Right result, state') + (_, state') -> (Right def, state') + _ -> eval op state +eval (Operation op) state = Bifunctor.first (Bifunctor.first Tree.Leaf) $ Operation.eval op state + +class FromQuery a where + parser :: Parser a + +parse :: FromQuery a => Wai.Request -> Either (Tree.Tree Operation.Error) a +parse req = fst $ eval parser req diff --git a/lib/src/Okapi/Parser/Headers/Ap.hs b/lib/src/Okapi/Parser/Headers/Ap.hs new file mode 100644 index 0000000..dacda07 --- /dev/null +++ b/lib/src/Okapi/Parser/Headers/Ap.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Okapi.Parser.Headers.Ap where + +import Data.ByteString qualified as BS +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Network.HTTP.Types qualified as HTTP +import Web.HttpApiData qualified as Web +import Network.Wai qualified as Wai +import Network.Wai.Internal qualified as Wai +import Okapi.Parser.Headers.Operation qualified as Operation + +data Parser a where + FMap :: (a -> b) -> Parser a -> Parser b + Pure :: a -> Parser a + Apply :: Parser (a -> b) -> Parser a -> Parser b + Optional :: Parser a -> Parser (Maybe a) + Option :: a -> Parser a -> Parser a + Operation :: Operation.Parser a -> Parser a + +instance Functor Parser where + fmap = FMap + +instance Applicative Parser where + pure = Pure + (<*>) = Apply + +param :: Web.FromHttpApiData a => HTTP.HeaderName -> Parser a +param = Operation . Operation.Param + +cookie :: BS.ByteString -> Parser () +cookie = Operation . Operation.Cookie + +optional :: Web.FromHttpApiData a => Parser a -> Parser (Maybe a) +optional = Optional + +option :: Web.FromHttpApiData a => a -> Parser a -> Parser a +option = Option + +eval :: + Parser a -> + Wai.Request -> + (Either Operation.Error a, Wai.Request) +eval (FMap f opX) state = case eval opX state of + (Left e, state') -> (Left e, state') + (Right x, state') -> (Right $ f x, state') +eval (Pure x) state = (Right x, state) +eval (Apply opF opX) state = case eval opF state of + (Right f, state') -> case eval opX state' of + (Right x, state'') -> (Right $ f x, state'') + (Left e, state'') -> (Left e, state'') + (Left e, state') -> (Left e, state') +eval (Optional op) state = case op of + Operation param@(Operation.Param _) -> case Operation.eval param state of + (Right result, state') -> (Right $ Just result, state') + (_, state') -> (Right Nothing, state') + Operation cookie@(Operation.Cookie _) -> case Operation.eval cookie state of + (Right result, state') -> (Right $ Just result, state') + (_, state') -> (Right Nothing, state') + _ -> case eval op state of + (Right result, state') -> (Right $ Just result, state') + (Left err, state') -> (Left err, state') +eval (Option def op) state = case op of + Operation param@(Operation.Param _) -> case Operation.eval param state of + (Right result, state') -> (Right result, state') + (_, state') -> (Right def, state') + Operation cookie@(Operation.Cookie _) -> case Operation.eval cookie state of + (Right result, state') -> (Right result, state') + (_, state') -> (Right def, state') + _ -> eval op state +eval (Operation op) state = Operation.eval op state + +class FromQuery a where + parser :: Parser a + +parse :: FromQuery a => Wai.Request -> Either Operation.Error a +parse req = fst $ eval parser req diff --git a/lib/src/Okapi/Parser/Headers/Operation.hs b/lib/src/Okapi/Parser/Headers/Operation.hs new file mode 100644 index 0000000..d3f3118 --- /dev/null +++ b/lib/src/Okapi/Parser/Headers/Operation.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Okapi.Parser.Headers.Operation where + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Builder qualified as Builder +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Network.HTTP.Types qualified as HTTP +import Network.Wai qualified as Wai +import Network.Wai.Internal qualified as Wai +import Web.HttpApiData qualified as Web +import Web.Cookie qualified as Web + +data Error + = ParseFail + | ParamNotFound + | CookieHeaderNotFound + | CookieNotFound + | HeaderValueParseFail + | CookieValueParseFail + deriving (Eq, Show) + +data Parser a where + Param :: Web.FromHttpApiData a => HTTP.HeaderName -> Parser a + Cookie :: Web.FromHttpApiData a => BS.ByteString -> Parser a + +eval :: + Parser a -> + Wai.Request -> + (Either Error a, Wai.Request) +eval (Param name) state = case lookup name state.requestHeaders of + Nothing -> (Left ParamNotFound, state) + Just vBS -> case Web.parseHeaderMaybe vBS of + Nothing -> (Left HeaderValueParseFail, state) + Just v -> (Right v, state {Wai.requestHeaders = List.delete (name, vBS) state.requestHeaders}) +eval (Cookie name) state = case lookup "Cookie" state.requestHeaders of + Nothing -> (Left CookieHeaderNotFound, state) -- TODO: Cookie not found + Just cookiesBS -> case lookup name $ Web.parseCookies cookiesBS of + Nothing -> (Left CookieNotFound, state) -- TODO: Cookie parameter with given name not found + Just valueBS -> case Web.parseHeaderMaybe valueBS of + Nothing -> (Left CookieValueParseFail, state) + Just value -> + ( Right value, + let headersWithoutCookie = List.delete ("Cookie", cookiesBS) state.requestHeaders + newCookie = LBS.toStrict (Builder.toLazyByteString $ Web.renderCookies $ List.delete (name, valueBS) $ Web.parseCookies cookiesBS) + in state { Wai.requestHeaders = map (\header@(headerName, _) -> if headerName == "Cookie" then ("Cookie", newCookie) else header) state.requestHeaders } + -- TODO: Order of the cookie in the headers isn't preserved, but maybe this is fine?? + ) diff --git a/lib/src/Okapi/Parser/Query/Alt.hs b/lib/src/Okapi/Parser/Query/Alt.hs index 399807a..be68d09 100644 --- a/lib/src/Okapi/Parser/Query/Alt.hs +++ b/lib/src/Okapi/Parser/Query/Alt.hs @@ -69,7 +69,6 @@ eval (Or opA opB) state = case eval opA state of (Left l, state') -> case eval opB state' of (Right b, state'') -> (Right b, state'') (Left r, state'') -> (Left (l Tree.:|: r), state'') -eval (Operation op) state = Bifunctor.first (Bifunctor.first Tree.Leaf) $ Operation.eval op state eval (Optional op) state = case op of Operation param@(Operation.Param _) -> case Operation.eval param state of (Right result, state') -> (Right $ Just result, state') @@ -88,9 +87,10 @@ eval (Option def op) state = case op of (Right result, state') -> (Right result, state') (_, state') -> (Right def, state') _ -> eval op state +eval (Operation op) state = Bifunctor.first (Bifunctor.first Tree.Leaf) $ Operation.eval op state class FromQuery a where - parser :: Parser a + parser :: Parser a parse :: FromQuery a => Wai.Request -> Either (Tree.Tree Operation.Error) a parse req = fst $ eval parser req diff --git a/lib/src/Okapi/Parser/Query/Ap.hs b/lib/src/Okapi/Parser/Query/Ap.hs index bda6701..93ac923 100644 --- a/lib/src/Okapi/Parser/Query/Ap.hs +++ b/lib/src/Okapi/Parser/Query/Ap.hs @@ -54,7 +54,6 @@ eval (Apply opF opX) state = case eval opF state of (Right x, state'') -> (Right $ f x, state'') (Left e, state'') -> (Left e, state'') (Left e, state') -> (Left e, state') -eval (Operation op) state = Operation.eval op state eval (Optional op) state = case op of Operation param@(Operation.Param _) -> case Operation.eval param state of (Right result, state') -> (Right $ Just result, state') @@ -73,6 +72,7 @@ eval (Option def op) state = case op of (Right result, state') -> (Right result, state') (_, state') -> (Right def, state') _ -> eval op state +eval (Operation op) state = Operation.eval op state class FromQuery a where parser :: Parser a diff --git a/lib/src/Okapi/Tree.hs b/lib/src/Okapi/Tree.hs index 6f4b562..5961b79 100644 --- a/lib/src/Okapi/Tree.hs +++ b/lib/src/Okapi/Tree.hs @@ -1,4 +1,3 @@ module Okapi.Tree where data Tree a = Nil | Leaf a | (Tree a) :|: (Tree a) -