#include "overlapping-compat.h"
module Data.Swagger.Internal where
import Prelude ()
import Prelude.Compat
import Control.Applicative
import Control.Monad
import Data.Aeson
import qualified Data.Aeson.Types as JSON
import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid
import Data.Scientific (Scientific)
import Data.Set (Set)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic)
import Network (HostName, PortNumber)
import Network.HTTP.Media (MediaType)
import Text.Read (readMaybe)
import Data.Swagger.Internal.Utils
type Definitions = HashMap Text
data Swagger = Swagger
{
_swaggerInfo :: Info
, _swaggerHost :: Maybe Host
, _swaggerBasePath :: Maybe FilePath
, _swaggerSchemes :: Maybe [Scheme]
, _swaggerConsumes :: MimeList
, _swaggerProduces :: MimeList
, _swaggerPaths :: HashMap FilePath PathItem
, _swaggerDefinitions :: Definitions Schema
, _swaggerParameters :: Definitions Param
, _swaggerResponses :: Definitions Response
, _swaggerSecurityDefinitions :: Definitions SecurityScheme
, _swaggerSecurity :: [SecurityRequirement]
, _swaggerTags :: Set Tag
, _swaggerExternalDocs :: Maybe ExternalDocs
} deriving (Eq, Show, Generic, Data, Typeable)
data Info = Info
{
_infoTitle :: Text
, _infoDescription :: Maybe Text
, _infoTermsOfService :: Maybe Text
, _infoContact :: Maybe Contact
, _infoLicense :: Maybe License
, _infoVersion :: Text
} deriving (Eq, Show, Generic, Data, Typeable)
data Contact = Contact
{
_contactName :: Maybe Text
, _contactUrl :: Maybe URL
, _contactEmail :: Maybe Text
} deriving (Eq, Show, Generic, Data, Typeable)
data License = License
{
_licenseName :: Text
, _licenseUrl :: Maybe URL
} deriving (Eq, Show, Generic, Data, Typeable)
instance IsString License where
fromString s = License (fromString s) Nothing
data Host = Host
{ _hostName :: HostName
, _hostPort :: Maybe PortNumber
} deriving (Eq, Show, Generic, Typeable)
instance IsString Host where
fromString s = Host s Nothing
hostConstr :: Constr
hostConstr = mkConstr hostDataType "Host" [] Prefix
hostDataType :: DataType
hostDataType = mkDataType "Data.Swagger.Host" [hostConstr]
instance Data Host where
gunfold k z c = case constrIndex c of
1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport))))
_ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host."
toConstr (Host _ _) = hostConstr
dataTypeOf _ = hostDataType
data Scheme
= Http
| Https
| Ws
| Wss
deriving (Eq, Show, Generic, Data, Typeable)
data PathItem = PathItem
{
_pathItemGet :: Maybe Operation
, _pathItemPut :: Maybe Operation
, _pathItemPost :: Maybe Operation
, _pathItemDelete :: Maybe Operation
, _pathItemOptions :: Maybe Operation
, _pathItemHead :: Maybe Operation
, _pathItemPatch :: Maybe Operation
, _pathItemParameters :: [Referenced Param]
} deriving (Eq, Show, Generic, Data, Typeable)
data Operation = Operation
{
_operationTags :: Set TagName
, _operationSummary :: Maybe Text
, _operationDescription :: Maybe Text
, _operationExternalDocs :: Maybe ExternalDocs
, _operationOperationId :: Maybe Text
, _operationConsumes :: Maybe MimeList
, _operationProduces :: Maybe MimeList
, _operationParameters :: [Referenced Param]
, _operationResponses :: Responses
, _operationSchemes :: Maybe [Scheme]
, _operationDeprecated :: Maybe Bool
, _operationSecurity :: [SecurityRequirement]
} deriving (Eq, Show, Generic, Data, Typeable)
newtype MimeList = MimeList { getMimeList :: [MediaType] }
deriving (Eq, Show, Monoid, Typeable)
mimeListConstr :: Constr
mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
mimeListDataType :: DataType
mimeListDataType = mkDataType "Data.Swagger.MimeList" [mimeListConstr]
instance Data MimeList where
gunfold k z c = case constrIndex c of
1 -> k (z (\xs -> MimeList (map fromString xs)))
_ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList."
toConstr (MimeList _) = mimeListConstr
dataTypeOf _ = mimeListDataType
data Param = Param
{
_paramName :: Text
, _paramDescription :: Maybe Text
, _paramRequired :: Maybe Bool
, _paramSchema :: ParamAnySchema
} deriving (Eq, Show, Generic, Data, Typeable)
data ParamAnySchema
= ParamBody (Referenced Schema)
| ParamOther ParamOtherSchema
deriving (Eq, Show, Generic, Data, Typeable)
data ParamOtherSchema = ParamOtherSchema
{
_paramOtherSchemaIn :: ParamLocation
, _paramOtherSchemaAllowEmptyValue :: Maybe Bool
, _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
} deriving (Eq, Show, Generic, Data, Typeable)
data SwaggerItems t where
SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
deriving (Typeable)
deriving instance Eq (SwaggerItems t)
deriving instance Show (SwaggerItems t)
swaggerItemsPrimitiveConstr :: Constr
swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
swaggerItemsDataType :: DataType
swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where
gunfold k z c = case constrIndex c of
1 -> k (k (z SwaggerItemsPrimitive))
_ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
toConstr _ = swaggerItemsPrimitiveConstr
dataTypeOf _ = swaggerItemsDataType
deriving instance Data (SwaggerItems Schema)
data SwaggerType t where
SwaggerString :: SwaggerType t
SwaggerNumber :: SwaggerType t
SwaggerInteger :: SwaggerType t
SwaggerBoolean :: SwaggerType t
SwaggerArray :: SwaggerType t
SwaggerFile :: SwaggerType ParamOtherSchema
SwaggerNull :: SwaggerType Schema
SwaggerObject :: SwaggerType Schema
deriving (Typeable)
deriving instance Eq (SwaggerType t)
deriving instance Show (SwaggerType t)
swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
swaggerCommonTypes :: [SwaggerType t]
swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
swaggerParamTypes :: [SwaggerType ParamOtherSchema]
swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
swaggerSchemaTypes :: [SwaggerType Schema]
swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
swaggerTypeConstrs :: [Constr]
swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where
gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
toConstr = swaggerTypeConstr
dataTypeOf = swaggerTypeDataType
instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where
gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
toConstr = swaggerTypeConstr
dataTypeOf = swaggerTypeDataType
instance OVERLAPPABLE_ Data (SwaggerType Schema) where
gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
toConstr = swaggerTypeConstr
dataTypeOf = swaggerTypeDataType
data ParamLocation
=
ParamQuery
| ParamHeader
| ParamPath
| ParamFormData
deriving (Eq, Show, Generic, Data, Typeable)
type Format = Text
data CollectionFormat t where
CollectionCSV :: CollectionFormat t
CollectionSSV :: CollectionFormat t
CollectionTSV :: CollectionFormat t
CollectionPipes :: CollectionFormat t
CollectionMulti :: CollectionFormat ParamOtherSchema
deriving (Typeable)
deriving instance Eq (CollectionFormat t)
deriving instance Show (CollectionFormat t)
collectionFormatConstr :: CollectionFormat t -> Constr
collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix
collectionFormatDataType :: DataType
collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
map collectionFormatConstr collectionCommonFormats
collectionCommonFormats :: [CollectionFormat t]
collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where
gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
toConstr = collectionFormatConstr
dataTypeOf _ = collectionFormatDataType
deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)
type ParamName = Text
data Schema = Schema
{ _schemaTitle :: Maybe Text
, _schemaDescription :: Maybe Text
, _schemaRequired :: [ParamName]
, _schemaAllOf :: Maybe [Schema]
, _schemaProperties :: HashMap Text (Referenced Schema)
, _schemaAdditionalProperties :: Maybe Schema
, _schemaDiscriminator :: Maybe Text
, _schemaReadOnly :: Maybe Bool
, _schemaXml :: Maybe Xml
, _schemaExternalDocs :: Maybe ExternalDocs
, _schemaExample :: Maybe Value
, _schemaMaxProperties :: Maybe Integer
, _schemaMinProperties :: Maybe Integer
, _schemaParamSchema :: ParamSchema Schema
} deriving (Eq, Show, Generic, Data, Typeable)
data NamedSchema = NamedSchema
{ _namedSchemaName :: Maybe Text
, _namedSchemaSchema :: Schema
} deriving (Eq, Show, Generic, Data, Typeable)
type Pattern = Text
data ParamSchema t = ParamSchema
{
_paramSchemaDefault :: Maybe Value
, _paramSchemaType :: SwaggerType t
, _paramSchemaFormat :: Maybe Format
, _paramSchemaItems :: Maybe (SwaggerItems t)
, _paramSchemaMaximum :: Maybe Scientific
, _paramSchemaExclusiveMaximum :: Maybe Bool
, _paramSchemaMinimum :: Maybe Scientific
, _paramSchemaExclusiveMinimum :: Maybe Bool
, _paramSchemaMaxLength :: Maybe Integer
, _paramSchemaMinLength :: Maybe Integer
, _paramSchemaPattern :: Maybe Pattern
, _paramSchemaMaxItems :: Maybe Integer
, _paramSchemaMinItems :: Maybe Integer
, _paramSchemaUniqueItems :: Maybe Bool
, _paramSchemaEnum :: Maybe [Value]
, _paramSchemaMultipleOf :: Maybe Scientific
} deriving (Eq, Show, Generic, Typeable)
deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
data Xml = Xml
{
_xmlName :: Maybe Text
, _xmlNamespace :: Maybe Text
, _xmlPrefix :: Maybe Text
, _xmlAttribute :: Maybe Bool
, _xmlWrapped :: Maybe Bool
} deriving (Eq, Show, Generic, Data, Typeable)
data Responses = Responses
{
_responsesDefault :: Maybe (Referenced Response)
, _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
} deriving (Eq, Show, Generic, Data, Typeable)
type HttpStatusCode = Int
data Response = Response
{
_responseDescription :: Text
, _responseSchema :: Maybe (Referenced Schema)
, _responseHeaders :: HashMap HeaderName Header
, _responseExamples :: Maybe Example
} deriving (Eq, Show, Generic, Data, Typeable)
instance IsString Response where
fromString s = Response (fromString s) Nothing mempty Nothing
type HeaderName = Text
data Header = Header
{
_headerDescription :: Maybe Text
, _headerParamSchema :: ParamSchema Header
} deriving (Eq, Show, Generic, Data, Typeable)
data Example = Example { getExample :: Map MediaType Value }
deriving (Eq, Show, Generic, Typeable)
exampleConstr :: Constr
exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix
exampleDataType :: DataType
exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr]
instance Data Example where
gunfold k z c = case constrIndex c of
1 -> k (z (\m -> Example (Map.mapKeys fromString m)))
_ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Example."
toConstr (Example _) = exampleConstr
dataTypeOf _ = exampleDataType
data ApiKeyLocation
= ApiKeyQuery
| ApiKeyHeader
deriving (Eq, Show, Generic, Data, Typeable)
data ApiKeyParams = ApiKeyParams
{
_apiKeyName :: Text
, _apiKeyIn :: ApiKeyLocation
} deriving (Eq, Show, Generic, Data, Typeable)
type AuthorizationURL = Text
type TokenURL = Text
data OAuth2Flow
= OAuth2Implicit AuthorizationURL
| OAuth2Password TokenURL
| OAuth2Application TokenURL
| OAuth2AccessCode AuthorizationURL TokenURL
deriving (Eq, Show, Generic, Data, Typeable)
data OAuth2Params = OAuth2Params
{
_oauth2Flow :: OAuth2Flow
, _oauth2Scopes :: HashMap Text Text
} deriving (Eq, Show, Generic, Data, Typeable)
data SecuritySchemeType
= SecuritySchemeBasic
| SecuritySchemeApiKey ApiKeyParams
| SecuritySchemeOAuth2 OAuth2Params
deriving (Eq, Show, Generic, Data, Typeable)
data SecurityScheme = SecurityScheme
{
_securitySchemeType :: SecuritySchemeType
, _securitySchemeDescription :: Maybe Text
} deriving (Eq, Show, Generic, Data, Typeable)
newtype SecurityRequirement = SecurityRequirement
{ getSecurityRequirement :: HashMap Text [Text]
} deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
type TagName = Text
data Tag = Tag
{
_tagName :: TagName
, _tagDescription :: Maybe Text
, _tagExternalDocs :: Maybe ExternalDocs
} deriving (Eq, Ord, Show, Generic, Data, Typeable)
instance IsString Tag where
fromString s = Tag (fromString s) Nothing Nothing
data ExternalDocs = ExternalDocs
{
_externalDocsDescription :: Maybe Text
, _externalDocsUrl :: URL
} deriving (Eq, Ord, Show, Generic, Data, Typeable)
newtype Reference = Reference { getReference :: Text }
deriving (Eq, Show, Data, Typeable)
data Referenced a
= Ref Reference
| Inline a
deriving (Eq, Show, Functor, Data, Typeable)
instance IsString a => IsString (Referenced a) where
fromString = Inline . fromString
newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)
instance Monoid Swagger where
mempty = genericMempty
mappend = genericMappend
instance Monoid Info where
mempty = genericMempty
mappend = genericMappend
instance Monoid Contact where
mempty = genericMempty
mappend = genericMappend
instance Monoid PathItem where
mempty = genericMempty
mappend = genericMappend
instance Monoid Schema where
mempty = genericMempty
mappend = genericMappend
instance Monoid (ParamSchema t) where
mempty = genericMempty
mappend = genericMappend
instance Monoid Param where
mempty = genericMempty
mappend = genericMappend
instance Monoid ParamOtherSchema where
mempty = genericMempty
mappend = genericMappend
instance Monoid Header where
mempty = genericMempty
mappend = genericMappend
instance Monoid Responses where
mempty = genericMempty
mappend = genericMappend
instance Monoid Response where
mempty = genericMempty
mappend = genericMappend
instance Monoid ExternalDocs where
mempty = genericMempty
mappend = genericMappend
instance Monoid Operation where
mempty = genericMempty
mappend = genericMappend
instance Monoid Example where
mempty = genericMempty
mappend = genericMappend
instance SwaggerMonoid Info
instance SwaggerMonoid PathItem
instance SwaggerMonoid Schema
instance SwaggerMonoid (ParamSchema t)
instance SwaggerMonoid Param
instance SwaggerMonoid ParamOtherSchema
instance SwaggerMonoid Responses
instance SwaggerMonoid Response
instance SwaggerMonoid ExternalDocs
instance SwaggerMonoid Operation
instance SwaggerMonoid MimeList
deriving instance SwaggerMonoid URL
instance SwaggerMonoid (SwaggerType t) where
swaggerMempty = SwaggerString
swaggerMappend _ y = y
instance SwaggerMonoid ParamLocation where
swaggerMempty = ParamQuery
swaggerMappend _ y = y
instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where
swaggerMempty = HashMap.empty
swaggerMappend = HashMap.unionWith mappend
instance Monoid a => SwaggerMonoid (Referenced a) where
swaggerMempty = Inline mempty
swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
swaggerMappend _ y = y
instance SwaggerMonoid ParamAnySchema where
swaggerMempty = ParamOther swaggerMempty
swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
swaggerMappend _ y = y
instance ToJSON ParamLocation where
toJSON = genericToJSON (jsonPrefix "Param")
instance ToJSON Info where
toJSON = genericToJSON (jsonPrefix "Info")
instance ToJSON Contact where
toJSON = genericToJSON (jsonPrefix "Contact")
instance ToJSON License where
toJSON = genericToJSON (jsonPrefix "License")
instance ToJSON ApiKeyLocation where
toJSON = genericToJSON (jsonPrefix "ApiKey")
instance ToJSON ApiKeyParams where
toJSON = genericToJSON (jsonPrefix "apiKey")
instance ToJSON Scheme where
toJSON = genericToJSON (jsonPrefix "")
instance ToJSON Tag where
toJSON = genericToJSON (jsonPrefix "Tag")
instance ToJSON ExternalDocs where
toJSON = genericToJSON (jsonPrefix "ExternalDocs")
instance ToJSON Xml where
toJSON = genericToJSON (jsonPrefix "Xml")
instance FromJSON ParamLocation where
parseJSON = genericParseJSON (jsonPrefix "Param")
instance FromJSON Info where
parseJSON = genericParseJSON (jsonPrefix "Info")
instance FromJSON Contact where
parseJSON = genericParseJSON (jsonPrefix "Contact")
instance FromJSON License where
parseJSON = genericParseJSON (jsonPrefix "License")
instance FromJSON ApiKeyLocation where
parseJSON = genericParseJSON (jsonPrefix "ApiKey")
instance FromJSON ApiKeyParams where
parseJSON = genericParseJSON (jsonPrefix "apiKey")
instance FromJSON Scheme where
parseJSON = genericParseJSON (jsonPrefix "")
instance FromJSON Tag where
parseJSON = genericParseJSON (jsonPrefix "Tag")
instance FromJSON ExternalDocs where
parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")
instance ToJSON OAuth2Flow where
toJSON (OAuth2Implicit authUrl) = object
[ "flow" .= ("implicit" :: Text)
, "authorizationUrl" .= authUrl ]
toJSON (OAuth2Password tokenUrl) = object
[ "flow" .= ("password" :: Text)
, "tokenUrl" .= tokenUrl ]
toJSON (OAuth2Application tokenUrl) = object
[ "flow" .= ("application" :: Text)
, "tokenUrl" .= tokenUrl ]
toJSON (OAuth2AccessCode authUrl tokenUrl) = object
[ "flow" .= ("accessCode" :: Text)
, "authorizationUrl" .= authUrl
, "tokenUrl" .= tokenUrl ]
instance ToJSON OAuth2Params where
toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
instance ToJSON SecuritySchemeType where
toJSON SecuritySchemeBasic
= object [ "type" .= ("basic" :: Text) ]
toJSON (SecuritySchemeApiKey params)
= toJSON params
<+> object [ "type" .= ("apiKey" :: Text) ]
toJSON (SecuritySchemeOAuth2 params)
= toJSON params
<+> object [ "type" .= ("oauth2" :: Text) ]
instance ToJSON Swagger where
toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
where
addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
addVersion _ = error "impossible"
instance ToJSON SecurityScheme where
toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
instance ToJSON Schema where
toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
where
f "items" (Array _) = True
f _ _ = False
instance ToJSON Header where
toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
instance ToJSON (SwaggerItems t) where
toJSON (SwaggerItemsPrimitive fmt schema) = object
[ "collectionFormat" .= fmt
, "items" .= schema ]
toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
instance ToJSON Host where
toJSON (Host host mport) = toJSON $
case mport of
Nothing -> host
Just port -> host ++ ":" ++ show port
instance ToJSON MimeList where
toJSON (MimeList xs) = toJSON (map show xs)
instance ToJSON Param where
toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
instance ToJSON ParamAnySchema where
toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
toJSON (ParamOther s) = toJSON s
instance ToJSON ParamOtherSchema where
toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
instance ToJSON Responses where
toJSON (Responses def rs) = omitEmpties $
toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
instance ToJSON Response where
toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
instance ToJSON Operation where
toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
instance ToJSON PathItem where
toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
instance ToJSON Example where
toJSON = toJSON . Map.mapKeys show . getExample
instance ToJSON Reference where
toJSON (Reference ref) = object [ "$ref" .= ref ]
referencedToJSON :: ToJSON a => Text -> Referenced a -> Value
referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ]
referencedToJSON _ (Inline x) = toJSON x
instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/"
instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/"
instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/"
instance ToJSON (SwaggerType t) where
toJSON SwaggerArray = "array"
toJSON SwaggerString = "string"
toJSON SwaggerInteger = "integer"
toJSON SwaggerNumber = "number"
toJSON SwaggerBoolean = "boolean"
toJSON SwaggerFile = "file"
toJSON SwaggerNull = "null"
toJSON SwaggerObject = "object"
instance ToJSON (CollectionFormat t) where
toJSON CollectionCSV = "csv"
toJSON CollectionSSV = "ssv"
toJSON CollectionTSV = "tsv"
toJSON CollectionPipes = "pipes"
toJSON CollectionMulti = "multi"
instance ToJSON (ParamSchema t) where
toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
where
f "items" (Array _) = True
f _ _ = False
instance FromJSON OAuth2Flow where
parseJSON (Object o) = do
(flow :: Text) <- o .: "flow"
case flow of
"implicit" -> OAuth2Implicit <$> o .: "authorizationUrl"
"password" -> OAuth2Password <$> o .: "tokenUrl"
"application" -> OAuth2Application <$> o .: "tokenUrl"
"accessCode" -> OAuth2AccessCode
<$> o .: "authorizationUrl"
<*> o .: "tokenUrl"
_ -> empty
parseJSON _ = empty
instance FromJSON OAuth2Params where
parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
instance FromJSON SecuritySchemeType where
parseJSON js@(Object o) = do
(t :: Text) <- o .: "type"
case t of
"basic" -> pure SecuritySchemeBasic
"apiKey" -> SecuritySchemeApiKey <$> parseJSON js
"oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js
_ -> empty
parseJSON _ = empty
instance FromJSON Swagger where
parseJSON js@(Object o) = do
(version :: Text) <- o .: "swagger"
when (version /= "2.0") empty
(genericParseJSON (jsonPrefix "swagger")
`withDefaults` [ "consumes" .= (mempty :: MimeList)
, "produces" .= (mempty :: MimeList)
, "security" .= ([] :: [SecurityRequirement])
, "tags" .= ([] :: [Tag])
, "definitions" .= (mempty :: Definitions Schema)
, "parameters" .= (mempty :: Definitions Param)
, "responses" .= (mempty :: Definitions Response)
, "securityDefinitions" .= (mempty :: Definitions SecurityScheme)
] ) js
parseJSON _ = empty
instance FromJSON SecurityScheme where
parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
instance FromJSON Schema where
parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
`withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
, "required" .= ([] :: [ParamName]) ]
instance FromJSON Header where
parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
<$> o .:? "collectionFormat"
<*> (o .: "items" >>= parseJSON)
instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where
parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
parseJSON _ = empty
instance FromJSON Host where
parseJSON (String s) =
case fromInteger <$> readMaybe portStr of
Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
mport -> pure $ Host host mport
where
(hostText, portText) = Text.breakOn ":" s
[host, portStr] = map Text.unpack [hostText, portText]
parseJSON _ = empty
instance FromJSON MimeList where
parseJSON js = (MimeList . map fromString) <$> parseJSON js
instance FromJSON Param where
parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
instance FromJSON ParamAnySchema where
parseJSON js@(Object o) = do
(i :: Text) <- o .: "in"
case i of
"body" -> do
schema <- o .: "schema"
ParamBody <$> parseJSON schema
_ -> ParamOther <$> parseJSON js
parseJSON _ = empty
instance FromJSON ParamOtherSchema where
parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
instance FromJSON Responses where
parseJSON (Object o) = Responses
<$> o .:? "default"
<*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
parseJSON _ = empty
instance FromJSON Example where
parseJSON js = do
m <- parseJSON js
pure $ Example (Map.mapKeys fromString m)
instance FromJSON Response where
parseJSON = genericParseJSON (jsonPrefix "response")
`withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
instance FromJSON Operation where
parseJSON = genericParseJSON (jsonPrefix "operation")
`withDefaults` [ "security" .= ([] :: [SecurityRequirement])
, "tags" .= ([] :: [Tag])
, "parameters" .= ([] :: [Referenced Param]) ]
instance FromJSON PathItem where
parseJSON = genericParseJSON (jsonPrefix "pathItem")
`withDefaults` [ "parameters" .= ([] :: [Param]) ]
instance FromJSON Reference where
parseJSON (Object o) = Reference <$> o .: "$ref"
parseJSON _ = empty
referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a)
referencedParseJSON prefix js@(Object o) = do
ms <- o .:? "$ref"
case ms of
Nothing -> Inline <$> parseJSON js
Just s -> Ref <$> parseRef s
where
parseRef s = do
case Text.stripPrefix prefix s of
Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s
Just suffix -> pure (Reference suffix)
referencedParseJSON _ _ = fail "referenceParseJSON: not an object"
instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/"
instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/"
instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/"
instance FromJSON Xml where
parseJSON = genericParseJSON (jsonPrefix "xml")
instance FromJSON (SwaggerType Schema) where
parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
instance FromJSON (SwaggerType ParamOtherSchema) where
parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
instance OVERLAPPABLE_ FromJSON (SwaggerType t) where
parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where
parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
instance FromJSON (CollectionFormat ParamOtherSchema) where
parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")