Main.hs

{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE ViewPatterns      #-}

-- |
-- Module      :  Main
-- Copyright   :  Herbert Valerio Riedel, Andreas Abel
-- SPDX-License-Identifier: GPL-3.0-or-later
--
module Main where

import           Prelude                                hiding (log)

import qualified Data.Aeson                             as J
import qualified Data.Aeson.Types                       as J
import qualified Data.ByteString.Builder                as Builder
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.Except                   (MonadError(..), ExceptT, runExceptT)
import           Control.Monad.State.Strict
import           Data.Bits
import           Data.ByteString                        (ByteString)
import qualified Data.ByteString                        as BS
import qualified Data.ByteString.Char8                  as BS8
import qualified Data.ByteString.Lazy                   as BSL
import qualified Data.ByteString.Search                 as BSS
import           Data.Char                              (isSpace)
import           Data.Foldable                          (toList)
import           Data.Function.Compat                   (applyWhen)
import qualified Data.List                              as List
import           Data.Maybe
import           Data.Time.Clock.POSIX                  (getPOSIXTime)
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup                         (Semigroup(..))
#endif

import qualified Distribution.Package                   as C
import qualified Distribution.PackageDescription        as C
import qualified Distribution.PackageDescription.Parsec as C
import qualified Distribution.Parsec                    as C
import qualified Distribution.Fields                    as C
import qualified Distribution.Fields.Field              as C (fieldAnn)
import qualified Distribution.Pretty                    as C
import qualified Distribution.Verbosity                 as C
import qualified Distribution.Version                   as C
import qualified Distribution.Text                      as C
#if MIN_VERSION_Cabal(3,7,0)
import qualified Distribution.Simple.PackageDescription as C
#endif
#if MIN_VERSION_Cabal(3,14,0)
import Distribution.Utils.Path (makeSymbolicPath)
#endif

import           Lens.Micro
import           Lens.Micro.Mtl
import           Lens.Micro.TH

import           Network.Http.Client
import           Network.NetRc
import           Numeric.Natural                        (Natural)
import           Options.Applicative                    as OA
import           System.Directory
import           System.Environment                     (lookupEnv)
import           System.Exit                            (ExitCode (..), exitFailure)
import           System.FilePath
import           System.IO                              (hPutStrLn, stderr)
import           System.IO.Error                        (tryIOError, isDoesNotExistError)
import qualified System.IO.Streams                      as Streams
import           System.Process.ByteString              (readProcessWithExitCode)
import           Text.HTML.TagSoup
import           Text.Printf                            (printf)
import qualified Paths_hackage_cli
import qualified Data.Version as V

import qualified Distribution.Types.BuildInfo.Lens                 as LC
import qualified Distribution.Types.GenericPackageDescription.Lens as LC

-- import Cabal

import           Distribution.Client.Add
import           Distribution.Server.Util.CabalRevisions  ( diffCabalRevisions, Change(Change) )
import           IndexShaSum                              ( IndexShaSumOptions(IndexShaSumOptions), run )
import           CabalEdit                                ( PkgRev, cabalEditXRev )

type PkgName = ByteString
type PkgVer  = ByteString

showVersion :: C.Version -> String
showVersion = C.display

pkgVerToVersion :: PkgVer -> C.Version
pkgVerToVersion = fromMaybe (error "invalid version") . C.simpleParse . BS8.unpack

pkgVerInRange :: PkgVer -> C.VersionRange -> Bool
pkgVerInRange v vr = pkgVerToVersion v `C.withinRange` vr

type HIO = StateT HConn IO

data HConn = HConn
    { _hcMkConn :: IO Connection
    , _hcConn   :: Maybe Connection
    , _hcReqCnt :: Natural -- ^ requests submitted on current 'Connection'
    , _hcRspCnt :: Natural -- ^ responses read from current 'Connection'
    }

makeLenses ''HConn

-- | Requests that can be issued in current connection before exhausting the 50-req/conn server limit
hcReqLeft :: SimpleGetter HConn Natural -- (Natural -> f Natural) -> HConn -> f HConn
hcReqLeft = hcReqCnt . to f
  where
    f n | n > lim   = 0
        | otherwise = lim - n
    lim = 50

setUA :: RequestBuilder ()
setUA = setHeader "User-Agent" uaStr
  where
    uaStr = "hackage-cli/" <> BS8.pack (V.showVersion Paths_hackage_cli.version)

hackageSendGET :: ByteString -> ByteString -> HIO ()
hackageSendGET p a = do
    q1 <- liftIO $ buildRequest $ do
        http GET p
        setUA
        setAccept a

    lft <- use hcReqLeft
    unless (lft > 0) $
        fail "hackageSendGET: request budget exhausted for current connection"

    c <- openHConn
    liftIO $ sendRequest c q1 emptyBody
    hcReqCnt += 1

hackagePutTgz :: ByteString -> ByteString -> HIO ByteString
hackagePutTgz p tgz = do
    q1 <- liftIO $ buildRequest $ do
        http PUT p
        setUA
        -- setAccept "application/json" -- wishful thinking
        setContentType "application/x-tar"
        -- setContentEncoding "gzip"
        setContentLength (fromIntegral $ BS.length tgz)

    lft <- use hcReqLeft
    unless (lft > 0) $
        fail "hackagePutTgz: request budget exhausted for current connection"

    c <- openHConn
    liftIO $ sendRequest c q1 (bsBody tgz)
    resp <- liftIO $ try (receiveResponse c concatHandler')
    closeHConn
    hcReqCnt += 1

    case resp of
        Right bs -> -- do
            -- liftIO $ BS.writeFile "raw.out" bs
            return bs

        Left e@HttpClientError {} -> -- do
            return (BS8.pack $ show e)

hackageRecvResp :: HIO ByteString
hackageRecvResp = do
    c <- openHConn
    reqCnt <- use hcReqCnt
    rspCnt <- use hcRspCnt
    unless (reqCnt > rspCnt) $
        fail "hackageRecvResp: not response available to receive"

    resp <- liftIO $ receiveResponse c concatHandler'
    hcRspCnt += 1

    return resp

-- | Whether to operate in review/test mode or publish the revision for real
data DryWetRun = DryRun -- ^ review/test mode
               | WetRun -- ^ publish

hackagePostCabal :: (ByteString,ByteString) -> (PkgName,PkgVer) -> ByteString -> DryWetRun -> HIO ByteString
hackagePostCabal cred (pkgn,pkgv) rawcab dry = do
    when (boundary `BS.isInfixOf` rawcab) $ fail "WTF... cabal file contains boundary-pattern"

    q1 <- liftIO $ buildRequest $ do
        http POST urlpath
        setUA
        uncurry setAuthorizationBasic cred
        setAccept "application/json" -- wishful thinking
        setContentType ("multipart/form-data; boundary="<>boundary) -- RFC2388
        setContentLength bodyLen

    c <- reOpenHConn

    liftIO $ sendRequest c q1 (bsBody body)

    resp <- liftIO $ try (receiveResponse c concatHandler')
    closeHConn

    case resp of
        Right bs -> -- do
            -- liftIO $ BS.writeFile "raw.out" bs
            return (BS8.unlines [ h2 <> ":\n" <> renderTags ts | (h2, ts) <- scrape200 bs ])

        Left e@HttpClientError {} -> -- do
            -- Hackage currently timeouts w/ 503 guru meditation errors,
            -- which usually means that the transaction has succeeded
            -- liftIO $ BS.writeFile "raw.out" bs
            return (BS8.pack $ show e)
  where
    urlpath = mconcat [ "/package/", pkgn, "-", pkgv, "/", pkgn, ".cabal/edit" ]

    isDry DryRun = True
    isDry WetRun = False

    body = Builder.toLazyByteString $ multiPartBuilder boundary
           [ ("cabalfile",[],[],rawcab)
           , if isDry dry
             then ("review", [],[],"Review changes")
             else ("publish",[],[],"Publish new revision")
           ]

    bodyLen = fromIntegral $ BSL.length body

    boundary = "4d5bb1565a084d78868ff0178bdf4f61"

    -- scrape200 :: ByteString -> (Bool, h2parts)
    scrape200 html = h2parts
      where
        tags = parseTags (html :: ByteString)

        h2parts = [ (t,map cleanText $ takeWhile (/= TagClose "form") xs)
                  | (TagOpen "h2" _: TagText t: TagClose "h2": xs) <- partitions (== TagOpen "h2" []) tags
                  , t /= "Advice on adjusting version constraints" ]

        cleanText (TagText t)
          | t' == "", '\n' `BS8.elem` t = TagText "\n"
          | otherwise               = TagText t
          where
            t' = fst . BS8.spanEnd (=='\n') . BS8.dropWhile (=='\n') $ t
        cleanText x = x

class ToBuilder a where
  toBuilder :: a -> Builder.Builder

instance ToBuilder ByteString where
  toBuilder = Builder.byteString

instance ToBuilder BSL.ByteString where
  toBuilder = Builder.lazyByteString

bsBody :: ToBuilder a => a -> Streams.OutputStream Builder.Builder -> IO ()
bsBody bs = Streams.write (Just (toBuilder bs))

-- | Upload a candidate to Hackage
--
-- This is a bit overkill, as one could easily just use @curl(1)@ for this:
--
-- > curl --form package=@"$PKGID".tar.gz -u "${CREDS}" https://hackage.haskell.org/packages/candidates/
--
hackagePushCandidate :: (ByteString,ByteString) -> (FilePath,ByteString) -> HIO ByteString
hackagePushCandidate cred (tarname,rawtarball) = do
    when (boundary `BS.isInfixOf` rawtarball) $ fail "WTF... tarball contains boundary-pattern"

    q1 <- liftIO $ buildRequest $ do
        http POST urlpath
        setUA
        uncurry setAuthorizationBasic cred
        setAccept "application/json" -- wishful thinking
        setContentType ("multipart/form-data; boundary="<>boundary) -- RFC2388
        setContentLength bodyLen

    c <- reOpenHConn

    liftIO $ sendRequest c q1 (bsBody body)

    resp <- liftIO $ try (receiveResponse c (\r is -> (,) r <$> concatHandler r is))
    closeHConn

    case resp of
        Right (rc,bs) -> do
            return (BS8.pack (show rc) <> bs)
        Left (HttpClientError code bs) -> return (BS8.pack ("code=" <> show code <> "\n") <> bs)
            -- Hackage currently timeouts w/ 503 guru meditation errors,
            -- which usually means that the transaction has succeeded
  where
    urlpath = "/packages/candidates/"

    body = Builder.toLazyByteString $
           multiPartBuilder boundary [ ("package", [("filename", BS8.pack tarname)]
                                     , ["Content-Type: application/gzip"], rawtarball)]
    bodyLen = fromIntegral $ BSL.length body

    boundary = "4d5bb1565a084d78868ff0178bdf4f61"

-- | Simplified RFC2388 multipart/form-data formatter
--
-- TODO: make a streaming-variant
multiPartBuilder :: ByteString -> [(ByteString,[(ByteString,ByteString)],[ByteString],ByteString)] -> Builder.Builder
multiPartBuilder boundary mparts = mconcat $ concatMap mkPart mparts ++ trailer
  where
    mkPart (name, xprops, xhdrs, payload)
        = [ dash, bs boundary, crlf
          , bs"Content-Disposition: form-data; name=\"", bs name, bs"\""
          ] ++
          concat [ [bs "; ", bs k, bs"=\"", bs v, bs"\"" ] | (k,v) <- xprops ] ++ [ crlf ] ++
          concat [ [bs h, crlf] | h <- xhdrs ] ++
          [ crlf
          , bs payload, crlf
          ]

    trailer = [ dash, bs boundary, dash, crlf ]

    crlf = bs"\r\n"
    dash = bs"--"
    bs = Builder.byteString

fetchVersions :: PkgName -> HIO [(PkgVer,PkgVerStatus)]
fetchVersions pkgn = do
    hackageSendGET ("/package/" <> pkgn <> "/preferred") "application/json"
    resp <- hackageRecvResp
    case decodeVersions resp of
        Right xs -> pure xs
        Left err -> fail err

fetchCabalFile :: PkgName -> PkgVer -> HIO ByteString
fetchCabalFile pkgn pkgv = do
    hackageSendGET urlpath "text/plain"
    hackageRecvResp
  where
    urlpath = mconcat ["/package/", pkgn, "-", pkgv, "/", pkgn, ".cabal"]

fetchCabalFiles :: PkgName -> [PkgVer] -> HIO [(PkgVer,ByteString)]
fetchCabalFiles pkgn pkgvs0 = do
    -- HTTP pipelining
    tmp <- go [] pkgvs0
    return (concat . reverse $ tmp)
  where
    go acc [] = pure acc
    go acc vs0 = do
        (_,lft) <- getHConn
        let (vs,vs') = nsplitAt lft vs0
        when (null vs) $ fail "fetchCabalFiles: the impossible happened"

        -- HTTP-pipeline requests; compensates a bit for SSL-induced latency
        mcabs <- forM (mkPipeline 4 vs) $ \case
            Left pkgv -> do -- request
                let urlpath = mconcat ["/package/", pkgn, "-", pkgv, "/", pkgn, ".cabal"]
                -- liftIO $ putStrLn $ show urlpath
                hackageSendGET urlpath "text/plain"
                return Nothing

            Right pkgv -> do -- response
                -- liftIO $ putStrLn ("read " ++ show pkgv)
                resp <- hackageRecvResp
                return $ Just (pkgv, resp)

        go (catMaybes mcabs : acc) vs'

-- Left means request; Right means receive
mkPipeline :: Natural -> [a] -> [Either a a]
mkPipeline maxQ vs
  | not postCond = error "mkPipeline: internal error" -- paranoia
  | otherwise    = concat [ map Left rqs1
                          , concat [ [Left v1, Right v2] | (v1,v2) <- zip rqs2 res2 ]
                          , map Right res3
                          ]
  where
    (rqs1,rqs2) = nsplitAt n vs
    (res2,res3) = nsplitAt m vs

    postCond = sameLen rqs2 res2 && sameLen rqs1 res3

    l = nlength vs
    n = min l maxQ
    m = l-n

    sameLen [] []         = True
    sameLen (_:xs) (_:ys) = sameLen xs ys
    sameLen [] (_:_)      = False
    sameLen (_:_) []      = False

fetchAllCabalFiles :: PkgName -> C.VersionRange -> HIO [(PkgVer,Maybe ByteString)]
fetchAllCabalFiles pkgn vrange = do
    vs <- fetchVersions pkgn
    liftIO $ putStrLn ("Found " ++ show (length vs) ++ " package versions for " ++ show pkgn ++ ", downloading now...")

    let (wanted,unwanted) = List.partition (`pkgVerInRange` vrange) (map fst vs)

    fetched <- map (fmap Just) <$> fetchCabalFiles pkgn wanted
    pure (List.sortOn (pkgVerToVersion . fst) (fetched ++ [ (v,Nothing) | v <- unwanted ]))

data PkgVerStatus = Normal | UnPreferred | Deprecated deriving (Eq,Show)
instance NFData PkgVerStatus where rnf !_ = ()

decodeVersions :: ByteString -> Either String [(PkgVer,PkgVerStatus)]
decodeVersions bs = do
    obj <- J.eitherDecode' (BSL.fromStrict bs)
    flip J.parseEither obj $ \o -> do
        normal <- o J..:? "normal-version"
        unpreferred <- o J..:? "unpreferred-version"
        deprecated <- o J..:? "deprecated-version"
        pure $ toPairs Normal normal ++ toPairs UnPreferred unpreferred ++ toPairs Deprecated deprecated
  where
    toPairs :: PkgVerStatus -> Maybe [String] -> [(PkgVer,PkgVerStatus)]
    toPairs s (Just vs) = [(BS8.pack v, s) | v <- vs]
    toPairs _ _ = []

closeHConn :: HIO ()
closeHConn = do
    mhc <- use hcConn
    forM_ mhc $ \hc -> do
        liftIO $ closeConnection hc
        hcConn   .= Nothing

        reqCnt <- use hcReqCnt
        rspCnt <- use hcRspCnt
        unless (reqCnt == rspCnt) $
            liftIO $ putStrLn $ concat ["warning: req-cnt=", show reqCnt, " rsp-cnt=", show rspCnt]

        hcReqCnt .= 0
        hcRspCnt .= 0

openHConn :: HIO Connection
openHConn = use hcConn >>= \case
    Just c -> return c
    Nothing -> do
        mkConn <- use hcMkConn
        c <- liftIO mkConn
        hcConn   .= Just c
        hcReqCnt .= 0 -- redundant
        hcRspCnt .= 0 -- redundant
        return c

reOpenHConn :: HIO Connection
reOpenHConn = closeHConn >> openHConn

getHConn :: HIO (Connection,Natural)
getHConn = do
    lft <- use hcReqLeft
    c <- if lft > 0 then openHConn else reOpenHConn
    (,) c <$> use hcReqLeft

nlength :: [a] -> Natural
nlength = fromIntegral . length

nsplitAt :: Natural -> [a] -> ([a],[a])
nsplitAt n = splitAt i
  where
    i = fromMaybe (error "nsplitAt: overflow") $ toIntegralSized n

-- | Returns the position @(line, indentation)@ where to insert the
-- new @build-depends:@ immediately after the first @library@ section,
-- if any.
--
findLibrarySection :: [C.Field C.Position] -> Maybe (Int, Int)
findLibrarySection [] = Nothing
findLibrarySection (C.Section (C.Name (C.Position row _) "library") [] fs : _) =
    Just (row, findIndent fs)
  where
    findIndent [] = 4
    findIndent (f : _) = case C.fieldAnn f of
        C.Position _ col -> pred col
findLibrarySection (_ : fs) = findLibrarySection fs

----------------------------------------------------------------------------
-- CLI Interface

data Options = Options
  { optVerbose :: !Bool
  , optHost    :: !Hostname
  , optCommand :: !Command
  } deriving Show

data PullCOptions = PullCOptions
  { optPlCPkgName :: !PkgName
  , optPlCIncrRev :: !Bool
  , optPlCForce   :: !Bool
  , optPlCPkgVers :: Maybe C.VersionRange
  } deriving Show

data SyncCOptions = SyncCOptions
  { optSyCFile    :: FilePath
  , optSyCIncrRev :: !Bool
  , optSyCForce   :: !Bool
  } deriving Show

data ListCOptions = ListCOptions
  { optLCPkgName :: !PkgName
  , optNoAnn     :: !Bool
  , optRevUrls   :: !Bool
  } deriving Show

data PushCOptions = PushCOptions
  { optPsCIncrRev :: !Bool
  , optPsCPublish :: !Bool
  , optPsCFiles   :: [FilePath]
  } deriving Show

data PushPCOptions = PushPCOptions
  { optPPCFiles :: [FilePath]
  } deriving Show

data CheckROptions = CheckROptions
  { optCRNew  :: FilePath
  , optCROrig :: FilePath
  } deriving Show

type AddBoundOptions = AddBoundOptions' [FilePath]
data AddBoundOptions' a = AddBoundOptions
  { optABPackageName  :: C.PackageName
  , optABVersionRange :: C.VersionRange
  , optForce          :: Bool              -- ^ Disable the check whether bound is subsumed by existing constraints.
  , optABFiles        :: a                 -- ^ One or several files.
  } deriving (Show, Functor)

data Command
    = ListCabal !ListCOptions
    | PullCabal !PullCOptions
    | PushCabal !PushCOptions
    | SyncCabal !SyncCOptions
    | PushCandidate !PushPCOptions
    | CheckRevision !CheckROptions
    | IndexShaSum   !IndexShaSumOptions
    | AddBound !AddBoundOptions
    deriving Show

optionsParserInfo :: ParserInfo Options
optionsParserInfo
    = info (helper <*> verOption <*> oParser)
           (fullDesc
            <> header "hackage-cli - CLI tool for Hackage"
            <> footer footerStr)
  where
    footerStr = unwords
        [ "Each command has a sub-`--help` text. Hackage credentials are expected to be"
        , "stored in an `${HOME}/.netrc`-entry (or `.netrc.gpg`) for the respective Hackage hostname."
        , "E.g. \"machine hackage.haskell.org login MyUserName password TrustNo\"."
        , "All interactions with Hackage occur TLS-encrypted via the HTTPS protocol."
        ]

    bstr = BS8.pack <$> str

    prsc :: C.Parsec s => OA.ReadM s
    prsc = OA.eitherReader C.eitherParsec

    vrange = do
        s <- str
        case C.simpleParse s of
            Nothing -> fail "invalid version range"
            Just vr -> pure vr

    listcoParser = ListCabal <$>
        (ListCOptions <$> OA.argument bstr (metavar "PKGNAME" <> action "file")
                      <*> switch (long "no-annotations" <> help "don't add preferred-versions annotations")
                      <*> switch (long "rev-urls" <> help "list revision URLs"))

    pullcoParser = PullCabal <$>
        (PullCOptions <$> OA.argument bstr (metavar "PKGNAME" <> action "file")
                      <*> switch (long "incr-rev" <> help "increment x-revision field")
                      <*> switch (long "force" <> help "force overwriting existing files")
                      <*> optional (OA.argument vrange (metavar "VERSION-CONSTRAINT")))

    synccoParser = SyncCabal <$>
        (SyncCOptions <$> OA.argument str (metavar "CABALFILE" <> action "file")
                      <*> switch (long "incr-rev" <> help "increment x-revision field")
                      <*> switch (long "force" <> help "force overwriting local file with older revision"))

    pushcoParser = PushCabal <$> (PushCOptions
                             <$> switch (long "incr-rev" <> help "increment x-revision field")
                             <*> switch (long "publish"  <> help "publish revision (review-mode)")
                             <*> some (OA.argument str (metavar "CABALFILES..." <> action "file")))

    pushpcoParser = PushCandidate <$> (PushPCOptions <$> some (OA.argument str (metavar "TARBALLS..." <> action "file")))

    checkrevParsser = CheckRevision <$> (CheckROptions <$> OA.argument str (metavar "NEWCABAL" <> action "file")
                                                       <*> OA.argument str (metavar "OLDCABAL" <> action "file"))


    indexssParser = IndexShaSum <$> (IndexShaSumOptions <$> switch (long "flat" <> help "flat filesystem layout (used by mirrors)")
                                                        <*> OA.argument str (metavar "INDEX-TAR" <> action "file")
                                                        <*> optional (OA.argument str (metavar "BASEDIR" <> action "directory")))

    addboundParser = AddBound <$> (AddBoundOptions <$> OA.argument prsc (metavar "DEPENDENCY")
                                                   <*> OA.argument prsc (metavar "VERSIONRANGE")
                                                   <*> OA.switch (long "force" <> help "Add bound even if it is already subsumed by existing constraints.")
                                                   <*> some (OA.argument str (metavar "CABALFILES..." <> action "file")))

    oParser
        = Options <$> switch (long "verbose" <> help "Enable verbose output.")
                  <*> option bstr (long "hostname"  <> metavar "HOSTNAME" <> value "hackage.haskell.org"
                                   <> help "Hackage hostname" <> showDefault)
                  <*> subparser (mconcat [ command "pull-cabal" (info (helper <*> pullcoParser)
                                                   (progDesc "Download .cabal files for a package."))
                                         , command "push-cabal" (info (helper <*> pushcoParser)
                                                   (progDesc "Upload revised .cabal files."))
                                         , command "sync-cabal" (info (helper <*> synccoParser)
                                                   (progDesc "Update/sync local .cabal file with latest revision on Hackage."))
                                         , command "push-candidate" (info (helper <*> pushpcoParser)
                                                   (progDesc "Upload package candidate(s)."))
                                         , command "list-versions" (info (helper <*> listcoParser)
                                                   (progDesc "List versions for a package."))
                                         , command "check-revision" (info (helper <*> checkrevParsser)
                                                   (progDesc "Validate revision."))
                                         , command "index-sha256sum" (info (helper <*> indexssParser)
                                                   (progDesc "Generate sha256sum-format file."))
                                         , command "add-bound" (info (helper <*> addboundParser)
                                                   (progDesc "Add bound to the library section of a package, unless the bound is redundant. The .cabal file is edited in place."))
                                         ])

    verOption = infoOption verMsg (long "version" <> help "Output version information and exit.")
      where
        verMsg = "hackage-cli " <> V.showVersion Paths_hackage_cli.version

----------------------------------------------------------------------------

main :: IO ()
main = do
    opts <- execParser optionsParserInfo
    mainWithOptions opts

mainWithOptions :: Options -> IO ()
mainWithOptions Options{ optHost, optCommand } = do
   case optCommand of
       PullCabal (PullCOptions{ optPlCPkgName, optPlCIncrRev, optPlCForce, optPlCPkgVers }) -> do
           let pkgn = optPlCPkgName

           cs <- runHConn (fetchAllCabalFiles pkgn (fromMaybe C.anyVersion optPlCPkgVers))

           forM_ cs $ \(v,mraw) -> case mraw of
             Nothing -> putStrLn ("skipped excluded " ++ BS8.unpack v)
             Just raw0 -> do
               let fn = BS8.unpack $ pkgn <> "-" <> v <> ".cabal"

               let raw | optPlCIncrRev = incrXrev raw0
                       | otherwise     = raw0

               doesFileExist fn >>= \case
                   False -> do
                       BS.writeFile fn raw
                       putStrLn ("saved " ++ fn ++ " (" ++ show (BS.length raw) ++ " bytes)")
                   True ->
                       if optPlCForce
                       then do
                         BS.writeFile fn raw
                         putStrLn ("overwritten " ++ fn ++ " (" ++ show (BS.length raw) ++ " bytes)")
                       else
                         putStrLn ("WARNING: skipped existing " ++ fn ++ " (use --force to overwrite)")

           return ()

       SyncCabal (SyncCOptions{ optSyCFile, optSyCIncrRev, optSyCForce }) -> do
           (pkgn,pkgv,xrev) <- pkgDescToPkgIdXrev <$>
             C.readGenericPackageDescription
               C.deafening
#if MIN_VERSION_Cabal(3,14,0)
               Nothing
               (makeSymbolicPath optSyCFile)
#else
               optSyCFile
#endif
           cab0 <- BS.readFile optSyCFile

           BS8.putStrLn $ mconcat [ "local :  "
                                  , pkgn, "-", pkgv, "-r", BS8.pack (show xrev)
                                  , "   ('", BS8.pack optSyCFile, "')"
                                  ]

           cab' <- runHConn (fetchCabalFile pkgn pkgv)

           let (pkgn',pkgv',xrev') = pkgDescToPkgIdXrev $ parseGenericPackageDescription' cab'

           BS8.putStrLn $ mconcat [ "remote:  "
                                  , pkgn', "-", pkgv', "-r", BS8.pack (show xrev')
                                  ]

           let cab'' = cabalEditXRev (xrev'+1) cab'
               bakfn = optSyCFile <> "~"

           case () of
             _ | optSyCIncrRev, cab'' == cab0 -> do
                     putStrLn "INFO: local and (incremented) latest remote .cabal revision are already identical! Nothing to do."

             _ | not optSyCForce, xrev' < xrev -> do
                     putStrLn "ERROR: Local file has higher revision number than Hackage - aborting! (use --force to allow this)"
                     exitFailure

             _ | optSyCIncrRev, cab'' /= cab0 -> do
                     when (cab' == cab0) $ do
                         putStrLn "NOTE: local and (non-incremented) latest remote .cabal revision are identical."

                     BS.writeFile bakfn cab0
                     putStrLn ("INFO: saved backup of original local file to " <> bakfn)

                     BS.writeFile optSyCFile cab''
                     BS8.putStrLn $ mconcat [ "local :  "
                                            , pkgn, "-", pkgv, "-r", BS8.pack (show $ xrev'+1)
                                            , "   ('", BS8.pack optSyCFile, "')"
                                            ]

             _ | cab' == cab0 -> do
                     putStrLn "INFO: local and latest remote .cabal revision are already identical! Nothing to do."

             _ -> do
                     BS.writeFile bakfn cab0
                     putStrLn ("INFO: saved backup of original local file to " <> bakfn)

                     BS.writeFile optSyCFile cab'
                     BS8.putStrLn $ mconcat [ "local :  "
                                            , pkgn, "-", pkgv, "-r", BS8.pack (show xrev')
                                            , "   ('", BS8.pack optSyCFile, "')"
                                            ]


       ListCabal (ListCOptions{ optLCPkgName, optNoAnn, optRevUrls }) -> do
           let pkgn = optLCPkgName

           vs <- runHConn (fetchVersions pkgn)

           unless optNoAnn $
             putStrLn $ concat [ "Found ", show (length vs), " package versions for "
                               , show pkgn, " ([U]npreferred, [D]eprecated):"
                               ]

           if optRevUrls then do
             forM_ vs $ \(v,_) -> do
                 let pid = pkgn <> "-" <> v
                 BS8.putStrLn $ mconcat [ " - https://hackage.haskell.org/package/", pid, "/revisions/" ]
           else do
             forM_ vs $ \(v,unp) -> do
                 let status = case unp of
                         _ | optNoAnn -> ""
                         Normal      -> "    "
                         Deprecated  -> "[D] "
                         UnPreferred -> "[U] "
                 BS8.putStrLn $ status <> pkgn <> "-" <> v
           return ()

       PushCabal (PushCOptions{ optPsCIncrRev, optPsCPublish, optPsCFiles }) -> do
           (username,password) <- maybe (fail "missing Hackage credentials") return =<< getHackageCreds
           putStrLn $ "Using Hackage credentials for username " ++ show username

           forM_ optPsCFiles $ \fn -> do
               (pkgn, pkgv, xrev0) <- pkgDescToPkgIdXrev <$>
                 C.readGenericPackageDescription
                   C.deafening
#if MIN_VERSION_Cabal(3,14,0)
                   Nothing
                   (makeSymbolicPath fn)
#else
                   fn
#endif
               let xrev = applyWhen optPsCIncrRev (+1) xrev0

               putStrLn $ concat [ "Pushing ", show fn
                                 , " (", BS8.unpack pkgn, "-", BS8.unpack pkgv, "~", show xrev, ")"
                                 , if not optPsCPublish then " [review-mode]" else "", " ..."
                                 ]

               rawcab <- applyWhen optPsCIncrRev (cabalEditXRev xrev) <$> BS.readFile fn
               (dt, tmp) <- timeIt $ runHConn $
                 hackagePostCabal (username, password) (pkgn, pkgv) rawcab $
                   if optPsCPublish then WetRun else DryRun

               printf "Hackage response was (after %.3f secs):\n" dt
               putStrLn (replicate 80 '=')
               BS8.putStrLn (tidyHtml tmp)
               putStrLn (replicate 80 '=')

       PushCandidate (PushPCOptions{ optPPCFiles }) -> do
           (username,password) <- maybe (fail "missing Hackage credentials") return =<< getHackageCreds
           putStrLn $ "Using Hackage credentials for username " ++ show username

           forM_ optPPCFiles $ \fn -> do
               putStrLn $ "reading " ++ show fn ++ " ..."
               rawtar <- BS.readFile fn
               putStrLn $ "uplading to Hackage..."
               tmp <- runHConn (hackagePushCandidate (username,password) (takeFileName fn, rawtar))

               putStrLn "Hackage response was:"
               putStrLn (replicate 80 '=')
               BS8.putStrLn tmp
               putStrLn (replicate 80 '=')


       CheckRevision (CheckROptions{ optCRNew, optCROrig }) -> do
           old <- BS.readFile optCROrig
           new <- BS.readFile optCRNew

           case diffCabalRevisions old new of
               Left err -> do
                   putStrLn "change not allowed:"
                   putStrLn err
                   exitFailure

               Right [] -> do
                   putStrLn "no-op change detected"
                   exitFailure

               Right changes -> do
                   putStrLn "change allowed:"
                   forM_ changes $ \(Change _ what old' new') -> do
                       putStrLn $ "what: " ++ what
                       putStrLn $ " old: " ++ old'
                       putStrLn $ " new: " ++ new'

           return ()

       IndexShaSum opts -> IndexShaSum.run opts

       AddBound ab@AddBoundOptions{ optABFiles } -> do
         -- Run add-bound for all given cabal files, skipping to next on error.
         results <- forM optABFiles $ \fp -> do
           runExceptT (addBound (fp <$ ab)) >>= \case
             Left err -> False <$ log err
             Right () -> return True
         -- If add-bound failed for one cabal file, report failure.
         unless (and results) $ exitFailure

   return ()
  where
    mkHConn = do
        sslCtx <- baselineContextSSL
        pure $ HConn (openConnectionSSL sslCtx optHost 443) Nothing 0 0

    runHConn act = do
        hc0 <- mkHConn
        flip evalStateT hc0 $ do
            res <- act
            closeHConn
            return res

    getNetrcContents :: IO (Maybe ByteString)
    getNetrcContents = do
        mhome <- lookupEnv "HOME"
        case mhome of
            Nothing -> return Nothing
            Just "" -> return Nothing
            Just ho -> do
                let fnGpg = ho ++ "/.netrc.gpg"
                let fn = ho ++ "/.netrc"
                gpgExists <- doesFileExist fnGpg
                if gpgExists
                then readGpg fnGpg
                else readPlain fn
      where
        readGpg fn = do
            (ec, out, err) <- readProcessWithExitCode "gpg" ["--decrypt", fn] ""
            case ec of
                ExitSuccess   -> return (Just out)
                ExitFailure _ -> BS.putStr err >> return Nothing

        readPlain fn = do
            ret <- tryIOError (BS.readFile fn)
            case ret of
                Left e | isDoesNotExistError e -> return Nothing
                       | otherwise             -> ioError e
                Right b -> return $! Just b

    getHackageCreds :: IO (Maybe (ByteString,ByteString))
    getHackageCreds = do
        getNetrcContents >>= \case
            Nothing -> pure Nothing
            Just contents -> case parseNetRc "netrc" contents of
                Left _ -> fail "Invalid ${HOME}/.netrc(.gpg) found"
                Right NetRc {..} ->
                    evaluate $ (\NetRcHost{..} -> (nrhLogin,nrhPassword))
                               <$> listToMaybe (filter ((== optHost) . nrhName) nrHosts)


    pkgDescToPkgIdXrev pdesc = force (BS8.pack pkgn, BS8.pack $ showVersion pkgv, read xrev :: PkgRev)
      where
        C.PackageIdentifier (C.unPackageName -> pkgn) pkgv = C.package . C.packageDescription $ pdesc
        xrev = fromMaybe "0" . lookup "x-revision" . C.customFieldsPD . C.packageDescription $ pdesc

    incrXrev :: ByteString -> ByteString
    incrXrev cabdata0 = cabalEditXRev (xrev0+1) cabdata0
      where
        pdesc0 = parseGenericPackageDescription' cabdata0
        (_,_,xrev0) = pkgDescToPkgIdXrev pdesc0

parseGenericPackageDescription' :: ByteString -> LC.GenericPackageDescription
parseGenericPackageDescription' bs =
    case snd $ C.runParseResult $ C.parseGenericPackageDescription bs of
        Left (_, es) -> error $ List.intercalate "\n" $ map (C.showPError "<.cabal>") $ toList es
        Right x      -> x

extractRange :: LC.GenericPackageDescription -> C.PackageName -> C.VersionRange
extractRange gpd pkgName =
    List.foldl' C.intersectVersionRanges C.anyVersion vss
  where
    vss = gpd ^.. LC.condLibrary . _Just . condTreeDataL . LC.targetBuildDepends . traverse . to ext . _Just
    ext (C.Dependency pkgName' vr _)
       | pkgName == pkgName' = Just vr
       | otherwise           = Nothing

condTreeDataL :: Functor f => (a -> f a) -> C.CondTree v c a -> f (C.CondTree v c a)
condTreeDataL f (C.CondNode x c cs) = f x <&> \y -> C.CondNode y c cs


-- | Try to add the given bound to the given cabal file.
--
-- Non-fatal errors (like parse errors) are reported in the Except monad.
--
addBound :: AddBoundOptions' FilePath -> ExceptT String IO ()
addBound AddBoundOptions{ optABPackageName, optABVersionRange, optForce, optABFiles = fp } = do

  old <- liftIO $ BS.readFile fp
  fs <- either (\ err -> throwError $ unwords ["Parsing", fp, "failed:", show err]) return $
      C.readFields old
  let addConfig = AddConfig
        { cnfOrigContents = old
        , cnfFields = fs
        , cnfComponent = Right (C.CLibName C.LMainLibName)
        , cnfTargetField = BuildDepends
        , cnfAdditions = pure $ BS8.pack $ C.prettyShow optABPackageName ++ " " ++ C.prettyShow optABVersionRange
        }
  new <- case executeAddConfig (\_ _ -> True) addConfig of
    Just x -> pure x
    Nothing -> throwError $ "Cannot find library section in " ++ fp

  -- interpretation of version ranges
  let oldGpd = parseGenericPackageDescription' old
      newGpd = parseGenericPackageDescription' new

      oldRange = extractRange oldGpd optABPackageName
      newRange = extractRange newGpd optABPackageName

      oldRange' = C.intersectVersionRanges oldRange optABVersionRange

      -- Canonical forms (semantics)
      oldSem  = C.toVersionIntervals oldRange   -- existing range
      oldSem' = C.toVersionIntervals oldRange'  -- range after adding the bound (theory)
      newSem  = C.toVersionIntervals newRange   -- range after adding the bound (practice)

  -- Necessity check: does the addition of the bound change the semantics?
  -- if not, it can be skipped.

  if not optForce && oldSem' == oldSem then do

    log $ concat [ "Skipping ", fp, ": bound already subsumed by existing constraints (use --force to add nevertheless)." ]

  else do
    -- sanity check: did the addition have the intended outcome?
    unless (newSem == oldSem') $
      (if optForce then log . ("Ignoring check: " ++) else throwError . ("Edit failed, " ++)) $
         unwords
           [ "version ranges don't match: "
           , C.prettyShow oldRange
           , "&&"
           , C.prettyShow optABVersionRange
           , "=/="
           , C.prettyShow newRange
           ]

    -- write new version
    log $ unwords [ "Adding bound to", fp ]
    liftIO $ BS.writeFile fp new

-- | Print line to 'stderr'.
log :: MonadIO m => String -> m ()
log = liftIO . hPutStrLn stderr

-- | Try to clean-up HTML fragments to be more readable
tidyHtml :: ByteString -> ByteString
tidyHtml =
    replace "&amp;"  "&"     . -- must be last entity substitution
    replace "&gt;"   ">"     .
    replace "&lt;"   "<"     .
    replace "<p>"    ""      . -- tags must be replaced before entities
    replace "</p>"   "\n"    .
    replace "<li>"   "\n * " .
    replace "</li>"  ""      .
    replace "</pre>" "`"     .
    replace "<pre>"  "`"     .
    stripEnd
  where
    stripEnd = fst . BS8.spanEnd isSpace

    replace :: ByteString -> ByteString -> ByteString -> ByteString
    replace old new = BSL.toStrict . BSS.replace old new


timeIt :: IO a -> IO (Double, a)
timeIt act = do
    t0  <- getTime
    res <- act
    t1  <- getTime
    let !dt = t1 - t0
    pure (dt, res)
  where
    getTime :: IO Double
    getTime = realToFrac `fmap` getPOSIXTime