[Git][haskell-team/tools][master] binNMUs: add capability for JSON output format

[Clint Adams]

Clint Adams pushed to branch master at Debian Haskell Group / tools


Commits:
d619cc2e by Clint Adams at 2019-09-02T19:06:16Z
binNMUs: add capability for JSON output format

- - - - -


3 changed files:

- AcquireFile.hs → binnmus/AcquireFile.hs
- binnmus/binNMUs.cabal
- binnmus/binNMUs.hs


Changes:

=====================================
AcquireFile.hs → binnmus/AcquireFile.hs
=====================================


=====================================
binnmus/binNMUs.cabal
=====================================
@@ -16,6 +16,8 @@ executable binNMUs
   main-is:             binNMUs.hs
   other-modules:       AcquireFile
   build-depends:       base >=4.10 && <5
+                     , aeson
+                     , aeson-pretty
                      , bytestring
                      , containers
                      , debian
@@ -25,6 +27,7 @@ executable binNMUs
                      , lzma
                      , optparse-applicative
                      , parallel
+                     , postgresql-simple
                      , process
                      , regex-pcre
                      , split


=====================================
binnmus/binNMUs.hs
=====================================
@@ -35,6 +35,8 @@ import Control.Seq
 import GHC.Generics (Generic)
 import Control.DeepSeq
 import Data.Foldable (for_)
+import qualified Data.Aeson as A
+import Data.Aeson.Encode.Pretty (encodePretty)
 
 
 import Database.PostgreSQL.Simple hiding (Binary)
@@ -87,6 +89,22 @@ data Reason
 type BinNMU = (Binary, [Reason])
 type CBinNMU = (Status, ((SourceName, Version), Arch, [Reason]))
 
+data JBinNMU = JBinNMU
+    { _pkg :: String
+    , _ver :: String
+    , _arches :: [String]
+    , _suite :: String
+    , _reason :: String
+    } deriving Generic
+
+customOptions = A.defaultOptions
+                { A.fieldLabelModifier = drop 1
+                }
+
+instance A.ToJSON JBinNMU where
+    toJSON     = A.genericToJSON customOptions
+    toEncoding = A.genericToEncoding customOptions
+
 data Binary = Binary
     { bPkgName :: String
     , bSourceName :: SourceName
@@ -102,21 +120,29 @@ instance NFData Binary
 -- The main action
 
 run :: Conf -> IO ()
-run conf = do
-    printHeader conf
-    when (not (sql conf) && distribution conf /= "sid") $ do
-        putCLn $ "When reading data via HTTP, only sid is supported"
-        putCLn $ "as other distributions do not have dumps of the wanna-build data."
-        putCLn $ "Use --sql on wuiet.debian.org!"
-        exitFailure
-    rms <- fetchWnppDump conf
-    cBinNMUss <- mapM (getNMUs conf rms) (arches conf)
-    -- Parallelization, if required
-    --let cBinNMUs = concat (cBinNMUss `using` parList (evalList (evalTuple2 rseq rseq)))
-    let cBinNMUs = concat cBinNMUss
-    doPresentProblems conf cBinNMUs
-    presentBinNMUs conf cBinNMUs
-
+run conf = case outputFormat conf of
+    WannaBuild -> do
+        printHeader conf
+        when (not (sql conf) && distribution conf /= "sid") $ do
+            putCLn $ "When reading data via HTTP, only sid is supported"
+            putCLn $ "as other distributions do not have dumps of the wanna-build data."
+            putCLn $ "Use --sql on wuiet.debian.org!"
+            exitFailure
+        rms <- fetchWnppDump conf
+        cBinNMUss <- mapM (getNMUs conf rms) (arches conf)
+        -- Parallelization, if required
+        --let cBinNMUs = concat (cBinNMUss `using` parList (evalList (evalTuple2 rseq rseq)))
+        let cBinNMUs = concat cBinNMUss
+        doPresentProblems conf cBinNMUs
+        presentBinNMUs conf cBinNMUs
+    JSON -> do
+        when (not (sql conf) && distribution conf /= "sid") $ do
+            exitFailure
+        rms <- fetchWnppDump conf
+        cBinNMUss <- mapM (getNMUs conf rms) (arches conf)
+        let cBinNMUs = concat cBinNMUss
+            json = encodePretty (finalizeBinNMUs conf cBinNMUs)
+        BL.putStr $ json
 
 printHeader :: Conf -> IO ()
 printHeader conf = do
@@ -197,6 +223,17 @@ presentBinNMUs conf cBinNMUs = do
                 ]
             putStrLn ""
 
+finalizeBinNMUs :: Conf -> [CBinNMU] -> [JBinNMU]
+finalizeBinNMUs conf cBinNMUs =
+    let needed = filter (actStatus . fst) cBinNMUs
+        binNMUs = map snd needed
+        grouped = sortBy (compare `on` (^. _1)) $ groupNMUs conf binNMUs
+    in concatMap transformNMUs grouped
+    where
+        transformNMUs :: ([(SourceName, Version)], [Arch], [Reason]) -> [JBinNMU]
+        transformNMUs (svs, as, rs) = map (\(s,v) -> transformNMU s v as (distribution conf) (rstr rs)) svs
+        rstr = intercalate ", " . map formatReason
+        transformNMU = JBinNMU
 
 groupNMUs :: (Ord a, Ord b, Ord c) => Conf -> [(a, b, c)] -> [([a], [b], c)]
 groupNMUs conf =
@@ -547,6 +584,8 @@ fetchWnppDump conf = do
     wnppRegex = makeRegex "^(.*): RM"
 
 
+data OutputFormat = WannaBuild | JSON
+    deriving (Bounded, Enum, Eq, Read, Show)
 
 -- Option parsing
 data Conf = Conf
@@ -561,9 +600,10 @@ data Conf = Conf
     , sql :: Bool
     , groupPkgs :: Bool
     , presentProblems :: Bool
+    , outputFormat :: OutputFormat
     }
 
-mkConf :: String -> [Arch] -> String -> Maybe Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Conf
+mkConf :: String -> [Arch] -> String -> Maybe Int -> Bool -> Bool -> Bool -> Bool -> Bool -> OutputFormat -> Conf
 mkConf d a r p =
     Conf d a (makeRegex ("^"++r++"$")) (makeRegex r) r p
 
@@ -625,6 +665,13 @@ conf = mkConf
     long "present-problems" <>
     help "list all problems (changed dependencies etc.)"
     )
+ <*> option auto (
+    long "output-format" <>
+    help "output as WannaBuild or JSON" <>
+    metavar "FORMAT" <>
+    showDefault <>
+    value WannaBuild
+    )
 
 haskellRegex :: String
 haskellRegex = "libghc-(.*)-dev-([0-9.]+)-([0-9a-f]{5})"



View it on GitLab: https://salsa.debian.org/haskell-team/tools/commit/d619cc2e862fe5436d56b863bb0fcd70f208e563

-- 
View it on GitLab: https://salsa.debian.org/haskell-team/tools/commit/d619cc2e862fe5436d56b863bb0fcd70f208e563
You're receiving this email because of your account on salsa.debian.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://alioth-lists.debian.net/pipermail/pkg-haskell-commits/attachments/20190902/8b329c9d/attachment-0001.html>