{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE TypeApplications    #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module provides helper functions to generate Swagger schemas that
-- describe JSONPB encodings for protobuf types.
module Proto3.Suite.DotProto.Generate.Swagger
  ( ppSchema
  , OverrideToSchema(..)
  , asProxy
  , insOrdFromList
  )
where

#if MIN_VERSION_swagger2(2,4,0)
import           Control.Lens                    ((&), (?~))
#else
import           Control.Lens                    ((&), (.~), (?~))
#endif
import           Data.Aeson                      (Value (String), ToJSONKey,
                                                  ToJSONKeyFunction(..))
import qualified Data.Aeson                      as Aeson
import           Data.Aeson.Encode.Pretty        (encodePretty)
import           Data.ByteString                 (ByteString)
import qualified Data.ByteString.Lazy.Char8      as LC8
import           Data.Hashable                   (Hashable)
import           Data.HashMap.Strict.InsOrd      (InsOrdHashMap)
import qualified Data.HashMap.Strict.InsOrd
import           Data.Map                        (Map)
import           Data.Swagger
import qualified Data.Text                       as T
import           Data.Proxy
import qualified Data.Vector                     as V
import           GHC.Exts                        (Proxy#, proxy#)
import           GHC.Int
import           GHC.Word
import           Proto3.Suite                    (Enumerated (..), Finite (..),
                                                  Fixed (..), Named (..), enumerate)

-- | Convenience re-export so that users of generated code don't have to add
--   an explicit dependency on @insert-ordered-containers@
insOrdFromList :: (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
insOrdFromList :: [(k, v)] -> InsOrdHashMap k v
insOrdFromList = [(k, v)] -> InsOrdHashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
Data.HashMap.Strict.InsOrd.fromList

{-| This is a hack to work around the `swagger2` library forbidding `ToSchema`
    instances for `ByteString`s
-}
newtype OverrideToSchema a = OverrideToSchema { OverrideToSchema a -> a
unOverride :: a }

instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema (OverrideToSchema a) where
  declareNamedSchema :: Proxy (OverrideToSchema a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (OverrideToSchema a)
_ = Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema ByteString) where
  declareNamedSchema :: Proxy (OverrideToSchema ByteString)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (OverrideToSchema ByteString)
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing Schema
byteSchema)

-- | This instance is the same as the instance for @OverrideToSchema ByteString@.
-- See: https://hackage.haskell.org/package/swagger2-2.6/docs/src/Data.Swagger.Internal.Schema.html#line-451
instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe ByteString)) where
  declareNamedSchema :: Proxy (OverrideToSchema (Maybe ByteString))
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (OverrideToSchema (Maybe ByteString))
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing Schema
byteSchema)

instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (V.Vector ByteString)) where
  declareNamedSchema :: Proxy (OverrideToSchema (Vector ByteString))
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (OverrideToSchema (Vector ByteString))
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing Schema
schema_)
    where
      schema_ :: Schema
schema_ = Schema
forall a. Monoid a => a
mempty
#if MIN_VERSION_swagger2(2,4,0)
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> Schema -> Identity Schema)
-> SwaggerType 'SwaggerKindSchema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
forall (t :: SwaggerKind *). SwaggerType t
SwaggerArray
#else
        & type_ .~ SwaggerArray
#endif
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerItems 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerItems 'SwaggerKindSchema)))
-> Schema -> Identity Schema
forall s a. HasItems s a => Lens' s a
items ((Maybe (SwaggerItems 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerItems 'SwaggerKindSchema)))
 -> Schema -> Identity Schema)
-> SwaggerItems 'SwaggerKindSchema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema -> SwaggerItems 'SwaggerKindSchema
SwaggerItemsObject (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
byteSchema)

instance {-# OVERLAPPING #-} (ToJSONKey k, ToSchema k) => ToSchema (OverrideToSchema (Map k ByteString)) where
  declareNamedSchema :: Proxy (OverrideToSchema (Map k ByteString))
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (OverrideToSchema (Map k ByteString))
_ = case ToJSONKeyFunction k
forall a. ToJSONKey a => ToJSONKeyFunction a
Aeson.toJSONKey :: ToJSONKeyFunction k of
      ToJSONKeyText k -> Text
_ k -> Encoding' Text
_ -> do
          NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing Schema
schema_)
      ToJSONKeyValue k -> Value
_ k -> Encoding
_ -> do
          Proxy [(k, OverrideToSchema ByteString)]
-> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy [(k, OverrideToSchema ByteString)]
forall k (t :: k). Proxy t
Proxy :: Proxy [(k, (OverrideToSchema ByteString))])
    where
      schema_ :: Schema
schema_ = Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> Schema -> Identity Schema)
-> SwaggerType 'SwaggerKindSchema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerObject
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe AdditionalProperties
 -> Identity (Maybe AdditionalProperties))
