arch-hs-0.16.2: sync/Submit.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

module Submit (submit, genCSV) where

import Control.Monad (unless)
import Data.Algorithm.Diff (getGroupedDiff)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import Data.List (sortOn)
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import qualified Data.Text as T
import Distribution.ArchHs.Exception
import Distribution.ArchHs.Internal.Prelude
import Distribution.ArchHs.Name (ghcProvidedPackages)
import Distribution.ArchHs.PP
import Distribution.ArchHs.Types
import Distribution.ArchHs.Utils
import Network.HTTP.Client
import Network.HTTP.Types.Status (statusCode, statusIsSuccessful, statusMessage)
import Submit.CSV
import Utils

-- | Generate Distro CSV from Extra DB
genCSV :: Members [ExtraEnv, HackageEnv, WithMyErr, Embed IO] r => Sem r DistroCSV
genCSV = do
  extra <- ask
  linked <- linkedHaskellPackages
  let providedByGHC = ghcProvidedPackages extra
  pure $
    sortOn
      (^. _1)
      [ (unPackageName hackageName, version, prefix <> tweakedName)
        | (archLinuxName, version, hackageName) <- linked,
          let tweakedName =
                if Set.member hackageName providedByGHC
                  then "ghc"
                  else unArchLinuxName archLinuxName
              prefix = "https://archlinux.org/packages/extra/x86_64/"
      ]

-- | Check and submit distro CSV to Hackage
submit :: Members [HackageEnv, ExtraEnv, WithMyErr, Reader Manager, Embed IO] r => Maybe String -> FilePath -> Bool -> Sem r ()
submit token output upload = do
  csv <- genCSV
  let v = renderDistroCSV csv
  embed $
    unless (null output) $ do
      printInfo $ "Write file" <> colon <+> pretty output
      writeFile output v
  check csv
  manager <- ask
  when ((not . null) token && upload) $ do
    status <- interceptHttpException $ do
      printInfo "Uploading..."
      initialRequest <- parseRequest "https://hackage.haskell.org/distro/Arch/packages"
      let req =
            initialRequest
              { method = "PUT",
                requestBody = RequestBodyBS . BS.pack $ v,
                requestHeaders =
                  [ ("Authorization", "X-ApiKey " <> BS.pack (fromJust token)),
                    ("Content-Type", "text/csv")
                  ]
              }
      result <- httpLbs req manager
      let status = responseStatus result
      printInfo $ "Status" <> colon <+> viaShow status
      printInfo "ResponseBody:"
      printInfo . pretty . decodeUtf8 . LBS.toStrict $ responseBody result
      pure status
    unless (statusIsSuccessful status) $
      throw . HackageUploadFailed (statusCode status) . BS.unpack $ statusMessage status

-- | Download Distro CSV from Hackage and print differences from @extra@
check :: Members [HackageEnv, WithMyErr, Reader Manager, Embed IO] r => DistroCSV -> Sem r ()
check extra = do
  printInfo "Checking generated csv file..."

  req <- interceptHttpException $ parseRequest "https://hackage.haskell.org/distro/Arch/packages.csv"
  printInfo "Downloading csv from hackage..."
  manager <- ask
  result <- interceptHttpException $ httpLbs req manager
  let bs = responseBody result
      hackage = parseDistroCSV . T.unpack . decodeUtf8 . LBS.toStrict $ bs

  let diff = getGroupedDiff hackage extra
      diffOld = filterFirstDiff diff >>= (ppDiffColored . mapDiff (fmap ppRecord))
      diffNew = filterSecondDiff diff >>= (ppDiffColored . mapDiff (fmap ppRecord))
      ppRecord (name, version, url) = "(" <> name <> ", " <> version <> ", " <> url <> ")"
      j g x = if null x then "[]" else g x
  embed . putDoc . annMagneta $ "Diff" <> colon <> line
  embed . putDoc . indent 2 $
    if noDiff diff
      then "[]"
      else
        j cat diffOld
          <> splitLine
          <> j cat diffNew
          <> line

  embed . putDoc $
    "Found"
      <+> pretty (length hackage)
      <+> "packages with submitted distribution information in hackage, and"
      <+> pretty (length extra)
      <+> "haskell packages in"
      <+> ppExtra
      <> dot
      <> line