module SwaggerPetstore.Core where
import SwaggerPetstore.MimeTypes
import SwaggerPetstore.Logging
import qualified Control.Arrow as P (left)
import qualified Control.DeepSeq as NF
import qualified Control.Exception.Safe as E
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64.Lazy as BL64
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BCL
import qualified Data.CaseInsensitive as CI
import qualified Data.Data as P (Data, Typeable, TypeRep, typeRep)
import qualified Data.Foldable as P
import qualified Data.Ix as P
import qualified Data.Maybe as P
import qualified Data.Proxy as P (Proxy(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Time as TI
import qualified Data.Time.ISO8601 as TI
import qualified GHC.Base as P (Alternative)
import qualified Lens.Micro as L
import qualified Network.HTTP.Client.MultipartFormData as NH
import qualified Network.HTTP.Types as NH
import qualified Prelude as P
import qualified Web.FormUrlEncoded as WH
import qualified Web.HttpApiData as WH
import qualified Text.Printf as T
import Control.Applicative ((<|>))
import Control.Applicative (Alternative)
import Data.Function ((&))
import Data.Foldable(foldlM)
import Data.Monoid ((<>))
import Data.Text (Text)
import Prelude (($), (.), (<$>), (<*>), Maybe(..), Bool(..), Char, String, fmap, mempty, pure, return, show, IO, Monad, Functor)
data SwaggerPetstoreConfig = SwaggerPetstoreConfig
{ configHost :: BCL.ByteString
, configUserAgent :: Text
, configLogExecWithContext :: LogExecWithContext
, configLogContext :: LogContext
, configAuthMethods :: [AnyAuthMethod]
, configValidateAuthMethods :: Bool
}
instance P.Show SwaggerPetstoreConfig where
show c =
T.printf
"{ configHost = %v, configUserAgent = %v, ..}"
(show (configHost c))
(show (configUserAgent c))
newConfig :: IO SwaggerPetstoreConfig
newConfig = do
logCxt <- initLogContext
return $ SwaggerPetstoreConfig
{ configHost = "http://petstore.swagger.io:80/v2"
, configUserAgent = "swagger-haskell-http-client/1.0.0"
, configLogExecWithContext = runDefaultLogExecWithContext
, configLogContext = logCxt
, configAuthMethods = []
, configValidateAuthMethods = True
}
addAuthMethod :: AuthMethod auth => SwaggerPetstoreConfig -> auth -> SwaggerPetstoreConfig
addAuthMethod config@SwaggerPetstoreConfig {configAuthMethods = as} a =
config { configAuthMethods = AnyAuthMethod a : as}
withStdoutLogging :: SwaggerPetstoreConfig -> IO SwaggerPetstoreConfig
withStdoutLogging p = do
logCxt <- stdoutLoggingContext (configLogContext p)
return $ p { configLogExecWithContext = stdoutLoggingExec, configLogContext = logCxt }
withStderrLogging :: SwaggerPetstoreConfig -> IO SwaggerPetstoreConfig
withStderrLogging p = do
logCxt <- stderrLoggingContext (configLogContext p)
return $ p { configLogExecWithContext = stderrLoggingExec, configLogContext = logCxt }
withNoLogging :: SwaggerPetstoreConfig -> SwaggerPetstoreConfig
withNoLogging p = p { configLogExecWithContext = runNullLogExec}
data SwaggerPetstoreRequest req contentType res accept = SwaggerPetstoreRequest
{ rMethod :: NH.Method
, rUrlPath :: [BCL.ByteString]
, rParams :: Params
, rAuthTypes :: [P.TypeRep]
}
deriving (P.Show)
rMethodL :: Lens_' (SwaggerPetstoreRequest req contentType res accept) NH.Method
rMethodL f SwaggerPetstoreRequest{..} = (\rMethod -> SwaggerPetstoreRequest { rMethod, ..} ) <$> f rMethod
rUrlPathL :: Lens_' (SwaggerPetstoreRequest req contentType res accept) [BCL.ByteString]
rUrlPathL f SwaggerPetstoreRequest{..} = (\rUrlPath -> SwaggerPetstoreRequest { rUrlPath, ..} ) <$> f rUrlPath
rParamsL :: Lens_' (SwaggerPetstoreRequest req contentType res accept) Params
rParamsL f SwaggerPetstoreRequest{..} = (\rParams -> SwaggerPetstoreRequest { rParams, ..} ) <$> f rParams
rAuthTypesL :: Lens_' (SwaggerPetstoreRequest req contentType res accept) [P.TypeRep]
rAuthTypesL f SwaggerPetstoreRequest{..} = (\rAuthTypes -> SwaggerPetstoreRequest { rAuthTypes, ..} ) <$> f rAuthTypes
class HasBodyParam req param where
setBodyParam :: forall contentType res accept. (Consumes req contentType, MimeRender contentType param) => SwaggerPetstoreRequest req contentType res accept -> param -> SwaggerPetstoreRequest req contentType res accept
setBodyParam req xs =
req `_setBodyLBS` mimeRender (P.Proxy :: P.Proxy contentType) xs & _setContentTypeHeader
class HasOptionalParam req param where
applyOptionalParam :: SwaggerPetstoreRequest req contentType res accept -> param -> SwaggerPetstoreRequest req contentType res accept
applyOptionalParam = (-&-)
(-&-) :: SwaggerPetstoreRequest req contentType res accept -> param -> SwaggerPetstoreRequest req contentType res accept
(-&-) = applyOptionalParam
infixl 2 -&-
data Params = Params
{ paramsQuery :: NH.Query
, paramsHeaders :: NH.RequestHeaders
, paramsBody :: ParamBody
}
deriving (P.Show)
paramsQueryL :: Lens_' Params NH.Query
paramsQueryL f Params{..} = (\paramsQuery -> Params { paramsQuery, ..} ) <$> f paramsQuery
paramsHeadersL :: Lens_' Params NH.RequestHeaders
paramsHeadersL f Params{..} = (\paramsHeaders -> Params { paramsHeaders, ..} ) <$> f paramsHeaders
paramsBodyL :: Lens_' Params ParamBody
paramsBodyL f Params{..} = (\paramsBody -> Params { paramsBody, ..} ) <$> f paramsBody
data ParamBody
= ParamBodyNone
| ParamBodyB B.ByteString
| ParamBodyBL BL.ByteString
| ParamBodyFormUrlEncoded WH.Form
| ParamBodyMultipartFormData [NH.Part]
deriving (P.Show)
_mkRequest :: NH.Method
-> [BCL.ByteString]
-> SwaggerPetstoreRequest req contentType res accept
_mkRequest m u = SwaggerPetstoreRequest m u _mkParams []
_mkParams :: Params
_mkParams = Params [] [] ParamBodyNone
setHeader :: SwaggerPetstoreRequest req contentType res accept -> [NH.Header] -> SwaggerPetstoreRequest req contentType res accept
setHeader req header =
req `removeHeader` P.fmap P.fst header &
L.over (rParamsL . paramsHeadersL) (header P.++)
removeHeader :: SwaggerPetstoreRequest req contentType res accept -> [NH.HeaderName] -> SwaggerPetstoreRequest req contentType res accept
removeHeader req header =
req &
L.over
(rParamsL . paramsHeadersL)
(P.filter (\h -> cifst h `P.notElem` P.fmap CI.mk header))
where
cifst = CI.mk . P.fst
_setContentTypeHeader :: forall req contentType res accept. MimeType contentType => SwaggerPetstoreRequest req contentType res accept -> SwaggerPetstoreRequest req contentType res accept
_setContentTypeHeader req =
case mimeType (P.Proxy :: P.Proxy contentType) of
Just m -> req `setHeader` [("content-type", BC.pack $ P.show m)]
Nothing -> req `removeHeader` ["content-type"]
_setAcceptHeader :: forall req contentType res accept. MimeType accept => SwaggerPetstoreRequest req contentType res accept -> SwaggerPetstoreRequest req contentType res accept
_setAcceptHeader req =
case mimeType (P.Proxy :: P.Proxy accept) of
Just m -> req `setHeader` [("accept", BC.pack $ P.show m)]
Nothing -> req `removeHeader` ["accept"]
setQuery :: SwaggerPetstoreRequest req contentType res accept -> [NH.QueryItem] -> SwaggerPetstoreRequest req contentType res accept
setQuery req query =
req &
L.over
(rParamsL . paramsQueryL)
((query P.++) . P.filter (\q -> cifst q `P.notElem` P.fmap cifst query))
where
cifst = CI.mk . P.fst
addForm :: SwaggerPetstoreRequest req contentType res accept -> WH.Form -> SwaggerPetstoreRequest req contentType res accept
addForm req newform =
let form = case paramsBody (rParams req) of
ParamBodyFormUrlEncoded _form -> _form
_ -> mempty
in req & L.set (rParamsL . paramsBodyL) (ParamBodyFormUrlEncoded (newform <> form))
_addMultiFormPart :: SwaggerPetstoreRequest req contentType res accept -> NH.Part -> SwaggerPetstoreRequest req contentType res accept
_addMultiFormPart req newpart =
let parts = case paramsBody (rParams req) of
ParamBodyMultipartFormData _parts -> _parts
_ -> []
in req & L.set (rParamsL . paramsBodyL) (ParamBodyMultipartFormData (newpart : parts))
_setBodyBS :: SwaggerPetstoreRequest req contentType res accept -> B.ByteString -> SwaggerPetstoreRequest req contentType res accept
_setBodyBS req body =
req & L.set (rParamsL . paramsBodyL) (ParamBodyB body)
_setBodyLBS :: SwaggerPetstoreRequest req contentType res accept -> BL.ByteString -> SwaggerPetstoreRequest req contentType res accept
_setBodyLBS req body =
req & L.set (rParamsL . paramsBodyL) (ParamBodyBL body)
_hasAuthType :: AuthMethod authMethod => SwaggerPetstoreRequest req contentType res accept -> P.Proxy authMethod -> SwaggerPetstoreRequest req contentType res accept
_hasAuthType req proxy =
req & L.over rAuthTypesL (P.typeRep proxy :)
toPath
:: WH.ToHttpApiData a
=> a -> BCL.ByteString
toPath = BB.toLazyByteString . WH.toEncodedUrlPiece
toHeader :: WH.ToHttpApiData a => (NH.HeaderName, a) -> [NH.Header]
toHeader x = [fmap WH.toHeader x]
toForm :: WH.ToHttpApiData v => (BC.ByteString, v) -> WH.Form
toForm (k,v) = WH.toForm [(BC.unpack k,v)]
toQuery :: WH.ToHttpApiData a => (BC.ByteString, Maybe a) -> [NH.QueryItem]
toQuery x = [(fmap . fmap) toQueryParam x]
where toQueryParam = T.encodeUtf8 . WH.toQueryParam
data CollectionFormat
= CommaSeparated
| SpaceSeparated
| TabSeparated
| PipeSeparated
| MultiParamArray
toHeaderColl :: WH.ToHttpApiData a => CollectionFormat -> (NH.HeaderName, [a]) -> [NH.Header]
toHeaderColl c xs = _toColl c toHeader xs
toFormColl :: WH.ToHttpApiData v => CollectionFormat -> (BC.ByteString, [v]) -> WH.Form
toFormColl c xs = WH.toForm $ fmap unpack $ _toColl c toHeader $ pack xs
where
pack (k,v) = (CI.mk k, v)
unpack (k,v) = (BC.unpack (CI.original k), BC.unpack v)
toQueryColl :: WH.ToHttpApiData a => CollectionFormat -> (BC.ByteString, Maybe [a]) -> NH.Query
toQueryColl c xs = _toCollA c toQuery xs
_toColl :: P.Traversable f => CollectionFormat -> (f a -> [(b, BC.ByteString)]) -> f [a] -> [(b, BC.ByteString)]
_toColl c encode xs = fmap (fmap P.fromJust) (_toCollA' c fencode BC.singleton (fmap Just xs))
where fencode = fmap (fmap Just) . encode . fmap P.fromJust
_toCollA :: (P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t BC.ByteString)]) -> f (t [a]) -> [(b, t BC.ByteString)]
_toCollA c encode xs = _toCollA' c encode BC.singleton xs
_toCollA' :: (P.Monoid c, P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t c)]) -> (Char -> c) -> f (t [a]) -> [(b, t c)]
_toCollA' c encode one xs = case c of
CommaSeparated -> go (one ',')
SpaceSeparated -> go (one ' ')
TabSeparated -> go (one '\t')
PipeSeparated -> go (one '|')
MultiParamArray -> expandList
where
go sep =
[P.foldl1 (\(sk, sv) (_, v) -> (sk, (combine sep <$> sv <*> v) <|> sv <|> v)) expandList]
combine sep x y = x <> sep <> y
expandList = (P.concatMap encode . (P.traverse . P.traverse) P.toList) xs
class P.Typeable a =>
AuthMethod a where
applyAuthMethod
:: SwaggerPetstoreConfig
-> a
-> SwaggerPetstoreRequest req contentType res accept
-> IO (SwaggerPetstoreRequest req contentType res accept)
data AnyAuthMethod = forall a. AuthMethod a => AnyAuthMethod a deriving (P.Typeable)
instance AuthMethod AnyAuthMethod where applyAuthMethod config (AnyAuthMethod a) req = applyAuthMethod config a req
data AuthMethodException = AuthMethodException String deriving (P.Show, P.Typeable)
instance E.Exception AuthMethodException
_applyAuthMethods
:: SwaggerPetstoreRequest req contentType res accept
-> SwaggerPetstoreConfig
-> IO (SwaggerPetstoreRequest req contentType res accept)
_applyAuthMethods req config@(SwaggerPetstoreConfig {configAuthMethods = as}) =
foldlM go req as
where
go r (AnyAuthMethod a) = applyAuthMethod config a r
_omitNulls :: [(Text, A.Value)] -> A.Value
_omitNulls = A.object . P.filter notNull
where
notNull (_, A.Null) = False
notNull _ = True
_toFormItem :: (WH.ToHttpApiData a, Functor f) => t -> f a -> f (t, [Text])
_toFormItem name x = (name,) . (:[]) . WH.toQueryParam <$> x
_emptyToNothing :: Maybe String -> Maybe String
_emptyToNothing (Just "") = Nothing
_emptyToNothing x = x
_memptyToNothing :: (P.Monoid a, P.Eq a) => Maybe a -> Maybe a
_memptyToNothing (Just x) | x P.== P.mempty = Nothing
_memptyToNothing x = x
newtype DateTime = DateTime { unDateTime :: TI.UTCTime }
deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData,TI.ParseTime,TI.FormatTime)
instance A.FromJSON DateTime where
parseJSON = A.withText "DateTime" (_readDateTime . T.unpack)
instance A.ToJSON DateTime where
toJSON (DateTime t) = A.toJSON (_showDateTime t)
instance WH.FromHttpApiData DateTime where
parseUrlPiece = P.left T.pack . _readDateTime . T.unpack
instance WH.ToHttpApiData DateTime where
toUrlPiece (DateTime t) = T.pack (_showDateTime t)
instance P.Show DateTime where
show (DateTime t) = _showDateTime t
instance MimeRender MimeMultipartFormData DateTime where
mimeRender _ = mimeRenderDefaultMultipartFormData
_readDateTime :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t
_readDateTime =
_parseISO8601
_showDateTime :: (t ~ TI.UTCTime, TI.FormatTime t) => t -> String
_showDateTime =
TI.formatISO8601Millis
_parseISO8601 :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t
_parseISO8601 t =
P.asum $
P.flip (TI.parseTimeM True TI.defaultTimeLocale) t <$>
["%FT%T%QZ", "%FT%T%Q%z", "%FT%T%Q%Z"]
newtype Date = Date { unDate :: TI.Day }
deriving (P.Enum,P.Eq,P.Data,P.Ord,P.Ix,NF.NFData,TI.ParseTime,TI.FormatTime)
instance A.FromJSON Date where
parseJSON = A.withText "Date" (_readDate . T.unpack)
instance A.ToJSON Date where
toJSON (Date t) = A.toJSON (_showDate t)
instance WH.FromHttpApiData Date where
parseUrlPiece = P.left T.pack . _readDate . T.unpack
instance WH.ToHttpApiData Date where
toUrlPiece (Date t) = T.pack (_showDate t)
instance P.Show Date where
show (Date t) = _showDate t
instance MimeRender MimeMultipartFormData Date where
mimeRender _ = mimeRenderDefaultMultipartFormData
_readDate :: (TI.ParseTime t, Monad m) => String -> m t
_readDate =
TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d"
_showDate :: TI.FormatTime t => t -> String
_showDate =
TI.formatTime TI.defaultTimeLocale "%Y-%m-%d"
newtype ByteArray = ByteArray { unByteArray :: BL.ByteString }
deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData)
instance A.FromJSON ByteArray where
parseJSON = A.withText "ByteArray" _readByteArray
instance A.ToJSON ByteArray where
toJSON = A.toJSON . _showByteArray
instance WH.FromHttpApiData ByteArray where
parseUrlPiece = P.left T.pack . _readByteArray
instance WH.ToHttpApiData ByteArray where
toUrlPiece = _showByteArray
instance P.Show ByteArray where
show = T.unpack . _showByteArray
instance MimeRender MimeMultipartFormData ByteArray where
mimeRender _ = mimeRenderDefaultMultipartFormData
_readByteArray :: Monad m => Text -> m ByteArray
_readByteArray = P.either P.fail (pure . ByteArray) . BL64.decode . BL.fromStrict . T.encodeUtf8
_showByteArray :: ByteArray -> Text
_showByteArray = T.decodeUtf8 . BL.toStrict . BL64.encode . unByteArray
newtype Binary = Binary { unBinary :: BL.ByteString }
deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData)
instance A.FromJSON Binary where
parseJSON = A.withText "Binary" _readBinaryBase64
instance A.ToJSON Binary where
toJSON = A.toJSON . _showBinaryBase64
instance WH.FromHttpApiData Binary where
parseUrlPiece = P.left T.pack . _readBinaryBase64
instance WH.ToHttpApiData Binary where
toUrlPiece = _showBinaryBase64
instance P.Show Binary where
show = T.unpack . _showBinaryBase64
instance MimeRender MimeMultipartFormData Binary where
mimeRender _ = unBinary
_readBinaryBase64 :: Monad m => Text -> m Binary
_readBinaryBase64 = P.either P.fail (pure . Binary) . BL64.decode . BL.fromStrict . T.encodeUtf8
_showBinaryBase64 :: Binary -> Text
_showBinaryBase64 = T.decodeUtf8 . BL.toStrict . BL64.encode . unBinary
type Lens_' s a = Lens_ s s a a
type Lens_ s t a b = forall (f :: * -> *). Functor f => (a -> f b) -> s -> f t