/package/" fn
+
+ packagejson2sha :: J.Value -> Maybe [(ByteString, ByteString)]
+ packagejson2sha = J.parseMaybe go1
+ where
+ go1 :: J.Value -> J.Parser [(ByteString, ByteString)]
+ go1 = J.withObject "PackageJson" $ \o -> do
+ signed <- o J..: "signed"
+ targets <- signed J..: "targets"
+ J.withObject "PackageJson.signed.targets" go2 targets
+
+ go2 :: J.Object -> J.Parser [(ByteString, ByteString)]
+ go2 m = forM (KeyMap.toList m) $ \(k,v) -> do
+ J.withObject ".targets{}" (go3 k) v
+
+ go3 :: Key -> J.Object -> J.Parser (ByteString, ByteString)
+ go3 k o = do
+ hashes <- o J..: "hashes"
+ sh256 <- hashes J..: "sha256"
+ return (T.encodeUtf8 (keyToText k), T.encodeUtf8 sh256)
+
+strictPair :: a -> b -> (a,b)
+strictPair !a !b = (a,b)
+
+stripPrefixBS :: ByteString -> ByteString -> Maybe ByteString
+stripPrefixBS pfx b
+ | BS.isPrefixOf pfx b = Just $ BS.drop (BS.length pfx) b
+ | otherwise = Nothing
+
+
+stripSuffixBS :: ByteString -> ByteString -> Maybe ByteString
+stripSuffixBS sfx b
+ | BS.isSuffixOf sfx b = Just $ BS.take (BS.length b - BS.length sfx) b
+ | otherwise = Nothing
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,958 @@
+{-# 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 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.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 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
+
+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.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.Server.Util.CabalRevisions
+import IndexShaSum
+import CabalEdit
+
+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
+
+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
+
+data AddBoundOptions = AddBoundOptions
+ { optABPackageName :: C.PackageName
+ , optABVersionRange :: C.VersionRange
+ , optForce :: Bool -- ^ Disable the check whether bound is subsumed by existing constraints.
+ , optABMessage :: [String]
+ , optABFiles :: [FilePath]
+ } deriving Show
+
+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.")
+ <*> many (OA.option str (OA.short 'm' <> OA.long "message" <> metavar "MSG" <> help "Use given MSG as a comment. If multiple -m options are given, their values are concatenated with 'unlines'."))
+ <*> 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 {..} = do
+ case optCommand of
+ PullCabal (PullCOptions {..}) -> 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 {..}) -> do
+ (pkgn,pkgv,xrev) <- pkgDescToPkgIdXrev <$> C.readGenericPackageDescription C.deafening optSyCFile
+ 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 {..}) -> 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 {..}) -> do
+ (username,password) <- maybe (fail "missing Hackage credentials") return =<< getHackageCreds
+ putStrLn $ "Using Hackage credentials for username " ++ show username
+
+ forM_ optPsCFiles $ \fn -> do
+ (pkgn,pkgv,xrev) <- pkgDescToPkgIdXrev <$> C.readGenericPackageDescription C.deafening fn
+ putStrLn $ concat [ "Pushing ", show fn
+ , " (", BS8.unpack pkgn, "-", BS8.unpack pkgv, "~", show xrev, ")"
+ , if not optPsCPublish then " [review-mode]" else "", " ..."
+ ]
+
+ let editCab | optPsCIncrRev = cabalEditXRev (xrev+1)
+ | otherwise = id
+
+ rawcab <- editCab <$> 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 {..}) -> 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 {..}) -> 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 AddBoundOptions {..} -> forM_ optABFiles $ \fp -> do
+ old <- BS.readFile fp
+
+ -- idea is simple:
+ -- - .cabal is line oriented file
+ -- - find "library" section start
+ -- - bonus: look of an indentation used from the next field/section there
+ -- - insert data into a bytestring "manually"
+ fs <- either (exitFailureWith . show) return $ C.readFields old
+ (lin, indent) <- maybe
+ (exitFailureWith $ "Cannot find library section in " ++ fp)
+ return
+ (findLibrarySection fs)
+
+ let msgLines = map ("-- " ++) optABMessage
+ bdLine = "build-depends: " ++ C.prettyShow optABPackageName ++ " " ++ C.prettyShow optABVersionRange
+ midLines = [ BS8.pack $ replicate indent ' ' ++ l
+ | l <- msgLines ++ [bdLine]
+ ] ++ [""] -- also add an empty line separator
+ (preLines, postLines) = splitAt lin $ BS8.lines old
+ new = BS8.unlines (preLines ++ midLines ++ postLines)
+
+ -- 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
+
+ putStrLn $ 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') $
+ exitFailureWith $ unwords
+ [ "Edit failed, version ranges don't match: "
+ , C.prettyShow oldRange
+ , "&&"
+ , C.prettyShow optABVersionRange
+ , "=/="
+ , C.prettyShow newRange
+ ]
+
+ -- write new version
+ putStrLn $ unwords [ "Adding bound to", fp ]
+ BS.writeFile fp new
+
+ 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
+
+ exitFailureWith e = do
+ putStrLn e
+ exitFailure
+
+ 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 gpd pkgName = case vss of
+ [] -> C.noVersion
+ (v:vs) -> List.foldl' C.intersectVersionRanges v vs
+ 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 clean-up HTML fragments to be more readable
+tidyHtml :: ByteString -> ByteString
+tidyHtml =
+ replace "&" "&" . -- must be last entity substitution
+ replace ">" ">" .
+ replace "<" "<" .
+ replace "" "" . -- tags must be replaced before entities
+ replace "
" "\n" .
+ replace "" "\n * " .
+ replace "" "" .
+ replace "" "`" .
+ replace "" "`" .
+ 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
diff --git a/tests/Tests.hs b/tests/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Tests.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE TupleSections #-}
+module Main (main) where
+
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import Distribution.Server.Util.CabalRevisions (diffCabalRevisions', Change (..))
+import Distribution.Simple.Utils (toUTF8BS)
+import System.FilePath ((), (-<.>))
+import Test.Tasty (defaultMain, testGroup, TestTree)
+import Test.Tasty.Golden (goldenVsStringDiff)
+
+main :: IO ()
+main = defaultMain $ testGroup "Fixtures"
+ -- basic sanity tests
+ [ golden "tree-diff" 0 1
+ , golden "deepseq" 0 1
+
+ -- adding a new conditional section with restricted bounds
+ -- TODO: this is not allowed
+ , golden "SVGFonts" 0 2
+
+ , golden "semigroups" 0 2
+ ]
+
+golden :: String -> Int -> Int -> TestTree
+golden name mi ma = case pairs [mi .. ma] of
+ [] -> golden' name mi ma
+ [(x, y)] -> golden' name x y
+ ps -> testGroup name
+ [ golden' name x y
+ | (x, y) <- ps
+ ]
+
+golden' :: String -> Int -> Int -> TestTree
+golden' name mi ma = goldenVsStringDiff name' diff gold $ do
+ o <- BS.readFile orig
+ e <- BS.readFile edit
+ return $ LBS.fromStrict $ toUTF8BS $ unlines $ case diffCabalRevisions' False o e of
+ Left err -> [ "ERROR", err ]
+ Right changes -> "OK" : concatMap showChange changes
+ where
+ name' = unwords [ name, show mi, "->", show ma ]
+ orig = "fixtures" name -<.> (show mi ++ ".cabal")
+ edit = "fixtures" name -<.> (show ma ++ ".cabal")
+ gold = "fixtures" name -<.> (show mi ++ "." ++ show ma ++ ".diff")
+
+ diff ref new = ["diff", "-u", ref, new]
+
+ showChange (Change sev what from to) =
+ [ show sev
+ , what
+ , "- " ++ from
+ , "+ " ++ to
+ ]
+
+-- cartesian product without diagonal
+-- the idea is that revisions should be transitive and symmetric
+pairs :: [a] -> [(a,a)]
+pairs [] = []
+pairs (x:xs) = map (x,) xs ++ map (,x) xs ++ pairs xs