Add parsers for Headers

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:

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

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

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??
+        )

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,6 +87,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 = Bifunctor.first (Bifunctor.first Tree.Leaf) $ Operation.eval op state
 
 class FromQuery a where
   parser :: Parser a

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

lib/src/Okapi/Tree.hs

@@ -1,4 +1,3 @@
 module Okapi.Tree where
 
 data Tree a = Nil | Leaf a | (Tree a) :|: (Tree a)
-