module Propellor.DotDir
( distrepo
, dotPropellor
, interactiveInit
, checkRepoUpToDate
) where
import Propellor.Message
import Propellor.Bootstrap
import Propellor.Git
import Propellor.Gpg
import Propellor.Types.Result
import Utility.UserInfo
import Utility.Monad
import Utility.Process
import Utility.SafeCommand
import Utility.Exception
import Utility.Directory
import Utility.Path
import qualified Paths_propellor as Package
import Data.Char
import Data.List
import Data.Version
import Control.Monad
import Control.Monad.IfElse
import System.FilePath
import System.Posix.Directory
import System.IO
import System.Console.Concurrent
import Control.Applicative
import Prelude
distdir :: FilePath
distdir :: FilePath
distdir = "/usr/src/propellor"
distrepo :: FilePath
distrepo :: FilePath
distrepo = FilePath
distdir FilePath -> FilePath -> FilePath
</> "propellor.git"
disthead :: FilePath
disthead :: FilePath
disthead = FilePath
distdir FilePath -> FilePath -> FilePath
</> "head"
upstreambranch :: String
upstreambranch :: FilePath
upstreambranch = "upstream/master"
netrepo :: String
netrepo :: FilePath
netrepo = "https://git.joeyh.name/git/propellor.git"
dotPropellor :: IO FilePath
dotPropellor :: IO FilePath
dotPropellor = do
FilePath
home <- IO FilePath
myHomeDir
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
home FilePath -> FilePath -> FilePath
</> ".propellor")
buildSystem :: IO String
buildSystem :: IO FilePath
buildSystem = do
FilePath
d <- IO FilePath
Package.getLibDir
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ if "stack-work" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
d then "stack" else "cabal"
interactiveInit :: IO ()
interactiveInit :: IO ()
interactiveInit = IO Bool -> (IO (), IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesDirectoryExist (FilePath -> IO Bool) -> IO FilePath -> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
dotPropellor)
( FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error "~/.propellor/ already exists, not doing anything"
, do
IO ()
welcomeBanner
IO ()
setup
)
cabalSandboxRequired :: IO Bool
cabalSandboxRequired :: IO Bool
cabalSandboxRequired = IO Bool -> (IO Bool, IO Bool) -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM IO Bool
cabal
( do
FilePath
home <- IO FilePath
myHomeDir
[FilePath]
ls <- FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO []
(FilePath -> IO FilePath
readFile (FilePath
home FilePath -> FilePath -> FilePath
</> ".cabal" FilePath -> FilePath -> FilePath
</> "config"))
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ("True" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) ([FilePath] -> Bool) -> [FilePath] -> Bool
forall a b. (a -> b) -> a -> b
$
(FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ("require-sandbox:" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [FilePath]
ls
, Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
)
where
cabal :: IO Bool
cabal = IO FilePath
buildSystem IO FilePath -> (FilePath -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \bSystem :: FilePath
bSystem -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
bSystem FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "cabal")
say :: String -> IO ()
say :: FilePath -> IO ()
say = FilePath -> IO ()
forall v. Outputable v => v -> IO ()
outputConcurrent
sayLn :: String -> IO ()
sayLn :: FilePath -> IO ()
sayLn s :: FilePath
s = FilePath -> IO ()
say (FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n")
welcomeBanner :: IO ()
welcomeBanner :: IO ()
welcomeBanner = FilePath -> IO ()
say (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
prettify
[ ""
, ""
, " _ ______`| ,-.__"
, " .--------------------------- / ~___-=O`/|O`/__| (____.'"
, " - Welcome to -- ~ / | / ) _.-'-._"
, " - Propellor! -- `/-==__ _/__|/__=-| ( ~_"
, " `--------------------------- * ~ | | '--------'"
, " (o) `"
, ""
, ""
]
where
prettify :: FilePath -> FilePath
prettify = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char -> Char
forall p. Eq p => p -> p -> p -> p
replace '~' '\\')
replace :: p -> p -> p -> p
replace x :: p
x y :: p
y c :: p
c
| p
c p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
x = p
y
| Bool
otherwise = p
c
prompt :: String -> [(String, IO ())] -> IO ()
prompt :: FilePath -> [(FilePath, IO ())] -> IO ()
prompt p :: FilePath
p cs :: [(FilePath, IO ())]
cs = do
FilePath -> IO ()
say (FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " [" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "|" (((FilePath, IO ()) -> FilePath)
-> [(FilePath, IO ())] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, IO ()) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, IO ())]
cs) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "] ")
IO ()
flushConcurrentOutput
Handle -> IO ()
hFlush Handle
stdout
FilePath
r <- (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getLine
if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
r
then (FilePath, IO ()) -> IO ()
forall a b. (a, b) -> b
snd ([(FilePath, IO ())] -> (FilePath, IO ())
forall a. [a] -> a
head [(FilePath, IO ())]
cs)
else case ((FilePath, IO ()) -> Bool)
-> [(FilePath, IO ())] -> [(FilePath, IO ())]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(s :: FilePath
s, _) -> (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
r) [(FilePath, IO ())]
cs of
[(_, a :: IO ()
a)] -> IO ()
a
_ -> do
FilePath -> IO ()
sayLn "Not a valid choice, try again.. (Or ctrl-c to quit)"
FilePath -> [(FilePath, IO ())] -> IO ()
prompt FilePath
p [(FilePath, IO ())]
cs
section :: IO ()
section :: IO ()
section = do
FilePath -> IO ()
sayLn ""
FilePath -> IO ()
sayLn "------------------------------------------------------------------------------"
FilePath -> IO ()
sayLn ""
setup :: IO ()
setup :: IO ()
setup = do
FilePath -> IO ()
sayLn "Propellor's configuration file is ~/.propellor/config.hs"
FilePath -> IO ()
sayLn ""
FilePath -> IO ()
sayLn "Let's get you started with a simple config that you can adapt"
FilePath -> IO ()
sayLn "to your needs. You can start with:"
FilePath -> IO ()
sayLn " A: A clone of propellor's git repository (most flexible)"
FilePath -> IO ()
sayLn " B: The bare minimum files to use propellor (most simple)"
FilePath -> [(FilePath, IO ())] -> IO ()
prompt "Which would you prefer?"
[ ("A", IO Result -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Result -> IO ()) -> IO Result -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Result -> IO Result
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
FilePath -> m r -> m r
actionMessage "Cloning propellor's git repository" IO Result
fullClone)
, ("B", IO Result -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Result -> IO ()) -> IO Result -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Result -> IO Result
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
FilePath -> m r -> m r
actionMessage "Creating minimal config" IO Result
minimalConfig)
]
FilePath -> IO ()
changeWorkingDirectory (FilePath -> IO ()) -> IO FilePath -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
dotPropellor
IO ()
section
FilePath -> IO ()
sayLn "Let's try building the propellor configuration, to make sure it will work..."
FilePath -> IO ()
sayLn ""
FilePath
b <- IO FilePath
buildSystem
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [CommandParam] -> IO Bool
boolSystem "git"
[ FilePath -> CommandParam
Param "config"
, FilePath -> CommandParam
Param "propellor.buildsystem"
, FilePath -> CommandParam
Param FilePath
b
]
IO Bool -> (IO (), IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM IO Bool
cabalSandboxRequired
( IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [CommandParam] -> IO Bool
boolSystem "cabal"
[ FilePath -> CommandParam
Param "sandbox"
, FilePath -> CommandParam
Param "init"
]
, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
)
Maybe Host -> IO ()
buildPropellor Maybe Host
forall a. Maybe a
Nothing
FilePath -> IO ()
sayLn ""
FilePath -> IO ()
sayLn "Great! Propellor is bootstrapped."
IO ()
section
FilePath -> IO ()
sayLn "Propellor can use gpg to encrypt private data about the systems it manages,"
FilePath -> IO ()
sayLn "and to sign git commits."
FilePath
gpg <- IO FilePath
getGpgBin
IO Bool -> (IO (), IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
inPath FilePath
gpg)
( IO ()
setupGpgKey
, do
FilePath -> IO ()
sayLn "You don't seem to have gpg installed, so skipping setting it up."
IO ()
explainManualSetupGpgKey
)
IO ()
section
FilePath -> IO ()
sayLn "Everything is set up ..."
FilePath -> IO ()
sayLn "Your next step is to edit ~/.propellor/config.hs"
FilePath -> IO ()
sayLn "and run propellor again to try it out."
FilePath -> IO ()
sayLn ""
FilePath -> IO ()
sayLn "For docs, see https://propellor.branchable.com/"
FilePath -> IO ()
sayLn "Enjoy propellor!"
explainManualSetupGpgKey :: IO ()
explainManualSetupGpgKey :: IO ()
explainManualSetupGpgKey = do
FilePath -> IO ()
sayLn "Propellor can still be used without gpg, but it won't be able to"
FilePath -> IO ()
sayLn "manage private data. You can set this up later:"
FilePath -> IO ()
sayLn " 1. gpg --gen-key"
FilePath -> IO ()
sayLn " 2. propellor --add-key (pass it the key ID generated in step 1)"
setupGpgKey :: IO ()
setupGpgKey :: IO ()
setupGpgKey = do
[(FilePath, FilePath)]
ks <- IO [(FilePath, FilePath)]
listSecretKeys
FilePath -> IO ()
sayLn ""
case [(FilePath, FilePath)]
ks of
[] -> IO ()
makeGpgKey
[(k :: FilePath
k, d :: FilePath
d)] -> do
FilePath -> IO ()
sayLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "You have one gpg key: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
desckey FilePath
k FilePath
d
FilePath -> [(FilePath, IO ())] -> IO ()
prompt "Should propellor use that key?"
[ ("Y", FilePath -> IO ()
propellorAddKey FilePath
k)
, ("N", FilePath -> IO ()
sayLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Skipping gpg setup. If you change your mind, run: propellor --add-key " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
k)
]
_ -> do
let nks :: [((FilePath, FilePath), FilePath)]
nks = [(FilePath, FilePath)]
-> [FilePath] -> [((FilePath, FilePath), FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(FilePath, FilePath)]
ks ((Integer -> FilePath) -> [Integer] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> FilePath
forall a. Show a => a -> FilePath
show ([1..] :: [Integer]))
FilePath -> IO ()
sayLn "I see you have several gpg keys:"
[((FilePath, FilePath), FilePath)]
-> (((FilePath, FilePath), FilePath) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((FilePath, FilePath), FilePath)]
nks ((((FilePath, FilePath), FilePath) -> IO ()) -> IO ())
-> (((FilePath, FilePath), FilePath) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \((k :: FilePath
k, d :: FilePath
d), n :: FilePath
n) ->
FilePath -> IO ()
sayLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ " " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
desckey FilePath
k FilePath
d
FilePath -> [(FilePath, IO ())] -> IO ()
prompt "Which of your gpg keys should propellor use?"
((((FilePath, FilePath), FilePath) -> (FilePath, IO ()))
-> [((FilePath, FilePath), FilePath)] -> [(FilePath, IO ())]
forall a b. (a -> b) -> [a] -> [b]
map (\((k :: FilePath
k, _), n :: FilePath
n) -> (FilePath
n, FilePath -> IO ()
propellorAddKey FilePath
k)) [((FilePath, FilePath), FilePath)]
nks)
where
desckey :: FilePath -> FilePath -> FilePath
desckey k :: FilePath
k d :: FilePath
d = FilePath
d FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " (keyid " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
k FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ")"
makeGpgKey :: IO ()
makeGpgKey :: IO ()
makeGpgKey = do
FilePath -> IO ()
sayLn "You seem to not have any gpg secret keys."
FilePath -> [(FilePath, IO ())] -> IO ()
prompt "Would you like to create one now?"
[("Y", IO ()
rungpg), ("N", IO ()
nope)]
where
nope :: IO ()
nope = do
FilePath -> IO ()
sayLn "No problem."
IO ()
explainManualSetupGpgKey
rungpg :: IO ()
rungpg = do
FilePath -> IO ()
sayLn "Running gpg --gen-key ..."
FilePath
gpg <- IO FilePath
getGpgBin
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
gpg [FilePath -> CommandParam
Param "--gen-key"]
[(FilePath, FilePath)]
ks <- IO [(FilePath, FilePath)]
listSecretKeys
case [(FilePath, FilePath)]
ks of
[] -> do
FilePath -> IO ()
sayLn "Hmm, gpg seemed to not set up a secret key."
FilePath -> [(FilePath, IO ())] -> IO ()
prompt "Want to try running gpg again?"
[("Y", IO ()
rungpg), ("N", IO ()
nope)]
((k :: FilePath
k, _):_) -> FilePath -> IO ()
propellorAddKey FilePath
k
propellorAddKey :: String -> IO ()
propellorAddKey :: FilePath -> IO ()
propellorAddKey keyid :: FilePath
keyid = do
FilePath -> IO ()
sayLn ""
FilePath -> IO ()
sayLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Telling propellor to use your gpg key by running: propellor --add-key " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
keyid
FilePath
d <- IO FilePath
dotPropellor
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> [CommandParam] -> IO Bool
boolSystem (FilePath
d FilePath -> FilePath -> FilePath
</> "propellor") [FilePath -> CommandParam
Param "--add-key", FilePath -> CommandParam
Param FilePath
keyid]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
sayLn "Oops, that didn't work! You can retry the same command later."
FilePath -> IO ()
sayLn "Continuing onward ..."
minimalConfig :: IO Result
minimalConfig :: IO Result
minimalConfig = do
FilePath
d <- IO FilePath
dotPropellor
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
d
FilePath -> IO ()
changeWorkingDirectory FilePath
d
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [CommandParam] -> IO Bool
boolSystem "git" [FilePath -> CommandParam
Param "init"]
FilePath -> [FilePath] -> IO ()
addfile "config.cabal" [FilePath]
cabalcontent
FilePath -> [FilePath] -> IO ()
addfile "config.hs" [FilePath]
configcontent
FilePath -> [FilePath] -> IO ()
addfile "stack.yaml" [FilePath]
stackcontent
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
where
addfile :: FilePath -> [FilePath] -> IO ()
addfile f :: FilePath
f content :: [FilePath]
content = do
FilePath -> FilePath -> IO ()
writeFile FilePath
f ([FilePath] -> FilePath
unlines [FilePath]
content)
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [CommandParam] -> IO Bool
boolSystem "git" [FilePath -> CommandParam
Param "add" , FilePath -> CommandParam
File FilePath
f]
cabalcontent :: [FilePath]
cabalcontent =
[ "-- This is a cabal file to use to build your propellor configuration."
, ""
, "Name: config"
, "Cabal-Version: >= 1.6"
, "Build-Type: Simple"
, "Version: 0"
, ""
, "Executable propellor-config"
, " Main-Is: config.hs"
, " GHC-Options: -threaded -Wall -fno-warn-tabs -O0"
, " Extensions: TypeOperators"
, " Build-Depends: propellor >= 3.0, base >= 4.9"
]
configcontent :: [FilePath]
configcontent =
[ "-- This is the main configuration file for Propellor, and is used to build"
, "-- the propellor program. https://propellor.branchable.com/"
, ""
, "import Propellor"
, "import qualified Propellor.Property.File as File"
, "import qualified Propellor.Property.Apt as Apt"
, "import qualified Propellor.Property.Cron as Cron"
, "import qualified Propellor.Property.User as User"
, ""
, "main :: IO ()"
, "main = defaultMain hosts"
, ""
, "-- The hosts propellor knows about."
, "hosts :: [Host]"
, "hosts ="
, " [ mybox"
, " ]"
, ""
, "-- An example host."
, "mybox :: Host"
, "mybox = host \"mybox.example.com\" $ props"
, " & osDebian Unstable X86_64"
, " & Apt.stdSourcesList"
, " & Apt.unattendedUpgrades"
, " & Apt.installed [\"etckeeper\"]"
, " & Apt.installed [\"ssh\"]"
, " & User.hasSomePassword (User \"root\")"
, " & File.dirExists \"/var/www\""
, " & Cron.runPropellor (Cron.Times \"30 * * * *\")"
, ""
]
stackcontent :: [FilePath]
stackcontent =
[ "resolver: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
stackResolver
, "packages:"
, "- '.'"
, "extra-deps:"
, "- propellor-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
Package.version
]
stackResolver :: String
stackResolver :: FilePath
stackResolver = "lts-9.21"
fullClone :: IO Result
fullClone :: IO Result
fullClone = do
FilePath
d <- IO FilePath
dotPropellor
let enterdotpropellor :: IO Bool
enterdotpropellor = FilePath -> IO ()
changeWorkingDirectory FilePath
d IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Bool
ok <- IO Bool -> (IO Bool, IO Bool) -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesFileExist FilePath
distrepo IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<||> FilePath -> IO Bool
doesDirectoryExist FilePath
distrepo)
( (IO Bool -> IO Bool) -> [IO Bool] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM IO Bool -> IO Bool
forall a. a -> a
id
[ FilePath -> [CommandParam] -> IO Bool
boolSystem "git" [FilePath -> CommandParam
Param "clone", FilePath -> CommandParam
File FilePath
distrepo, FilePath -> CommandParam
File FilePath
d]
, FilePath -> IO Bool
fetchUpstreamBranch FilePath
distrepo
, IO Bool
enterdotpropellor
, FilePath -> [CommandParam] -> IO Bool
boolSystem "git" [FilePath -> CommandParam
Param "remote", FilePath -> CommandParam
Param "rm", FilePath -> CommandParam
Param "origin"]
]
, (IO Bool -> IO Bool) -> [IO Bool] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM IO Bool -> IO Bool
forall a. a -> a
id
[ FilePath -> [CommandParam] -> IO Bool
boolSystem "git" [FilePath -> CommandParam
Param "clone", FilePath -> CommandParam
Param FilePath
netrepo, FilePath -> CommandParam
File FilePath
d]
, IO Bool
enterdotpropellor
, FilePath -> [CommandParam] -> IO Bool
boolSystem "git" [FilePath -> CommandParam
Param "remote", FilePath -> CommandParam
Param "rename", FilePath -> CommandParam
Param "origin", FilePath -> CommandParam
Param "upstream"]
, FilePath -> [CommandParam] -> IO Bool
boolSystem "git" [FilePath -> CommandParam
Param "config", FilePath -> CommandParam
Param "--unset", FilePath -> CommandParam
Param "branch.master.remote", FilePath -> CommandParam
Param "upstream"]
]
)
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Result
forall t. ToResult t => t -> Result
toResult Bool
ok)
fetchUpstreamBranch :: FilePath -> IO Bool
fetchUpstreamBranch :: FilePath -> IO Bool
fetchUpstreamBranch repo :: FilePath
repo = do
FilePath -> IO ()
changeWorkingDirectory (FilePath -> IO ()) -> IO FilePath -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
dotPropellor
FilePath -> [CommandParam] -> IO Bool
boolSystem "git"
[ FilePath -> CommandParam
Param "fetch"
, FilePath -> CommandParam
File FilePath
repo
, FilePath -> CommandParam
Param ("+refs/heads/master:refs/remotes/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
upstreambranch)
, FilePath -> CommandParam
Param "--quiet"
]
checkRepoUpToDate :: IO ()
checkRepoUpToDate :: IO ()
checkRepoUpToDate = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool
gitbundleavail IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> IO Bool
dotpropellorpopulated) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilePath
headrev <- (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n') (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile FilePath
disthead
FilePath -> IO ()
changeWorkingDirectory (FilePath -> IO ()) -> IO FilePath -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
dotPropellor
Maybe ()
headknown <- IO () -> IO (Maybe ())
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$
CreateProcessRunner -> CreateProcess -> IO ()
withQuietOutput CreateProcessRunner
createProcessSuccess (CreateProcess -> IO ()) -> CreateProcess -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> [FilePath] -> CreateProcess
proc "git" ["log", FilePath
headrev]
if (Maybe ()
headknown Maybe () -> Maybe () -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ()
forall a. Maybe a
Nothing)
then FilePath -> IO ()
updateUpstreamMaster FilePath
headrev
else do
FilePath
theirhead <- FilePath -> IO FilePath
getCurrentGitSha1 (FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
getCurrentBranchRef
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
theirhead FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
headrev) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool
merged <- Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FilePath -> Bool) -> IO FilePath -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
FilePath -> [FilePath] -> IO FilePath
readProcess "git" ["log", FilePath
headrev FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "..HEAD", "--ancestry-path"]
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
merged (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> IO ()
warnoutofdate Bool
True
where
gitbundleavail :: IO Bool
gitbundleavail = FilePath -> IO Bool
doesFileExist FilePath
disthead
dotpropellorpopulated :: IO Bool
dotpropellorpopulated = do
FilePath
d <- IO FilePath
dotPropellor
FilePath -> IO Bool
doesFileExist (FilePath
d FilePath -> FilePath -> FilePath
</> "propellor.cabal")
updateUpstreamMaster :: String -> IO ()
updateUpstreamMaster :: FilePath -> IO ()
updateUpstreamMaster newref :: FilePath
newref = do
FilePath -> IO ()
changeWorkingDirectory (FilePath -> IO ()) -> IO FilePath -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
dotPropellor
Maybe FilePath -> IO ()
go (Maybe FilePath -> IO ()) -> IO (Maybe FilePath) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe FilePath)
getoldref
where
go :: Maybe FilePath -> IO ()
go Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go (Just oldref :: FilePath
oldref) = do
let tmprepo :: FilePath
tmprepo = ".git/propellordisttmp"
let cleantmprepo :: IO ()
cleantmprepo = IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Maybe ())
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
tmprepo
IO ()
cleantmprepo
[FilePath] -> IO ()
git ["clone", "--quiet", ".", FilePath
tmprepo]
FilePath -> IO ()
changeWorkingDirectory FilePath
tmprepo
[FilePath] -> IO ()
git ["fetch", FilePath
distrepo, "--quiet"]
[FilePath] -> IO ()
git ["reset", "--hard", FilePath
oldref, "--quiet"]
Version
v <- IO Version
gitVersion
let mergeparams :: [FilePath]
mergeparams =
[ "merge", FilePath
newref
, "-s", "recursive"
, "-Xtheirs"
, "--quiet"
, "-m", "merging upstream version"
] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ if Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [2,9]
then [ "--allow-unrelated-histories" ]
else []
[FilePath] -> IO ()
git [FilePath]
mergeparams
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
fetchUpstreamBranch FilePath
tmprepo
IO ()
cleantmprepo
Bool -> IO ()
warnoutofdate Bool
True
git :: [FilePath] -> IO ()
git = FilePath -> [FilePath] -> IO ()
run "git"
run :: FilePath -> [FilePath] -> IO ()
run cmd :: FilePath
cmd ps :: [FilePath]
ps = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
cmd ((FilePath -> CommandParam) -> [FilePath] -> [CommandParam]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> CommandParam
Param [FilePath]
ps)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Failed to run " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
ps
getoldref :: IO (Maybe FilePath)
getoldref = do
Maybe FilePath
mref <- IO FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO FilePath -> IO (Maybe FilePath))
-> IO FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n')
(FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO FilePath
readProcess "git" ["show-ref", FilePath
upstreambranch, "--hash"]
case Maybe FilePath
mref of
Just _ -> do
IO Bool
-> (IO (Maybe FilePath), IO (Maybe FilePath))
-> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
hasRemote "upstream")
( do
Maybe FilePath
v <- FilePath -> IO (Maybe FilePath)
remoteUrl "upstream"
Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ case Maybe FilePath
v of
Just rurl :: FilePath
rurl | FilePath
rurl FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
distrepo -> Maybe FilePath
mref
_ -> Maybe FilePath
forall a. Maybe a
Nothing
, Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
mref
)
Nothing -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
mref
warnoutofdate :: Bool -> IO ()
warnoutofdate :: Bool -> IO ()
warnoutofdate havebranch :: Bool
havebranch = FilePath -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
warningMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
[ "** Your ~/.propellor/ is out of date.."
, FilePath -> FilePath
indent "A newer upstream version is available in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
distrepo
, FilePath -> FilePath
indent (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ if Bool
havebranch
then "To merge it, run: git merge " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
upstreambranch
else "To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
upstreambranch FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " to it. Then run propellor again."
]
where
indent :: FilePath -> FilePath
indent s :: FilePath
s = " " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s