{-# LANGUAGE CPP #-}
module Releaser.Primitives
(
CabalInfo (..),
cabalRead,
cabalWriteVersion,
cabalBumpVersion,
cabalSdist,
cabalUpload,
cabalMakeHaddocks,
cabalUploadDocs,
gitCheckout,
gitGetTags,
gitTag,
gitCommit,
gitPush,
gitPushTags,
gitAssertEmptyStaging,
prompt,
abort,
logStep,
changelogPrepare,
)
where
import qualified Data.ByteString as BS
import Data.Foldable (toList)
import Data.Functor (void)
import Data.List (intercalate)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Version (parseVersion)
import Distribution.PackageDescription.Parsec
import Distribution.Parsec (PWarning (..), showPError)
import Distribution.Simple.Utils (die', tryFindPackageDesc)
import Distribution.Types.GenericPackageDescription (GenericPackageDescription, packageDescription)
import Distribution.Types.PackageDescription (package)
import Distribution.Types.PackageId (pkgName, pkgVersion)
import Distribution.Types.PackageName (unPackageName)
import Distribution.Types.Version (mkVersion', versionNumbers)
import Distribution.Verbosity (Verbosity, normal, silent)
import System.Console.Pretty (Color (..), color)
import System.Environment (lookupEnv)
import System.Exit (ExitCode (..), exitFailure)
import System.IO
import System.Process
import Text.ParserCombinators.ReadP (ReadP, readP_to_S)
import Text.Regex.TDFA
import Text.Regex.TDFA.Text
logStep :: String -> IO ()
logStep :: String -> IO ()
logStep String
str =
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> String -> String
forall a. Pretty a => Color -> a -> a
color Color
Green String
">> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str
prompt :: String -> IO String
prompt :: String -> IO String
prompt String
str = do
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> String -> String
forall a. Pretty a => Color -> a -> a
color Color
Blue String
">> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str
Handle -> IO ()
hFlush Handle
stdout
IO String
getLine
promptRetry :: String -> IO ()
promptRetry :: String -> IO ()
promptRetry String
str =
IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
prompt (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
str String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". Retry? (press enter) "
abort :: String -> IO a
abort :: forall a. String -> IO a
abort String
str = do
String -> IO ()
putStrLnErr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> String -> String
forall a. Pretty a => Color -> a -> a
color Color
Red String
">> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str
IO a
forall a. IO a
exitFailure
data CabalInfo = CabalInfo
{ CabalInfo -> String
name :: String,
CabalInfo -> String
version :: String
}
#if MIN_VERSION_Cabal(3,8,0)
readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription :: Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
v String
p = do
ByteString
bs <- String -> IO ByteString
BS.readFile String
p
case ParseResult GenericPackageDescription
-> ([PWarning],
Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription ByteString
bs) of
([PWarning]
_warnings, Right GenericPackageDescription
gpd) -> GenericPackageDescription -> IO GenericPackageDescription
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd
([PWarning]
_warnings, Left (Maybe Version
v, NonEmpty PError
e)) -> String -> IO GenericPackageDescription
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO GenericPackageDescription)
-> String -> IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ String
"Cabal file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has problems:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((PError -> String) -> [PError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PError -> String
showPError String
p) (NonEmpty PError -> [PError]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
e))
#endif
cabalRead :: FilePath -> IO CabalInfo
cabalRead :: String -> IO CabalInfo
cabalRead String
dir = do
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Looking for a cabal file in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir
String
cabalFile <- Verbosity -> String -> IO String
tryFindPackageDesc Verbosity
silent String
dir
GenericPackageDescription
genericPackageDescription <- Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent String
cabalFile
let pkgversion :: Version
pkgversion = PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
genericPackageDescription
pkgname :: PackageName
pkgname = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
genericPackageDescription
cabalinfo :: CabalInfo
cabalinfo =
CabalInfo
{ version :: String
version = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> [Int] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> [Int]
versionNumbers Version
pkgversion,
name :: String
name = PackageName -> String
unPackageName PackageName
pkgname
}
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Found " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CabalInfo -> String
name CabalInfo
cabalinfo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CabalInfo -> String
version CabalInfo
cabalinfo
CabalInfo -> IO CabalInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CabalInfo
cabalinfo
cabalWriteVersion :: FilePath -> String -> IO ()
cabalWriteVersion :: String -> String -> IO ()
cabalWriteVersion String
dir String
versionStr = do
if String -> Bool
validCabalVersion String
versionStr
then do
String
cabalFile <- Verbosity -> String -> IO String
tryFindPackageDesc Verbosity
silent String
dir
CabalInfo
cabalinfo <- String -> IO CabalInfo
cabalRead String
dir
Text
cabal <- String -> IO Text
T.readFile String
cabalFile
let versionPrev :: T.Text
versionPrev :: Text
versionPrev = Text
cabal Text -> String -> Text
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (String
"version:[ \t]*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CabalInfo -> String
version CabalInfo
cabalinfo)
if Text
versionPrev Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
""
then String -> IO ()
forall a. String -> IO a
abort (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to replace version in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cabalFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", please open an issue at https://github.com/domenkozar/releaser/issues"
else do
String -> Text -> IO ()
T.writeFile String
cabalFile (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
versionPrev (Text
"version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
versionStr) Text
cabal
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Bumped " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CabalInfo -> String
name CabalInfo
cabalinfo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
versionStr
else do
String -> IO ()
promptRetry String
"Cabal version does not match /^[0-9]+([.][0-9]+)*$/"
IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
cabalBumpVersion String
dir
validCabalVersion :: String -> Bool
validCabalVersion :: String -> Bool
validCabalVersion String
version =
String
version String -> String -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (String
"^[0-9]+([.][0-9]+)*$" :: String)
putStrLnErr :: String -> IO ()
putStrLnErr :: String -> IO ()
putStrLnErr = Handle -> String -> IO ()
hPutStrLn Handle
stderr
cabalBumpVersion :: FilePath -> IO String
cabalBumpVersion :: String -> IO String
cabalBumpVersion String
dir = do
CabalInfo
cabalinfo <- String -> IO CabalInfo
cabalRead String
dir
String
version <- String -> IO String
prompt (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Bump cabal version from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CabalInfo -> String
version CabalInfo
cabalinfo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to: "
String -> String -> IO ()
cabalWriteVersion String
dir String
version
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
version
cabalSdist :: FilePath -> IO FilePath
cabalSdist :: String -> IO String
cabalSdist String
dir = do
String -> IO ()
logStep String
"Running $ cabal dist"
CabalInfo
cabalinfo <- String -> IO CabalInfo
cabalRead String
dir
IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
readProcess String
"cabal" [String
"v2-sdist"] String
forall a. Monoid a => a
mempty
let sdistTarball :: String
sdistTarball = String
"dist-newstyle/sdist/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CabalInfo -> String
name CabalInfo
cabalinfo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CabalInfo -> String
version CabalInfo
cabalinfo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".tar.gz"
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Created " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sdistTarball
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
sdistTarball
cabalMakeHaddocks :: FilePath -> IO FilePath
cabalMakeHaddocks :: String -> IO String
cabalMakeHaddocks String
dir = do
String -> IO ()
logStep String
"Running $ cabal haddock"
CabalInfo
cabalinfo <- String -> IO CabalInfo
cabalRead String
dir
IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
readProcess String
"cabal" [String
"v2-haddock", String
"--haddock-for-hackage"] String
forall a. Monoid a => a
mempty
let docsTarball :: String
docsTarball = String
"dist-newstyle/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CabalInfo -> String
name CabalInfo
cabalinfo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CabalInfo -> String
version CabalInfo
cabalinfo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-docs.tar.gz"
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Created " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
docsTarball
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
docsTarball
cabalUploadDocs :: FilePath -> IO ()
cabalUploadDocs :: String -> IO ()
cabalUploadDocs String
docsTarball = do
String -> IO ()
logStep String
"Running $ cabal upload -d"
CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess (String -> [String] -> CreateProcess
proc String
"cabal" [String
"upload", String
"-d", String
"--publish", String
docsTarball]) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> do
String -> IO ()
promptRetry String
"cabal upload -d"
String -> IO ()
cabalUploadDocs String
docsTarball
cabalUpload :: FilePath -> IO ()
cabalUpload :: String -> IO ()
cabalUpload String
sdistTarball = do
String -> IO ()
logStep String
"Running $ cabal upload"
CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess (String -> [String] -> CreateProcess
proc String
"cabal" [String
"upload", String
"--publish", String
sdistTarball]) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> do
String -> IO ()
promptRetry String
"cabal upload"
String -> IO ()
cabalUpload String
sdistTarball
gitGetTags :: IO [String]
gitGetTags :: IO [String]
gitGetTags = do
String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"git" [String
"tag"] String
forall a. Monoid a => a
mempty
gitCheckout :: String -> IO ()
gitCheckout :: String -> IO ()
gitCheckout String
tag = do
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Running $ git checkout -b " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tag
CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess (String -> [String] -> CreateProcess
proc String
"git" [String
"checkout", String
"-b", String
tag]) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
String -> IO ()
promptRetry String
"git checkout failed"
String -> IO ()
gitCheckout String
tag
gitTag :: String -> IO ()
gitTag :: String -> IO ()
gitTag String
tag = do
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Running $ git tag --annotate --sign " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tag
[String]
tags <- IO [String]
gitGetTags
if String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
tag [String]
tags
then String -> IO ()
forall a. String -> IO a
abort String
"git tag already exists, please delete it and start over"
else CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess (String -> [String] -> CreateProcess
proc String
"git" [String
"tag", String
"--annotate", String
"--sign", String
tag]) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
String -> IO ()
promptRetry String
"git tag failed"
String -> IO ()
gitTag String
tag
gitCommit :: String -> IO ()
gitCommit :: String -> IO ()
gitCommit String
message = do
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Running $ git commit "
CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess (String -> [String] -> CreateProcess
proc String
"git" [String
"commit", String
"-a", String
"-m", String
message]) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
String -> IO ()
promptRetry String
"git commit failed"
String -> IO ()
gitCommit String
message
gitPush :: String -> IO ()
gitPush :: String -> IO ()
gitPush String
remote = do
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Pushing git to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
remote
CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess (String -> [String] -> CreateProcess
proc String
"git" [String
"push", String
remote, String
"HEAD"]) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
String -> IO ()
promptRetry String
"git push"
String -> IO ()
gitPush String
remote
gitPushTags :: String -> IO ()
gitPushTags :: String -> IO ()
gitPushTags String
remote = do
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Pushing git tags to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
remote
IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
readProcess String
"git" [String
"push", String
remote, String
"--tags"] String
forall a. Monoid a => a
mempty
gitAssertEmptyStaging :: IO ()
gitAssertEmptyStaging :: IO ()
gitAssertEmptyStaging = do
String -> IO ()
logStep String
"Assserting there are no uncommitted files"
String
output <- String -> [String] -> String -> IO String
readProcess String
"git" [String
"status", String
"--untracked-files=no", String
"--porcelain"] String
forall a. Monoid a => a
mempty
if String
output String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else String -> IO ()
forall a. String -> IO a
abort String
"git status is not clean"
changelogPrepare :: IO ()
changelogPrepare :: IO ()
changelogPrepare = do
String -> IO ()
logStep String
"Assserting there are no uncommitted files"
Maybe String
editorEnv <- String -> IO (Maybe String)
lookupEnv String
"EDITOR"
case Maybe String
editorEnv of
Maybe String
Nothing -> String -> IO ()
forall a. String -> IO a
abort String
"please make sure $EDITOR is set"
Just String
editor -> do
CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess (String -> [String] -> CreateProcess
proc String
editor [String
"CHANGELOG.md"]) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
String -> IO ()
logStep (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
editor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" failed with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", retrying"
IO ()
changelogPrepare
interactiveProcess :: CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess :: CreateProcess -> (Int -> IO ()) -> IO ()
interactiveProcess CreateProcess
cmd Int -> IO ()
bad = do
(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cmd
ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
case ExitCode
exitcode of
ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
i -> Int -> IO ()
bad Int
i