{-# LANGUAGE CPP #-}

module Releaser.Primitives
  ( -- cabal utilities
    CabalInfo (..),
    cabalRead,
    cabalWriteVersion,
    cabalBumpVersion,
    cabalSdist,
    cabalUpload,
    cabalMakeHaddocks,
    cabalUploadDocs,
    -- git primitives
    gitCheckout,
    gitGetTags,
    gitTag,
    gitCommit,
    gitPush,
    gitPushTags,
    gitAssertEmptyStaging,
    -- utilities
    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

-- | Given a folder, find a Cabal file and read the package version
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

-- | Given a folder, find a Cabal file and update the package version
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"
  -- TODO: recommend that credentials are configured via ~/cabal/config
  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"
  -- TODO: recommend that credentials are configured via ~/cabal/config
  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

-- TODO: what can we do if previous release process terminated and branch exists?
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
  -- TODO: check for existing branch
  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
      -- TODO: prepare the changelog
      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

-- internal

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