-> Schema -> Identity Schema
forall s a. HasAdditionalProperties s a => Lens' s a
additionalProperties ((Maybe AdditionalProperties
  -> Identity (Maybe AdditionalProperties))
 -> Schema -> Identity Schema)
-> AdditionalProperties -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema -> AdditionalProperties
AdditionalPropertiesSchema (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
byteSchema)

{-| This is a convenience function that uses type inference to select the
    correct instance of `ToSchema` to use for fields of a message
-}
asProxy :: (Proxy (OverrideToSchema a) -> b) -> Proxy a
asProxy :: (Proxy (OverrideToSchema a) -> b) -> Proxy a
asProxy Proxy (OverrideToSchema a) -> b
_ = Proxy a
forall k (t :: k). Proxy t
Proxy

-- | Pretty-prints a schema. Useful when playing around with schemas in the
-- REPL.
ppSchema :: ToSchema a => Proxy a -> IO ()
ppSchema :: Proxy a -> IO ()
ppSchema = ByteString -> IO ()
LC8.putStrLn (ByteString -> IO ())
-> (Proxy a -> ByteString) -> Proxy a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Schema -> ByteString)
-> (Proxy a -> Schema) -> Proxy a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> Schema
forall a. ToSchema a => Proxy a -> Schema
toSchema

-- | JSONPB schemas for protobuf enumerations
instance (Finite e, Named e) => ToSchema (Enumerated e) where
  declareNamedSchema :: Proxy (Enumerated e) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Enumerated e)
_ = do
    let enumName :: Text
enumName        = Proxy# e -> Text
forall a string. (Named a, IsString string) => Proxy# a -> string
nameOf (Proxy# e
forall k (a :: k). Proxy# a
proxy# :: Proxy# e)
    let dropPrefix :: Text -> Text
dropPrefix      = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
enumName)
    let enumMemberNames :: [Text]
enumMemberNames = Text -> Text
dropPrefix (Text -> Text) -> ((Text, Int32) -> Text) -> (Text, Int32) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Int32) -> Text
forall a b. (a, b) -> a
fst ((Text, Int32) -> Text) -> [(Text, Int32)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy# e -> [(Text, Int32)]
forall a string.
(Finite a, IsString string) =>
Proxy# a -> [(string, Int32)]
enumerate (Proxy# e
forall k (a :: k). Proxy# a
proxy# :: Proxy# e)
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
enumName)
           (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
#if MIN_VERSION_swagger2(2,4,0)
             Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> Schema -> Identity Schema)
-> SwaggerType 'SwaggerKindSchema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
forall (t :: SwaggerKind *). SwaggerType t
SwaggerString
#else
             & type_ .~ SwaggerString
#endif
             Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Text -> Value) -> [Text] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Value
String [Text]
enumMemberNames

instance ToSchema (Fixed Int32) where
  declareNamedSchema :: Proxy (Fixed Int32) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Fixed Int32)
_ = Proxy Int32 -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy Int32
forall k (t :: k). Proxy t
Proxy @Int32)

instance ToSchema (Fixed Int64) where
  declareNamedSchema :: Proxy (Fixed Int64) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Fixed Int64)
_ = Proxy Int64 -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy Int64
forall k (t :: k). Proxy t
Proxy @Int64)

instance ToSchema (Fixed Word32) where
  declareNamedSchema :: Proxy (Fixed Word32) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Fixed Word32)
_ = Proxy Word32 -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy Word32
forall k (t :: k). Proxy t
Proxy @Word32)

instance ToSchema (Fixed Word64) where
  declareNamedSchema :: Proxy (Fixed Word64) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Fixed Word64)
_ = Proxy Word64 -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy Word64
forall k (t :: k). Proxy t
Proxy @Word64)