module Data.Swagger.Internal where
import Control.Applicative
import Control.Monad
import Data.Aeson
import Data.Aeson.TH (deriveJSON)
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.String (fromString)
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
data Swagger = Swagger
{
_info :: Info
, _host :: Maybe Host
, _basePath :: Maybe FilePath
, _schemes :: Maybe [Scheme]
, _consumes :: MimeList
, _produces :: MimeList
, _paths :: Paths
, _definitions :: HashMap Text Schema
, _parameters :: HashMap Text Parameter
, _responses :: HashMap Text Response
, _securityDefinitions :: HashMap Text SecurityScheme
, _security :: [SecurityRequirement]
, _tags :: [Tag]
, _externalDocs :: Maybe ExternalDocs
} deriving (Eq, Show, Generic)
data Info = Info
{
_infoTitle :: Text
, _infoDescription :: Maybe Text
, _infoTermsOfService :: Maybe Text
, _infoContact :: Maybe Contact
, _infoLicense :: Maybe License
, _infoVersion :: Text
} deriving (Eq, Show, Generic)
data Contact = Contact
{
_contactName :: Maybe Text
, _contactUrl :: Maybe URL
, _contactEmail :: Maybe Text
} deriving (Eq, Show)
data License = License
{
_licenseName :: Text
, _licenseUrl :: Maybe URL
} deriving (Eq, Show)
data Host = Host
{ _hostName :: HostName
, _hostPort :: Maybe PortNumber
} deriving (Eq, Show)
data Scheme
= Http
| Https
| Ws
| Wss
deriving (Eq, Show)
data Paths = Paths
{
_pathsMap :: HashMap FilePath PathItem
} deriving (Eq, Show, Generic)
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 Parameter]
} deriving (Eq, Show, Generic)
data Operation = Operation
{
_operationTags :: [Text]
, _operationSummary :: Maybe Text
, _operationDescription :: Maybe Text
, _operationExternalDocs :: Maybe ExternalDocs
, _operationOperationId :: Maybe Text
, _operationConsumes :: Maybe MimeList
, _operationProduces :: Maybe MimeList
, _operationParameters :: [Referenced Parameter]
, _operationResponses :: Responses
, _operationSchemes :: Maybe [Scheme]
, _operationDeprecated :: Maybe Bool
, _operationSecurity :: [SecurityRequirement]
} deriving (Eq, Show, Generic)
newtype MimeList = MimeList { getMimeList :: [MediaType] }
deriving (Eq, Show, Monoid)
data Parameter = Parameter
{
_parameterName :: Text
, _parameterDescription :: Maybe Text
, _parameterRequired :: Maybe Bool
, _parameterSchema :: ParameterSchema
} deriving (Eq, Show, Generic)
data ParameterSchema
= ParameterBody (Referenced Schema)
| ParameterOther ParameterOtherSchema
deriving (Eq, Show)
data ParameterOtherSchema = ParameterOtherSchema
{
_parameterOtherSchemaIn :: ParameterLocation
, _parameterOtherSchemaType :: ParameterType
, _parameterOtherSchemaFormat :: Maybe Format
, _parameterOtherSchemaAllowEmptyValue :: Maybe Bool
, _parameterOtherSchemaItems :: Maybe Items
, _parameterOtherSchemaCollectionFormat :: Maybe CollectionFormat
, _parameterOtherSchemaCommon :: SchemaCommon
} deriving (Eq, Show, Generic)
data ParameterType
= ParamString
| ParamNumber
| ParamInteger
| ParamBoolean
| ParamArray
| ParamFile
deriving (Eq, Show)
data ParameterLocation
=
ParameterQuery
| ParameterHeader
| ParameterPath
| ParameterFormData
deriving (Eq, Show)
type Format = Text
data CollectionFormat
= CollectionCSV
| CollectionSSV
| CollectionTSV
| CollectionPipes
| CollectionMulti
deriving (Eq, Show)
data ItemsType
= ItemsString
| ItemsNumber
| ItemsInteger
| ItemsBoolean
| ItemsArray
deriving (Eq, Show)
data SchemaType
= SchemaArray
| SchemaBoolean
| SchemaInteger
| SchemaNumber
| SchemaNull
| SchemaObject
| SchemaString
deriving (Eq, Show)
data ItemsCollectionFormat
= ItemsCollectionCSV
| ItemsCollectionSSV
| ItemsCollectionTSV
| ItemsCollectionPipes
deriving (Eq, Show)
type ParamName = Text
data Schema = Schema
{ _schemaType :: SchemaType
, _schemaFormat :: Maybe Format
, _schemaTitle :: Maybe Text
, _schemaDescription :: Maybe Text
, _schemaRequired :: [ParamName]
, _schemaItems :: Maybe SchemaItems
, _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
, _schemaSchemaCommon :: SchemaCommon
} deriving (Eq, Show, Generic)
data SchemaItems
= SchemaItemsObject (Referenced Schema)
| SchemaItemsArray [Referenced Schema]
deriving (Eq, Show)
data SchemaCommon = SchemaCommon
{
_schemaCommonDefault :: Maybe Value
, _schemaCommonMaximum :: Maybe Scientific
, _schemaCommonExclusiveMaximum :: Maybe Bool
, _schemaCommonMinimum :: Maybe Scientific
, _schemaCommonExclusiveMinimum :: Maybe Bool
, _schemaCommonMaxLength :: Maybe Integer
, _schemaCommonMinLength :: Maybe Integer
, _schemaCommonPattern :: Maybe Text
, _schemaCommonMaxItems :: Maybe Integer
, _schemaCommonMinItems :: Maybe Integer
, _schemaCommonUniqueItems :: Maybe Bool
, _schemaCommonEnum :: Maybe [Value]
, _schemaCommonMultipleOf :: Maybe Scientific
} deriving (Eq, Show, Generic)
data Xml = Xml
{
_xmlName :: Maybe Text
, _xmlNamespace :: Maybe Text
, _xmlPrefix :: Maybe Text
, _xmlAttribute :: Maybe Bool
, _xmlWrapped :: Maybe Bool
} deriving (Eq, Show, Generic)
data Items = Items
{
_itemsType :: ItemsType
, _itemsFormat :: Maybe Format
, _itemsItems :: Maybe Items
, _itemsCollectionFormat :: Maybe ItemsCollectionFormat
, _itemsCommon :: SchemaCommon
} deriving (Eq, Show, Generic)
data Responses = Responses
{
_responsesDefault :: Maybe (Referenced Response)
, _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
} deriving (Eq, Show, Generic)
type HttpStatusCode = Int
data Response = Response
{
_responseDescription :: Text
, _responseSchema :: Maybe (Referenced Schema)
, _responseHeaders :: HashMap HeaderName Header
, _responseExamples :: Maybe Example
} deriving (Eq, Show, Generic)
type HeaderName = Text
data Header = Header
{
_headerDescription :: Maybe Text
, _headerType :: ItemsType
, _headerFormat :: Maybe Format
, _headerItems :: Maybe Items
, _headerCollectionFormat :: Maybe ItemsCollectionFormat
, _headerCommon :: SchemaCommon
} deriving (Eq, Show, Generic)
data Example = Example { getExample :: Map MediaType Value }
deriving (Eq, Show)
data ApiKeyLocation
= ApiKeyQuery
| ApiKeyHeader
deriving (Eq, Show)
data ApiKeyParams = ApiKeyParams
{
_apiKeyName :: Text
, _apiKeyIn :: ApiKeyLocation
} deriving (Eq, Show)
type AuthorizationURL = Text
type TokenURL = Text
data OAuth2Flow
= OAuth2Implicit AuthorizationURL
| OAuth2Password TokenURL
| OAuth2Application TokenURL
| OAuth2AccessCode AuthorizationURL TokenURL
deriving (Eq, Show)
data OAuth2Params = OAuth2Params
{
_oauth2Flow :: OAuth2Flow
, _oauth2Scopes :: HashMap Text Text
} deriving (Eq, Show, Generic)
data SecuritySchemeType
= SecuritySchemeBasic
| SecuritySchemeApiKey ApiKeyParams
| SecuritySchemeOAuth2 OAuth2Params
deriving (Eq, Show)
data SecurityScheme = SecurityScheme
{
_securitySchemeType :: SecuritySchemeType
, _securitySchemeDescription :: Maybe Text
} deriving (Eq, Show, Generic)
newtype SecurityRequirement = SecurityRequirement
{ getSecurityRequirement :: HashMap Text [Text]
} deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON)
data Tag = Tag
{
_tagName :: Text
, _tagDescription :: Maybe Text
, _tagExternalDocs :: Maybe ExternalDocs
} deriving (Eq, Show)
data ExternalDocs = ExternalDocs
{
_externalDocsDescription :: Maybe Text
, _externalDocsUrl :: URL
} deriving (Eq, Show, Generic)
newtype Reference = Reference { getReference :: Text }
deriving (Eq, Show)
data Referenced a
= Ref Reference
| Inline a
deriving (Eq, Show)
newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON)
instance Monoid Swagger where
mempty = genericMempty
mappend = genericMappend
instance Monoid Info where
mempty = genericMempty
mappend = genericMappend
instance Monoid Paths where
mempty = genericMempty
mappend = genericMappend
instance Monoid PathItem where
mempty = genericMempty
mappend = genericMappend
instance Monoid Schema where
mempty = genericMempty
mappend = genericMappend
instance Monoid SchemaCommon where
mempty = genericMempty
mappend = genericMappend
instance Monoid Parameter where
mempty = genericMempty
mappend = genericMappend
instance Monoid ParameterOtherSchema 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 SwaggerMonoid Info
instance SwaggerMonoid Paths
instance SwaggerMonoid PathItem
instance SwaggerMonoid Schema
instance SwaggerMonoid SchemaCommon
instance SwaggerMonoid Parameter
instance SwaggerMonoid ParameterOtherSchema
instance SwaggerMonoid Responses
instance SwaggerMonoid Response
instance SwaggerMonoid ExternalDocs
instance SwaggerMonoid Operation
instance SwaggerMonoid MimeList
deriving instance SwaggerMonoid URL
instance SwaggerMonoid SchemaType where
swaggerMempty = SchemaNull
swaggerMappend _ y = y
instance SwaggerMonoid ParameterType where
swaggerMempty = ParamString
swaggerMappend _ y = y
instance SwaggerMonoid ParameterLocation where
swaggerMempty = ParameterQuery
swaggerMappend _ y = y
instance SwaggerMonoid (HashMap Text Schema) where
swaggerMempty = HashMap.empty
swaggerMappend = HashMap.unionWith mappend
instance SwaggerMonoid (HashMap Text (Referenced Schema)) where
swaggerMempty = HashMap.empty
swaggerMappend = HashMap.unionWith swaggerMappend
instance Monoid a => SwaggerMonoid (Referenced a) where
swaggerMempty = Inline mempty
swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
swaggerMappend _ y = y
instance SwaggerMonoid (HashMap Text Parameter) where
swaggerMempty = HashMap.empty
swaggerMappend = HashMap.unionWith mappend
instance SwaggerMonoid (HashMap Text Response) where
swaggerMempty = HashMap.empty
swaggerMappend = flip HashMap.union
instance SwaggerMonoid (HashMap Text SecurityScheme) where
swaggerMempty = HashMap.empty
swaggerMappend = flip HashMap.union
instance SwaggerMonoid (HashMap FilePath PathItem) where
swaggerMempty = HashMap.empty
swaggerMappend = HashMap.unionWith mappend
instance SwaggerMonoid (HashMap HeaderName Header) where
swaggerMempty = HashMap.empty
swaggerMappend = flip HashMap.union
instance SwaggerMonoid (HashMap HttpStatusCode (Referenced Response)) where
swaggerMempty = HashMap.empty
swaggerMappend = flip HashMap.union
instance SwaggerMonoid ParameterSchema where
swaggerMempty = ParameterOther swaggerMempty
swaggerMappend (ParameterBody x) (ParameterBody y) = ParameterBody (swaggerMappend x y)
swaggerMappend (ParameterOther x) (ParameterOther y) = ParameterOther (swaggerMappend x y)
swaggerMappend _ y = y
deriveJSON (jsonPrefix "Parameter") ''ParameterLocation
deriveJSON (jsonPrefix "Param") ''ParameterType
deriveJSON' ''Info
deriveJSON' ''Contact
deriveJSON' ''License
deriveJSON (jsonPrefix "Schema") ''SchemaType
deriveJSON (jsonPrefix "Items") ''ItemsType
deriveJSON (jsonPrefix "ItemsCollection") ''ItemsCollectionFormat
deriveJSON (jsonPrefix "Collection") ''CollectionFormat
deriveJSON (jsonPrefix "ApiKey") ''ApiKeyLocation
deriveJSON (jsonPrefix "apiKey") ''ApiKeyParams
deriveJSON' ''SchemaCommon
deriveJSONDefault ''Scheme
deriveJSON' ''Tag
deriveJSON' ''ExternalDocs
deriveToJSON' ''Operation
deriveToJSON' ''Response
deriveToJSON' ''PathItem
deriveToJSON' ''Xml
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 = 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 = addVersion . genericToJSON (jsonPrefix "")
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 = genericToJSONWithSub "schemaCommon" (jsonPrefix "schema")
instance ToJSON Header where
toJSON = genericToJSONWithSub "common" (jsonPrefix "header")
instance ToJSON Items where
toJSON = genericToJSONWithSub "common" (jsonPrefix "items")
instance ToJSON Host where
toJSON (Host host mport) = toJSON $
case mport of
Nothing -> host
Just port -> host ++ ":" ++ show port
instance ToJSON Paths where
toJSON (Paths m) = toJSON m
instance ToJSON MimeList where
toJSON (MimeList xs) = toJSON (map show xs)
instance ToJSON Parameter where
toJSON = genericToJSONWithSub "schema" (jsonPrefix "parameter")
instance ToJSON ParameterSchema where
toJSON (ParameterBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
toJSON (ParameterOther s) = toJSON s
instance ToJSON ParameterOtherSchema where
toJSON = genericToJSONWithSub "common" (jsonPrefix "parameterOtherSchema")
instance ToJSON SchemaItems where
toJSON (SchemaItemsObject x) = toJSON x
toJSON (SchemaItemsArray xs) = toJSON xs
instance ToJSON Responses where
toJSON (Responses def rs) = toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
instance ToJSON Example where
toJSON = toJSON . Map.mapKeys show . getExample
instance ToJSON Reference where
toJSON (Reference ref) = object [ "$ref" .= ref ]
instance ToJSON a => ToJSON (Referenced a) where
toJSON (Ref ref) = toJSON ref
toJSON (Inline x) = toJSON x
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 "")
`withDefaults` [ "consumes" .= (mempty :: MimeList)
, "produces" .= (mempty :: MimeList)
, "security" .= ([] :: [SecurityRequirement])
, "tags" .= ([] :: [Tag])
, "definitions" .= (mempty :: HashMap Text Schema)
, "parameters" .= (mempty :: HashMap Text Parameter)
, "responses" .= (mempty :: HashMap Text Response)
, "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme)
] ) js
parseJSON _ = empty
instance FromJSON SecurityScheme where
parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
instance FromJSON Schema where
parseJSON = genericParseJSONWithSub "schemaCommon" (jsonPrefix "schema")
`withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
, "required" .= ([] :: [ParamName]) ]
instance FromJSON Header where
parseJSON = genericParseJSONWithSub "common" (jsonPrefix "header")
instance FromJSON Items where
parseJSON = genericParseJSONWithSub "common" (jsonPrefix "items")
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 Paths where
parseJSON js = Paths <$> parseJSON js
instance FromJSON MimeList where
parseJSON js = (MimeList . map fromString) <$> parseJSON js
instance FromJSON Parameter where
parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "parameter")
instance FromJSON ParameterSchema where
parseJSON js@(Object o) = do
(i :: Text) <- o .: "in"
case i of
"body" -> do
schema <- o .: "schema"
ParameterBody <$> parseJSON schema
_ -> ParameterOther <$> parseJSON js
parseJSON _ = empty
instance FromJSON ParameterOtherSchema where
parseJSON = genericParseJSONWithSub "common" (jsonPrefix "parameterOtherSchema")
instance FromJSON SchemaItems where
parseJSON js@(Object _) = SchemaItemsObject <$> parseJSON js
parseJSON js@(Array _) = SchemaItemsArray <$> parseJSON js
parseJSON _ = empty
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]) ]
instance FromJSON PathItem where
parseJSON = genericParseJSON (jsonPrefix "pathItem")
`withDefaults` [ "parameters" .= ([] :: [Parameter]) ]
instance FromJSON Reference where
parseJSON (Object o) = Reference <$> o .: "$ref"
parseJSON _ = empty
instance FromJSON a => FromJSON (Referenced a) where
parseJSON js
= Ref <$> parseJSON js
<|> Inline <$> parseJSON js
instance FromJSON Xml where
parseJSON = genericParseJSON (jsonPrefix "xml")