Implement parsers for query

lib/okapi.cabal

@@ -28,14 +28,10 @@ source-repository head
 library
   exposed-modules:
       Okapi
-      Okapi.Parser.Alt.Body
-      Okapi.Parser.Alt.Headers
-      Okapi.Parser.Alt.Path
-      Okapi.Parser.Alt.Query
-      Okapi.Parser.Ap.Body
-      Okapi.Parser.Ap.Headers
-      Okapi.Parser.Ap.Path
-      Okapi.Parser.Ap.Query
+      Okapi.Tree
+      Okapi.Parser.Query.Alt
+      Okapi.Parser.Query.Ap
+      Okapi.Parser.Query.Operation
       Okapi.Pattern
   other-modules:
       Paths_okapi

lib/src/Okapi/Parser/Alt/Body.hs

@@ -1 +0,0 @@
-module Okapi.Parser.Alt.Body where

lib/src/Okapi/Parser/Alt/Headers.hs

@@ -1 +0,0 @@
-module Okapi.Parser.Alt.Headers where

lib/src/Okapi/Parser/Alt/Path.hs

@@ -1 +0,0 @@
-module Okapi.Parser.Alt.Path where

lib/src/Okapi/Parser/Alt/Query.hs

@@ -1 +0,0 @@
-module Okapi.Parser.Alt.Query where

lib/src/Okapi/Parser/Ap/Body.hs

@@ -1 +0,0 @@
-module Okapi.Parser.Ap.Body where

lib/src/Okapi/Parser/Ap/Headers.hs

@@ -1 +0,0 @@
-module Okapi.Parser.Ap.Headers where

lib/src/Okapi/Parser/Ap/Path.hs

@@ -1 +0,0 @@
-module Okapi.Parser.Ap.Path where

lib/src/Okapi/Parser/Ap/Query.hs

@@ -1 +0,0 @@
-module Okapi.Parser.Ap.Query where

lib/src/Okapi/Parser/Query/Alt.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Okapi.Parser.Query.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.Query.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 => BS.ByteString -> Parser a
+param = Operation . Operation.Param
+
+flag :: BS.ByteString -> Parser ()
+flag = Operation . Operation.Flag
+
+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 (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')
+      (_, state') -> (Right Nothing, state')
+    Operation flag@(Operation.Flag _) -> case Operation.eval flag 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 flag@(Operation.Flag _) -> case Operation.eval flag state of
+      (Right result, state') -> (Right result, state')
+      (_, state') -> (Right def, state')
+    _ -> 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/Query/Ap.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Okapi.Parser.Query.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.Query.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 => BS.ByteString -> Parser a
+param = Operation . Operation.Param
+
+flag :: BS.ByteString -> Parser ()
+flag = Operation . Operation.Flag
+
+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 (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')
+      (_, state') -> (Right Nothing, state')
+    Operation flag@(Operation.Flag _) -> case Operation.eval flag 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 flag@(Operation.Flag _) -> case Operation.eval flag state of
+      (Right result, state') -> (Right result, state')
+      (_, state') -> (Right def, state')
+    _ -> 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/Query/Operation.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Okapi.Parser.Query.Operation 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
+
+data Error
+  = ParseFail
+  | FlagNotFound
+  | ParamNotFound
+  | ParamNoValue
+  deriving (Eq, Show)
+
+data Parser a where
+  Param :: Web.FromHttpApiData a => BS.ByteString -> Parser a
+  Flag :: BS.ByteString -> Parser ()
+
+eval ::
+  Parser a ->
+  Wai.Request ->
+  (Either Error a, Wai.Request)
+eval (Param name) state = case lookup name state.queryString of
+    Nothing -> (Left ParamNotFound, state)
+    Just maybeVBS -> case maybeVBS of
+      Nothing -> (Left ParamNoValue, state)
+      Just vBS -> case Web.parseQueryParamMaybe $ Text.decodeUtf8 vBS of
+        Nothing -> (Left ParseFail, state)
+        Just v -> (Right v, state { Wai.queryString = List.delete (name, Just vBS) state.queryString })
+eval (Flag name) state = case lookup name state.queryString of
+    Nothing -> (Left FlagNotFound, state)
+    Just found -> (Right (), state { Wai.queryString = List.delete (name, found) state.queryString })

lib/src/Okapi/Pattern.hs

@@ -9,18 +9,18 @@ module Okapi.Pattern where
 import Data.Text qualified as Text
 import Network.Wai qualified as Wai
 import Network.Wai.Internal qualified as Wai
-import Web.HttpApiData qualified as HttpApiData
+import Web.HttpApiData qualified as Web
 import Network.HTTP.Types qualified as HTTP
 
-pattern Route :: HTTP.Method -> [Text.Text] -> Wai.Request
-pattern Route requestMethod pathInfo <- Wai.Request { Wai.requestMethod, Wai.pathInfo }
+pattern Endpoint :: HTTP.Method -> [Text.Text] -> Wai.Request
+pattern Endpoint requestMethod pathInfo <- Wai.Request { Wai.requestMethod, Wai.pathInfo }
   where
-    Route requestMethod pathInfo = Wai.defaultRequest { Wai.requestMethod = requestMethod, Wai.pathInfo = pathInfo }
+    Endpoint requestMethod pathInfo = Wai.defaultRequest { Wai.requestMethod = requestMethod, Wai.pathInfo = pathInfo }
 
-pattern Param :: (HttpApiData.FromHttpApiData a, HttpApiData.ToHttpApiData a) => a -> Text.Text
-pattern Param x <- (HttpApiData.parseUrlPiece -> Right x)
+pattern Param :: (Web.FromHttpApiData a, Web.ToHttpApiData a) => a -> Text.Text
+pattern Param x <- (Web.parseUrlPiece -> Right x)
   where
-    Param x = HttpApiData.toUrlPiece x
+    Param x = Web.toUrlPiece x
 
 pattern GET :: HTTP.Method
 pattern GET = "GET"

lib/src/Okapi/Tree.hs

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