module Test.Swagger.Types (FullyQualifiedHost
, Seed
, Size
, NormalizedSwagger
, getSwagger
, OperationId
, HttpHeader
, Headers
, HttpRequest(..)
, HttpResponse(..)
, refToMaybe) where
import Control.Arrow
import Control.Lens hiding ((.=))
import Data.Aeson
import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive
import Data.Generics
import qualified Data.HashMap.Lazy as HM
import qualified Data.HashMap.Strict.InsOrd as M
import Data.Monoid ((<>))
import Data.Swagger hiding (prependPath)
import qualified Data.Text as T
import Data.Text.Encoding
import Network.HTTP.Types
import System.FilePath.Posix
type FullyQualifiedHost = String
type Seed = Int
type Size = Int
type OperationId = T.Text
type HttpHeader = (CI T.Text, T.Text)
type Headers = [HttpHeader]
data HttpRequest = HttpRequest { requestHost :: Maybe FullyQualifiedHost
, requestMethod :: Method
, requestPath :: T.Text
, requestQuery :: QueryText
, requestHeaders :: Headers
, requestBody :: Maybe LBS.ByteString }
deriving (Eq, Show)
instance ToJSON HttpRequest where
toJSON r = object [ "host" .= toJSON (requestHost r)
, "method" .= toJSON (decodeUtf8 $ requestMethod r)
, "path" .= toJSON (requestPath r)
, "query" .= toJSON (requestQuery r)
, "headers" .= toJSON headersMap
, "body" .= toJSON (decodeUtf8 . LBS.toStrict <$> requestBody r) ]
where
headersMap = HM.fromList $ first original <$> requestHeaders r
data HttpResponse = HttpResponse { responseHttpVersion :: HttpVersion
, responseStatus :: Status
, responseHeaders :: Headers
, responseBody :: Maybe LBS.ByteString }
deriving (Eq, Show)
instance ToJSON HttpResponse where
toJSON r = object [ "version" .= object [ "major" .= toJSON (httpMajor ver)
, "minor" .= toJSON (httpMinor ver)]
, "status" .= object [ "code" .= toJSON (statusCode st)
, "message" .= toJSON (decodeUtf8 $ statusMessage st) ]
, "headers" .= toJSON headersMap
, "body" .= toJSON (decodeUtf8 . LBS.toStrict <$> responseBody r) ]
where
ver = responseHttpVersion r
st = responseStatus r
headersMap = M.fromList $ first original <$> responseHeaders r
newtype NormalizedSwagger = Normalized { getSwagger :: Swagger }
instance FromJSON NormalizedSwagger where
parseJSON = fmap (Normalized . resolveReferences . prependBase) . parseJSON
where
prependBase :: Swagger -> Swagger
prependBase s =
maybe s (`prependPath` s) (s ^. basePath) & basePath .~ Nothing
resolveReferences :: Swagger -> Swagger
resolveReferences s = everywhere' (mkT resolveSchema) $ everywhere' (mkT resolveParam) s
where
resolveParam :: Referenced Param -> Referenced Param
resolveParam i@Inline {} = i
resolveParam (Ref (Reference r)) = maybe (error $ "undefied schema: " <> T.unpack r) Inline
$ M.lookup r $ s ^. parameters
resolveSchema :: Referenced Schema -> Referenced Schema
resolveSchema i@Inline {} = i
resolveSchema (Ref (Reference r)) = maybe (error $ "undefied schema: " <> T.unpack r) Inline
$ M.lookup r $ s ^. definitions
prependPath :: FilePath -> Swagger -> Swagger
prependPath path = paths %~ M.mapKeys (\x -> path </> dropWhile (== '/') x)
refToMaybe :: Referenced a -> Maybe a
refToMaybe (Inline i) = Just i
refToMaybe (Ref _) = Nothing