Migrate to aeson-2.0

hackage-server.cabal

@@ -112,7 +112,7 @@ common defaults
     , scientific
   -- other dependencies shared by most components
   build-depends:
-    , aeson                 ^>= 1.5
+    , aeson                 ^>= 2.0.3.0
     , Cabal                 ^>= 3.4.1.0
     , fail                  ^>= 4.9.0
       -- we use Control.Monad.Except, introduced in mtl-2.2.1
@@ -361,7 +361,7 @@ library lib-server
     , acid-state            ^>= 0.16
     , async                 ^>= 2.2.1
     -- requires bumping http-io-streams
-    , attoparsec            ^>= 0.13
+    , attoparsec            ^>= 0.14.4
     , base16-bytestring     ^>= 1.0
     -- requires bumping http-io-streams
     , base64-bytestring     ^>= 1.1

src/Distribution/Server/Features/Core.hs

@@ -23,9 +23,10 @@ module Distribution.Server.Features.Core (
 -- stdlib
 import qualified Codec.Compression.GZip                             as GZip
 import           Data.Aeson                                         (Value (..))
+import qualified Data.Aeson.Key                                     as Key
+import qualified Data.Aeson.KeyMap                                  as KeyMap
 import           Data.ByteString.Lazy                               (ByteString)
 import qualified Data.Foldable                                      as Foldable
-import qualified Data.HashMap.Strict                                as HashMap
 import qualified Data.Text                                          as Text
 import           Data.Time.Clock                                    (UTCTime, getCurrentTime)
 import           Data.Time.Format                                   (defaultTimeLocale, formatTime)
@@ -688,8 +689,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
       -- in particular, we use objects for the packages so that we can add
       -- additional fields later without (hopefully) breaking clients
       let json = flip map list $ \str ->
-            Object . HashMap.fromList $ [
-                (Text.pack "packageName", String (Text.pack str))
+            Object . KeyMap.fromList $ [
+                (Key.fromString "packageName", String (Text.pack str))
               ]
       return . toResponse $ Array (Vec.fromList json)
 
@@ -727,10 +728,10 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
       let revisions = pkgMetadataRevisions pkginfo
           revisionToObj rev (_, (utime, uid)) =
             let uname = userIdToName users uid in
-            Object $ HashMap.fromList
-              [ (Text.pack "number", Number (fromIntegral rev))
-              , (Text.pack "user", String (Text.pack (display uname)))
-              , (Text.pack "time", String (Text.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" utime)))
+            Object $ KeyMap.fromList
+              [ (Key.fromString "number", Number (fromIntegral rev))
+              , (Key.fromString "user", String (Text.pack (display uname)))
+              , (Key.fromString "time", String (Text.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" utime)))
               ]
           revisionsJson = Array $ Vec.imap revisionToObj revisions
       return (toResponse revisionsJson)

src/Distribution/Server/Features/PackageCandidates.hs

@@ -43,15 +43,15 @@ import Distribution.Version
 import qualified Data.Text                as T
 import qualified Data.Text.Encoding       as T
 import qualified Data.Text.Encoding.Error as T
-import qualified Data.ByteString.Lazy as BS (ByteString, toStrict)
-import qualified Text.XHtml.Strict as XHtml
-import           Text.XHtml.Strict ((<<), (!))
-import Data.Aeson (Value (..), object, toJSON, (.=))
-
-import Data.Function (fix)
-import Data.List (find, intersperse)
-import Data.Time.Clock (getCurrentTime)
-import qualified Data.Vector as Vec
+import qualified Data.ByteString.Lazy     as BS (ByteString, toStrict)
+import qualified Text.XHtml.Strict        as XHtml
+import           Text.XHtml.Strict        ((<<), (!))
+import           Data.Aeson               (Value (..), object, toJSON, (.=))
+import qualified Data.Aeson.Key           as Key
+import           Data.Function            (fix)
+import           Data.List                (find, intersperse)
+import           Data.Time.Clock          (getCurrentTime)
+import qualified Data.Vector               as Vec
 
 
 data PackageCandidatesFeature = PackageCandidatesFeature {
@@ -281,10 +281,10 @@ candidatesFeature ServerEnv{serverBlobStore = store}
         users  <- queryGetUserDb
         let lupUserName uid = (uid, fmap Users.userName (Users.lookupUserId uid users))
 
-        let pvs = [ object [ T.pack "version"  .= (T.pack . display . packageVersion . candInfoId) p
-                           , T.pack "sha256"   .= (blobInfoHashSHA256 . pkgTarballGz . fst) tarball
-                           , T.pack "time"     .= (fst . snd) tarball
-                           , T.pack "uploader" .= (lupUserName . snd . snd) tarball
+        let pvs = [ object [ Key.fromString "version"  .= (T.pack . display . packageVersion . candInfoId) p
+                           , Key.fromString "sha256"   .= (blobInfoHashSHA256 . pkgTarballGz . fst) tarball
+                           , Key.fromString "time"     .= (fst . snd) tarball
+                           , Key.fromString "uploader" .= (lupUserName . snd . snd) tarball
                            ]
                   | p <- pkgs
                   , let tarball = Vec.last . pkgTarballRevisions . candPkgInfo $ p
@@ -304,11 +304,14 @@ candidatesFeature ServerEnv{serverBlobStore = store}
       where
         cpiToJSON :: [CandPkgInfo] -> Value
         cpiToJSON [] = Null -- should never happen
-        cpiToJSON pkgs = object [ T.pack "name" .= pn, T.pack "candidates" .= pvs ]
+        cpiToJSON pkgs = object
+            [ Key.fromString "name" .= pn
+            , Key.fromString "candidates" .= pvs
+            ]
           where
             pn = T.pack . display . pkgName . candInfoId . head $ pkgs
-            pvs = [ object [ T.pack "version" .= (T.pack . display . packageVersion . candInfoId) p
-                           , T.pack "sha256"  .= (blobInfoHashSHA256 . pkgTarballGz . fst) tarball
+            pvs = [ object [ Key.fromString "version" .= (T.pack . display . packageVersion . candInfoId) p
+                           , Key.fromString "sha256"  .= (blobInfoHashSHA256 . pkgTarballGz . fst) tarball
                            ]
                   | p <- pkgs
                   , let tarball = Vec.last . pkgTarballRevisions . candPkgInfo $ p

src/Distribution/Server/Features/PackageInfoJSON/State.hs

@@ -15,8 +15,9 @@ import           Control.Monad.Reader (ask, asks)
 import qualified Control.Monad.State  as State
 import qualified Data.Aeson           as Aeson
 import           Data.Aeson           ((.=), (.:))
+import qualified Data.Aeson.Key       as Key
+import qualified Data.Aeson.KeyMap    as KeyMap
 import           Data.Acid            (Query, Update, makeAcidic)
-import qualified Data.HashMap.Strict  as HashMap
 import qualified Data.Map.Strict      as Map
 import           Data.Monoid          (Sum(..))
 import qualified Data.Text            as T
@@ -85,30 +86,30 @@ instance SafeCopy PackageBasicDescription where
 instance Aeson.ToJSON PackageBasicDescription where
   toJSON PackageBasicDescription {..} =
     Aeson.object
-      [ T.pack "license"           .= Pretty.prettyShow pbd_license
-      , T.pack "copyright"         .= pbd_copyright
-      , T.pack "synopsis"          .= pbd_synopsis
-      , T.pack "description"       .= pbd_description
-      , T.pack "author"            .= pbd_author
-      , T.pack "homepage"          .= pbd_homepage
-      , T.pack "metadata_revision" .= pbd_metadata_revision
+      [ Key.fromString "license"           .= Pretty.prettyShow pbd_license
+      , Key.fromString "copyright"         .= pbd_copyright
+      , Key.fromString "synopsis"          .= pbd_synopsis
+      , Key.fromString "description"       .= pbd_description
+      , Key.fromString "author"            .= pbd_author
+      , Key.fromString "homepage"          .= pbd_homepage
+      , Key.fromString "metadata_revision" .= pbd_metadata_revision
       ]
 
 
 instance Aeson.FromJSON PackageBasicDescription where
   parseJSON = Aeson.withObject "PackageBasicDescription" $ \obj -> do
-    pbd_version'     <- obj .: T.pack "license"
+    pbd_version'     <- obj .: Key.fromString "license"
     let parseEitherLicense t =
           Parsec.simpleParsec t <|> fmap licenseToSPDX (simpleParse t)
     case parseEitherLicense pbd_version' of
       Nothing -> fail $ concat ["Could not parse version: \"", pbd_version', "\""]
       Just pbd_license -> do
-        pbd_copyright         <- obj .: T.pack "copyright"
-        pbd_synopsis          <- obj .: T.pack "synopsis"
-        pbd_description       <- obj .: T.pack "description"
-        pbd_author            <- obj .: T.pack "author"
-        pbd_homepage          <- obj .: T.pack "homepage"
-        pbd_metadata_revision <- obj .: T.pack "metadata_revision"
+        pbd_copyright         <- obj .: Key.fromString "copyright"
+        pbd_synopsis          <- obj .: Key.fromString "synopsis"
+        pbd_description       <- obj .: Key.fromString "description"
+        pbd_author            <- obj .: Key.fromString "author"
+        pbd_homepage          <- obj .: Key.fromString "homepage"
+        pbd_metadata_revision <- obj .: Key.fromString "metadata_revision"
         return $
           PackageBasicDescription {..}
 
@@ -161,14 +162,13 @@ instance Aeson.FromJSON PackageVersions where
   parseJSON = Aeson.withObject "PackageVersions" $ \obj ->
     fmap PackageVersions
     $ traverse (parsePair)
-    $ HashMap.toList obj
+    $ KeyMap.toList obj
     where
       parsePair (vStr, vStatus) =
-        (,) <$> parseVersion vStr <*> parseStatus vStatus
+        (,) <$> parseVersion (Key.toString vStr) <*> parseStatus vStatus
 
-      parseVersion verText =
-        let verString = T.unpack verText
-        in case simpleParse verString of
+      parseVersion verString =
+        case simpleParse verString of
              Just ver -> return ver
              Nothing  -> fail $ concat ["Could not parse \""
                                        , verString ++ "\" as Version. "

src/Distribution/Server/Features/PreferredVersions.hs

@@ -28,18 +28,19 @@ import Distribution.Package
 import Distribution.Version
 import Distribution.Text
 
-import Data.Function (fix)
-import Data.List (intercalate, find)
-import Data.Maybe (isJust, fromMaybe, catMaybes)
-import Data.Time.Clock (getCurrentTime)
-import Control.Arrow (second)
-import Control.Applicative (optional)
-import qualified Data.Map as Map
+import           Control.Arrow              (first, second)
+import           Control.Applicative        (optional)
+import           Data.Aeson                 (Value(..))
+import           Data.Function              (fix)
+import           Data.List                  (intercalate, find)
+import           Data.Maybe                 (isJust, fromMaybe, catMaybes)
+import           Data.Time.Clock            (getCurrentTime)
+import qualified Data.Aeson.Key             as Key
+import qualified Data.Aeson.KeyMap          as KeyMap
 import qualified Data.ByteString.Lazy.Char8 as BS (pack) -- Only used for ASCII data
-import Data.Aeson (Value(..))
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Text           as Text
-import qualified Data.Vector         as Vector
+import qualified Data.Map                   as Map
+import qualified Data.Text                  as Text
+import qualified Data.Vector                as Vector
 
 data VersionsFeature = VersionsFeature {
     versionsFeatureInterface :: HackageFeature,
@@ -198,7 +199,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
         versionType DeprecatedVersion = "deprecated-version"
         versionType UnpreferredVersion = "unpreferred-version"
       return . toResponse . object
-        $ map (\(i, vs) -> (Text.pack . versionType $ i, array $ map (string . display) vs))
+        $ map (\(i, vs) -> (versionType $ i, array $ map (string . display) vs))
           $ Map.toList classifiedVersions
 
     handlePackagesDeprecatedGet :: DynamicPath -> ServerPartE Response
@@ -234,7 +235,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
         Object o
           -- FIXME should just be a nested case
           -- or something more human friendly
-          | fields <- HashMap.toList o
+          | fields <- KeyMap.toList o
           , Just (Bool deprecated) <- lookup "is-deprecated" fields
           , Just (Array strs)      <- lookup "in-favour-of"  fields
           -- FIXME Audit this parsing -> PackageName code, suspiciously
@@ -415,8 +416,8 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
 array :: [Value] -> Value
 array = Array . Vector.fromList
 
-object :: [(Text.Text, Value)] -> Value
-object = Object . HashMap.fromList
+object :: [(String, Value)] -> Value
+object = Object . KeyMap.fromList . map (first Key.fromString)
 
 string :: String -> Value
 string = String . Text.pack

src/Distribution/Server/Features/Search.hs

@@ -32,6 +32,7 @@ import qualified Data.Map as Map
 
 import Control.Applicative (optional)
 import Data.Aeson
+import qualified Data.Aeson.Key as Key
 
 data SearchFeature = SearchFeature {
     searchFeatureInterface :: HackageFeature,
@@ -185,7 +186,7 @@ searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists}
         _ ->
           errBadRequest "Invalid search request" [MText $ "Empty terms query"]
       where packageNameJSON pkgName =
-              object [ T.pack "name" .= unPackageName pkgName ]
+              object [ Key.fromString "name" .= unPackageName pkgName ]
 
 {-
     suggestJson :: ServerPartE Response

src/Distribution/Server/Features/ServerIntrospect.hs

@@ -14,7 +14,8 @@ import Text.XHtml.Strict
          , anchor, (!), href, name
          , ordList, unordList )
 import Data.Aeson (Value(..))
-import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Aeson.Key      as Key
+import qualified Data.Aeson.KeyMap   as KeyMap
 import qualified Data.Vector         as Vector
 import qualified Data.Text           as Text
 import Data.List
@@ -338,7 +339,7 @@ array :: [Value] -> Value
 array = Array . Vector.fromList
 
 object :: [(String, Value)] -> Value
-object = Object . HashMap.fromList . map (first Text.pack)
+object = Object . KeyMap.fromList . map (first Key.fromString)
 
 string :: String -> Value
 string = String . Text.pack

src/Distribution/Server/Features/Votes.hs

@@ -21,9 +21,10 @@ import Distribution.Package
 import Distribution.Text
 
 import Data.Aeson
+import qualified Data.Aeson.Key    as Key
+import qualified Data.Aeson.KeyMap as KeyMap
 import qualified Data.Map as Map
 import qualified Data.Text as T
-import qualified Data.HashMap.Strict as HashMap
 
 import Control.Arrow (first)
 import qualified Text.XHtml.Strict as X
@@ -212,7 +213,7 @@ votesFeature  ServerEnv{..}
 
 -- Use to construct a list of tuples that can be toJSON'd
 objectL :: [(String, Value)] -> Value
-objectL = Object . HashMap.fromList . map (first T.pack)
+objectL = Object . KeyMap.fromList . map (first Key.fromString)
 
 -- Use inside an objectL to transform strings into json values
 string :: String -> Value

src/Distribution/Server/Framework/HtmlFormWrapper.hs

@@ -13,7 +13,8 @@ import qualified Data.ByteString.Lazy as BS
 import qualified Data.ByteString.Lazy.Char8 as BS8
 import qualified Data.Aeson as JSON
 import qualified Data.Text as T
-import qualified Data.HashMap.Strict as HMap
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KeyMap
 import Control.Concurrent.MVar
 
 import Distribution.Server.Framework.HappstackUtils (showContentType)
@@ -181,23 +182,26 @@ parsePathTmpl v = parseKey
     parseJVal s                          = JSON.decode (BS8.pack s)
 
 accumJPaths :: [JPath] -> Maybe JSON.Value
-accumJPaths js = foldr (\j r v -> case insertJPath j v of
-                                    Nothing -> Nothing
-                                    Just v' -> r v') Just js JSON.Null
+accumJPaths js = f JSON.Null
+  where
+  f :: JSON.Value -> Maybe JSON.Value
+  f = foldr (\ j r -> insertJPath j >=> r) Just js
 
 insertJPath :: JPath -> JSON.Value -> Maybe JSON.Value
+
 insertJPath (JField f p) JSON.Null = do
   v <- insertJPath p JSON.Null
-  return (JSON.object [(f, v)])
+  return (JSON.object [(Key.fromText f, v)])
 
 insertJPath (JField f p) (JSON.Object obj) = do
-  case HMap.lookup f obj of
+  let k = Key.fromText f
+  case KeyMap.lookup k obj of
     Nothing -> do
       v <- insertJPath p JSON.Null
-      return (JSON.Object (HMap.insert f v obj))
+      return (JSON.Object (KeyMap.insert k v obj))
     Just v0 -> do
       v <- insertJPath p v0
-      return (JSON.Object (HMap.insert f v obj))
+      return (JSON.Object (KeyMap.insert k v obj))
 
 insertJPath (JVal v) JSON.Null = return v
 insertJPath _        _         = Nothing