Merge pull request #56 from phadej/ordhashmap

Add OrdHashMap

src/Data/Swagger.hs

@@ -186,7 +186,7 @@ import Data.Swagger.Internal
 --         & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
 --         & at 404 ?~ "User info not found")) ]
 -- :}
--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}},\"produces\":[\"application/json\"]}}}}"
+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
 --
 -- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
 -- which produces @application/json@ output. It should respond with code @200@ and body specified
@@ -205,7 +205,7 @@ import Data.Swagger.Internal
 --   & type_       .~ SwaggerBoolean
 --   & description ?~ "To be or not to be"
 -- :}
--- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"
+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
 --
 -- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
 -- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
@@ -271,7 +271,7 @@ import Data.Swagger.Internal
 -- >>> encode (Person "David" 28)
 -- "{\"age\":28,\"name\":\"David\"}"
 -- >>> encode $ toSchema (Proxy :: Proxy Person)
--- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"
+-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
 
 -- $manipulation
 -- Sometimes you have to work with an imported or generated @'Swagger'@.

src/Data/Swagger/Internal/AesonUtils.hs

@@ -0,0 +1,333 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Data.Swagger.Internal.AesonUtils (
+    -- * Generic functions
+    AesonDefaultValue(..),
+    sopSwaggerGenericToJSON,
+#if MIN_VERSION_aeson(0,10,0)
+    sopSwaggerGenericToEncoding,
+#endif
+    sopSwaggerGenericToJSONWithOpts,
+    sopSwaggerGenericParseJSON,
+    -- * Options
+    HasSwaggerAesonOptions(..),
+    SwaggerAesonOptions,
+    mkSwaggerAesonOptions,
+    saoPrefix,
+    saoAdditionalPairs,
+    saoSubObject,
+    ) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Applicative ((<|>))
+import Control.Lens     (makeLenses, (^.))
+import Control.Monad    (unless)
+import Data.Aeson       (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)
+import Data.Aeson.Types (Parser, Pair)
+import Data.Char        (toLower, isUpper)
+import Data.Foldable    (traverse_)
+import Data.Text        (Text)
+
+import Generics.SOP
+
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Set as Set
+import qualified Data.HashMap.Strict.InsOrd as InsOrd
+
+#if MIN_VERSION_aeson(0,10,0)
+import Data.Aeson (Encoding, pairs, (.=), Series)
+import Data.Monoid ((<>))
+#endif
+
+-------------------------------------------------------------------------------
+-- SwaggerAesonOptions
+-------------------------------------------------------------------------------
+
+data SwaggerAesonOptions = SwaggerAesonOptions
+    { _saoPrefix          :: String
+    , _saoAdditionalPairs :: [(Text, Value)]
+    , _saoSubObject       :: Maybe String
+    }
+
+mkSwaggerAesonOptions
+    :: String  -- ^ prefix
+    -> SwaggerAesonOptions
+mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
+
+makeLenses ''SwaggerAesonOptions
+
+class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
+    swaggerAesonOptions :: proxy a -> SwaggerAesonOptions
+
+    -- So far we use only default definitions
+    aesonDefaults :: proxy a -> POP Maybe (Code a)
+    aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
+
+-------------------------------------------------------------------------------
+-- Generics
+-------------------------------------------------------------------------------
+
+class AesonDefaultValue a where
+    defaultValue :: Maybe a
+    defaultValue = Nothing
+
+instance AesonDefaultValue Text where defaultValue = Nothing
+instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
+instance AesonDefaultValue [a] where defaultValue = Just []
+instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
+instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
+
+-------------------------------------------------------------------------------
+-- ToJSON
+-------------------------------------------------------------------------------
+
+-- | Generic serialisation for swagger records.
+--
+-- Features
+--
+-- * omits nulls, empty objects and empty arrays (configurable)
+-- * possible to add fields
+-- * possible to merge sub-object
+sopSwaggerGenericToJSON
+    :: forall a xs.
+        ( Generic a
+        , HasDatatypeInfo a
+        , HasSwaggerAesonOptions a
+        , All2 ToJSON (Code a)
+        , All2 Eq (Code a)
+        , Code a ~ '[xs]
+        )
+    => a
+    -> Value
+sopSwaggerGenericToJSON x =
+    let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
+    in object (opts ^. saoAdditionalPairs ++ ps)
+  where
+    proxy = Proxy :: Proxy a
+    opts  = swaggerAesonOptions proxy
+
+-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)
+--
+-- Also uses default `aesonDefaults`
+sopSwaggerGenericToJSONWithOpts
+    :: forall a xs.
+        ( Generic a
+        , All2 AesonDefaultValue (Code a)
+        , HasDatatypeInfo a
+        , All2 ToJSON (Code a)
+        , All2 Eq (Code a)
+        , Code a ~ '[xs]
+        )
+    => SwaggerAesonOptions
+    -> a
+    -> Value
+sopSwaggerGenericToJSONWithOpts opts x =
+    let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs
+    in object (opts ^. saoAdditionalPairs ++ ps)
+  where
+    proxy = Proxy :: Proxy a
+    defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
+
+sopSwaggerGenericToJSON'
+    :: (All2 ToJSON '[xs], All2 Eq '[xs])
+    => SwaggerAesonOptions
+    -> SOP I '[xs]
+    -> DatatypeInfo '[xs]
+    -> POP Maybe '[xs]
+    -> [Pair]
+sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
+    sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
+sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
+
+sopSwaggerGenericToJSON''
+    :: (All ToJSON xs, All Eq xs)
+    => SwaggerAesonOptions
+    -> NP I xs
+    -> NP FieldInfo xs
+    -> NP Maybe xs
+    -> [Pair]
+sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
+  where
+    go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
+    go  Nil Nil Nil = []
+    go (I x :* xs) (FieldInfo name :* names) (def :* defs)
+        | Just name' == sub = case json of
+              Object m -> HM.toList m ++ rest
+              Null     -> rest
+              _        -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
+        -- If default value: omit it.
+        | Just x == def =
+            rest
+        | otherwise =
+            (T.pack name', json) : rest
+      where
+        json  = toJSON x
+        name' = fieldNameModifier name
+        rest  = go xs names defs
+#if __GLASGOW_HASKELL__ < 800
+    go _ _ _ = error "not empty"
+#endif
+
+    fieldNameModifier = modifier . drop 1
+    modifier = lowerFirstUppers . drop (length prefix)
+    lowerFirstUppers s = map toLower x ++ y
+      where (x, y) = span isUpper s
+
+-------------------------------------------------------------------------------
+-- FromJSON
+-------------------------------------------------------------------------------
+
+sopSwaggerGenericParseJSON
+    :: forall a xs.
+        ( Generic a
+        , HasDatatypeInfo a
+        , HasSwaggerAesonOptions a
+        , All2 FromJSON (Code a)
+        , All2 Eq (Code a)
+        , Code a ~ '[xs]
+        )
+    => Value
+    -> Parser a
+sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
+    let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)
+    in do
+        traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)
+        to <$> ps
+  where
+    proxy = Proxy :: Proxy a
+    opts  = swaggerAesonOptions proxy
+
+    parseAdditionalField :: Object -> (Text, Value) -> Parser ()
+    parseAdditionalField obj (k, v) = do
+        v' <- obj .: k
+        unless (v == v') $ fail $
+            "Additonal field don't match for key " ++ T.unpack k
+            ++ ": " ++ show v
+            ++ " /= " ++ show v'
+
+sopSwaggerGenericParseJSON'
+    :: (All2 FromJSON '[xs], All2 Eq '[xs])
+    => SwaggerAesonOptions
+    -> Object
+    -> DatatypeInfo '[xs]
+    -> POP Maybe '[xs]
+    -> Parser (SOP I '[xs])
+sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
+    SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
+sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
+
+sopSwaggerGenericParseJSON''
+    :: (All FromJSON xs, All Eq xs)
+    => SwaggerAesonOptions
+    -> Object
+    -> NP FieldInfo xs
+    -> NP Maybe xs
+    -> Parser (NP I xs)
+sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
+  where
+    go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
+    go  Nil Nil = pure Nil
+    go (FieldInfo name :* names) (def :* defs)
+        | Just name' == sub =
+            -- Note: we might strip fields of outer structure.
+            cons <$> (withDef $ parseJSON $ Object obj) <*> rest
+        | otherwise = case def of
+            Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest
+            Nothing  ->  cons <$> obj .: T.pack name' <*> rest
+      where
+        cons h t = I h :* t
+        name' = fieldNameModifier name
+        rest  = go names defs
+
+        withDef = case def of
+            Just def' -> (<|> pure def')
+            Nothing   -> id
+#if __GLASGOW_HASKELL__ < 800
+    go _ _ = error "not empty"
+#endif
+
+    fieldNameModifier = modifier . drop 1
+    modifier = lowerFirstUppers . drop (length prefix)
+    lowerFirstUppers s = map toLower x ++ y
+      where (x, y) = span isUpper s
+
+-------------------------------------------------------------------------------
+-- ToEncoding
+-------------------------------------------------------------------------------
+
+#if MIN_VERSION_aeson(0,10,0)
+
+sopSwaggerGenericToEncoding
+    :: forall a xs.
+        ( Generic a
+        , HasDatatypeInfo a
+        , HasSwaggerAesonOptions a
+        , All2 ToJSON (Code a)
+        , All2 Eq (Code a)
+        , Code a ~ '[xs]
+        )
+    => a
+    -> Encoding
+sopSwaggerGenericToEncoding x =
+    let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
+    in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)
+  where
+    proxy = Proxy :: Proxy a
+    opts  = swaggerAesonOptions proxy
+
+pairsToSeries :: [Pair] -> Series
+pairsToSeries = foldMap (\(k, v) -> (k .= v))
+
+sopSwaggerGenericToEncoding'
+    :: (All2 ToJSON '[xs], All2 Eq '[xs])
+    => SwaggerAesonOptions
+    -> SOP I '[xs]
+    -> DatatypeInfo '[xs]
+    -> POP Maybe '[xs]
+    -> Series
+sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
+    sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
+sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
+
+sopSwaggerGenericToEncoding''
+    :: (All ToJSON xs, All Eq xs)
+    => SwaggerAesonOptions
+    -> NP I xs
+    -> NP FieldInfo xs
+    -> NP Maybe xs
+    -> Series
+sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go
+  where
+    go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
+    go  Nil Nil Nil = mempty
+    go (I x :* xs) (FieldInfo name :* names) (def :* defs)
+        | Just name' == sub = case toJSON x of
+              Object m -> pairsToSeries (HM.toList m) <> rest
+              Null     -> rest
+              _        -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
+        -- If default value: omit it.
+        | Just x == def =
+            rest
+        | otherwise =
+            (T.pack name' .= x) <> rest
+      where
+        name' = fieldNameModifier name
+        rest  = go xs names defs
+#if __GLASGOW_HASKELL__ < 800
+    go _ _ _ = error "not empty"
+#endif
+
+    fieldNameModifier = modifier . drop 1
+    modifier = lowerFirstUppers . drop (length prefix)
+    lowerFirstUppers s = map toLower x ++ y
+      where (x, y) = span isUpper s
+
+#endif