@@ -3,20 +3,28 @@
33{-# LANGUAGE GeneralizedNewtypeDeriving #-}
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
67{-# LANGUAGE TemplateHaskell #-}
78module Data.Swagger.Internal where
89
10+import Control.Applicative
11+import Control.Monad
912import Data.Aeson
10−import Data.Aeson.TH (deriveToJSON)
13+import Data.Aeson.TH (deriveJSON)
1114import Data.Foldable (Foldable)
1215import Data.HashMap.Strict (HashMap)
1316import qualified Data.HashMap.Strict as HashMap
17+import Data.Map (Map)
18+import qualified Data.Map as Map
19+import Data.String (fromString)
1420import Data.Text (Text)
21+import qualified Data.Text as Text
1522import Data.Traversable (Traversable)
1623import Data.Hashable (Hashable)
1724import GHC.Generics (Generic)
1825import Network (HostName, PortNumber)
1926import Network.HTTP.Media (MediaType)
27+import Text.Read (readMaybe)
2028
2129import Data.Swagger.Internal.Utils
2230
@@ -133,12 +141,6 @@ data SwaggerHost = SwaggerHost
133141 , swaggerHostPort :: Maybe PortNumber -- ^ Optional port.
134142 } deriving (Show)
135143
136−instance ToJSON SwaggerHost where
137− toJSON (SwaggerHost host mport) = toJSON $
138− case mport of
139− Nothing -> host
140− Just port -> host ++ ":" ++ show port
141−
142144-- | The transfer protocol of the API.
143145data SwaggerScheme
144146 = Http
@@ -154,9 +156,6 @@ data SwaggerPaths = SwaggerPaths
154156 swaggerPathsMap :: HashMap FilePath SwaggerPathItem
155157 } deriving (Show)
156158
157−instance ToJSON SwaggerPaths where
158− toJSON (SwaggerPaths m) = toJSON m
159−
160159-- | Describes the operations available on a single path.
161160-- A @'SwaggerPathItem'@ may be empty, due to ACL constraints.
162161-- The path itself is still exposed to the documentation viewer
@@ -253,9 +252,6 @@ data SwaggerOperation = SwaggerOperation
253252newtype SwaggerMimeList = SwaggerMimeList { getSwaggerMimeList :: [MediaType] }
254253 deriving (Show)
255254
256−instance ToJSON SwaggerMimeList where
257− toJSON (SwaggerMimeList xs) = toJSON (map show xs)
258−
259255-- | Describes a single operation parameter.
260256-- A unique parameter is defined by a combination of a name and location.
261257data SwaggerParameter = SwaggerParameter
@@ -277,18 +273,11 @@ data SwaggerParameter = SwaggerParameter
277273 , swaggerParameterSchema :: SwaggerParameterSchema
278274 } deriving (Show, Generic)
279275
280−instance ToJSON SwaggerParameter where
281− toJSON = genericToJSONWithSub "schema" (jsonPrefix "swaggerParameter")
282−
283276data SwaggerParameterSchema
284277 = SwaggerParameterBody SwaggerSchema
285278 | SwaggerParameterOther SwaggerParameterOtherSchema
286279 deriving (Show)
287280
288−instance ToJSON SwaggerParameterSchema where
289− toJSON (SwaggerParameterBody s) = toJSON s <+> object [ "in" .= ("body" :: Text) ]
290− toJSON (SwaggerParameterOther s) = toJSON s
291−
292281data SwaggerParameterOtherSchema = SwaggerParameterOtherSchema
293282 { -- | The location of the parameter.
294283 swaggerParameterOtherSchemaIn :: SwaggerParameterLocation
@@ -321,9 +310,6 @@ data SwaggerParameterOtherSchema = SwaggerParameterOtherSchema
321310 , swaggerParameterOtherSchemaCommon :: SwaggerSchemaCommon
322311 } deriving (Show, Generic)
323312
324−instance ToJSON SwaggerParameterOtherSchema where
325− toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerParameterOtherSchema")
326−
327313data SwaggerParameterType
328314 = SwaggerParamString
329315 | SwaggerParamNumber
@@ -421,10 +407,6 @@ data SwaggerSchemaItems
421407 | SwaggerSchemaItemsArray [SwaggerSchema]
422408 deriving (Show)
423409
424−instance ToJSON SwaggerSchemaItems where
425− toJSON (SwaggerSchemaItemsObject x) = toJSON x
426− toJSON (SwaggerSchemaItemsArray xs) = toJSON xs
427−
428410data SwaggerSchemaCommon = SwaggerSchemaCommon
429411 { -- | Declares the value of the parameter that the server will use if none is provided,
430412 -- for example a @"count"@ to control the number of results per page might default to @100@
@@ -508,11 +490,6 @@ data SwaggerResponses = SwaggerResponses
508490 , swaggerResponsesResponses :: HashMap HttpStatusCode SwaggerResponse
509491 } deriving (Show)
510492
511−instance ToJSON SwaggerResponses where
512− toJSON (SwaggerResponses def rs) = object
513− [ "default" .= def
514− , "responses" .= hashMapMapKeys show rs ]
515−
516493type HttpStatusCode = Int
517494
518495-- | Describes a single response from an API Operation.
@@ -558,12 +535,9 @@ data SwaggerHeader = SwaggerHeader
558535 , swaggerHeaderCommon :: SwaggerSchemaCommon
559536 } deriving (Show, Generic)
560537
561−data SwaggerExample = SwaggerExample { getSwaggerExample :: HashMap MediaType Value }
538+data SwaggerExample = SwaggerExample { getSwaggerExample :: Map MediaType Value }
562539 deriving (Show)
563540
564−instance ToJSON SwaggerExample where
565− toJSON = toJSON . hashMapMapKeys show . getSwaggerExample
566−
567541-- | The location of the API key.
568542data SwaggerApiKeyLocation
569543 = SwaggerApiKeyQuery
@@ -611,10 +585,16 @@ data SwaggerSecuritySchemeTypeName
611585 | SwaggerSecuritySchemeTypeOAuth2
612586 deriving (Eq, Read, Show, Generic)
613587
614−swaggerSecuritySchemeTypeNameText :: SwaggerSecuritySchemeTypeName -> Text
615−swaggerSecuritySchemeTypeNameText SwaggerSecuritySchemeTypeBasic = "basic"
616−swaggerSecuritySchemeTypeNameText SwaggerSecuritySchemeTypeApiKey = "apiKey"
617−swaggerSecuritySchemeTypeNameText SwaggerSecuritySchemeTypeOAuth2 = "oauth2"
588+swaggerSecuritySchemeTypeNameToText :: SwaggerSecuritySchemeTypeName -> Text
589+swaggerSecuritySchemeTypeNameToText SwaggerSecuritySchemeTypeBasic = "basic"
590+swaggerSecuritySchemeTypeNameToText SwaggerSecuritySchemeTypeApiKey = "apiKey"
591+swaggerSecuritySchemeTypeNameToText SwaggerSecuritySchemeTypeOAuth2 = "oauth2"
592+
593+swaggerSecuritySchemeTypeNameFromText :: Alternative f => Text -> f SwaggerSecuritySchemeTypeName
594+swaggerSecuritySchemeTypeNameFromText "basic" = pure SwaggerSecuritySchemeTypeBasic
595+swaggerSecuritySchemeTypeNameFromText "apiKey" = pure SwaggerSecuritySchemeTypeApiKey
596+swaggerSecuritySchemeTypeNameFromText "oauth2" = pure SwaggerSecuritySchemeTypeOAuth2
597+swaggerSecuritySchemeTypeNameFromText _ = empty
618598
619599instance Hashable SwaggerSecuritySchemeTypeName
620600
@@ -633,9 +613,6 @@ newtype SwaggerSecurityRequirement = SwaggerSecurityRequirement
633613 { getSwaggerSecurityRequirement :: HashMap SwaggerSecuritySchemeTypeName Text
634614 } deriving (Eq, Read, Show, Monoid)
635615
636−instance ToJSON SwaggerSecurityRequirement where
637− toJSON (SwaggerSecurityRequirement m) = toJSON (hashMapMapKeys swaggerSecuritySchemeTypeNameText m)
638−
639616-- | Allows adding meta data to a single tag that is used by @SwaggerOperation@.
640617-- It is not mandatory to have a @SwaggerTag@ per tag used there.
641618data SwaggerTag = SwaggerTag
@@ -662,26 +639,34 @@ data SwaggerExternalDocs = SwaggerExternalDocs
662639
663640newtype URL = URL { getUrl :: Text } deriving (Show, ToJSON, FromJSON)
664641
665−deriveToJSON' ''SwaggerOperation
666−deriveToJSON (jsonPrefix "SwaggerParameter") ''SwaggerParameterLocation
667−deriveToJSON (jsonPrefix "SwaggerParam") ''SwaggerParameterType
668−deriveToJSON' ''SwaggerPathItem
669−deriveToJSON' ''SwaggerInfo
670−deriveToJSON' ''SwaggerContact
671−deriveToJSON' ''SwaggerLicense
672−deriveToJSON (jsonPrefix "SwaggerSchema") ''SwaggerSchemaType
673−deriveToJSON (jsonPrefix "SwaggerItems") ''SwaggerItemsType
674−deriveToJSON (jsonPrefix "SwaggerItemsCollection") ''SwaggerItemsCollectionFormat
675−deriveToJSON (jsonPrefix "SwaggerCollection") ''SwaggerCollectionFormat
676−deriveToJSON (jsonPrefix "SwaggerSecuritySchemeType") ''SwaggerSecuritySchemeTypeName
677−deriveToJSON (jsonPrefix "SwaggerApiKey") ''SwaggerApiKeyLocation
678−deriveToJSON (jsonPrefix "swaggerApiKey") ''SwaggerApiKeyParams
679−deriveToJSON' ''SwaggerResponse
680−deriveToJSON' ''SwaggerSchemaCommon
681−deriveToJSONDefault ''SwaggerScheme
682−deriveToJSON' ''SwaggerTag
683−deriveToJSON' ''SwaggerExternalDocs
684−deriveToJSON' ''SwaggerXml
642+-- =======================================================================
643+-- TH derived ToJSON and FromJSON instances
644+-- =======================================================================
645+
646+deriveJSON' ''SwaggerOperation
647+deriveJSON (jsonPrefix "SwaggerParameter") ''SwaggerParameterLocation
648+deriveJSON (jsonPrefix "SwaggerParam") ''SwaggerParameterType
649+deriveJSON' ''SwaggerPathItem
650+deriveJSON' ''SwaggerInfo
651+deriveJSON' ''SwaggerContact
652+deriveJSON' ''SwaggerLicense
653+deriveJSON (jsonPrefix "SwaggerSchema") ''SwaggerSchemaType
654+deriveJSON (jsonPrefix "SwaggerItems") ''SwaggerItemsType
655+deriveJSON (jsonPrefix "SwaggerItemsCollection") ''SwaggerItemsCollectionFormat
656+deriveJSON (jsonPrefix "SwaggerCollection") ''SwaggerCollectionFormat
657+deriveJSON (jsonPrefix "SwaggerSecuritySchemeType") ''SwaggerSecuritySchemeTypeName
658+deriveJSON (jsonPrefix "SwaggerApiKey") ''SwaggerApiKeyLocation
659+deriveJSON (jsonPrefix "swaggerApiKey") ''SwaggerApiKeyParams
660+deriveJSON' ''SwaggerResponse
661+deriveJSON' ''SwaggerSchemaCommon
662+deriveJSONDefault ''SwaggerScheme
663+deriveJSON' ''SwaggerTag
664+deriveJSON' ''SwaggerExternalDocs
665+deriveJSON' ''SwaggerXml
666+
667+-- =======================================================================
668+-- Manual ToJSON instances
669+-- =======================================================================
685670
686671instance ToJSON SwaggerOAuth2Flow where
687672 toJSON (SwaggerOAuth2Implicit authUrl) = object
@@ -729,3 +714,139 @@ instance ToJSON SwaggerHeader where
729714instance ToJSON SwaggerItems where
730715 toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerItems")
731716
717+instance ToJSON SwaggerHost where
718+ toJSON (SwaggerHost host mport) = toJSON $
719+ case mport of
720+ Nothing -> host
721+ Just port -> host ++ ":" ++ show port
722+
723+instance ToJSON SwaggerPaths where
724+ toJSON (SwaggerPaths m) = toJSON m
725+
726+instance ToJSON SwaggerMimeList where
727+ toJSON (SwaggerMimeList xs) = toJSON (map show xs)
728+
729+instance ToJSON SwaggerParameter where
730+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "swaggerParameter")
731+
732+instance ToJSON SwaggerParameterSchema where
733+ toJSON (SwaggerParameterBody s) = toJSON s <+> object [ "in" .= ("body" :: Text) ]
734+ toJSON (SwaggerParameterOther s) = toJSON s
735+
736+instance ToJSON SwaggerParameterOtherSchema where
737+ toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerParameterOtherSchema")
738+
739+instance ToJSON SwaggerSchemaItems where
740+ toJSON (SwaggerSchemaItemsObject x) = toJSON x
741+ toJSON (SwaggerSchemaItemsArray xs) = toJSON xs
742+
743+instance ToJSON SwaggerResponses where
744+ toJSON (SwaggerResponses def rs) = object
745+ [ "default" .= def
746+ , "responses" .= hashMapMapKeys show rs ]
747+
748+instance ToJSON SwaggerExample where
749+ toJSON = toJSON . Map.mapKeys show . getSwaggerExample
750+
751+instance ToJSON SwaggerSecurityRequirement where
752+ toJSON (SwaggerSecurityRequirement m) = toJSON (hashMapMapKeys swaggerSecuritySchemeTypeNameToText m)
753+
754+-- =======================================================================
755+-- Manual FromJSON instances
756+-- =======================================================================
757+
758+instance FromJSON SwaggerOAuth2Flow where
759+ parseJSON (Object o) = do
760+ (flow :: Text) <- o .: "flow"
761+ case flow of
762+ "implicit" -> SwaggerOAuth2Implicit <$> o .: "authorizationUrl"
763+ "password" -> SwaggerOAuth2Password <$> o .: "tokenUrl"
764+ "application" -> SwaggerOAuth2Application <$> o .: "tokenUrl"
765+ "accessCode" -> SwaggerOAuth2AccessCode
766+ <$> o .: "authorizationUrl"
767+ <*> o .: "tokenUrl"
768+ _ -> empty
769+ parseJSON _ = empty
770+
771+instance FromJSON SwaggerOAuth2Params where
772+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "swaggerOAuth2")
773+
774+instance FromJSON SwaggerSecuritySchemeType where
775+ parseJSON json@(Object o) = do
776+ t <- o .: "type"
777+ case t of
778+ SwaggerSecuritySchemeTypeBasic -> pure SwaggerSecuritySchemeBasic
779+ SwaggerSecuritySchemeTypeApiKey -> SwaggerSecuritySchemeApiKey <$> parseJSON json
780+ SwaggerSecuritySchemeTypeOAuth2 -> SwaggerSecuritySchemeOAuth2 <$> parseJSON json
781+ parseJSON _ = empty
782+
783+instance FromJSON Swagger where
784+ parseJSON json@(Object o) = do
785+ (version :: Text) <- o .: "swagger"
786+ when (version /= "2.0") empty
787+ genericParseJSON (jsonPrefix "swagger") json
788+ parseJSON _ = empty
789+
790+instance FromJSON SwaggerSecurityScheme where
791+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "swaggerSecurityScheme")
792+
793+instance FromJSON SwaggerSchema where
794+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerSchema")
795+
796+instance FromJSON SwaggerHeader where
797+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerHeader")
798+
799+instance FromJSON SwaggerItems where
800+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerItems")
801+
802+instance FromJSON SwaggerHost where
803+ parseJSON (String s) =
804+ case fromInteger <$> readMaybe portStr of
805+ Nothing | not (null portStr) -> empty
806+ mport -> pure $ SwaggerHost host mport
807+ where
808+ (hostText, portText) = Text.breakOnEnd ":" s
809+ [host, portStr] = map Text.unpack [hostText, portText]
810+ parseJSON _ = empty
811+
812+instance FromJSON SwaggerPaths where
813+ parseJSON json = SwaggerPaths <$> parseJSON json
814+
815+instance FromJSON SwaggerMimeList where
816+ parseJSON json = (SwaggerMimeList . map fromString) <$> parseJSON json
817+
818+instance FromJSON SwaggerParameter where
819+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "swaggerParameter")
820+
821+instance FromJSON SwaggerParameterSchema where
822+ parseJSON json@(Object o) = do
823+ (i :: Text) <- o .: "in"
824+ case i of
825+ "body" -> SwaggerParameterBody <$> parseJSON json
826+ _ -> SwaggerParameterOther <$> parseJSON json
827+ parseJSON _ = empty
828+
829+instance FromJSON SwaggerParameterOtherSchema where
830+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerParameterOtherSchema")
831+
832+instance FromJSON SwaggerSchemaItems where
833+ parseJSON json@(Object _) = SwaggerSchemaItemsObject <$> parseJSON json
834+ parseJSON json@(Array _) = SwaggerSchemaItemsArray <$> parseJSON json
835+ parseJSON _ = empty
836+
837+instance FromJSON SwaggerResponses where
838+ parseJSON (Object o) = SwaggerResponses
839+ <$> o .: "default"
840+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
841+ parseJSON _ = empty
842+
843+instance FromJSON SwaggerExample where
844+ parseJSON json = do
845+ m <- parseJSON json
846+ pure $ SwaggerExample (Map.mapKeys fromString m)
847+
848+instance FromJSON SwaggerSecurityRequirement where
849+ parseJSON json = do
850+ m <- parseJSON json
851+ SwaggerSecurityRequirement <$> hashMapTraverseKeys swaggerSecuritySchemeTypeNameFromText m
852+