mirror of
https://github.com/scarf-sh/tie.git
synced 2024-11-22 10:31:56 +03:00
Fix bug with 1-elemen oneOfs
This commit is contained in:
Alex Biehl
Alexander Biehl
parent
b765a2461d
commit
1aadc110ad
@ -508,8 +508,6 @@ objectTypeDependencies getDependencies objectType =
|
||||
-- | Casting a 'Type' to the set of types it could be.
|
||||
isOneOfType :: Type -> Maybe (Maybe (Discriminator (Named Type)), [Named Type])
|
||||
isOneOfType ty = case ty of
|
||||
OneOf _ [_] ->
|
||||
Nothing
|
||||
OneOf discriminator oneOfs ->
|
||||
Just (discriminator, oneOfs)
|
||||
_ ->
|
||||
|
||||
47
test/golden/bug-2.yaml
Normal file
47
test/golden/bug-2.yaml
Normal file
@ -0,0 +1,47 @@
|
||||
openapi: "3.0.0"
|
||||
info:
|
||||
version: 1.0.0
|
||||
title: Scarf
|
||||
license:
|
||||
name: AllRightsReserved
|
||||
servers:
|
||||
- url: https://scarf.sh/api/v1
|
||||
paths:
|
||||
/test:
|
||||
get:
|
||||
summary: test
|
||||
operationId: test
|
||||
responses:
|
||||
'200':
|
||||
description: Successful response
|
||||
content:
|
||||
application/json:
|
||||
schema:
|
||||
$ref: "#/components/schemas/Testee"
|
||||
components:
|
||||
schemas:
|
||||
Testee:
|
||||
discriminator:
|
||||
propertyName: type
|
||||
mapping:
|
||||
scarf: "#/components/schemas/Test"
|
||||
oneOf:
|
||||
- $ref: "#/components/schemas/Test"
|
||||
|
||||
Enum:
|
||||
type: string
|
||||
enum:
|
||||
- a
|
||||
- b
|
||||
|
||||
Base:
|
||||
properties:
|
||||
enum:
|
||||
$ref: "#/components/schemas/Enum"
|
||||
|
||||
Test:
|
||||
allOf:
|
||||
- $ref: "#/components/schemas/Base"
|
||||
- properties:
|
||||
name:
|
||||
type: string
|
||||
776
test/golden/bug-2.yaml.out
Normal file
776
test/golden/bug-2.yaml.out
Normal file
@ -0,0 +1,776 @@
|
||||
Test/Api.hs
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Test.Api where
|
||||
|
||||
import qualified Control.Applicative
|
||||
import qualified Control.Exception
|
||||
import qualified Control.Monad
|
||||
import qualified Control.Monad.IO.Class
|
||||
import qualified Data.Aeson
|
||||
import qualified Data.Aeson.Encoding
|
||||
import qualified Data.Aeson.Parser
|
||||
import qualified Data.Aeson.Types
|
||||
import qualified Data.Attoparsec.ByteString
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.List
|
||||
import qualified Data.List.NonEmpty
|
||||
import qualified Data.Map
|
||||
import qualified Data.Maybe
|
||||
import qualified Data.Text
|
||||
import qualified Data.Time
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified GHC.Float
|
||||
import qualified GHC.Int
|
||||
import qualified GHC.Records
|
||||
import qualified GHC.Types
|
||||
import qualified Network.HTTP.Types
|
||||
import qualified Network.Wai
|
||||
import qualified Web.HttpApiData
|
||||
|
||||
import Test.Request
|
||||
import Test.Response
|
||||
|
||||
|
||||
|
||||
import Test.Schemas.Testee
|
||||
|
||||
import Test.Response.Test
|
||||
|
||||
data Api m = Api {
|
||||
-- | test
|
||||
test ::
|
||||
m TestResponse
|
||||
}
|
||||
|
||||
application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application
|
||||
application run api notFound request respond =
|
||||
case Network.Wai.pathInfo request of
|
||||
["test"] ->
|
||||
case Network.Wai.requestMethod request of
|
||||
"GET" ->
|
||||
run request (do
|
||||
response <- test api
|
||||
Control.Monad.IO.Class.liftIO (respond $! (toResponse response))
|
||||
)
|
||||
x ->
|
||||
unsupportedMethod x
|
||||
|
||||
_ ->
|
||||
notFound request respond
|
||||
where
|
||||
unsupportedMethod _ =
|
||||
respond (Network.Wai.responseBuilder Network.HTTP.Types.status405 [] mempty)
|
||||
{-# INLINABLE application #-}
|
||||
---------------------
|
||||
Test/Request.hs
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Test.Request
|
||||
( -- * Parameters
|
||||
Style (..),
|
||||
pathVariable,
|
||||
requiredQueryParameter,
|
||||
requiredQueryParameters,
|
||||
optionalQueryParameter,
|
||||
optionalQueryParameters,
|
||||
requiredHeader,
|
||||
optionalHeader,
|
||||
|
||||
-- * Request body
|
||||
parseRequestBody,
|
||||
jsonBodyParser,
|
||||
formBodyParser,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Aeson (FromJSON, parseJSON)
|
||||
import qualified Data.Aeson.Parser
|
||||
import qualified Data.Aeson.Types
|
||||
import Data.Attoparsec.ByteString (eitherResult, parseWith)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Coerce (coerce)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.List as List
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import qualified Network.HTTP.Media
|
||||
import Network.HTTP.Types (HeaderName, hContentType)
|
||||
import qualified Network.Wai as Wai
|
||||
import System.IO.Unsafe (unsafeInterleaveIO)
|
||||
import Web.FormUrlEncoded
|
||||
( FromForm,
|
||||
parseAll,
|
||||
urlDecodeAsForm,
|
||||
urlDecodeForm,
|
||||
)
|
||||
import Web.HttpApiData
|
||||
( FromHttpApiData,
|
||||
parseHeader,
|
||||
parseQueryParam,
|
||||
parseUrlPiece,
|
||||
parseUrlPieces,
|
||||
)
|
||||
|
||||
pathVariable ::
|
||||
(FromHttpApiData a) =>
|
||||
-- | Path variable value
|
||||
Text ->
|
||||
(a -> Wai.Application) ->
|
||||
Wai.Application
|
||||
pathVariable value withVariable = \request respond ->
|
||||
case parseUrlPiece value of
|
||||
Left _err ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right x ->
|
||||
withVariable x request respond
|
||||
{-# INLINEABLE pathVariable #-}
|
||||
|
||||
data Style
|
||||
= FormStyle
|
||||
| CommaDelimitedStyle
|
||||
| SpaceDelimitedStyle
|
||||
| PipeDelimitedStyle
|
||||
|
||||
newtype CommaDelimitedValue a = CommaDelimitedValue {unCommaDelimitedValue :: [a]}
|
||||
|
||||
instance (FromHttpApiData a) => FromHttpApiData (CommaDelimitedValue a) where
|
||||
parseUrlPiece input = do
|
||||
xs <- parseUrlPieces (Text.splitOn "," input)
|
||||
pure (CommaDelimitedValue xs)
|
||||
|
||||
newtype SpaceDelimitedValue a = SpaceDelimitedValue {unSpaceDelimitedValue :: [a]}
|
||||
|
||||
instance (FromHttpApiData a) => FromHttpApiData (SpaceDelimitedValue a) where
|
||||
parseUrlPiece input = do
|
||||
xs <- parseUrlPieces (Text.splitOn " " input)
|
||||
pure (SpaceDelimitedValue xs)
|
||||
|
||||
newtype PipeDelimitedValue a = PipeDelimitedValue {unPipeDelimitedValue :: [a]}
|
||||
|
||||
instance (FromHttpApiData a) => FromHttpApiData (PipeDelimitedValue a) where
|
||||
parseUrlPiece input = do
|
||||
xs <- parseUrlPieces (Text.splitOn "|" input)
|
||||
pure (PipeDelimitedValue xs)
|
||||
|
||||
requiredQueryParameters ::
|
||||
(FromHttpApiData a) =>
|
||||
Style ->
|
||||
ByteString ->
|
||||
(NonEmpty.NonEmpty a -> Wai.Application) ->
|
||||
Wai.Application
|
||||
requiredQueryParameters style name withParam =
|
||||
case style of
|
||||
FormStyle -> \request respond ->
|
||||
case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of
|
||||
Left error ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right form ->
|
||||
case parseAll (Text.decodeUtf8 name) form of
|
||||
Left _ ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right [] ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right (x : xs) ->
|
||||
withParam (x NonEmpty.:| xs) request respond
|
||||
SpaceDelimitedStyle ->
|
||||
requiredQueryParameter
|
||||
name
|
||||
( \xs -> \request respond ->
|
||||
case NonEmpty.nonEmpty (unSpaceDelimitedValue xs) of
|
||||
Nothing ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Just xs ->
|
||||
withParam xs request respond
|
||||
)
|
||||
PipeDelimitedStyle ->
|
||||
requiredQueryParameter
|
||||
name
|
||||
( \xs -> \request respond ->
|
||||
case NonEmpty.nonEmpty (unPipeDelimitedValue xs) of
|
||||
Nothing ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Just xs ->
|
||||
withParam xs request respond
|
||||
)
|
||||
CommaDelimitedStyle ->
|
||||
requiredQueryParameter
|
||||
name
|
||||
( \xs -> \request respond ->
|
||||
case NonEmpty.nonEmpty (unCommaDelimitedValue xs) of
|
||||
Nothing ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Just xs ->
|
||||
withParam xs request respond
|
||||
)
|
||||
|
||||
optionalQueryParameters ::
|
||||
(FromHttpApiData a) =>
|
||||
Style ->
|
||||
ByteString ->
|
||||
(Maybe (NonEmpty.NonEmpty a) -> Wai.Application) ->
|
||||
Wai.Application
|
||||
optionalQueryParameters style name withParam =
|
||||
case style of
|
||||
FormStyle -> \request respond ->
|
||||
case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of
|
||||
Left error ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right form ->
|
||||
case parseAll (Text.decodeUtf8 name) form of
|
||||
Left _ ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right [] ->
|
||||
withParam Nothing request respond
|
||||
Right (x : xs) ->
|
||||
withParam (Just (x NonEmpty.:| xs)) request respond
|
||||
SpaceDelimitedStyle ->
|
||||
optionalQueryParameter
|
||||
name
|
||||
False
|
||||
( \xs ->
|
||||
withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue)
|
||||
)
|
||||
PipeDelimitedStyle ->
|
||||
optionalQueryParameter
|
||||
name
|
||||
False
|
||||
( \xs ->
|
||||
withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue)
|
||||
)
|
||||
CommaDelimitedStyle ->
|
||||
optionalQueryParameter
|
||||
name
|
||||
False
|
||||
( \xs ->
|
||||
withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue)
|
||||
)
|
||||
|
||||
requiredQueryParameter ::
|
||||
(FromHttpApiData a) =>
|
||||
ByteString ->
|
||||
(a -> Wai.Application) ->
|
||||
Wai.Application
|
||||
requiredQueryParameter name withParam = \request respond ->
|
||||
case List.lookup name (Wai.queryString request) of
|
||||
Nothing ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Just Nothing ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Just (Just value) ->
|
||||
case parseQueryParam (Text.decodeUtf8 value) of
|
||||
Left _err ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right x ->
|
||||
withParam x request respond
|
||||
{-# INLINEABLE requiredQueryParameter #-}
|
||||
|
||||
optionalQueryParameter ::
|
||||
(FromHttpApiData a) =>
|
||||
ByteString ->
|
||||
-- | Allow empty, e.g. "x="
|
||||
Bool ->
|
||||
(Maybe a -> Wai.Application) ->
|
||||
Wai.Application
|
||||
optionalQueryParameter name allowEmpty withParam = \request respond ->
|
||||
case List.lookup name (Wai.queryString request) of
|
||||
Nothing ->
|
||||
withParam Nothing request respond
|
||||
Just Nothing
|
||||
| allowEmpty ->
|
||||
withParam Nothing request respond
|
||||
| otherwise ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Just (Just value) ->
|
||||
case parseQueryParam (Text.decodeUtf8 value) of
|
||||
Left _err ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right x ->
|
||||
withParam (Just x) request respond
|
||||
{-# INLINEABLE optionalQueryParameter #-}
|
||||
|
||||
optionalHeader ::
|
||||
(FromHttpApiData a) =>
|
||||
HeaderName ->
|
||||
(Maybe a -> Wai.Application) ->
|
||||
Wai.Application
|
||||
optionalHeader name withHeader = \request respond ->
|
||||
case List.lookup name (Wai.requestHeaders request) of
|
||||
Nothing ->
|
||||
withHeader Nothing request respond
|
||||
Just value ->
|
||||
case parseHeader value of
|
||||
Left _err ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right x ->
|
||||
withHeader (Just x) request respond
|
||||
{-# INLINEABLE optionalHeader #-}
|
||||
|
||||
requiredHeader ::
|
||||
(FromHttpApiData a) =>
|
||||
HeaderName ->
|
||||
(a -> Wai.Application) ->
|
||||
Wai.Application
|
||||
requiredHeader name withHeader = \request respond ->
|
||||
case List.lookup name (Wai.requestHeaders request) of
|
||||
Nothing ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Just value ->
|
||||
case parseHeader value of
|
||||
Left _err ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right x ->
|
||||
withHeader x request respond
|
||||
{-# INLINEABLE requiredHeader #-}
|
||||
|
||||
data BodyParser a
|
||||
= BodyParser
|
||||
Network.HTTP.Media.MediaType
|
||||
((a -> Wai.Application) -> Wai.Application)
|
||||
|
||||
jsonBodyParser :: (FromJSON a) => BodyParser a
|
||||
jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON
|
||||
{-# INLINE jsonBodyParser #-}
|
||||
|
||||
formBodyParser :: (FromForm a) => BodyParser a
|
||||
formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm
|
||||
{-# INLINE formBodyParser #-}
|
||||
|
||||
parseRequestBody :: [BodyParser a] -> (a -> Wai.Application) -> Wai.Application
|
||||
parseRequestBody parsers withBody = \request respond -> do
|
||||
let contentType =
|
||||
fromMaybe
|
||||
"application/octet-stream"
|
||||
(List.lookup hContentType (Wai.requestHeaders request))
|
||||
|
||||
bodyParser =
|
||||
Network.HTTP.Media.mapAccept
|
||||
[(mediaType, parser) | BodyParser mediaType parser <- parsers]
|
||||
contentType
|
||||
|
||||
case bodyParser of
|
||||
Just parseBody ->
|
||||
parseBody withBody request respond
|
||||
Nothing ->
|
||||
respond (Wai.responseBuilder (toEnum 415) [] mempty)
|
||||
{-# INLINE parseRequestBody #-}
|
||||
|
||||
parseRequestBodyJSON :: (FromJSON a) => (a -> Wai.Application) -> Wai.Application
|
||||
parseRequestBodyJSON withBody = \request respond -> do
|
||||
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
|
||||
case eitherResult result of
|
||||
Left _err ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right value ->
|
||||
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
|
||||
Left _err ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right body ->
|
||||
withBody body request respond
|
||||
{-# INLINEABLE parseRequestBodyJSON #-}
|
||||
|
||||
parseRequestBodyForm :: (FromForm a) => (a -> Wai.Application) -> Wai.Application
|
||||
parseRequestBodyForm withBody = \request respond -> do
|
||||
-- Reads the body using lazy IO. Not great but it gets us
|
||||
-- going and is pretty local.
|
||||
let getBodyBytes :: IO [ByteString]
|
||||
getBodyBytes = do
|
||||
chunk <- Wai.getRequestBodyChunk request
|
||||
case chunk of
|
||||
"" -> pure []
|
||||
_ -> do
|
||||
rest <- unsafeInterleaveIO getBodyBytes
|
||||
pure (chunk : rest)
|
||||
|
||||
bytes <- getBodyBytes
|
||||
case urlDecodeAsForm (LBS.fromChunks bytes) of
|
||||
Left _err ->
|
||||
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
||||
Right form ->
|
||||
withBody form request respond
|
||||
{-# INLINEABLE parseRequestBodyForm #-}
|
||||
|
||||
---------------------
|
||||
Test/Response.hs
|
||||
|
||||
module Test.Response
|
||||
( ToResponse (..),
|
||||
|
||||
-- * NDJSON support
|
||||
NDJSON,
|
||||
responseNDJSON,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Aeson
|
||||
import qualified Data.Aeson.Encoding
|
||||
import qualified Data.ByteString.Builder
|
||||
import qualified Network.HTTP.Types
|
||||
import qualified Network.Wai
|
||||
|
||||
type NDJSON element = ((element -> IO ()) -> IO () -> IO ())
|
||||
|
||||
responseNDJSON :: (Data.Aeson.ToJSON element) => Network.HTTP.Types.Status -> Network.HTTP.Types.ResponseHeaders -> NDJSON element -> Network.Wai.Response
|
||||
responseNDJSON status responseHeaders stream =
|
||||
Network.Wai.responseStream status responseHeaders $ \emit flush ->
|
||||
stream
|
||||
( \element ->
|
||||
emit
|
||||
( Data.Aeson.Encoding.fromEncoding (Data.Aeson.toEncoding element)
|
||||
<> Data.ByteString.Builder.char7 '\n'
|
||||
)
|
||||
)
|
||||
flush
|
||||
|
||||
class ToResponse a where
|
||||
toResponse :: a -> Network.Wai.Response
|
||||
|
||||
---------------------
|
||||
Test/Response/Test.hs
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Test.Response.Test where
|
||||
|
||||
import qualified Control.Applicative
|
||||
import qualified Control.Exception
|
||||
import qualified Control.Monad
|
||||
import qualified Control.Monad.IO.Class
|
||||
import qualified Data.Aeson
|
||||
import qualified Data.Aeson.Encoding
|
||||
import qualified Data.Aeson.Parser
|
||||
import qualified Data.Aeson.Types
|
||||
import qualified Data.Attoparsec.ByteString
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.List
|
||||
import qualified Data.List.NonEmpty
|
||||
import qualified Data.Map
|
||||
import qualified Data.Maybe
|
||||
import qualified Data.Text
|
||||
import qualified Data.Time
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified GHC.Float
|
||||
import qualified GHC.Int
|
||||
import qualified GHC.Records
|
||||
import qualified GHC.Types
|
||||
import qualified Network.HTTP.Types
|
||||
import qualified Network.Wai
|
||||
import qualified Web.HttpApiData
|
||||
|
||||
import Test.Schemas.Testee
|
||||
|
||||
import Test.Response
|
||||
|
||||
data TestResponse
|
||||
= TestResponse200 Testee
|
||||
deriving (Show)
|
||||
|
||||
instance ToResponse TestResponse where
|
||||
toResponse (TestResponse200 x) =
|
||||
Network.Wai.responseBuilder Network.HTTP.Types.status200 ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
|
||||
|
||||
instance GHC.Records.HasField "status" TestResponse Network.HTTP.Types.Status where
|
||||
getField (TestResponse200 {}) = Network.HTTP.Types.status200
|
||||
---------------------
|
||||
Test/Schemas/Base.hs
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Test.Schemas.Base where
|
||||
|
||||
import qualified Control.Applicative
|
||||
import qualified Control.Exception
|
||||
import qualified Control.Monad
|
||||
import qualified Control.Monad.IO.Class
|
||||
import qualified Data.Aeson
|
||||
import qualified Data.Aeson.Encoding
|
||||
import qualified Data.Aeson.Parser
|
||||
import qualified Data.Aeson.Types
|
||||
import qualified Data.Attoparsec.ByteString
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.List
|
||||
import qualified Data.List.NonEmpty
|
||||
import qualified Data.Map
|
||||
import qualified Data.Maybe
|
||||
import qualified Data.Text
|
||||
import qualified Data.Time
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified GHC.Float
|
||||
import qualified GHC.Int
|
||||
import qualified GHC.Records
|
||||
import qualified GHC.Types
|
||||
import qualified Network.HTTP.Types
|
||||
import qualified Network.Wai
|
||||
import qualified Web.HttpApiData
|
||||
|
||||
|
||||
|
||||
import Test.Schemas.Enum
|
||||
|
||||
newtype Base = Base
|
||||
{
|
||||
enum :: (Data.Maybe.Maybe (Enum))
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Data.Aeson.ToJSON Base where
|
||||
toJSON Base {..} = Data.Aeson.object
|
||||
([
|
||||
]
|
||||
++ [ "enum" Data.Aeson..= enum | Just enum <- [enum] ])
|
||||
|
||||
toEncoding Base {..} = Data.Aeson.Encoding.pairs
|
||||
( maybe mempty (Data.Aeson.Encoding.pair "enum" . Data.Aeson.toEncoding) enum
|
||||
)
|
||||
|
||||
instance Data.Aeson.FromJSON Base where
|
||||
parseJSON = Data.Aeson.withObject "Base" $ \o ->
|
||||
Base
|
||||
<$> o Data.Aeson..:? "enum"
|
||||
---------------------
|
||||
Test/Schemas/Enum.hs
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Test.Schemas.Enum where
|
||||
|
||||
import qualified Control.Applicative
|
||||
import qualified Control.Exception
|
||||
import qualified Control.Monad
|
||||
import qualified Control.Monad.IO.Class
|
||||
import qualified Data.Aeson
|
||||
import qualified Data.Aeson.Encoding
|
||||
import qualified Data.Aeson.Parser
|
||||
import qualified Data.Aeson.Types
|
||||
import qualified Data.Attoparsec.ByteString
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.List
|
||||
import qualified Data.List.NonEmpty
|
||||
import qualified Data.Map
|
||||
import qualified Data.Maybe
|
||||
import qualified Data.Text
|
||||
import qualified Data.Time
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified GHC.Float
|
||||
import qualified GHC.Int
|
||||
import qualified GHC.Records
|
||||
import qualified GHC.Types
|
||||
import qualified Network.HTTP.Types
|
||||
import qualified Network.Wai
|
||||
import qualified Web.HttpApiData
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
data Enum
|
||||
= EnumA
|
||||
| EnumB
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Data.Aeson.ToJSON Enum where
|
||||
toJSON x = case x of
|
||||
EnumA -> "a"
|
||||
EnumB -> "b"
|
||||
|
||||
toEncoding x = case x of
|
||||
EnumA -> Data.Aeson.Encoding.text "a"
|
||||
EnumB -> Data.Aeson.Encoding.text "b"
|
||||
|
||||
instance Data.Aeson.FromJSON Enum where
|
||||
parseJSON = Data.Aeson.withText "Enum" $ \s ->
|
||||
case s of
|
||||
"a" -> pure EnumA
|
||||
"b" -> pure EnumB
|
||||
_ -> fail "invalid enum value"
|
||||
|
||||
instance Web.HttpApiData.ToHttpApiData Enum where
|
||||
toQueryParam x = case x of
|
||||
EnumA -> "a"
|
||||
EnumB -> "b"
|
||||
|
||||
instance Web.HttpApiData.FromHttpApiData Enum where
|
||||
parseUrlPiece x =
|
||||
case x of
|
||||
"a" -> pure EnumA
|
||||
"b" -> pure EnumB
|
||||
_ -> Left "invalid enum value"
|
||||
---------------------
|
||||
Test/Schemas/Test.hs
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Test.Schemas.Test where
|
||||
|
||||
import qualified Control.Applicative
|
||||
import qualified Control.Exception
|
||||
import qualified Control.Monad
|
||||
import qualified Control.Monad.IO.Class
|
||||
import qualified Data.Aeson
|
||||
import qualified Data.Aeson.Encoding
|
||||
import qualified Data.Aeson.Parser
|
||||
import qualified Data.Aeson.Types
|
||||
import qualified Data.Attoparsec.ByteString
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.List
|
||||
import qualified Data.List.NonEmpty
|
||||
import qualified Data.Map
|
||||
import qualified Data.Maybe
|
||||
import qualified Data.Text
|
||||
import qualified Data.Time
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified GHC.Float
|
||||
import qualified GHC.Int
|
||||
import qualified GHC.Records
|
||||
import qualified GHC.Types
|
||||
import qualified Network.HTTP.Types
|
||||
import qualified Network.Wai
|
||||
import qualified Web.HttpApiData
|
||||
|
||||
|
||||
|
||||
import Test.Schemas.Base
|
||||
import Test.Schemas.Enum
|
||||
|
||||
data Test = Test
|
||||
{
|
||||
enum :: (Data.Maybe.Maybe (Enum)),
|
||||
name :: (Data.Maybe.Maybe (Data.Text.Text))
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Data.Aeson.ToJSON Test where
|
||||
toJSON Test {..} = Data.Aeson.object
|
||||
([
|
||||
]
|
||||
++ [ "enum" Data.Aeson..= enum | Just enum <- [enum] ]
|
||||
++ [ "name" Data.Aeson..= name | Just name <- [name] ])
|
||||
|
||||
toEncoding Test {..} = Data.Aeson.Encoding.pairs
|
||||
( maybe mempty (Data.Aeson.Encoding.pair "enum" . Data.Aeson.toEncoding) enum <>
|
||||
maybe mempty (Data.Aeson.Encoding.pair "name" . Data.Aeson.toEncoding) name
|
||||
)
|
||||
|
||||
instance Data.Aeson.FromJSON Test where
|
||||
parseJSON = Data.Aeson.withObject "Test" $ \o ->
|
||||
Test
|
||||
<$> o Data.Aeson..:? "enum"
|
||||
<*> o Data.Aeson..:? "name"
|
||||
---------------------
|
||||
Test/Schemas/Testee.hs
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Test.Schemas.Testee where
|
||||
|
||||
import qualified Control.Applicative
|
||||
import qualified Control.Exception
|
||||
import qualified Control.Monad
|
||||
import qualified Control.Monad.IO.Class
|
||||
import qualified Data.Aeson
|
||||
import qualified Data.Aeson.Encoding
|
||||
import qualified Data.Aeson.Parser
|
||||
import qualified Data.Aeson.Types
|
||||
import qualified Data.Attoparsec.ByteString
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.List
|
||||
import qualified Data.List.NonEmpty
|
||||
import qualified Data.Map
|
||||
import qualified Data.Maybe
|
||||
import qualified Data.Text
|
||||
import qualified Data.Time
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified GHC.Float
|
||||
import qualified GHC.Int
|
||||
import qualified GHC.Records
|
||||
import qualified GHC.Types
|
||||
import qualified Network.HTTP.Types
|
||||
import qualified Network.Wai
|
||||
import qualified Web.HttpApiData
|
||||
|
||||
|
||||
|
||||
import Test.Schemas.Test
|
||||
|
||||
data Testee
|
||||
= TesteeTest Test
|
||||
deriving (Show)
|
||||
|
||||
instance Data.Aeson.ToJSON Testee where
|
||||
toJSON (TesteeTest x) = Data.Aeson.toJSON x
|
||||
|
||||
toEncoding (TesteeTest x) = Data.Aeson.toEncoding x
|
||||
|
||||
instance Data.Aeson.FromJSON Testee where
|
||||
parseJSON x =
|
||||
(TesteeTest <$> (Data.Aeson.Types.withObject "Test" $ \o ->
|
||||
do ("scarf" :: Data.Text.Text) <- o Data.Aeson..: "type"
|
||||
Data.Aeson.parseJSON (Data.Aeson.Object o)
|
||||
) x)
|
||||
---------------------
|
||||
test.cabal
|
||||
|
||||
cabal-version: 3.0
|
||||
name: test
|
||||
version: 0.1.0.0
|
||||
library
|
||||
build-depends:
|
||||
, aeson
|
||||
, attoparsec
|
||||
, base
|
||||
, bytestring
|
||||
, containers
|
||||
, ghc-prim
|
||||
, http-api-data
|
||||
, http-media
|
||||
, http-types
|
||||
, text
|
||||
, time
|
||||
, unordered-containers
|
||||
, wai
|
||||
exposed-modules:
|
||||
Test.Api
|
||||
Test.Request
|
||||
Test.Response
|
||||
Test.Response.Test
|
||||
Test.Schemas.Base
|
||||
Test.Schemas.Enum
|
||||
Test.Schemas.Test
|
||||
Test.Schemas.Testee
|
||||
Loading…
Reference in New Issue
Block a user