option sortRecordFields

Author: epoberezkin

src/Data/Aeson/TH.hs

@@ -124,13 +124,14 @@ import Data.Aeson.Key (Key)
 import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.KeyMap as KM
 import Data.Foldable (foldr')
-import Data.List (genericLength, intercalate, union)
+import Data.List (genericLength, intercalate, sortOn, union)
 import Data.List.NonEmpty ((<|), NonEmpty((:|)))
 import Data.Map (Map)
 import qualified Data.Monoid as Monoid
 import Data.Set (Set)
 import Language.Haskell.TH hiding (Arity)
 import Language.Haskell.TH.Datatype
+import qualified Language.Haskell.TH.Syntax as THS
 import Text.Printf (printf)
 import qualified Data.Aeson.Encoding.Internal as E
 import qualified Data.List.NonEmpty as NE (length, reverse)
@@ -461,8 +462,10 @@ argsToValue letInsert target jc tvMap opts multiCons
 
         argTys' <- mapM resolveTypeSynonyms argTys
         args <- newNameList "arg" $ length argTys'
-        let argCons = zip3 (map varE args) argTys' fields
-
+        let argCons_ = zip3 (map varE args) argTys' fields
+            argCons
+              | sortRecordFields opts = sortOn (\(_, _, THS.Name (THS.OccName name) _) -> name) argCons_
+              | otherwise = argCons_
             toPair (arg, argTy, fld) =
               let fieldName = fieldLabel opts fld
                   toValue = dispatchToJSON target jc conName tvMap argTy

src/Data/Aeson/Types.hs

@@ -145,6 +145,7 @@ module Data.Aeson.Types
     , nullaryToObject
     , omitNothingFields
     , allowOmittedFields
+    , sortRecordFields
     , sumEncoding
     , unwrapUnaryRecords
     , tagSingleConstructors

src/Data/Aeson/Types/Internal.hs

@@ -59,6 +59,7 @@ module Data.Aeson.Types.Internal
         , nullaryToObject
         , omitNothingFields
         , allowOmittedFields
+        , sortRecordFields
         , sumEncoding
         , unwrapUnaryRecords
         , tagSingleConstructors
@@ -733,6 +734,11 @@ data Options = Options
       -- ^ If 'True', missing fields of a record will be filled
       -- with 'omittedField' values (if they are 'Just').
       -- If 'False', all fields will required to present in the record object.
+    , sortRecordFields :: Bool
+      -- ^ If 'True, fields will be sorted alphabetically in record encodings.
+      -- This is useful for comparing JSON encodings
+      -- or when the whole or some parts of JSON encoding needs to be signed,
+      -- to avoid multi-stage encoding/decoding for signing and signature verification.
     , sumEncoding :: SumEncoding
       -- ^ Specifies how to encode constructors of a sum datatype.
     , unwrapUnaryRecords :: Bool
@@ -748,7 +754,7 @@ data Options = Options
     }
 
 instance Show Options where
-  show (Options f c a n o q s u t r) =
+  show (Options f c a n o q d s u t r) =
        "Options {"
     ++ intercalate ", "
       [ "fieldLabelModifier =~ " ++ show (f "exampleField")
@@ -757,6 +763,7 @@ instance Show Options where
       , "nullaryToObject = " ++ show n
       , "omitNothingFields = " ++ show o
       , "allowOmittedFields = " ++ show q
+      , "sortRecordFields = " ++ show d
       , "sumEncoding = " ++ show s
       , "unwrapUnaryRecords = " ++ show u
       , "tagSingleConstructors = " ++ show t
@@ -854,6 +861,7 @@ defaultOptions = Options
                  , nullaryToObject         = False
                  , omitNothingFields       = False
                  , allowOmittedFields      = True
+                 , sortRecordFields        = False
                  , sumEncoding             = defaultTaggedObject
                  , unwrapUnaryRecords      = False
                  , tagSingleConstructors   = False

tests/UnitTests.hs

@@ -281,6 +281,7 @@ showOptions =
         ++ ", nullaryToObject = False"
         ++ ", omitNothingFields = False"
         ++ ", allowOmittedFields = True"
+        ++ ", sortRecordFields = False"
         ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
         ++ ", unwrapUnaryRecords = False"
         ++ ", tagSingleConstructors = False"