arch-hs-0.12.2: sync/Submit.hs

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

module Submit (submit) 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.Text as T
import Distribution.ArchHs.Exception
import Distribution.ArchHs.Internal.Prelude
import Distribution.ArchHs.Name (isGHCLibs)
import Distribution.ArchHs.PP
import Distribution.ArchHs.Types
import Distribution.ArchHs.Utils
import Distribution.Package (packageName)
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
  linked <- linkedHaskellPackages
  pure $
    sortOn
      (^. _1)
      [ (unPackageName hackageName, version, prefix <> tweakedName)
        | (archLinuxName, version, packageName -> hackageName) <- linked,
          let tweakedName =
                if isGHCLibs hackageName
                  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