mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-12-18 03:52:45 +03:00
Implement the basics for Elixir-like Plugs
This commit is contained in:
Rashad Gover
parent
ea3dedaada
commit
c4591352c7
@ -41,6 +41,7 @@ library
|
||||
Okapi.Parser.Responder
|
||||
Okapi.Parser.Responder.AddHeader
|
||||
Okapi.Parser.Security
|
||||
Okapi.Plug
|
||||
other-modules:
|
||||
Paths_okapi
|
||||
hs-source-dirs:
|
||||
|
||||
@ -1,138 +1,138 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
-- {-# LANGUAGE DeriveAnyClass #-}
|
||||
-- {-# LANGUAGE DeriveGeneric #-}
|
||||
-- {-# LANGUAGE GADTs #-}
|
||||
-- {-# LANGUAGE ImportQualifiedPost #-}
|
||||
-- {-# LANGUAGE InstanceSigs #-}
|
||||
-- {-# LANGUAGE OverloadedStrings #-}
|
||||
-- {-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Okapi.Parser.Body where
|
||||
|
||||
import Control.Monad.Par qualified as Par
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Bifunctor (Bifunctor (..))
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Builder qualified as Builder
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.List qualified as List
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Set.NonEmpty (NESet)
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as Text
|
||||
import GHC.Generics qualified as Generics
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai.Parse (RequestBodyType (UrlEncoded))
|
||||
import Network.Wai.Parse qualified as WAI
|
||||
import Okapi.Parser
|
||||
import Okapi.Parser.Body.Multipart qualified as Multipart
|
||||
import Web.Cookie qualified as Web
|
||||
import Web.FormUrlEncoded qualified as Web
|
||||
import Web.HttpApiData qualified as Web
|
||||
-- import Control.Monad.Par qualified as Par
|
||||
-- import Data.Aeson qualified as Aeson
|
||||
-- import Data.Bifunctor (Bifunctor (..))
|
||||
-- import Data.ByteString qualified as BS
|
||||
-- import Data.ByteString.Builder qualified as Builder
|
||||
-- import Data.ByteString.Lazy qualified as LBS
|
||||
-- import Data.List qualified as List
|
||||
-- import Data.List.NonEmpty (NonEmpty)
|
||||
-- import Data.Set.NonEmpty (NESet)
|
||||
-- import Data.Text qualified as Text
|
||||
-- import Data.Text.Encoding qualified as Text
|
||||
-- import GHC.Generics qualified as Generics
|
||||
-- import Network.HTTP.Types qualified as HTTP
|
||||
-- import Network.Wai.Parse (RequestBodyType (UrlEncoded))
|
||||
-- import Network.Wai.Parse qualified as WAI
|
||||
-- import Okapi.Parser
|
||||
-- import Okapi.Parser.Body.Multipart qualified as Multipart
|
||||
-- import Web.Cookie qualified as Web
|
||||
-- import Web.FormUrlEncoded qualified as Web
|
||||
-- import Web.HttpApiData qualified as Web
|
||||
|
||||
data Error
|
||||
= JSONParseFail
|
||||
| URLEncodedParseFail Text.Text
|
||||
| URLEncodedInvalid Text.Text
|
||||
| NotMultipart
|
||||
| MultipartError Multipart.Error
|
||||
deriving (Eq, Show, Generics.Generic)
|
||||
-- data Error
|
||||
-- = JSONParseFail
|
||||
-- | URLEncodedParseFail Text.Text
|
||||
-- | URLEncodedInvalid Text.Text
|
||||
-- | NotMultipart
|
||||
-- | MultipartError Multipart.Error
|
||||
-- deriving (Eq, Show, Generics.Generic)
|
||||
|
||||
data ContentType a where
|
||||
JSON :: Aeson.FromJSON a => ContentType a
|
||||
URLEncoded :: Web.FromForm a => ContentType a
|
||||
Multipart :: Multipart.Parser a -> ContentType a
|
||||
-- data ContentType a where
|
||||
-- JSON :: Aeson.FromJSON a => ContentType a
|
||||
-- URLEncoded :: Web.FromForm a => ContentType a
|
||||
-- Multipart :: Multipart.Parser a -> ContentType a
|
||||
|
||||
instance Eq (ContentType a) where
|
||||
JSON == JSON = True
|
||||
URLEncoded == UrlEncoded = True
|
||||
Multipart _ == Multipart _ = True
|
||||
_ == _ = False
|
||||
-- instance Eq (ContentType a) where
|
||||
-- JSON == JSON = True
|
||||
-- URLEncoded == UrlEncoded = True
|
||||
-- Multipart _ == Multipart _ = True
|
||||
-- _ == _ = False
|
||||
|
||||
instance Functor ContentType
|
||||
-- instance Functor ContentType
|
||||
|
||||
data Parser a where
|
||||
FMap :: (a -> b) -> Parser a -> Parser b
|
||||
Pure :: a -> Parser a
|
||||
Apply :: Parser (a -> b) -> Parser a -> Parser b
|
||||
None :: Parser ()
|
||||
Optional :: NESet (ContentType a) -> Parser (Maybe a)
|
||||
Required :: NESet (ContentType a) -> Parser a
|
||||
-- data Parser a where
|
||||
-- FMap :: (a -> b) -> Parser a -> Parser b
|
||||
-- Pure :: a -> Parser a
|
||||
-- Apply :: Parser (a -> b) -> Parser a -> Parser b
|
||||
-- None :: Parser ()
|
||||
-- Optional :: NESet (ContentType a) -> Parser (Maybe a)
|
||||
-- Required :: NESet (ContentType a) -> Parser a
|
||||
|
||||
instance Functor Parser where
|
||||
fmap :: (a -> b) -> Parser a -> Parser b
|
||||
fmap = FMap
|
||||
-- instance Functor Parser where
|
||||
-- fmap :: (a -> b) -> Parser a -> Parser b
|
||||
-- fmap = FMap
|
||||
|
||||
instance Applicative Parser where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
-- instance Applicative Parser where
|
||||
-- pure = Pure
|
||||
-- (<*>) = Apply
|
||||
|
||||
data RequestBody
|
||||
= RequestBodyRaw LBS.ByteString
|
||||
| RequestBodyMultipart ([WAI.Param], [WAI.File LBS.ByteString])
|
||||
-- data RequestBody
|
||||
-- = RequestBodyRaw LBS.ByteString
|
||||
-- | RequestBodyMultipart ([WAI.Param], [WAI.File LBS.ByteString])
|
||||
|
||||
eval ::
|
||||
Parser a ->
|
||||
RequestBody ->
|
||||
(Result Error a, RequestBody)
|
||||
eval op state = case op of
|
||||
FMap f opX ->
|
||||
case eval opX state of
|
||||
(Fail e, state') -> (Fail e, state')
|
||||
(Ok x, state') -> (Ok $ f x, state')
|
||||
Pure x -> (Ok x, state)
|
||||
Apply opF opX -> case eval opF state of
|
||||
(Ok f, state') -> case eval opX state' of
|
||||
(Ok x, state'') -> (Ok $ f x, state'')
|
||||
(Fail e, state'') -> (Fail e, state'')
|
||||
(Fail e, state') -> (Fail e, state')
|
||||
-- None -> (Ok (), state)
|
||||
JSON -> case state of
|
||||
RequestBodyRaw bs -> case Aeson.decode bs of
|
||||
Nothing -> (Fail JSONParseFail, state)
|
||||
Just value -> (Ok value, RequestBodyRaw mempty)
|
||||
RequestBodyMultipart _ -> (Fail JSONParseFail, state)
|
||||
URLEncoded -> case state of
|
||||
RequestBodyRaw bs -> case Web.urlDecodeForm bs of
|
||||
Left err -> (Fail $ URLEncodedInvalid err, state)
|
||||
Right form -> case Web.fromForm form of
|
||||
Left err -> (Fail $ URLEncodedParseFail err, state)
|
||||
Right value -> (Ok value, RequestBodyRaw mempty)
|
||||
RequestBodyMultipart (params, files) ->
|
||||
let bsParams = map (bimap Text.decodeUtf8 Text.decodeUtf8) params
|
||||
bs = Web.urlEncodeParams bsParams
|
||||
in case Web.urlDecodeForm bs of
|
||||
Left err -> (Fail $ URLEncodedInvalid err, state)
|
||||
Right form -> case Web.fromForm form of
|
||||
Left err -> (Fail $ URLEncodedParseFail err, state)
|
||||
Right value -> (Ok value, RequestBodyMultipart (mempty, files))
|
||||
Multipart parser -> case state of
|
||||
RequestBodyRaw _ -> (Fail NotMultipart, state)
|
||||
RequestBodyMultipart parts -> case Multipart.eval parser parts of
|
||||
(Ok value, state') -> (Ok value, RequestBodyMultipart state')
|
||||
(Fail err, state') -> (Fail $ MultipartError err, RequestBodyMultipart state')
|
||||
-- eval ::
|
||||
-- Parser a ->
|
||||
-- RequestBody ->
|
||||
-- (Result Error a, RequestBody)
|
||||
-- eval op state = case op of
|
||||
-- FMap f opX ->
|
||||
-- case eval opX state of
|
||||
-- (Fail e, state') -> (Fail e, state')
|
||||
-- (Ok x, state') -> (Ok $ f x, state')
|
||||
-- Pure x -> (Ok x, state)
|
||||
-- Apply opF opX -> case eval opF state of
|
||||
-- (Ok f, state') -> case eval opX state' of
|
||||
-- (Ok x, state'') -> (Ok $ f x, state'')
|
||||
-- (Fail e, state'') -> (Fail e, state'')
|
||||
-- (Fail e, state') -> (Fail e, state')
|
||||
-- -- None -> (Ok (), state)
|
||||
-- JSON -> case state of
|
||||
-- RequestBodyRaw bs -> case Aeson.decode bs of
|
||||
-- Nothing -> (Fail JSONParseFail, state)
|
||||
-- Just value -> (Ok value, RequestBodyRaw mempty)
|
||||
-- RequestBodyMultipart _ -> (Fail JSONParseFail, state)
|
||||
-- URLEncoded -> case state of
|
||||
-- RequestBodyRaw bs -> case Web.urlDecodeForm bs of
|
||||
-- Left err -> (Fail $ URLEncodedInvalid err, state)
|
||||
-- Right form -> case Web.fromForm form of
|
||||
-- Left err -> (Fail $ URLEncodedParseFail err, state)
|
||||
-- Right value -> (Ok value, RequestBodyRaw mempty)
|
||||
-- RequestBodyMultipart (params, files) ->
|
||||
-- let bsParams = map (bimap Text.decodeUtf8 Text.decodeUtf8) params
|
||||
-- bs = Web.urlEncodeParams bsParams
|
||||
-- in case Web.urlDecodeForm bs of
|
||||
-- Left err -> (Fail $ URLEncodedInvalid err, state)
|
||||
-- Right form -> case Web.fromForm form of
|
||||
-- Left err -> (Fail $ URLEncodedParseFail err, state)
|
||||
-- Right value -> (Ok value, RequestBodyMultipart (mempty, files))
|
||||
-- Multipart parser -> case state of
|
||||
-- RequestBodyRaw _ -> (Fail NotMultipart, state)
|
||||
-- RequestBodyMultipart parts -> case Multipart.eval parser parts of
|
||||
-- (Ok value, state') -> (Ok value, RequestBodyMultipart state')
|
||||
-- (Fail err, state') -> (Fail $ MultipartError err, RequestBodyMultipart state')
|
||||
|
||||
none :: Parser ()
|
||||
none = None
|
||||
-- none :: Parser ()
|
||||
-- none = None
|
||||
|
||||
json :: Aeson.FromJSON a => Parser a
|
||||
json = JSON
|
||||
-- json :: Aeson.FromJSON a => Parser a
|
||||
-- json = JSON
|
||||
|
||||
urlEncoded :: Web.FromForm a => Parser a
|
||||
urlEncoded = URLEncoded
|
||||
-- urlEncoded :: Web.FromForm a => Parser a
|
||||
-- urlEncoded = URLEncoded
|
||||
|
||||
multipart :: Multipart.Parser a -> Parser a
|
||||
multipart = Multipart
|
||||
-- multipart :: Multipart.Parser a -> Parser a
|
||||
-- multipart = Multipart
|
||||
|
||||
class Interface a where
|
||||
parser :: NonEmpty (Parser a)
|
||||
-- class Interface a where
|
||||
-- parser :: NonEmpty (Parser a)
|
||||
|
||||
-- TODO: Add optional for body
|
||||
-- -- TODO: Add optional for body
|
||||
|
||||
countOps :: Parser a -> Int
|
||||
countOps path = case path of
|
||||
FMap _ opX -> countOps opX
|
||||
Pure _ -> 0
|
||||
Apply opF opX -> countOps opF + countOps opX
|
||||
JSON -> 1
|
||||
URLEncoded -> 1
|
||||
Multipart -> undefined
|
||||
-- countOps :: Parser a -> Int
|
||||
-- countOps path = case path of
|
||||
-- FMap _ opX -> countOps opX
|
||||
-- Pure _ -> 0
|
||||
-- Apply opF opX -> countOps opF + countOps opX
|
||||
-- JSON -> 1
|
||||
-- URLEncoded -> 1
|
||||
-- Multipart -> undefined
|
||||
79
lib/src/Okapi/Plug.hs
Normal file
79
lib/src/Okapi/Plug.hs
Normal file
@ -0,0 +1,79 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module Okapi.Plug where
|
||||
|
||||
import Control.Applicative (Alternative (..))
|
||||
import Data.Text
|
||||
import qualified Network.Wai as WAI
|
||||
|
||||
data Conn = Conn {request :: WAI.Request, response :: WAI.Response}
|
||||
|
||||
data Error = Skipped [Text] | Halted [Text]
|
||||
|
||||
data Plug a where
|
||||
FMap :: (a -> b) -> Plug a -> Plug b
|
||||
Pure :: a -> Plug a
|
||||
Apply :: Plug (a -> b) -> Plug a -> Plug b
|
||||
Alt :: Plug a -> Plug a -> Plug a
|
||||
Skip :: [Text] -> Plug a
|
||||
Halt :: [Text] -> Plug a
|
||||
|
||||
instance Functor Plug where
|
||||
fmap = FMap
|
||||
|
||||
instance Applicative Plug where
|
||||
pure = Pure
|
||||
(<*>) = Apply
|
||||
|
||||
instance Alternative Plug where
|
||||
empty = Skip []
|
||||
(<|>) = Alt
|
||||
|
||||
skip = Skip
|
||||
|
||||
halt = Halt
|
||||
|
||||
class IsRoute r
|
||||
|
||||
class IsQuery q
|
||||
|
||||
class IsBody b
|
||||
|
||||
class IsHeaders h
|
||||
|
||||
class IsResponder r
|
||||
|
||||
class Monad m => IOable m
|
||||
|
||||
data Response = Response
|
||||
|
||||
data Endpoint where
|
||||
GET :: (IOable m, IsRoute r, IsQuery q, IsHeaders h, IsResponder res) => (r -> q -> h -> res -> m Response) -> Endpoint
|
||||
POST :: (IOable m, IsRoute r, IsQuery q, IsBody b, IsHeaders h, IsResponder res) => (r -> q -> h -> b -> res -> m Response) -> Endpoint
|
||||
PUT :: (IOable m, IsRoute r, IsQuery q, IsBody b, IsHeaders h, IsResponder res) => (r -> q -> h -> b -> res -> m Response) -> Endpoint
|
||||
DELETE :: (IOable m, IsRoute r, IsQuery q, IsHeaders h, IsResponder res) => (r -> q -> h -> res -> m Response) -> Endpoint
|
||||
|
||||
get :: (IOable m, IsRoute r, IsQuery q, IsHeaders h, IsResponder res) => (r -> q -> h -> res -> m Response) -> Endpoint
|
||||
get = GET
|
||||
|
||||
post :: (IOable m, IsRoute r, IsQuery q, IsBody b, IsHeaders h, IsResponder res) => (r -> q -> h -> b -> res -> m Response) -> Endpoint
|
||||
post = POST
|
||||
|
||||
put :: (IOable m, IsRoute r, IsQuery q, IsBody b, IsHeaders h, IsResponder res) => (r -> q -> h -> b -> res -> m Response) -> Endpoint
|
||||
put = PUT
|
||||
|
||||
delete :: (IOable m, IsRoute r, IsQuery q, IsHeaders h, IsResponder res) => (r -> q -> h -> res -> m Response) -> Endpoint
|
||||
delete = DELETE
|
||||
|
||||
router :: [Endpoint] -> Plug ()
|
||||
router [] = pure ()
|
||||
router (h : t) = undefined
|
||||
|
||||
-- Filter Endpoints by method
|
||||
--
|
||||
|
||||
scope :: [Text] -> Plug () -> Plug ()
|
||||
scope path plug = undefined
|
||||
|
||||
eval :: Plug a -> Conn -> (Either Error a, Conn)
|
||||
eval = undefined
|
||||
@ -1,127 +1,127 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE ImpredicativeTypes #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LinearTypes #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
-- {-# LANGUAGE BlockArguments #-}
|
||||
-- {-# LANGUAGE DataKinds #-}
|
||||
-- {-# LANGUAGE DuplicateRecordFields #-}
|
||||
-- {-# LANGUAGE GADTs #-}
|
||||
-- {-# LANGUAGE ImportQualifiedPost #-}
|
||||
-- {-# LANGUAGE ImpredicativeTypes #-}
|
||||
-- {-# LANGUAGE KindSignatures #-}
|
||||
-- {-# LANGUAGE LinearTypes #-}
|
||||
-- {-# LANGUAGE NamedFieldPuns #-}
|
||||
-- {-# LANGUAGE OverloadedRecordDot #-}
|
||||
-- {-# LANGUAGE OverloadedStrings #-}
|
||||
-- {-# LANGUAGE PolyKinds #-}
|
||||
-- {-# LANGUAGE RankNTypes #-}
|
||||
-- {-# LANGUAGE RecordWildCards #-}
|
||||
-- {-# LANGUAGE ScopedTypeVariables #-}
|
||||
-- {-# LANGUAGE StandaloneKindSignatures #-}
|
||||
-- {-# LANGUAGE TypeApplications #-}
|
||||
-- {-# LANGUAGE TypeFamilies #-}
|
||||
-- {-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Okapi.Route where
|
||||
|
||||
import Control.Natural (type (~>))
|
||||
import Control.Object (Object (..), (#))
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Bifunctor (Bifunctor (..))
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.CaseInsensitive qualified as CI
|
||||
import Data.Function ((&))
|
||||
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
|
||||
import Data.Kind (Type)
|
||||
import Data.List (groupBy)
|
||||
import Data.List qualified as List
|
||||
import Data.List.Extra qualified as List
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.OpenApi (OpenApi (_openApiInfo))
|
||||
import Data.OpenApi qualified as OAPI
|
||||
import Data.OpenApi.Declare qualified as OAPI
|
||||
import Data.OpenApi.Internal (OpenApiSpecVersion (..), upperOpenApiSpecVersion)
|
||||
import Data.Proxy
|
||||
import Data.Semigroup (Semigroup (..))
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as Text
|
||||
import Data.Version qualified as Version
|
||||
import Debug.Trace qualified as Debug
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as WAI
|
||||
import Network.Wai.Parse qualified as WAI
|
||||
import Okapi.Parser
|
||||
import Okapi.Parser.Body qualified as Body
|
||||
import Okapi.Parser.Headers qualified as Headers
|
||||
import Okapi.Parser.Path qualified as Path
|
||||
import Okapi.Parser.Query qualified as Query
|
||||
import Okapi.Parser.Responder qualified as Responder
|
||||
import Okapi.Parser.Responder.AddHeader (Response, toWaiResponse)
|
||||
import Okapi.Parser.Security qualified as Security
|
||||
import Okapi.Parser.Security.Secure qualified as Secure
|
||||
import Okapi.Request (Request)
|
||||
-- import Control.Natural (type (~>))
|
||||
-- import Control.Object (Object (..), (#))
|
||||
-- import Data.Aeson qualified as Aeson
|
||||
-- import Data.Bifunctor (Bifunctor (..))
|
||||
-- import Data.ByteString qualified as BS
|
||||
-- import Data.CaseInsensitive qualified as CI
|
||||
-- import Data.Function ((&))
|
||||
-- import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
|
||||
-- import Data.Kind (Type)
|
||||
-- import Data.List (groupBy)
|
||||
-- import Data.List qualified as List
|
||||
-- import Data.List.Extra qualified as List
|
||||
-- import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
-- import Data.List.NonEmpty qualified as NonEmpty
|
||||
-- import Data.OpenApi (OpenApi (_openApiInfo))
|
||||
-- import Data.OpenApi qualified as OAPI
|
||||
-- import Data.OpenApi.Declare qualified as OAPI
|
||||
-- import Data.OpenApi.Internal (OpenApiSpecVersion (..), upperOpenApiSpecVersion)
|
||||
-- import Data.Proxy
|
||||
-- import Data.Semigroup (Semigroup (..))
|
||||
-- import Data.Text qualified as Text
|
||||
-- import Data.Text.Encoding qualified as Text
|
||||
-- import Data.Version qualified as Version
|
||||
-- import Debug.Trace qualified as Debug
|
||||
-- import Network.HTTP.Types qualified as HTTP
|
||||
-- import Network.Wai qualified as WAI
|
||||
-- import Network.Wai.Parse qualified as WAI
|
||||
-- import Okapi.Parser
|
||||
-- import Okapi.Parser.Body qualified as Body
|
||||
-- import Okapi.Parser.Headers qualified as Headers
|
||||
-- import Okapi.Parser.Path qualified as Path
|
||||
-- import Okapi.Parser.Query qualified as Query
|
||||
-- import Okapi.Parser.Responder qualified as Responder
|
||||
-- import Okapi.Parser.Responder.AddHeader (Response, toWaiResponse)
|
||||
-- import Okapi.Parser.Security qualified as Security
|
||||
-- -- import Okapi.Parser.Security.Secure qualified as Secure
|
||||
-- import Okapi.Request (Request)
|
||||
|
||||
type Routes :: [Type] -> Type
|
||||
data Routes resources where
|
||||
Nil :: Routes '[]
|
||||
(:&) :: Path.Interface resource => Route resource -> Routes resources -> Routes (resource ': resources)
|
||||
-- type Routes :: [Type] -> Type
|
||||
-- data Routes resources where
|
||||
-- Nil :: Routes '[]
|
||||
-- (:&) :: Path.Interface resource => Route resource -> Routes resources -> Routes (resource ': resources)
|
||||
|
||||
infixr 5 :&
|
||||
-- infixr 5 :&
|
||||
|
||||
type Append :: forall a. [a] -> [a] -> [a] -- kind signature
|
||||
type family Append xs ys where -- header
|
||||
Append '[] ys = ys -- clause 1
|
||||
Append (x ': xs) ys = x ': Append xs ys -- clause 2
|
||||
-- type Append :: forall a. [a] -> [a] -> [a] -- kind signature
|
||||
-- type family Append xs ys where -- header
|
||||
-- Append '[] ys = ys -- clause 1
|
||||
-- Append (x ': xs) ys = x ': Append xs ys -- clause 2
|
||||
|
||||
appendRoutes :: Routes resources1 -> Routes resources2 -> Routes (Append resources1 resources2)
|
||||
appendRoutes Nil pathItems = pathItems
|
||||
appendRoutes (h :& t) pathItems = h :& appendRoutes t pathItems
|
||||
-- appendRoutes :: Routes resources1 -> Routes resources2 -> Routes (Append resources1 resources2)
|
||||
-- appendRoutes Nil pathItems = pathItems
|
||||
-- appendRoutes (h :& t) pathItems = h :& appendRoutes t pathItems
|
||||
|
||||
data Route resource where
|
||||
Route ::
|
||||
Path.Interface resource =>
|
||||
{ summary :: Maybe Text.Text,
|
||||
description :: Maybe Text.Text,
|
||||
get :: Maybe (GET m resource security query headers responder),
|
||||
post :: Maybe (POST m resource security query body headers responder),
|
||||
put :: Maybe (PUT m resource security query body headers responder),
|
||||
delete :: Maybe (DELETE m resource security query headers responder)
|
||||
} ->
|
||||
Route resource
|
||||
-- data Route resource where
|
||||
-- Route ::
|
||||
-- Path.Interface resource =>
|
||||
-- { summary :: Maybe Text.Text,
|
||||
-- description :: Maybe Text.Text,
|
||||
-- get :: Maybe (GET m resource security query headers responder),
|
||||
-- post :: Maybe (POST m resource security query body headers responder),
|
||||
-- put :: Maybe (PUT m resource security query body headers responder),
|
||||
-- delete :: Maybe (DELETE m resource security query headers responder)
|
||||
-- } ->
|
||||
-- Route resource
|
||||
|
||||
data GET m resource security query headers responder where
|
||||
GET ::
|
||||
(Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Headers.Interface headers, Responder.Interface responder) =>
|
||||
{ summary :: Maybe Text.Text,
|
||||
description :: Maybe Text.Text,
|
||||
object :: Object m,
|
||||
handler :: resource -> security -> query -> headers -> responder -> m Response
|
||||
} ->
|
||||
GET m resource security query headers responder
|
||||
-- data GET m resource security query headers responder where
|
||||
-- GET ::
|
||||
-- (Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Headers.Interface headers, Responder.Interface responder) =>
|
||||
-- { summary :: Maybe Text.Text,
|
||||
-- description :: Maybe Text.Text,
|
||||
-- object :: Object m,
|
||||
-- handler :: resource -> security -> query -> headers -> responder -> m Response
|
||||
-- } ->
|
||||
-- GET m resource security query headers responder
|
||||
|
||||
data POST m resource security query body headers responder where
|
||||
POST ::
|
||||
(Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Body.Interface body, Headers.Interface headers, Responder.Interface responder) =>
|
||||
{ summary :: Maybe Text.Text,
|
||||
description :: Maybe Text.Text,
|
||||
object :: Object m,
|
||||
handler :: resource -> security -> query -> body -> headers -> responder -> m Response
|
||||
} ->
|
||||
POST m resource security query body headers responder
|
||||
-- data POST m resource security query body headers responder where
|
||||
-- POST ::
|
||||
-- (Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Body.Interface body, Headers.Interface headers, Responder.Interface responder) =>
|
||||
-- { summary :: Maybe Text.Text,
|
||||
-- description :: Maybe Text.Text,
|
||||
-- object :: Object m,
|
||||
-- handler :: resource -> security -> query -> body -> headers -> responder -> m Response
|
||||
-- } ->
|
||||
-- POST m resource security query body headers responder
|
||||
|
||||
data PUT m resource security query body headers responder where
|
||||
PUT ::
|
||||
(Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Body.Interface body, Headers.Interface headers, Responder.Interface responder) =>
|
||||
{ summary :: Maybe Text.Text,
|
||||
description :: Maybe Text.Text,
|
||||
object :: Object m,
|
||||
handler :: resource -> security -> query -> body -> headers -> responder -> m Response
|
||||
} ->
|
||||
PUT m resource security query body headers responder
|
||||
-- data PUT m resource security query body headers responder where
|
||||
-- PUT ::
|
||||
-- (Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Body.Interface body, Headers.Interface headers, Responder.Interface responder) =>
|
||||
-- { summary :: Maybe Text.Text,
|
||||
-- description :: Maybe Text.Text,
|
||||
-- object :: Object m,
|
||||
-- handler :: resource -> security -> query -> body -> headers -> responder -> m Response
|
||||
-- } ->
|
||||
-- PUT m resource security query body headers responder
|
||||
|
||||
data DELETE m resource security query headers responder where
|
||||
DELETE ::
|
||||
(Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Headers.Interface headers, Responder.Interface responder) =>
|
||||
{ summary :: Maybe Text.Text,
|
||||
description :: Maybe Text.Text,
|
||||
object :: Object m,
|
||||
handler :: resource -> security -> query -> headers -> responder -> m Response
|
||||
} ->
|
||||
DELETE m resource security query headers responder
|
||||
-- data DELETE m resource security query headers responder where
|
||||
-- DELETE ::
|
||||
-- (Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Headers.Interface headers, Responder.Interface responder) =>
|
||||
-- { summary :: Maybe Text.Text,
|
||||
-- description :: Maybe Text.Text,
|
||||
-- object :: Object m,
|
||||
-- handler :: resource -> security -> query -> headers -> responder -> m Response
|
||||
-- } ->
|
||||
-- DELETE m resource security query headers responder
|
||||
|
||||
@ -1,381 +1,381 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE ImpredicativeTypes #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LinearTypes #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
-- {-# LANGUAGE BlockArguments #-}
|
||||
-- {-# LANGUAGE DataKinds #-}
|
||||
-- {-# LANGUAGE DuplicateRecordFields #-}
|
||||
-- {-# LANGUAGE GADTs #-}
|
||||
-- {-# LANGUAGE ImportQualifiedPost #-}
|
||||
-- {-# LANGUAGE ImpredicativeTypes #-}
|
||||
-- {-# LANGUAGE KindSignatures #-}
|
||||
-- {-# LANGUAGE LinearTypes #-}
|
||||
-- {-# LANGUAGE NamedFieldPuns #-}
|
||||
-- {-# LANGUAGE OverloadedRecordDot #-}
|
||||
-- {-# LANGUAGE OverloadedStrings #-}
|
||||
-- {-# LANGUAGE PolyKinds #-}
|
||||
-- {-# LANGUAGE RankNTypes #-}
|
||||
-- {-# LANGUAGE RecordWildCards #-}
|
||||
-- {-# LANGUAGE ScopedTypeVariables #-}
|
||||
-- {-# LANGUAGE StandaloneKindSignatures #-}
|
||||
-- {-# LANGUAGE TypeApplications #-}
|
||||
-- {-# LANGUAGE TypeFamilies #-}
|
||||
-- {-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Okapi.Server where
|
||||
|
||||
import Control.Natural (type (~>))
|
||||
import Control.Object (Object (..), (#))
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Bifunctor (Bifunctor (..))
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.CaseInsensitive qualified as CI
|
||||
import Data.Function ((&))
|
||||
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
|
||||
import Data.Kind (Type)
|
||||
import Data.List (groupBy)
|
||||
import Data.List qualified as List
|
||||
import Data.List.Extra qualified as List
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.OpenApi (OpenApi (_openApiInfo))
|
||||
import Data.OpenApi qualified as OAPI
|
||||
import Data.OpenApi.Declare qualified as OAPI
|
||||
import Data.OpenApi.Internal (OpenApiSpecVersion (..), upperOpenApiSpecVersion)
|
||||
import Data.Proxy
|
||||
import Data.Semigroup (Semigroup (..))
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as Text
|
||||
import Data.Version qualified as Version
|
||||
import Debug.Trace qualified as Debug
|
||||
import Network.HTTP.Types qualified as HTTP
|
||||
import Network.Wai qualified as WAI
|
||||
import Network.Wai.Parse qualified as WAI
|
||||
import Okapi.Parser
|
||||
import Okapi.Parser.Body qualified as Body
|
||||
import Okapi.Parser.Headers qualified as Headers
|
||||
import Okapi.Parser.Path qualified as Path
|
||||
import Okapi.Parser.Query qualified as Query
|
||||
import Okapi.Parser.Responder qualified as Responder
|
||||
import Okapi.Parser.Responder.AddHeader (Response, toWaiResponse)
|
||||
import Okapi.Parser.Security qualified as Security
|
||||
import Okapi.Parser.Security.Secure qualified as Secure
|
||||
import Okapi.Request (Request)
|
||||
import Okapi.Route (DELETE (..), GET (..), POST (..), PUT (..), Route (..), Routes (..))
|
||||
-- import Control.Natural (type (~>))
|
||||
-- import Control.Object (Object (..), (#))
|
||||
-- import Data.Aeson qualified as Aeson
|
||||
-- import Data.Bifunctor (Bifunctor (..))
|
||||
-- import Data.ByteString qualified as BS
|
||||
-- import Data.CaseInsensitive qualified as CI
|
||||
-- import Data.Function ((&))
|
||||
-- import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
|
||||
-- import Data.Kind (Type)
|
||||
-- import Data.List (groupBy)
|
||||
-- import Data.List qualified as List
|
||||
-- import Data.List.Extra qualified as List
|
||||
-- import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
-- import Data.List.NonEmpty qualified as NonEmpty
|
||||
-- import Data.OpenApi (OpenApi (_openApiInfo))
|
||||
-- import Data.OpenApi qualified as OAPI
|
||||
-- import Data.OpenApi.Declare qualified as OAPI
|
||||
-- import Data.OpenApi.Internal (OpenApiSpecVersion (..), upperOpenApiSpecVersion)
|
||||
-- import Data.Proxy
|
||||
-- import Data.Semigroup (Semigroup (..))
|
||||
-- import Data.Text qualified as Text
|
||||
-- import Data.Text.Encoding qualified as Text
|
||||
-- import Data.Version qualified as Version
|
||||
-- import Debug.Trace qualified as Debug
|
||||
-- import Network.HTTP.Types qualified as HTTP
|
||||
-- import Network.Wai qualified as WAI
|
||||
-- import Network.Wai.Parse qualified as WAI
|
||||
-- import Okapi.Parser
|
||||
-- import Okapi.Parser.Body qualified as Body
|
||||
-- import Okapi.Parser.Headers qualified as Headers
|
||||
-- import Okapi.Parser.Path qualified as Path
|
||||
-- import Okapi.Parser.Query qualified as Query
|
||||
-- import Okapi.Parser.Responder qualified as Responder
|
||||
-- import Okapi.Parser.Responder.AddHeader (Response, toWaiResponse)
|
||||
-- import Okapi.Parser.Security qualified as Security
|
||||
-- import Okapi.Parser.Security.Secure qualified as Secure
|
||||
-- import Okapi.Request (Request)
|
||||
-- import Okapi.Route (DELETE (..), GET (..), POST (..), PUT (..), Route (..), Routes (..))
|
||||
|
||||
data Server resources = Server
|
||||
{ info :: OAPI.Info,
|
||||
url :: [Text.Text],
|
||||
description :: Maybe Text.Text,
|
||||
routes :: Routes resources
|
||||
}
|
||||
-- data Server resources = Server
|
||||
-- { info :: OAPI.Info,
|
||||
-- url :: [Text.Text],
|
||||
-- description :: Maybe Text.Text,
|
||||
-- routes :: Routes resources
|
||||
-- }
|
||||
|
||||
toApplication :: Server resources -> WAI.Application
|
||||
toApplication Server {url, routes} request respond = do
|
||||
let reqPath = List.dropPrefix url $ WAI.pathInfo request
|
||||
reqQuery = WAI.queryString request
|
||||
reqHeaders = WAI.requestHeaders request
|
||||
reqSecurity = Secure.State reqQuery reqHeaders [] -- TODO: Get cookies out of headers here instead of empty list
|
||||
if reqPath == WAI.pathInfo request && not (null url)
|
||||
then respond $ WAI.responseLBS HTTP.status404 mempty mempty -- TODO: If the incoming request URL doesn't have correct prefix. 404?
|
||||
else case getPathItemByPath reqPath routes of
|
||||
None -> respond $ WAI.responseLBS HTTP.status404 mempty mempty
|
||||
Some (Route {get, post, put, delete}, resourceParam) -> case HTTP.parseMethod $ WAI.requestMethod request of
|
||||
Left _ -> respond $ WAI.responseLBS HTTP.status501 mempty mempty -- TODO: Return 501 Not Implemented error
|
||||
Right reqMethod ->
|
||||
case reqMethod of
|
||||
HTTP.GET -> case get of
|
||||
Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
|
||||
Just (GET {handler, object}) ->
|
||||
case evalSecurity (sortSecurity Security.parser) reqSecurity of
|
||||
(Ok securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
|
||||
((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
|
||||
response <- object # handler resourceParam securityParam queryParam headersParam responderParam
|
||||
respond $ toWaiResponse response
|
||||
_ -> respond $ WAI.responseLBS HTTP.status422 mempty mempty -- TODO: Return 422 Unprocessable Content based on errors returned by Scripts
|
||||
_ -> respond $ WAI.responseLBS HTTP.status401 mempty mempty -- TODO: Return 401 Unauthorized
|
||||
HTTP.POST -> case post of
|
||||
Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
|
||||
Just (POST {handler, object}) ->
|
||||
case evalSecurity (sortSecurity Security.parser) reqSecurity of
|
||||
(Ok securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
|
||||
((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
|
||||
bodyResult <- evalBody (sortBody Body.parser) request
|
||||
case bodyResult of
|
||||
(Ok bodyParam, _) -> do
|
||||
response <- object # handler resourceParam securityParam queryParam bodyParam headersParam responderParam
|
||||
respond $ toWaiResponse response
|
||||
_ -> respond $ WAI.responseLBS HTTP.status400 mempty mempty -- TODO: Return 400 for now but can be more specific depending on content-type, etc.
|
||||
_ -> respond $ WAI.responseLBS HTTP.status422 mempty mempty -- TODO: Return 422 Unprocessable Content based on errors returned by Scripts
|
||||
_ -> respond $ WAI.responseLBS HTTP.status401 mempty mempty -- TODO: Return 401 Unauthorized
|
||||
HTTP.PUT -> case put of
|
||||
Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
|
||||
Just (PUT {handler, object}) ->
|
||||
case evalSecurity (sortSecurity Security.parser) reqSecurity of
|
||||
(Ok securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
|
||||
((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
|
||||
bodyResult <- evalBody (sortBody Body.parser) request
|
||||
case bodyResult of
|
||||
(Ok bodyParam, _) -> do
|
||||
response <- object # handler resourceParam securityParam queryParam bodyParam headersParam responderParam
|
||||
respond $ toWaiResponse response
|
||||
_ -> respond $ WAI.responseLBS HTTP.status400 mempty mempty -- TODO: Return 400 for now but can be more specific depending on content-type, etc.
|
||||
_ -> respond $ WAI.responseLBS HTTP.status422 mempty mempty -- TODO: Return 422 Unprocessable Content based on errors returned by Scripts
|
||||
_ -> respond $ WAI.responseLBS HTTP.status401 mempty mempty -- TODO: Return 401 Unauthorized
|
||||
HTTP.DELETE -> case delete of
|
||||
Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
|
||||
Just (DELETE {handler, object}) ->
|
||||
case evalSecurity (sortSecurity Security.parser) reqSecurity of
|
||||
(Ok securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
|
||||
((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
|
||||
response <- object # handler resourceParam securityParam queryParam headersParam responderParam
|
||||
respond $ toWaiResponse response
|
||||
_ -> respond $ WAI.responseLBS HTTP.status422 mempty mempty -- TODO: Return 422 Unprocessable Content based on errors returned by Scripts
|
||||
_ -> respond $ WAI.responseLBS HTTP.status401 mempty mempty -- TODO: Return 401 Unauthorized
|
||||
_ -> respond $ WAI.responseLBS HTTP.status501 mempty mempty -- TODO: Implement cases for remaing Standard HTTP methods
|
||||
-- toApplication :: Server resources -> WAI.Application
|
||||
-- toApplication Server {url, routes} request respond = do
|
||||
-- let reqPath = List.dropPrefix url $ WAI.pathInfo request
|
||||
-- reqQuery = WAI.queryString request
|
||||
-- reqHeaders = WAI.requestHeaders request
|
||||
-- reqSecurity = Secure.State reqQuery reqHeaders [] -- TODO: Get cookies out of headers here instead of empty list
|
||||
-- if reqPath == WAI.pathInfo request && not (null url)
|
||||
-- then respond $ WAI.responseLBS HTTP.status404 mempty mempty -- TODO: If the incoming request URL doesn't have correct prefix. 404?
|
||||
-- else case getPathItemByPath reqPath routes of
|
||||
-- None -> respond $ WAI.responseLBS HTTP.status404 mempty mempty
|
||||
-- Some (Route {get, post, put, delete}, resourceParam) -> case HTTP.parseMethod $ WAI.requestMethod request of
|
||||
-- Left _ -> respond $ WAI.responseLBS HTTP.status501 mempty mempty -- TODO: Return 501 Not Implemented error
|
||||
-- Right reqMethod ->
|
||||
-- case reqMethod of
|
||||
-- HTTP.GET -> case get of
|
||||
-- Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
|
||||
-- Just (GET {handler, object}) ->
|
||||
-- case evalSecurity (sortSecurity Security.parser) reqSecurity of
|
||||
-- (Ok securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
|
||||
-- ((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
|
||||
-- response <- object # handler resourceParam securityParam queryParam headersParam responderParam
|
||||
-- respond $ toWaiResponse response
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status422 mempty mempty -- TODO: Return 422 Unprocessable Content based on errors returned by Scripts
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status401 mempty mempty -- TODO: Return 401 Unauthorized
|
||||
-- HTTP.POST -> case post of
|
||||
-- Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
|
||||
-- Just (POST {handler, object}) ->
|
||||
-- case evalSecurity (sortSecurity Security.parser) reqSecurity of
|
||||
-- (Ok securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
|
||||
-- ((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
|
||||
-- bodyResult <- evalBody (sortBody Body.parser) request
|
||||
-- case bodyResult of
|
||||
-- (Ok bodyParam, _) -> do
|
||||
-- response <- object # handler resourceParam securityParam queryParam bodyParam headersParam responderParam
|
||||
-- respond $ toWaiResponse response
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status400 mempty mempty -- TODO: Return 400 for now but can be more specific depending on content-type, etc.
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status422 mempty mempty -- TODO: Return 422 Unprocessable Content based on errors returned by Scripts
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status401 mempty mempty -- TODO: Return 401 Unauthorized
|
||||
-- HTTP.PUT -> case put of
|
||||
-- Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
|
||||
-- Just (PUT {handler, object}) ->
|
||||
-- case evalSecurity (sortSecurity Security.parser) reqSecurity of
|
||||
-- (Ok securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
|
||||
-- ((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
|
||||
-- bodyResult <- evalBody (sortBody Body.parser) request
|
||||
-- case bodyResult of
|
||||
-- (Ok bodyParam, _) -> do
|
||||
-- response <- object # handler resourceParam securityParam queryParam bodyParam headersParam responderParam
|
||||
-- respond $ toWaiResponse response
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status400 mempty mempty -- TODO: Return 400 for now but can be more specific depending on content-type, etc.
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status422 mempty mempty -- TODO: Return 422 Unprocessable Content based on errors returned by Scripts
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status401 mempty mempty -- TODO: Return 401 Unauthorized
|
||||
-- HTTP.DELETE -> case delete of
|
||||
-- Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
|
||||
-- Just (DELETE {handler, object}) ->
|
||||
-- case evalSecurity (sortSecurity Security.parser) reqSecurity of
|
||||
-- (Ok securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
|
||||
-- ((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
|
||||
-- response <- object # handler resourceParam securityParam queryParam headersParam responderParam
|
||||
-- respond $ toWaiResponse response
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status422 mempty mempty -- TODO: Return 422 Unprocessable Content based on errors returned by Scripts
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status401 mempty mempty -- TODO: Return 401 Unauthorized
|
||||
-- _ -> respond $ WAI.responseLBS HTTP.status501 mempty mempty -- TODO: Implement cases for remaing Standard HTTP methods
|
||||
|
||||
data Option where
|
||||
None :: Option
|
||||
Some :: forall resource. (Route resource, resource) -> Option
|
||||
-- data Option where
|
||||
-- None :: Option
|
||||
-- Some :: forall resource. (Route resource, resource) -> Option
|
||||
|
||||
getPathItemByPath :: [Text.Text] -> Routes resources -> Option
|
||||
getPathItemByPath reqPath Nil = None
|
||||
getPathItemByPath reqPath (route@(Route @resource _ _ _ _ _ _) :& t) = case Path.eval (Path.parser @resource) reqPath of
|
||||
(Ok resourceParam, _) -> Some (route, resourceParam)
|
||||
_ -> getPathItemByPath reqPath t
|
||||
-- getPathItemByPath :: [Text.Text] -> Routes resources -> Option
|
||||
-- getPathItemByPath reqPath Nil = None
|
||||
-- getPathItemByPath reqPath (route@(Route @resource _ _ _ _ _ _) :& t) = case Path.eval (Path.parser @resource) reqPath of
|
||||
-- (Ok resourceParam, _) -> Some (route, resourceParam)
|
||||
-- _ -> getPathItemByPath reqPath t
|
||||
|
||||
evalBody :: NonEmpty (Body.Parser a) -> WAI.Request -> IO (Result [Body.Error] a, Body.RequestBody)
|
||||
evalBody (h :| t) request = do
|
||||
state <- case WAI.getRequestBodyType request of
|
||||
Just (WAI.Multipart _boundary) -> Body.RequestBodyMultipart <$> WAI.parseRequestBodyEx WAI.defaultParseRequestBodyOptions WAI.lbsBackEnd request
|
||||
_ -> Body.RequestBodyRaw <$> WAI.lazyRequestBody request
|
||||
case first (first pure) $ Body.eval h state of
|
||||
(ok@(Ok _), s) -> return (ok, s)
|
||||
_ -> return $ loop state t
|
||||
where
|
||||
loop :: Body.RequestBody -> [Body.Parser a] -> (Result [Body.Error] a, Body.RequestBody)
|
||||
loop state [] = (Fail [], state)
|
||||
loop state (h : t) = case first (first pure) $ Body.eval h state of
|
||||
(ok@(Ok _), state') -> (ok, state')
|
||||
_ -> loop state t
|
||||
-- evalBody :: NonEmpty (Body.Parser a) -> WAI.Request -> IO (Result [Body.Error] a, Body.RequestBody)
|
||||
-- evalBody (h :| t) request = do
|
||||
-- state <- case WAI.getRequestBodyType request of
|
||||
-- Just (WAI.Multipart _boundary) -> Body.RequestBodyMultipart <$> WAI.parseRequestBodyEx WAI.defaultParseRequestBodyOptions WAI.lbsBackEnd request
|
||||
-- _ -> Body.RequestBodyRaw <$> WAI.lazyRequestBody request
|
||||
-- case first (first pure) $ Body.eval h state of
|
||||
-- (ok@(Ok _), s) -> return (ok, s)
|
||||
-- _ -> return $ loop state t
|
||||
-- where
|
||||
-- loop :: Body.RequestBody -> [Body.Parser a] -> (Result [Body.Error] a, Body.RequestBody)
|
||||
-- loop state [] = (Fail [], state)
|
||||
-- loop state (h : t) = case first (first pure) $ Body.eval h state of
|
||||
-- (ok@(Ok _), state') -> (ok, state')
|
||||
-- _ -> loop state t
|
||||
|
||||
sortBody :: NonEmpty (Body.Parser a) -> NonEmpty (Body.Parser a)
|
||||
sortBody = NonEmpty.sortBy comparer
|
||||
where
|
||||
comparer :: Body.Parser a -> Body.Parser a -> Ordering
|
||||
comparer Body.None Body.None = EQ
|
||||
comparer (Body.FMap _ Body.None) (Body.FMap _ Body.None) = EQ
|
||||
comparer (Body.FMap _ Body.None) _ = GT
|
||||
comparer _ (Body.FMap _ Body.None) = LT
|
||||
comparer Body.None _body = GT
|
||||
comparer _body Body.None = LT
|
||||
-- sortBody :: NonEmpty (Body.Parser a) -> NonEmpty (Body.Parser a)
|
||||
-- sortBody = NonEmpty.sortBy comparer
|
||||
-- where
|
||||
-- comparer :: Body.Parser a -> Body.Parser a -> Ordering
|
||||
-- comparer Body.None Body.None = EQ
|
||||
-- comparer (Body.FMap _ Body.None) (Body.FMap _ Body.None) = EQ
|
||||
-- comparer (Body.FMap _ Body.None) _ = GT
|
||||
-- comparer _ (Body.FMap _ Body.None) = LT
|
||||
-- comparer Body.None _body = GT
|
||||
-- comparer _body Body.None = LT
|
||||
|
||||
evalSecurity :: NonEmpty (Security.Parser a) -> Secure.State -> (Result Security.Error a, Secure.State)
|
||||
evalSecurity (h :| t) state = case Security.eval h state of
|
||||
(ok@(Ok _), s) -> (ok, s)
|
||||
_ -> loop state t
|
||||
where
|
||||
loop :: Secure.State -> [Security.Parser a] -> (Result Security.Error a, Secure.State)
|
||||
loop state [] = (Fail $ Security.SecureError Secure.ParseFail, state)
|
||||
loop state (h : t) = case Security.eval h state of
|
||||
(ok@(Ok _), state') -> (ok, state')
|
||||
_ -> loop state t
|
||||
-- evalSecurity :: NonEmpty (Security.Parser a) -> Secure.State -> (Result Security.Error a, Secure.State)
|
||||
-- evalSecurity (h :| t) state = case Security.eval h state of
|
||||
-- (ok@(Ok _), s) -> (ok, s)
|
||||
-- _ -> loop state t
|
||||
-- where
|
||||
-- loop :: Secure.State -> [Security.Parser a] -> (Result Security.Error a, Secure.State)
|
||||
-- loop state [] = (Fail $ Security.SecureError Secure.ParseFail, state)
|
||||
-- loop state (h : t) = case Security.eval h state of
|
||||
-- (ok@(Ok _), state') -> (ok, state')
|
||||
-- _ -> loop state t
|
||||
|
||||
sortSecurity :: NonEmpty (Security.Parser a) -> NonEmpty (Security.Parser a)
|
||||
sortSecurity = NonEmpty.sortBy comparer
|
||||
where
|
||||
comparer :: Security.Parser a -> Security.Parser a -> Ordering
|
||||
comparer Security.None Security.None = EQ
|
||||
comparer (Security.FMap _ Security.None) (Security.FMap _ Security.None) = EQ
|
||||
comparer Security.None _ = GT
|
||||
comparer (Security.FMap _ Security.None) _ = GT
|
||||
comparer _ Security.None = LT
|
||||
comparer _ (Security.FMap _ Security.None) = LT
|
||||
-- sortSecurity :: NonEmpty (Security.Parser a) -> NonEmpty (Security.Parser a)
|
||||
-- sortSecurity = NonEmpty.sortBy comparer
|
||||
-- where
|
||||
-- comparer :: Security.Parser a -> Security.Parser a -> Ordering
|
||||
-- comparer Security.None Security.None = EQ
|
||||
-- comparer (Security.FMap _ Security.None) (Security.FMap _ Security.None) = EQ
|
||||
-- comparer Security.None _ = GT
|
||||
-- comparer (Security.FMap _ Security.None) _ = GT
|
||||
-- comparer _ Security.None = LT
|
||||
-- comparer _ (Security.FMap _ Security.None) = LT
|
||||
|
||||
toOpenAPI ::
|
||||
Server resource ->
|
||||
OAPI.OpenApi
|
||||
toOpenAPI Server {info, description, routes, url} =
|
||||
mempty
|
||||
{ OAPI._openApiInfo = info,
|
||||
OAPI._openApiServers =
|
||||
[ OAPI.Server
|
||||
(Text.intercalate "/" url)
|
||||
description
|
||||
mempty
|
||||
],
|
||||
OAPI._openApiPaths = pathItemsToOpenAPIPaths routes,
|
||||
OAPI._openApiOpenapi = OpenApiSpecVersion {getVersion = Version.Version [3, 0, 3] []}
|
||||
}
|
||||
-- toOpenAPI ::
|
||||
-- Server resource ->
|
||||
-- OAPI.OpenApi
|
||||
-- toOpenAPI Server {info, description, routes, url} =
|
||||
-- mempty
|
||||
-- { OAPI._openApiInfo = info,
|
||||
-- OAPI._openApiServers =
|
||||
-- [ OAPI.Server
|
||||
-- (Text.intercalate "/" url)
|
||||
-- description
|
||||
-- mempty
|
||||
-- ],
|
||||
-- OAPI._openApiPaths = pathItemsToOpenAPIPaths routes,
|
||||
-- OAPI._openApiOpenapi = OpenApiSpecVersion {getVersion = Version.Version [3, 0, 3] []}
|
||||
-- }
|
||||
|
||||
pathItemsToOpenAPIPaths :: Routes resources -> InsOrdHashMap.InsOrdHashMap FilePath OAPI.PathItem
|
||||
pathItemsToOpenAPIPaths Nil = InsOrdHashMap.fromList []
|
||||
pathItemsToOpenAPIPaths (h :& t) = let (filePath, pathItem) = toOpenAPIPathItem h in InsOrdHashMap.insert filePath pathItem $ pathItemsToOpenAPIPaths t
|
||||
-- pathItemsToOpenAPIPaths :: Routes resources -> InsOrdHashMap.InsOrdHashMap FilePath OAPI.PathItem
|
||||
-- pathItemsToOpenAPIPaths Nil = InsOrdHashMap.fromList []
|
||||
-- pathItemsToOpenAPIPaths (h :& t) = let (filePath, pathItem) = toOpenAPIPathItem h in InsOrdHashMap.insert filePath pathItem $ pathItemsToOpenAPIPaths t
|
||||
|
||||
toOpenAPIPathItem :: Route resource -> (FilePath, OAPI.PathItem)
|
||||
toOpenAPIPathItem (Route @resource summary description get post put delete) = (pathName, pathItem)
|
||||
where
|
||||
pathName :: FilePath
|
||||
pathName = renderPath $ Path.parser @resource
|
||||
-- toOpenAPIPathItem :: Route resource -> (FilePath, OAPI.PathItem)
|
||||
-- toOpenAPIPathItem (Route @resource summary description get post put delete) = (pathName, pathItem)
|
||||
-- where
|
||||
-- pathName :: FilePath
|
||||
-- pathName = renderPath $ Path.parser @resource
|
||||
|
||||
pathItem :: OAPI.PathItem
|
||||
pathItem =
|
||||
mempty
|
||||
{ OAPI._pathItemSummary = summary,
|
||||
OAPI._pathItemDescription = description,
|
||||
OAPI._pathItemGet = fmap toGetOperation get,
|
||||
OAPI._pathItemPost = fmap toPostOperation post,
|
||||
OAPI._pathItemPut = fmap toPutOperation put,
|
||||
OAPI._pathItemDelete = fmap toDeleteOperation delete
|
||||
}
|
||||
-- pathItem :: OAPI.PathItem
|
||||
-- pathItem =
|
||||
-- mempty
|
||||
-- { OAPI._pathItemSummary = summary,
|
||||
-- OAPI._pathItemDescription = description,
|
||||
-- OAPI._pathItemGet = fmap toGetOperation get,
|
||||
-- OAPI._pathItemPost = fmap toPostOperation post,
|
||||
-- OAPI._pathItemPut = fmap toPutOperation put,
|
||||
-- OAPI._pathItemDelete = fmap toDeleteOperation delete
|
||||
-- }
|
||||
|
||||
toGetOperation :: GET m resource security query headers responder -> OAPI.Operation
|
||||
toGetOperation (GET @_ @resource @security @query @headers @responder summary description _ _) =
|
||||
mempty
|
||||
{ OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
|
||||
OAPI._operationResponses = toResponses $ Responder.parser @responder,
|
||||
OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
|
||||
OAPI._operationSummary = summary,
|
||||
OAPI._operationDescription = description
|
||||
}
|
||||
-- toGetOperation :: GET m resource security query headers responder -> OAPI.Operation
|
||||
-- toGetOperation (GET @_ @resource @security @query @headers @responder summary description _ _) =
|
||||
-- mempty
|
||||
-- { OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
|
||||
-- OAPI._operationResponses = toResponses $ Responder.parser @responder,
|
||||
-- OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
|
||||
-- OAPI._operationSummary = summary,
|
||||
-- OAPI._operationDescription = description
|
||||
-- }
|
||||
|
||||
toPostOperation :: POST m resource security query body headers responder -> OAPI.Operation
|
||||
toPostOperation (POST @_ @resource @security @query @body @headers @responder summary description _ _) =
|
||||
mempty
|
||||
{ OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
|
||||
OAPI._operationRequestBody = toOpenAPIRequestBody $ Body.parser @body,
|
||||
OAPI._operationResponses = toResponses $ Responder.parser @responder,
|
||||
OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
|
||||
OAPI._operationSummary = summary,
|
||||
OAPI._operationDescription = description
|
||||
}
|
||||
-- toPostOperation :: POST m resource security query body headers responder -> OAPI.Operation
|
||||
-- toPostOperation (POST @_ @resource @security @query @body @headers @responder summary description _ _) =
|
||||
-- mempty
|
||||
-- { OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
|
||||
-- OAPI._operationRequestBody = toOpenAPIRequestBody $ Body.parser @body,
|
||||
-- OAPI._operationResponses = toResponses $ Responder.parser @responder,
|
||||
-- OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
|
||||
-- OAPI._operationSummary = summary,
|
||||
-- OAPI._operationDescription = description
|
||||
-- }
|
||||
|
||||
toPutOperation :: PUT m resource security query body headers responder -> OAPI.Operation
|
||||
toPutOperation (PUT @_ @resource @security @query @body @headers @responder summary description _ _) =
|
||||
mempty
|
||||
{ OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
|
||||
OAPI._operationRequestBody = toOpenAPIRequestBody $ Body.parser @body,
|
||||
OAPI._operationResponses = toResponses $ Responder.parser @responder,
|
||||
OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
|
||||
OAPI._operationSummary = summary,
|
||||
OAPI._operationDescription = description
|
||||
}
|
||||
-- toPutOperation :: PUT m resource security query body headers responder -> OAPI.Operation
|
||||
-- toPutOperation (PUT @_ @resource @security @query @body @headers @responder summary description _ _) =
|
||||
-- mempty
|
||||
-- { OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
|
||||
-- OAPI._operationRequestBody = toOpenAPIRequestBody $ Body.parser @body,
|
||||
-- OAPI._operationResponses = toResponses $ Responder.parser @responder,
|
||||
-- OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
|
||||
-- OAPI._operationSummary = summary,
|
||||
-- OAPI._operationDescription = description
|
||||
-- }
|
||||
|
||||
toDeleteOperation :: DELETE m resource security query headers responder -> OAPI.Operation
|
||||
toDeleteOperation (DELETE @_ @resource @security @query @headers @responder summary description _ _) =
|
||||
mempty
|
||||
{ OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
|
||||
OAPI._operationResponses = toResponses $ Responder.parser @responder,
|
||||
OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
|
||||
OAPI._operationSummary = summary,
|
||||
OAPI._operationDescription = description
|
||||
}
|
||||
-- toDeleteOperation :: DELETE m resource security query headers responder -> OAPI.Operation
|
||||
-- toDeleteOperation (DELETE @_ @resource @security @query @headers @responder summary description _ _) =
|
||||
-- mempty
|
||||
-- { OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
|
||||
-- OAPI._operationResponses = toResponses $ Responder.parser @responder,
|
||||
-- OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
|
||||
-- OAPI._operationSummary = summary,
|
||||
-- OAPI._operationDescription = description
|
||||
-- }
|
||||
|
||||
toParameters :: (Path.Parser resource, Query.Parser q, Headers.Parser h) -> [OAPI.Referenced OAPI.Param]
|
||||
toParameters (path, query, headers) = pathParameters path <> queryParameters query <> headersParameters headers
|
||||
where
|
||||
pathParameters :: Path.Parser resource -> [OAPI.Referenced OAPI.Param]
|
||||
pathParameters path = case path of
|
||||
Path.FMap f p -> pathParameters p
|
||||
Path.Pure _ -> mempty
|
||||
Path.Apply pf px -> pathParameters pf <> pathParameters px
|
||||
Path.Static _ -> mempty
|
||||
Path.Param @p name ->
|
||||
[ OAPI.Inline $
|
||||
mempty
|
||||
{ OAPI._paramName = name,
|
||||
OAPI._paramRequired = Just True,
|
||||
OAPI._paramIn = OAPI.ParamPath,
|
||||
OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
|
||||
}
|
||||
]
|
||||
-- toParameters :: (Path.Parser resource, Query.Parser q, Headers.Parser h) -> [OAPI.Referenced OAPI.Param]
|
||||
-- toParameters (path, query, headers) = pathParameters path <> queryParameters query <> headersParameters headers
|
||||
-- where
|
||||
-- pathParameters :: Path.Parser resource -> [OAPI.Referenced OAPI.Param]
|
||||
-- pathParameters path = case path of
|
||||
-- Path.FMap f p -> pathParameters p
|
||||
-- Path.Pure _ -> mempty
|
||||
-- Path.Apply pf px -> pathParameters pf <> pathParameters px
|
||||
-- Path.Static _ -> mempty
|
||||
-- Path.Param @p name ->
|
||||
-- [ OAPI.Inline $
|
||||
-- mempty
|
||||
-- { OAPI._paramName = name,
|
||||
-- OAPI._paramRequired = Just True,
|
||||
-- OAPI._paramIn = OAPI.ParamPath,
|
||||
-- OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
|
||||
-- }
|
||||
-- ]
|
||||
|
||||
queryParameters :: Query.Parser q -> [OAPI.Referenced OAPI.Param]
|
||||
queryParameters query = case query of
|
||||
Query.FMap f q -> queryParameters q
|
||||
Query.Pure _ -> mempty
|
||||
Query.Apply pf px -> queryParameters pf <> queryParameters px
|
||||
Query.Param @p name ->
|
||||
[ OAPI.Inline $
|
||||
mempty
|
||||
{ OAPI._paramName = Text.decodeUtf8 name,
|
||||
OAPI._paramRequired = Just True,
|
||||
OAPI._paramIn = OAPI.ParamQuery,
|
||||
OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
|
||||
}
|
||||
]
|
||||
Query.Flag name ->
|
||||
[ OAPI.Inline $
|
||||
mempty
|
||||
{ OAPI._paramName = Text.decodeUtf8 name,
|
||||
OAPI._paramRequired = Just True,
|
||||
OAPI._paramIn = OAPI.ParamQuery,
|
||||
OAPI._paramAllowEmptyValue = Just True
|
||||
}
|
||||
]
|
||||
Query.Optional @p query' -> case query' of
|
||||
Query.Param _ -> do
|
||||
param <- queryParameters query'
|
||||
pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
|
||||
Query.Flag _ -> do
|
||||
param <- queryParameters query'
|
||||
pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
|
||||
_ -> queryParameters query'
|
||||
Query.Option @p def query' -> case query' of
|
||||
Query.Param _ -> do
|
||||
param <- queryParameters query'
|
||||
pure $ fmap (\param -> param {OAPI._paramRequired = Just False, OAPI._paramSchema = fmap (fmap (\schema -> schema {OAPI._schemaDefault = Just $ Aeson.toJSON def})) param._paramSchema}) param
|
||||
_ -> queryParameters query'
|
||||
-- queryParameters :: Query.Parser q -> [OAPI.Referenced OAPI.Param]
|
||||
-- queryParameters query = case query of
|
||||
-- Query.FMap f q -> queryParameters q
|
||||
-- Query.Pure _ -> mempty
|
||||
-- Query.Apply pf px -> queryParameters pf <> queryParameters px
|
||||
-- Query.Param @p name ->
|
||||
-- [ OAPI.Inline $
|
||||
-- mempty
|
||||
-- { OAPI._paramName = Text.decodeUtf8 name,
|
||||
-- OAPI._paramRequired = Just True,
|
||||
-- OAPI._paramIn = OAPI.ParamQuery,
|
||||
-- OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
|
||||
-- }
|
||||
-- ]
|
||||
-- Query.Flag name ->
|
||||
-- [ OAPI.Inline $
|
||||
-- mempty
|
||||
-- { OAPI._paramName = Text.decodeUtf8 name,
|
||||
-- OAPI._paramRequired = Just True,
|
||||
-- OAPI._paramIn = OAPI.ParamQuery,
|
||||
-- OAPI._paramAllowEmptyValue = Just True
|
||||
-- }
|
||||
-- ]
|
||||
-- Query.Optional @p query' -> case query' of
|
||||
-- Query.Param _ -> do
|
||||
-- param <- queryParameters query'
|
||||
-- pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
|
||||
-- Query.Flag _ -> do
|
||||
-- param <- queryParameters query'
|
||||
-- pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
|
||||
-- _ -> queryParameters query'
|
||||
-- Query.Option @p def query' -> case query' of
|
||||
-- Query.Param _ -> do
|
||||
-- param <- queryParameters query'
|
||||
-- pure $ fmap (\param -> param {OAPI._paramRequired = Just False, OAPI._paramSchema = fmap (fmap (\schema -> schema {OAPI._schemaDefault = Just $ Aeson.toJSON def})) param._paramSchema}) param
|
||||
-- _ -> queryParameters query'
|
||||
|
||||
headersParameters :: Headers.Parser h -> [OAPI.Referenced OAPI.Param]
|
||||
headersParameters headers = case headers of
|
||||
Headers.FMap f h -> headersParameters h
|
||||
Headers.Pure _ -> mempty
|
||||
Headers.Apply pf px -> headersParameters pf <> headersParameters px
|
||||
Headers.Param @p name ->
|
||||
[ OAPI.Inline $
|
||||
mempty
|
||||
{ OAPI._paramName = Text.decodeUtf8 $ CI.original name,
|
||||
OAPI._paramRequired = Just True,
|
||||
OAPI._paramIn = OAPI.ParamHeader,
|
||||
OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
|
||||
}
|
||||
]
|
||||
Headers.Cookie @p name ->
|
||||
[ OAPI.Inline $
|
||||
mempty
|
||||
{ OAPI._paramName = Text.decodeUtf8 name,
|
||||
OAPI._paramRequired = Just True,
|
||||
OAPI._paramIn = OAPI.ParamCookie,
|
||||
OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
|
||||
}
|
||||
]
|
||||
Headers.Optional @p headers' -> case headers' of
|
||||
Headers.Param _ -> do
|
||||
param <- headersParameters headers'
|
||||
pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
|
||||
Headers.Cookie _ -> do
|
||||
param <- headersParameters headers'
|
||||
pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
|
||||
_ -> headersParameters headers'
|
||||
Headers.Option @p def headers' -> case headers' of
|
||||
Headers.Param _ -> do
|
||||
param <- headersParameters headers'
|
||||
pure $ fmap (\param -> param {OAPI._paramRequired = Just False, OAPI._paramSchema = fmap (fmap (\schema -> schema {OAPI._schemaDefault = Just $ Aeson.toJSON def})) param._paramSchema}) param
|
||||
Headers.Cookie _ -> do
|
||||
param <- headersParameters headers'
|
||||
pure $ fmap (\param -> param {OAPI._paramRequired = Just False, OAPI._paramSchema = fmap (fmap (\schema -> schema {OAPI._schemaDefault = Just $ Aeson.toJSON def})) param._paramSchema}) param
|
||||
_ -> headersParameters headers'
|
||||
-- headersParameters :: Headers.Parser h -> [OAPI.Referenced OAPI.Param]
|
||||
-- headersParameters headers = case headers of
|
||||
-- Headers.FMap f h -> headersParameters h
|
||||
-- Headers.Pure _ -> mempty
|
||||
-- Headers.Apply pf px -> headersParameters pf <> headersParameters px
|
||||
-- Headers.Param @p name ->
|
||||
-- [ OAPI.Inline $
|
||||
-- mempty
|
||||
-- { OAPI._paramName = Text.decodeUtf8 $ CI.original name,
|
||||
-- OAPI._paramRequired = Just True,
|
||||
-- OAPI._paramIn = OAPI.ParamHeader,
|
||||
-- OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
|
||||
-- }
|
||||
-- ]
|
||||
-- Headers.Cookie @p name ->
|
||||
-- [ OAPI.Inline $
|
||||
-- mempty
|
||||
-- { OAPI._paramName = Text.decodeUtf8 name,
|
||||
-- OAPI._paramRequired = Just True,
|
||||
-- OAPI._paramIn = OAPI.ParamCookie,
|
||||
-- OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
|
||||
-- }
|
||||
-- ]
|
||||
-- Headers.Optional @p headers' -> case headers' of
|
||||
-- Headers.Param _ -> do
|
||||
-- param <- headersParameters headers'
|
||||
-- pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
|
||||
-- Headers.Cookie _ -> do
|
||||
-- param <- headersParameters headers'
|
||||
-- pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
|
||||
-- _ -> headersParameters headers'
|
||||
-- Headers.Option @p def headers' -> case headers' of
|
||||
-- Headers.Param _ -> do
|
||||
-- param <- headersParameters headers'
|
||||
-- pure $ fmap (\param -> param {OAPI._paramRequired = Just False, OAPI._paramSchema = fmap (fmap (\schema -> schema {OAPI._schemaDefault = Just $ Aeson.toJSON def})) param._paramSchema}) param
|
||||
-- Headers.Cookie _ -> do
|
||||
-- param <- headersParameters headers'
|
||||
-- pure $ fmap (\param -> param {OAPI._paramRequired = Just False, OAPI._paramSchema = fmap (fmap (\schema -> schema {OAPI._schemaDefault = Just $ Aeson.toJSON def})) param._paramSchema}) param
|
||||
-- _ -> headersParameters headers'
|
||||
|
||||
toSecurityRequirements :: NonEmpty (Security.Parser s) -> [OAPI.SecurityRequirement]
|
||||
toSecurityRequirements security = []
|
||||
-- toSecurityRequirements :: NonEmpty (Security.Parser s) -> [OAPI.SecurityRequirement]
|
||||
-- toSecurityRequirements security = []
|
||||
|
||||
toOpenAPIRequestBody :: NonEmpty (Body.Parser b) -> Maybe (OAPI.Referenced OAPI.RequestBody)
|
||||
toOpenAPIRequestBody body = Nothing
|
||||
-- toOpenAPIRequestBody :: NonEmpty (Body.Parser b) -> Maybe (OAPI.Referenced OAPI.RequestBody)
|
||||
-- toOpenAPIRequestBody body = Nothing
|
||||
|
||||
toResponses :: Responder.Parser r -> OAPI.Responses
|
||||
toResponses responder = mempty
|
||||
-- toResponses :: Responder.Parser r -> OAPI.Responses
|
||||
-- toResponses responder = mempty
|
||||
|
||||
renderPath :: Path.Parser a -> FilePath
|
||||
renderPath path = case path of
|
||||
Path.FMap f p -> renderPath p
|
||||
Path.Pure _ -> mempty
|
||||
Path.Apply pf px -> renderPath pf <> renderPath px
|
||||
Path.Static t -> "/" <> Text.unpack t
|
||||
Path.Param @p name -> "/{" <> Text.unpack name <> "}"
|
||||
-- renderPath :: Path.Parser a -> FilePath
|
||||
-- renderPath path = case path of
|
||||
-- Path.FMap f p -> renderPath p
|
||||
-- Path.Pure _ -> mempty
|
||||
-- Path.Apply pf px -> renderPath pf <> renderPath px
|
||||
-- Path.Static t -> "/" <> Text.unpack t
|
||||
-- Path.Param @p name -> "/{" <> Text.unpack name <> "}"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user