monadicsystems/okapi
1
1
Fork 0
mirror of https://github.com/monadicsystems/okapi.git synced 2024-12-18 12:01:46 +03:00
Code Issues Projects Releases Wiki Activity

Implement the basics for Elixir-like Plugs

Browse Source
This commit is contained in:
Rashad Gover 2023-05-15 10:57:16 +00:00
parent ea3dedaada
commit c4591352c7
5 changed files with 669 additions and 589 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lib/okapi.cabal
View File

@ -41,6 +41,7 @@ library
Okapi.Parser.Responder Okapi.Parser.Responder
Okapi.Parser.Responder.AddHeader Okapi.Parser.Responder.AddHeader
Okapi.Parser.Security Okapi.Parser.Security
Okapi.Plug
other-modules: other-modules:
Paths_okapi Paths_okapi
hs-source-dirs: hs-source-dirs:

238
lib/src/Okapi/Parser/Body.hs
View File

@ -1,138 +1,138 @@
{-# LANGUAGE DeriveAnyClass #-} -- {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} -- {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-} -- {-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-} -- {-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE InstanceSigs #-} -- {-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-} -- {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} -- {-# LANGUAGE RankNTypes #-}
module Okapi.Parser.Body where module Okapi.Parser.Body where
import Control.Monad.Par qualified as Par -- import Control.Monad.Par qualified as Par
import Data.Aeson qualified as Aeson -- import Data.Aeson qualified as Aeson
import Data.Bifunctor (Bifunctor (..)) -- import Data.Bifunctor (Bifunctor (..))
import Data.ByteString qualified as BS -- import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as Builder -- import Data.ByteString.Builder qualified as Builder
import Data.ByteString.Lazy qualified as LBS -- import Data.ByteString.Lazy qualified as LBS
import Data.List qualified as List -- import Data.List qualified as List
import Data.List.NonEmpty (NonEmpty) -- import Data.List.NonEmpty (NonEmpty)
import Data.Set.NonEmpty (NESet) -- import Data.Set.NonEmpty (NESet)
import Data.Text qualified as Text -- import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text -- import Data.Text.Encoding qualified as Text
import GHC.Generics qualified as Generics -- import GHC.Generics qualified as Generics
import Network.HTTP.Types qualified as HTTP -- import Network.HTTP.Types qualified as HTTP
import Network.Wai.Parse (RequestBodyType (UrlEncoded)) -- import Network.Wai.Parse (RequestBodyType (UrlEncoded))
import Network.Wai.Parse qualified as WAI -- import Network.Wai.Parse qualified as WAI
import Okapi.Parser -- import Okapi.Parser
import Okapi.Parser.Body.Multipart qualified as Multipart -- import Okapi.Parser.Body.Multipart qualified as Multipart
import Web.Cookie qualified as Web -- import Web.Cookie qualified as Web
import Web.FormUrlEncoded qualified as Web -- import Web.FormUrlEncoded qualified as Web
import Web.HttpApiData qualified as Web -- import Web.HttpApiData qualified as Web
data Error -- data Error
= JSONParseFail -- = JSONParseFail
| URLEncodedParseFail Text.Text -- | URLEncodedParseFail Text.Text
| URLEncodedInvalid Text.Text -- | URLEncodedInvalid Text.Text
| NotMultipart -- | NotMultipart
| MultipartError Multipart.Error -- | MultipartError Multipart.Error
deriving (Eq, Show, Generics.Generic) -- deriving (Eq, Show, Generics.Generic)
data ContentType a where -- data ContentType a where
JSON :: Aeson.FromJSON a => ContentType a -- JSON :: Aeson.FromJSON a => ContentType a
URLEncoded :: Web.FromForm a => ContentType a -- URLEncoded :: Web.FromForm a => ContentType a
Multipart :: Multipart.Parser a -> ContentType a -- Multipart :: Multipart.Parser a -> ContentType a
instance Eq (ContentType a) where -- instance Eq (ContentType a) where
JSON == JSON = True -- JSON == JSON = True
URLEncoded == UrlEncoded = True -- URLEncoded == UrlEncoded = True
Multipart _ == Multipart _ = True -- Multipart _ == Multipart _ = True
_ == _ = False -- _ == _ = False
instance Functor ContentType -- instance Functor ContentType
data Parser a where -- data Parser a where
FMap :: (a -> b) -> Parser a -> Parser b -- FMap :: (a -> b) -> Parser a -> Parser b
Pure :: a -> Parser a -- Pure :: a -> Parser a
Apply :: Parser (a -> b) -> Parser a -> Parser b -- Apply :: Parser (a -> b) -> Parser a -> Parser b
None :: Parser () -- None :: Parser ()
Optional :: NESet (ContentType a) -> Parser (Maybe a) -- Optional :: NESet (ContentType a) -> Parser (Maybe a)
Required :: NESet (ContentType a) -> Parser a -- Required :: NESet (ContentType a) -> Parser a
instance Functor Parser where -- instance Functor Parser where
fmap :: (a -> b) -> Parser a -> Parser b -- fmap :: (a -> b) -> Parser a -> Parser b
fmap = FMap -- fmap = FMap
instance Applicative Parser where -- instance Applicative Parser where
pure = Pure -- pure = Pure
(<*>) = Apply -- (<*>) = Apply
data RequestBody -- data RequestBody
= RequestBodyRaw LBS.ByteString -- = RequestBodyRaw LBS.ByteString
| RequestBodyMultipart ([WAI.Param], [WAI.File LBS.ByteString]) -- | RequestBodyMultipart ([WAI.Param], [WAI.File LBS.ByteString])
eval :: -- eval ::
Parser a -> -- Parser a ->
RequestBody -> -- RequestBody ->
(Result Error a, RequestBody) -- (Result Error a, RequestBody)
eval op state = case op of -- eval op state = case op of
FMap f opX -> -- FMap f opX ->
case eval opX state of -- case eval opX state of
(Fail e, state') -> (Fail e, state') -- (Fail e, state') -> (Fail e, state')
(Ok x, state') -> (Ok $ f x, state') -- (Ok x, state') -> (Ok $ f x, state')
Pure x -> (Ok x, state) -- Pure x -> (Ok x, state)
Apply opF opX -> case eval opF state of -- Apply opF opX -> case eval opF state of
(Ok f, state') -> case eval opX state' of -- (Ok f, state') -> case eval opX state' of
(Ok x, state'') -> (Ok $ f x, state'') -- (Ok x, state'') -> (Ok $ f x, state'')
(Fail e, state'') -> (Fail e, state'') -- (Fail e, state'') -> (Fail e, state'')
(Fail e, state') -> (Fail e, state') -- (Fail e, state') -> (Fail e, state')
-- None -> (Ok (), state) -- -- None -> (Ok (), state)
JSON -> case state of -- JSON -> case state of
RequestBodyRaw bs -> case Aeson.decode bs of -- RequestBodyRaw bs -> case Aeson.decode bs of
Nothing -> (Fail JSONParseFail, state) -- Nothing -> (Fail JSONParseFail, state)
Just value -> (Ok value, RequestBodyRaw mempty) -- Just value -> (Ok value, RequestBodyRaw mempty)
RequestBodyMultipart _ -> (Fail JSONParseFail, state) -- RequestBodyMultipart _ -> (Fail JSONParseFail, state)
URLEncoded -> case state of -- URLEncoded -> case state of
RequestBodyRaw bs -> case Web.urlDecodeForm bs of -- RequestBodyRaw bs -> case Web.urlDecodeForm bs of
Left err -> (Fail $ URLEncodedInvalid err, state) -- Left err -> (Fail $ URLEncodedInvalid err, state)
Right form -> case Web.fromForm form of -- Right form -> case Web.fromForm form of
Left err -> (Fail $ URLEncodedParseFail err, state) -- Left err -> (Fail $ URLEncodedParseFail err, state)
Right value -> (Ok value, RequestBodyRaw mempty) -- Right value -> (Ok value, RequestBodyRaw mempty)
RequestBodyMultipart (params, files) -> -- RequestBodyMultipart (params, files) ->
let bsParams = map (bimap Text.decodeUtf8 Text.decodeUtf8) params -- let bsParams = map (bimap Text.decodeUtf8 Text.decodeUtf8) params
bs = Web.urlEncodeParams bsParams -- bs = Web.urlEncodeParams bsParams
in case Web.urlDecodeForm bs of -- in case Web.urlDecodeForm bs of
Left err -> (Fail $ URLEncodedInvalid err, state) -- Left err -> (Fail $ URLEncodedInvalid err, state)
Right form -> case Web.fromForm form of -- Right form -> case Web.fromForm form of
Left err -> (Fail $ URLEncodedParseFail err, state) -- Left err -> (Fail $ URLEncodedParseFail err, state)
Right value -> (Ok value, RequestBodyMultipart (mempty, files)) -- Right value -> (Ok value, RequestBodyMultipart (mempty, files))
Multipart parser -> case state of -- Multipart parser -> case state of
RequestBodyRaw _ -> (Fail NotMultipart, state) -- RequestBodyRaw _ -> (Fail NotMultipart, state)
RequestBodyMultipart parts -> case Multipart.eval parser parts of -- RequestBodyMultipart parts -> case Multipart.eval parser parts of
(Ok value, state') -> (Ok value, RequestBodyMultipart state') -- (Ok value, state') -> (Ok value, RequestBodyMultipart state')
(Fail err, state') -> (Fail $ MultipartError err, RequestBodyMultipart state') -- (Fail err, state') -> (Fail $ MultipartError err, RequestBodyMultipart state')
none :: Parser () -- none :: Parser ()
none = None -- none = None
json :: Aeson.FromJSON a => Parser a -- json :: Aeson.FromJSON a => Parser a
json = JSON -- json = JSON
urlEncoded :: Web.FromForm a => Parser a -- urlEncoded :: Web.FromForm a => Parser a
urlEncoded = URLEncoded -- urlEncoded = URLEncoded
multipart :: Multipart.Parser a -> Parser a -- multipart :: Multipart.Parser a -> Parser a
multipart = Multipart -- multipart = Multipart
class Interface a where -- class Interface a where
parser :: NonEmpty (Parser a) -- parser :: NonEmpty (Parser a)
-- TODO: Add optional for body -- -- TODO: Add optional for body
countOps :: Parser a -> Int -- countOps :: Parser a -> Int
countOps path = case path of -- countOps path = case path of
FMap _ opX -> countOps opX -- FMap _ opX -> countOps opX
Pure _ -> 0 -- Pure _ -> 0
Apply opF opX -> countOps opF + countOps opX -- Apply opF opX -> countOps opF + countOps opX
JSON -> 1 -- JSON -> 1
URLEncoded -> 1 -- URLEncoded -> 1
Multipart -> undefined -- Multipart -> undefined

79
lib/src/Okapi/Plug.hs Normal file
View 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

230
lib/src/Okapi/Route.hs
View File

@ -1,127 +1,127 @@
{-# LANGUAGE BlockArguments #-} -- {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-} -- {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-} -- {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-} -- {-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-} -- {-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE ImpredicativeTypes #-} -- {-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE KindSignatures #-} -- {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LinearTypes #-} -- {-# LANGUAGE LinearTypes #-}
{-# LANGUAGE NamedFieldPuns #-} -- {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-} -- {-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} -- {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} -- {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-} -- {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-} -- {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} -- {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-} -- {-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-} -- {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} -- {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} -- {-# LANGUAGE TypeOperators #-}
module Okapi.Route where module Okapi.Route where
import Control.Natural (type (~>)) -- import Control.Natural (type (~>))
import Control.Object (Object (..), (#)) -- import Control.Object (Object (..), (#))
import Data.Aeson qualified as Aeson -- import Data.Aeson qualified as Aeson
import Data.Bifunctor (Bifunctor (..)) -- import Data.Bifunctor (Bifunctor (..))
import Data.ByteString qualified as BS -- import Data.ByteString qualified as BS
import Data.CaseInsensitive qualified as CI -- import Data.CaseInsensitive qualified as CI
import Data.Function ((&)) -- import Data.Function ((&))
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap -- import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Kind (Type) -- import Data.Kind (Type)
import Data.List (groupBy) -- import Data.List (groupBy)
import Data.List qualified as List -- import Data.List qualified as List
import Data.List.Extra qualified as List -- import Data.List.Extra qualified as List
import Data.List.NonEmpty (NonEmpty ((:|))) -- import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NonEmpty -- import Data.List.NonEmpty qualified as NonEmpty
import Data.OpenApi (OpenApi (_openApiInfo)) -- import Data.OpenApi (OpenApi (_openApiInfo))
import Data.OpenApi qualified as OAPI -- import Data.OpenApi qualified as OAPI
import Data.OpenApi.Declare qualified as OAPI -- import Data.OpenApi.Declare qualified as OAPI
import Data.OpenApi.Internal (OpenApiSpecVersion (..), upperOpenApiSpecVersion) -- import Data.OpenApi.Internal (OpenApiSpecVersion (..), upperOpenApiSpecVersion)
import Data.Proxy -- import Data.Proxy
import Data.Semigroup (Semigroup (..)) -- import Data.Semigroup (Semigroup (..))
import Data.Text qualified as Text -- import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text -- import Data.Text.Encoding qualified as Text
import Data.Version qualified as Version -- import Data.Version qualified as Version
import Debug.Trace qualified as Debug -- import Debug.Trace qualified as Debug
import Network.HTTP.Types qualified as HTTP -- import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as WAI -- import Network.Wai qualified as WAI
import Network.Wai.Parse qualified as WAI -- import Network.Wai.Parse qualified as WAI
import Okapi.Parser -- import Okapi.Parser
import Okapi.Parser.Body qualified as Body -- import Okapi.Parser.Body qualified as Body
import Okapi.Parser.Headers qualified as Headers -- import Okapi.Parser.Headers qualified as Headers
import Okapi.Parser.Path qualified as Path -- import Okapi.Parser.Path qualified as Path
import Okapi.Parser.Query qualified as Query -- import Okapi.Parser.Query qualified as Query
import Okapi.Parser.Responder qualified as Responder -- import Okapi.Parser.Responder qualified as Responder
import Okapi.Parser.Responder.AddHeader (Response, toWaiResponse) -- import Okapi.Parser.Responder.AddHeader (Response, toWaiResponse)
import Okapi.Parser.Security qualified as Security -- import Okapi.Parser.Security qualified as Security
import Okapi.Parser.Security.Secure qualified as Secure -- -- import Okapi.Parser.Security.Secure qualified as Secure
import Okapi.Request (Request) -- import Okapi.Request (Request)
type Routes :: [Type] -> Type -- type Routes :: [Type] -> Type
data Routes resources where -- data Routes resources where
Nil :: Routes '[] -- Nil :: Routes '[]
(:&) :: Path.Interface resource => Route resource -> Routes resources -> Routes (resource ': resources) -- (:&) :: Path.Interface resource => Route resource -> Routes resources -> Routes (resource ': resources)
infixr 5 :& -- infixr 5 :&
type Append :: forall a. [a] -> [a] -> [a] -- kind signature -- type Append :: forall a. [a] -> [a] -> [a] -- kind signature
type family Append xs ys where -- header -- type family Append xs ys where -- header
Append '[] ys = ys -- clause 1 -- Append '[] ys = ys -- clause 1
Append (x ': xs) ys = x ': Append xs ys -- clause 2 -- Append (x ': xs) ys = x ': Append xs ys -- clause 2
appendRoutes :: Routes resources1 -> Routes resources2 -> Routes (Append resources1 resources2) -- appendRoutes :: Routes resources1 -> Routes resources2 -> Routes (Append resources1 resources2)
appendRoutes Nil pathItems = pathItems -- appendRoutes Nil pathItems = pathItems
appendRoutes (h :& t) pathItems = h :& appendRoutes t pathItems -- appendRoutes (h :& t) pathItems = h :& appendRoutes t pathItems
data Route resource where -- data Route resource where
Route :: -- Route ::
Path.Interface resource => -- Path.Interface resource =>
{ summary :: Maybe Text.Text, -- { summary :: Maybe Text.Text,
description :: Maybe Text.Text, -- description :: Maybe Text.Text,
get :: Maybe (GET m resource security query headers responder), -- get :: Maybe (GET m resource security query headers responder),
post :: Maybe (POST m resource security query body headers responder), -- post :: Maybe (POST m resource security query body headers responder),
put :: Maybe (PUT 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) -- delete :: Maybe (DELETE m resource security query headers responder)
} -> -- } ->
Route resource -- Route resource
data GET m resource security query headers responder where -- data GET m resource security query headers responder where
GET :: -- GET ::
(Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Headers.Interface headers, Responder.Interface responder) => -- (Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Headers.Interface headers, Responder.Interface responder) =>
{ summary :: Maybe Text.Text, -- { summary :: Maybe Text.Text,
description :: Maybe Text.Text, -- description :: Maybe Text.Text,
object :: Object m, -- object :: Object m,
handler :: resource -> security -> query -> headers -> responder -> m Response -- handler :: resource -> security -> query -> headers -> responder -> m Response
} -> -- } ->
GET m resource security query headers responder -- GET m resource security query headers responder
data POST m resource security query body headers responder where -- data POST m resource security query body headers responder where
POST :: -- POST ::
(Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Body.Interface body, Headers.Interface headers, Responder.Interface responder) => -- (Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Body.Interface body, Headers.Interface headers, Responder.Interface responder) =>
{ summary :: Maybe Text.Text, -- { summary :: Maybe Text.Text,
description :: Maybe Text.Text, -- description :: Maybe Text.Text,
object :: Object m, -- object :: Object m,
handler :: resource -> security -> query -> body -> headers -> responder -> m Response -- handler :: resource -> security -> query -> body -> headers -> responder -> m Response
} -> -- } ->
POST m resource security query body headers responder -- POST m resource security query body headers responder
data PUT m resource security query body headers responder where -- data PUT m resource security query body headers responder where
PUT :: -- PUT ::
(Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Body.Interface body, Headers.Interface headers, Responder.Interface responder) => -- (Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Body.Interface body, Headers.Interface headers, Responder.Interface responder) =>
{ summary :: Maybe Text.Text, -- { summary :: Maybe Text.Text,
description :: Maybe Text.Text, -- description :: Maybe Text.Text,
object :: Object m, -- object :: Object m,
handler :: resource -> security -> query -> body -> headers -> responder -> m Response -- handler :: resource -> security -> query -> body -> headers -> responder -> m Response
} -> -- } ->
PUT m resource security query body headers responder -- PUT m resource security query body headers responder
data DELETE m resource security query headers responder where -- data DELETE m resource security query headers responder where
DELETE :: -- DELETE ::
(Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Headers.Interface headers, Responder.Interface responder) => -- (Monad m, Path.Interface resource, Security.Interface security, Query.Interface query, Headers.Interface headers, Responder.Interface responder) =>
{ summary :: Maybe Text.Text, -- { summary :: Maybe Text.Text,
description :: Maybe Text.Text, -- description :: Maybe Text.Text,
object :: Object m, -- object :: Object m,
handler :: resource -> security -> query -> headers -> responder -> m Response -- handler :: resource -> security -> query -> headers -> responder -> m Response
} -> -- } ->
DELETE m resource security query headers responder -- DELETE m resource security query headers responder

710
lib/src/Okapi/Server.hs
View File

@ -1,381 +1,381 @@
{-# LANGUAGE BlockArguments #-} -- {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-} -- {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-} -- {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-} -- {-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-} -- {-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE ImpredicativeTypes #-} -- {-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE KindSignatures #-} -- {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LinearTypes #-} -- {-# LANGUAGE LinearTypes #-}
{-# LANGUAGE NamedFieldPuns #-} -- {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-} -- {-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} -- {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} -- {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-} -- {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-} -- {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} -- {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-} -- {-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-} -- {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} -- {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} -- {-# LANGUAGE TypeOperators #-}
module Okapi.Server where module Okapi.Server where
import Control.Natural (type (~>)) -- import Control.Natural (type (~>))
import Control.Object (Object (..), (#)) -- import Control.Object (Object (..), (#))
import Data.Aeson qualified as Aeson -- import Data.Aeson qualified as Aeson
import Data.Bifunctor (Bifunctor (..)) -- import Data.Bifunctor (Bifunctor (..))
import Data.ByteString qualified as BS -- import Data.ByteString qualified as BS
import Data.CaseInsensitive qualified as CI -- import Data.CaseInsensitive qualified as CI
import Data.Function ((&)) -- import Data.Function ((&))
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap -- import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Kind (Type) -- import Data.Kind (Type)
import Data.List (groupBy) -- import Data.List (groupBy)
import Data.List qualified as List -- import Data.List qualified as List
import Data.List.Extra qualified as List -- import Data.List.Extra qualified as List
import Data.List.NonEmpty (NonEmpty ((:|))) -- import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NonEmpty -- import Data.List.NonEmpty qualified as NonEmpty
import Data.OpenApi (OpenApi (_openApiInfo)) -- import Data.OpenApi (OpenApi (_openApiInfo))
import Data.OpenApi qualified as OAPI -- import Data.OpenApi qualified as OAPI
import Data.OpenApi.Declare qualified as OAPI -- import Data.OpenApi.Declare qualified as OAPI
import Data.OpenApi.Internal (OpenApiSpecVersion (..), upperOpenApiSpecVersion) -- import Data.OpenApi.Internal (OpenApiSpecVersion (..), upperOpenApiSpecVersion)
import Data.Proxy -- import Data.Proxy
import Data.Semigroup (Semigroup (..)) -- import Data.Semigroup (Semigroup (..))
import Data.Text qualified as Text -- import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text -- import Data.Text.Encoding qualified as Text
import Data.Version qualified as Version -- import Data.Version qualified as Version
import Debug.Trace qualified as Debug -- import Debug.Trace qualified as Debug
import Network.HTTP.Types qualified as HTTP -- import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as WAI -- import Network.Wai qualified as WAI
import Network.Wai.Parse qualified as WAI -- import Network.Wai.Parse qualified as WAI
import Okapi.Parser -- import Okapi.Parser
import Okapi.Parser.Body qualified as Body -- import Okapi.Parser.Body qualified as Body
import Okapi.Parser.Headers qualified as Headers -- import Okapi.Parser.Headers qualified as Headers
import Okapi.Parser.Path qualified as Path -- import Okapi.Parser.Path qualified as Path
import Okapi.Parser.Query qualified as Query -- import Okapi.Parser.Query qualified as Query
import Okapi.Parser.Responder qualified as Responder -- import Okapi.Parser.Responder qualified as Responder
import Okapi.Parser.Responder.AddHeader (Response, toWaiResponse) -- import Okapi.Parser.Responder.AddHeader (Response, toWaiResponse)
import Okapi.Parser.Security qualified as Security -- import Okapi.Parser.Security qualified as Security
import Okapi.Parser.Security.Secure qualified as Secure -- import Okapi.Parser.Security.Secure qualified as Secure
import Okapi.Request (Request) -- import Okapi.Request (Request)
import Okapi.Route (DELETE (..), GET (..), POST (..), PUT (..), Route (..), Routes (..)) -- import Okapi.Route (DELETE (..), GET (..), POST (..), PUT (..), Route (..), Routes (..))
data Server resources = Server -- data Server resources = Server
{ info :: OAPI.Info, -- { info :: OAPI.Info,
url :: [Text.Text], -- url :: [Text.Text],
description :: Maybe Text.Text, -- description :: Maybe Text.Text,
routes :: Routes resources -- routes :: Routes resources
} -- }
toApplication :: Server resources -> WAI.Application -- toApplication :: Server resources -> WAI.Application
toApplication Server {url, routes} request respond = do -- toApplication Server {url, routes} request respond = do
let reqPath = List.dropPrefix url $ WAI.pathInfo request -- let reqPath = List.dropPrefix url $ WAI.pathInfo request
reqQuery = WAI.queryString request -- reqQuery = WAI.queryString request
reqHeaders = WAI.requestHeaders request -- reqHeaders = WAI.requestHeaders request
reqSecurity = Secure.State reqQuery reqHeaders [] -- TODO: Get cookies out of headers here instead of empty list -- reqSecurity = Secure.State reqQuery reqHeaders [] -- TODO: Get cookies out of headers here instead of empty list
if reqPath == WAI.pathInfo request && not (null url) -- 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? -- 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 -- else case getPathItemByPath reqPath routes of
None -> respond $ WAI.responseLBS HTTP.status404 mempty mempty -- None -> respond $ WAI.responseLBS HTTP.status404 mempty mempty
Some (Route {get, post, put, delete}, resourceParam) -> case HTTP.parseMethod $ WAI.requestMethod request of -- 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 -- Left _ -> respond $ WAI.responseLBS HTTP.status501 mempty mempty -- TODO: Return 501 Not Implemented error
Right reqMethod -> -- Right reqMethod ->
case reqMethod of -- case reqMethod of
HTTP.GET -> case get of -- HTTP.GET -> case get of
Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty -- Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
Just (GET {handler, object}) -> -- Just (GET {handler, object}) ->
case evalSecurity (sortSecurity Security.parser) reqSecurity of -- 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 securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do -- ((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
response <- object # handler resourceParam securityParam queryParam headersParam responderParam -- response <- object # handler resourceParam securityParam queryParam headersParam responderParam
respond $ toWaiResponse response -- 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.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.status401 mempty mempty -- TODO: Return 401 Unauthorized
HTTP.POST -> case post of -- HTTP.POST -> case post of
Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty -- Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
Just (POST {handler, object}) -> -- Just (POST {handler, object}) ->
case evalSecurity (sortSecurity Security.parser) reqSecurity of -- 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 securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do -- ((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
bodyResult <- evalBody (sortBody Body.parser) request -- bodyResult <- evalBody (sortBody Body.parser) request
case bodyResult of -- case bodyResult of
(Ok bodyParam, _) -> do -- (Ok bodyParam, _) -> do
response <- object # handler resourceParam securityParam queryParam bodyParam headersParam responderParam -- response <- object # handler resourceParam securityParam queryParam bodyParam headersParam responderParam
respond $ toWaiResponse response -- 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.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.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.status401 mempty mempty -- TODO: Return 401 Unauthorized
HTTP.PUT -> case put of -- HTTP.PUT -> case put of
Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty -- Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
Just (PUT {handler, object}) -> -- Just (PUT {handler, object}) ->
case evalSecurity (sortSecurity Security.parser) reqSecurity of -- 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 securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do -- ((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
bodyResult <- evalBody (sortBody Body.parser) request -- bodyResult <- evalBody (sortBody Body.parser) request
case bodyResult of -- case bodyResult of
(Ok bodyParam, _) -> do -- (Ok bodyParam, _) -> do
response <- object # handler resourceParam securityParam queryParam bodyParam headersParam responderParam -- response <- object # handler resourceParam securityParam queryParam bodyParam headersParam responderParam
respond $ toWaiResponse response -- 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.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.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.status401 mempty mempty -- TODO: Return 401 Unauthorized
HTTP.DELETE -> case delete of -- HTTP.DELETE -> case delete of
Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty -- Nothing -> respond $ WAI.responseLBS HTTP.status405 mempty mempty
Just (DELETE {handler, object}) -> -- Just (DELETE {handler, object}) ->
case evalSecurity (sortSecurity Security.parser) reqSecurity of -- 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 securityParam, _) -> case (Query.eval Query.parser reqQuery, Headers.eval Headers.parser reqHeaders, Responder.eval Responder.parser ()) of
((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do -- ((Ok queryParam, _), (Ok headersParam, _), (Ok responderParam, _)) -> do
response <- object # handler resourceParam securityParam queryParam headersParam responderParam -- response <- object # handler resourceParam securityParam queryParam headersParam responderParam
respond $ toWaiResponse response -- 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.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.status401 mempty mempty -- TODO: Return 401 Unauthorized
_ -> respond $ WAI.responseLBS HTTP.status501 mempty mempty -- TODO: Implement cases for remaing Standard HTTP methods -- _ -> respond $ WAI.responseLBS HTTP.status501 mempty mempty -- TODO: Implement cases for remaing Standard HTTP methods
data Option where -- data Option where
None :: Option -- None :: Option
Some :: forall resource. (Route resource, resource) -> Option -- Some :: forall resource. (Route resource, resource) -> Option
getPathItemByPath :: [Text.Text] -> Routes resources -> Option -- getPathItemByPath :: [Text.Text] -> Routes resources -> Option
getPathItemByPath reqPath Nil = None -- getPathItemByPath reqPath Nil = None
getPathItemByPath reqPath (route@(Route @resource _ _ _ _ _ _) :& t) = case Path.eval (Path.parser @resource) reqPath of -- getPathItemByPath reqPath (route@(Route @resource _ _ _ _ _ _) :& t) = case Path.eval (Path.parser @resource) reqPath of
(Ok resourceParam, _) -> Some (route, resourceParam) -- (Ok resourceParam, _) -> Some (route, resourceParam)
_ -> getPathItemByPath reqPath t -- _ -> getPathItemByPath reqPath t
evalBody :: NonEmpty (Body.Parser a) -> WAI.Request -> IO (Result [Body.Error] a, Body.RequestBody) -- evalBody :: NonEmpty (Body.Parser a) -> WAI.Request -> IO (Result [Body.Error] a, Body.RequestBody)
evalBody (h :| t) request = do -- evalBody (h :| t) request = do
state <- case WAI.getRequestBodyType request of -- state <- case WAI.getRequestBodyType request of
Just (WAI.Multipart _boundary) -> Body.RequestBodyMultipart <$> WAI.parseRequestBodyEx WAI.defaultParseRequestBodyOptions WAI.lbsBackEnd request -- Just (WAI.Multipart _boundary) -> Body.RequestBodyMultipart <$> WAI.parseRequestBodyEx WAI.defaultParseRequestBodyOptions WAI.lbsBackEnd request
_ -> Body.RequestBodyRaw <$> WAI.lazyRequestBody request -- _ -> Body.RequestBodyRaw <$> WAI.lazyRequestBody request
case first (first pure) $ Body.eval h state of -- case first (first pure) $ Body.eval h state of
(ok@(Ok _), s) -> return (ok, s) -- (ok@(Ok _), s) -> return (ok, s)
_ -> return $ loop state t -- _ -> return $ loop state t
where -- where
loop :: Body.RequestBody -> [Body.Parser a] -> (Result [Body.Error] a, Body.RequestBody) -- loop :: Body.RequestBody -> [Body.Parser a] -> (Result [Body.Error] a, Body.RequestBody)
loop state [] = (Fail [], state) -- loop state [] = (Fail [], state)
loop state (h : t) = case first (first pure) $ Body.eval h state of -- loop state (h : t) = case first (first pure) $ Body.eval h state of
(ok@(Ok _), state') -> (ok, state') -- (ok@(Ok _), state') -> (ok, state')
_ -> loop state t -- _ -> loop state t
sortBody :: NonEmpty (Body.Parser a) -> NonEmpty (Body.Parser a) -- sortBody :: NonEmpty (Body.Parser a) -> NonEmpty (Body.Parser a)
sortBody = NonEmpty.sortBy comparer -- sortBody = NonEmpty.sortBy comparer
where -- where
comparer :: Body.Parser a -> Body.Parser a -> Ordering -- comparer :: Body.Parser a -> Body.Parser a -> Ordering
comparer Body.None Body.None = EQ -- comparer Body.None Body.None = EQ
comparer (Body.FMap _ Body.None) (Body.FMap _ Body.None) = EQ -- comparer (Body.FMap _ Body.None) (Body.FMap _ Body.None) = EQ
comparer (Body.FMap _ Body.None) _ = GT -- comparer (Body.FMap _ Body.None) _ = GT
comparer _ (Body.FMap _ Body.None) = LT -- comparer _ (Body.FMap _ Body.None) = LT
comparer Body.None _body = GT -- comparer Body.None _body = GT
comparer _body Body.None = LT -- comparer _body Body.None = LT
evalSecurity :: NonEmpty (Security.Parser a) -> Secure.State -> (Result Security.Error a, Secure.State) -- evalSecurity :: NonEmpty (Security.Parser a) -> Secure.State -> (Result Security.Error a, Secure.State)
evalSecurity (h :| t) state = case Security.eval h state of -- evalSecurity (h :| t) state = case Security.eval h state of
(ok@(Ok _), s) -> (ok, s) -- (ok@(Ok _), s) -> (ok, s)
_ -> loop state t -- _ -> loop state t
where -- where
loop :: Secure.State -> [Security.Parser a] -> (Result Security.Error a, Secure.State) -- loop :: Secure.State -> [Security.Parser a] -> (Result Security.Error a, Secure.State)
loop state [] = (Fail $ Security.SecureError Secure.ParseFail, state) -- loop state [] = (Fail $ Security.SecureError Secure.ParseFail, state)
loop state (h : t) = case Security.eval h state of -- loop state (h : t) = case Security.eval h state of
(ok@(Ok _), state') -> (ok, state') -- (ok@(Ok _), state') -> (ok, state')
_ -> loop state t -- _ -> loop state t
sortSecurity :: NonEmpty (Security.Parser a) -> NonEmpty (Security.Parser a) -- sortSecurity :: NonEmpty (Security.Parser a) -> NonEmpty (Security.Parser a)
sortSecurity = NonEmpty.sortBy comparer -- sortSecurity = NonEmpty.sortBy comparer
where -- where
comparer :: Security.Parser a -> Security.Parser a -> Ordering -- comparer :: Security.Parser a -> Security.Parser a -> Ordering
comparer Security.None Security.None = EQ -- comparer Security.None Security.None = EQ
comparer (Security.FMap _ Security.None) (Security.FMap _ Security.None) = EQ -- comparer (Security.FMap _ Security.None) (Security.FMap _ Security.None) = EQ
comparer Security.None _ = GT -- comparer Security.None _ = GT
comparer (Security.FMap _ Security.None) _ = GT -- comparer (Security.FMap _ Security.None) _ = GT
comparer _ Security.None = LT -- comparer _ Security.None = LT
comparer _ (Security.FMap _ Security.None) = LT -- comparer _ (Security.FMap _ Security.None) = LT
toOpenAPI :: -- toOpenAPI ::
Server resource -> -- Server resource ->
OAPI.OpenApi -- OAPI.OpenApi
toOpenAPI Server {info, description, routes, url} = -- toOpenAPI Server {info, description, routes, url} =
mempty -- mempty
{ OAPI._openApiInfo = info, -- { OAPI._openApiInfo = info,
OAPI._openApiServers = -- OAPI._openApiServers =
[ OAPI.Server -- [ OAPI.Server
(Text.intercalate "/" url) -- (Text.intercalate "/" url)
description -- description
mempty -- mempty
], -- ],
OAPI._openApiPaths = pathItemsToOpenAPIPaths routes, -- OAPI._openApiPaths = pathItemsToOpenAPIPaths routes,
OAPI._openApiOpenapi = OpenApiSpecVersion {getVersion = Version.Version [3, 0, 3] []} -- OAPI._openApiOpenapi = OpenApiSpecVersion {getVersion = Version.Version [3, 0, 3] []}
} -- }
pathItemsToOpenAPIPaths :: Routes resources -> InsOrdHashMap.InsOrdHashMap FilePath OAPI.PathItem -- pathItemsToOpenAPIPaths :: Routes resources -> InsOrdHashMap.InsOrdHashMap FilePath OAPI.PathItem
pathItemsToOpenAPIPaths Nil = InsOrdHashMap.fromList [] -- pathItemsToOpenAPIPaths Nil = InsOrdHashMap.fromList []
pathItemsToOpenAPIPaths (h :& t) = let (filePath, pathItem) = toOpenAPIPathItem h in InsOrdHashMap.insert filePath pathItem $ pathItemsToOpenAPIPaths t -- pathItemsToOpenAPIPaths (h :& t) = let (filePath, pathItem) = toOpenAPIPathItem h in InsOrdHashMap.insert filePath pathItem $ pathItemsToOpenAPIPaths t
toOpenAPIPathItem :: Route resource -> (FilePath, OAPI.PathItem) -- toOpenAPIPathItem :: Route resource -> (FilePath, OAPI.PathItem)
toOpenAPIPathItem (Route @resource summary description get post put delete) = (pathName, pathItem) -- toOpenAPIPathItem (Route @resource summary description get post put delete) = (pathName, pathItem)
where -- where
pathName :: FilePath -- pathName :: FilePath
pathName = renderPath $ Path.parser @resource -- pathName = renderPath $ Path.parser @resource
pathItem :: OAPI.PathItem -- pathItem :: OAPI.PathItem
pathItem = -- pathItem =
mempty -- mempty
{ OAPI._pathItemSummary = summary, -- { OAPI._pathItemSummary = summary,
OAPI._pathItemDescription = description, -- OAPI._pathItemDescription = description,
OAPI._pathItemGet = fmap toGetOperation get, -- OAPI._pathItemGet = fmap toGetOperation get,
OAPI._pathItemPost = fmap toPostOperation post, -- OAPI._pathItemPost = fmap toPostOperation post,
OAPI._pathItemPut = fmap toPutOperation put, -- OAPI._pathItemPut = fmap toPutOperation put,
OAPI._pathItemDelete = fmap toDeleteOperation delete -- OAPI._pathItemDelete = fmap toDeleteOperation delete
} -- }
toGetOperation :: GET m resource security query headers responder -> OAPI.Operation -- toGetOperation :: GET m resource security query headers responder -> OAPI.Operation
toGetOperation (GET @_ @resource @security @query @headers @responder summary description _ _) = -- toGetOperation (GET @_ @resource @security @query @headers @responder summary description _ _) =
mempty -- mempty
{ OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers), -- { OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
OAPI._operationResponses = toResponses $ Responder.parser @responder, -- OAPI._operationResponses = toResponses $ Responder.parser @responder,
OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security, -- OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
OAPI._operationSummary = summary, -- OAPI._operationSummary = summary,
OAPI._operationDescription = description -- OAPI._operationDescription = description
} -- }
toPostOperation :: POST m resource security query body headers responder -> OAPI.Operation -- toPostOperation :: POST m resource security query body headers responder -> OAPI.Operation
toPostOperation (POST @_ @resource @security @query @body @headers @responder summary description _ _) = -- toPostOperation (POST @_ @resource @security @query @body @headers @responder summary description _ _) =
mempty -- mempty
{ OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers), -- { OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
OAPI._operationRequestBody = toOpenAPIRequestBody $ Body.parser @body, -- OAPI._operationRequestBody = toOpenAPIRequestBody $ Body.parser @body,
OAPI._operationResponses = toResponses $ Responder.parser @responder, -- OAPI._operationResponses = toResponses $ Responder.parser @responder,
OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security, -- OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
OAPI._operationSummary = summary, -- OAPI._operationSummary = summary,
OAPI._operationDescription = description -- OAPI._operationDescription = description
} -- }
toPutOperation :: PUT m resource security query body headers responder -> OAPI.Operation -- toPutOperation :: PUT m resource security query body headers responder -> OAPI.Operation
toPutOperation (PUT @_ @resource @security @query @body @headers @responder summary description _ _) = -- toPutOperation (PUT @_ @resource @security @query @body @headers @responder summary description _ _) =
mempty -- mempty
{ OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers), -- { OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
OAPI._operationRequestBody = toOpenAPIRequestBody $ Body.parser @body, -- OAPI._operationRequestBody = toOpenAPIRequestBody $ Body.parser @body,
OAPI._operationResponses = toResponses $ Responder.parser @responder, -- OAPI._operationResponses = toResponses $ Responder.parser @responder,
OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security, -- OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
OAPI._operationSummary = summary, -- OAPI._operationSummary = summary,
OAPI._operationDescription = description -- OAPI._operationDescription = description
} -- }
toDeleteOperation :: DELETE m resource security query headers responder -> OAPI.Operation -- toDeleteOperation :: DELETE m resource security query headers responder -> OAPI.Operation
toDeleteOperation (DELETE @_ @resource @security @query @headers @responder summary description _ _) = -- toDeleteOperation (DELETE @_ @resource @security @query @headers @responder summary description _ _) =
mempty -- mempty
{ OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers), -- { OAPI._operationParameters = toParameters (Path.parser @resource, Query.parser @query, Headers.parser @headers),
OAPI._operationResponses = toResponses $ Responder.parser @responder, -- OAPI._operationResponses = toResponses $ Responder.parser @responder,
OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security, -- OAPI._operationSecurity = toSecurityRequirements $ Security.parser @security,
OAPI._operationSummary = summary, -- OAPI._operationSummary = summary,
OAPI._operationDescription = description -- OAPI._operationDescription = description
} -- }
toParameters :: (Path.Parser resource, Query.Parser q, Headers.Parser h) -> [OAPI.Referenced OAPI.Param] -- toParameters :: (Path.Parser resource, Query.Parser q, Headers.Parser h) -> [OAPI.Referenced OAPI.Param]
toParameters (path, query, headers) = pathParameters path <> queryParameters query <> headersParameters headers -- toParameters (path, query, headers) = pathParameters path <> queryParameters query <> headersParameters headers
where -- where
pathParameters :: Path.Parser resource -> [OAPI.Referenced OAPI.Param] -- pathParameters :: Path.Parser resource -> [OAPI.Referenced OAPI.Param]
pathParameters path = case path of -- pathParameters path = case path of
Path.FMap f p -> pathParameters p -- Path.FMap f p -> pathParameters p
Path.Pure _ -> mempty -- Path.Pure _ -> mempty
Path.Apply pf px -> pathParameters pf <> pathParameters px -- Path.Apply pf px -> pathParameters pf <> pathParameters px
Path.Static _ -> mempty -- Path.Static _ -> mempty
Path.Param @p name -> -- Path.Param @p name ->
[ OAPI.Inline $ -- [ OAPI.Inline $
mempty -- mempty
{ OAPI._paramName = name, -- { OAPI._paramName = name,
OAPI._paramRequired = Just True, -- OAPI._paramRequired = Just True,
OAPI._paramIn = OAPI.ParamPath, -- OAPI._paramIn = OAPI.ParamPath,
OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy -- OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
} -- }
] -- ]
queryParameters :: Query.Parser q -> [OAPI.Referenced OAPI.Param] -- queryParameters :: Query.Parser q -> [OAPI.Referenced OAPI.Param]
queryParameters query = case query of -- queryParameters query = case query of
Query.FMap f q -> queryParameters q -- Query.FMap f q -> queryParameters q
Query.Pure _ -> mempty -- Query.Pure _ -> mempty
Query.Apply pf px -> queryParameters pf <> queryParameters px -- Query.Apply pf px -> queryParameters pf <> queryParameters px
Query.Param @p name -> -- Query.Param @p name ->
[ OAPI.Inline $ -- [ OAPI.Inline $
mempty -- mempty
{ OAPI._paramName = Text.decodeUtf8 name, -- { OAPI._paramName = Text.decodeUtf8 name,
OAPI._paramRequired = Just True, -- OAPI._paramRequired = Just True,
OAPI._paramIn = OAPI.ParamQuery, -- OAPI._paramIn = OAPI.ParamQuery,
OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy -- OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
} -- }
] -- ]
Query.Flag name -> -- Query.Flag name ->
[ OAPI.Inline $ -- [ OAPI.Inline $
mempty -- mempty
{ OAPI._paramName = Text.decodeUtf8 name, -- { OAPI._paramName = Text.decodeUtf8 name,
OAPI._paramRequired = Just True, -- OAPI._paramRequired = Just True,
OAPI._paramIn = OAPI.ParamQuery, -- OAPI._paramIn = OAPI.ParamQuery,
OAPI._paramAllowEmptyValue = Just True -- OAPI._paramAllowEmptyValue = Just True
} -- }
] -- ]
Query.Optional @p query' -> case query' of -- Query.Optional @p query' -> case query' of
Query.Param _ -> do -- Query.Param _ -> do
param <- queryParameters query' -- param <- queryParameters query'
pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param -- pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
Query.Flag _ -> do -- Query.Flag _ -> do
param <- queryParameters query' -- param <- queryParameters query'
pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param -- pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
_ -> queryParameters query' -- _ -> queryParameters query'
Query.Option @p def query' -> case query' of -- Query.Option @p def query' -> case query' of
Query.Param _ -> do -- Query.Param _ -> do
param <- queryParameters query' -- 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 -- 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'
headersParameters :: Headers.Parser h -> [OAPI.Referenced OAPI.Param] -- headersParameters :: Headers.Parser h -> [OAPI.Referenced OAPI.Param]
headersParameters headers = case headers of -- headersParameters headers = case headers of
Headers.FMap f h -> headersParameters h -- Headers.FMap f h -> headersParameters h
Headers.Pure _ -> mempty -- Headers.Pure _ -> mempty
Headers.Apply pf px -> headersParameters pf <> headersParameters px -- Headers.Apply pf px -> headersParameters pf <> headersParameters px
Headers.Param @p name -> -- Headers.Param @p name ->
[ OAPI.Inline $ -- [ OAPI.Inline $
mempty -- mempty
{ OAPI._paramName = Text.decodeUtf8 $ CI.original name, -- { OAPI._paramName = Text.decodeUtf8 $ CI.original name,
OAPI._paramRequired = Just True, -- OAPI._paramRequired = Just True,
OAPI._paramIn = OAPI.ParamHeader, -- OAPI._paramIn = OAPI.ParamHeader,
OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy -- OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
} -- }
] -- ]
Headers.Cookie @p name -> -- Headers.Cookie @p name ->
[ OAPI.Inline $ -- [ OAPI.Inline $
mempty -- mempty
{ OAPI._paramName = Text.decodeUtf8 name, -- { OAPI._paramName = Text.decodeUtf8 name,
OAPI._paramRequired = Just True, -- OAPI._paramRequired = Just True,
OAPI._paramIn = OAPI.ParamCookie, -- OAPI._paramIn = OAPI.ParamCookie,
OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy -- OAPI._paramSchema = Just $ OAPI.Inline $ OAPI._namedSchemaSchema $ OAPI.undeclare $ OAPI.declareNamedSchema @p Proxy
} -- }
] -- ]
Headers.Optional @p headers' -> case headers' of -- Headers.Optional @p headers' -> case headers' of
Headers.Param _ -> do -- Headers.Param _ -> do
param <- headersParameters headers' -- param <- headersParameters headers'
pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param -- pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
Headers.Cookie _ -> do -- Headers.Cookie _ -> do
param <- headersParameters headers' -- param <- headersParameters headers'
pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param -- pure $ fmap (\param -> param {OAPI._paramRequired = Just False}) param
_ -> headersParameters headers' -- _ -> headersParameters headers'
Headers.Option @p def headers' -> case headers' of -- Headers.Option @p def headers' -> case headers' of
Headers.Param _ -> do -- Headers.Param _ -> do
param <- headersParameters headers' -- 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 -- 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 -- Headers.Cookie _ -> do
param <- headersParameters headers' -- 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 -- 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'
toSecurityRequirements :: NonEmpty (Security.Parser s) -> [OAPI.SecurityRequirement] -- toSecurityRequirements :: NonEmpty (Security.Parser s) -> [OAPI.SecurityRequirement]
toSecurityRequirements security = [] -- toSecurityRequirements security = []
toOpenAPIRequestBody :: NonEmpty (Body.Parser b) -> Maybe (OAPI.Referenced OAPI.RequestBody) -- toOpenAPIRequestBody :: NonEmpty (Body.Parser b) -> Maybe (OAPI.Referenced OAPI.RequestBody)
toOpenAPIRequestBody body = Nothing -- toOpenAPIRequestBody body = Nothing
toResponses :: Responder.Parser r -> OAPI.Responses -- toResponses :: Responder.Parser r -> OAPI.Responses
toResponses responder = mempty -- toResponses responder = mempty
renderPath :: Path.Parser a -> FilePath -- renderPath :: Path.Parser a -> FilePath
renderPath path = case path of -- renderPath path = case path of
Path.FMap f p -> renderPath p -- Path.FMap f p -> renderPath p
Path.Pure _ -> mempty -- Path.Pure _ -> mempty
Path.Apply pf px -> renderPath pf <> renderPath px -- Path.Apply pf px -> renderPath pf <> renderPath px
Path.Static t -> "/" <> Text.unpack t -- Path.Static t -> "/" <> Text.unpack t
Path.Param @p name -> "/{" <> Text.unpack name <> "}" -- Path.Param @p name -> "/{" <> Text.unpack name <> "}"