{-# LANGUAGE DeriveDataTypeable #-}
module Propellor.Bootstrap (
Bootstrapper(..),
Builder(..),
defaultBootstrapper,
getBootstrapper,
bootstrapPropellorCommand,
checkBinaryCommand,
installGitCommand,
buildPropellor,
checkDepsCommand,
buildCommand,
) where
import Propellor.Base
import Propellor.Types.Info
import Propellor.Git.Config
import System.Posix.Files
import Data.List
type ShellCommand = String
data Bootstrapper = Robustly Builder | OSOnly
deriving (Int -> Bootstrapper -> ShowS
[Bootstrapper] -> ShowS
Bootstrapper -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bootstrapper] -> ShowS
$cshowList :: [Bootstrapper] -> ShowS
show :: Bootstrapper -> String
$cshow :: Bootstrapper -> String
showsPrec :: Int -> Bootstrapper -> ShowS
$cshowsPrec :: Int -> Bootstrapper -> ShowS
Show, Typeable)
data Builder = Cabal | Stack
deriving (Int -> Builder -> ShowS
[Builder] -> ShowS
Builder -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Builder] -> ShowS
$cshowList :: [Builder] -> ShowS
show :: Builder -> String
$cshow :: Builder -> String
showsPrec :: Int -> Builder -> ShowS
$cshowsPrec :: Int -> Builder -> ShowS
Show, Typeable)
defaultBootstrapper :: Bootstrapper
defaultBootstrapper :: Bootstrapper
defaultBootstrapper = Builder -> Bootstrapper
Robustly Builder
Cabal
getBootstrapper :: Propellor Bootstrapper
getBootstrapper :: Propellor Bootstrapper
getBootstrapper = InfoVal Bootstrapper -> Bootstrapper
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. IsInfo v => Propellor v
askInfo
where
go :: InfoVal Bootstrapper -> Bootstrapper
go InfoVal Bootstrapper
NoInfoVal = Bootstrapper
defaultBootstrapper
go (InfoVal Bootstrapper
bs) = Bootstrapper
bs
getBuilder :: Bootstrapper -> Builder
getBuilder :: Bootstrapper -> Builder
getBuilder (Robustly Builder
b) = Builder
b
getBuilder Bootstrapper
OSOnly = Builder
Cabal
bootstrapPropellorCommand :: Bootstrapper -> Maybe System -> ShellCommand
bootstrapPropellorCommand :: Bootstrapper -> Maybe System -> String
bootstrapPropellorCommand Bootstrapper
bs Maybe System
msys = Bootstrapper -> Maybe System -> String
checkDepsCommand Bootstrapper
bs Maybe System
msys forall a. [a] -> [a] -> [a]
++
String
"&& if ! test -x ./propellor; then "
forall a. [a] -> [a] -> [a]
++ Bootstrapper -> String
buildCommand Bootstrapper
bs forall a. [a] -> [a] -> [a]
++
String
"; fi;" forall a. [a] -> [a] -> [a]
++ Bootstrapper -> String
checkBinaryCommand Bootstrapper
bs
checkBinaryCommand :: Bootstrapper -> ShellCommand
checkBinaryCommand :: Bootstrapper -> String
checkBinaryCommand Bootstrapper
bs = String
"if test -x ./propellor && ! ./propellor --check; then " forall a. [a] -> [a] -> [a]
++ Builder -> String
go (Bootstrapper -> Builder
getBuilder Bootstrapper
bs) forall a. [a] -> [a] -> [a]
++ String
"; fi"
where
go :: Builder -> String
go Builder
Cabal = forall a. [a] -> [[a]] -> [a]
intercalate String
" && "
[ String
"cabal clean"
, Bootstrapper -> String
buildCommand Bootstrapper
bs
]
go Builder
Stack = forall a. [a] -> [[a]] -> [a]
intercalate String
" && "
[ String
"stack clean"
, Bootstrapper -> String
buildCommand Bootstrapper
bs
]
buildCommand :: Bootstrapper -> ShellCommand
buildCommand :: Bootstrapper -> String
buildCommand Bootstrapper
bs = forall a. [a] -> [[a]] -> [a]
intercalate String
" && " (Builder -> [String]
go (Bootstrapper -> Builder
getBuilder Bootstrapper
bs))
where
go :: Builder -> [String]
go Builder
Cabal =
[ String
"cabal configure"
, String
"cabal build -j1 propellor-config"
, String
"ln -sf" String -> ShowS
`commandCabalBuildTo` String
"propellor"
]
go Builder
Stack =
[ String
"stack build :propellor-config"
, String
"ln -sf $(stack path --dist-dir)/build/propellor-config/propellor-config propellor"
]
commandCabalBuildTo :: ShellCommand -> FilePath -> ShellCommand
commandCabalBuildTo :: String -> ShowS
commandCabalBuildTo String
cmd String
dest = forall a. [a] -> [[a]] -> [a]
intercalate String
"; "
[ String
"if [ -d dist-newstyle ]"
, String
"then " forall a. [a] -> [a] -> [a]
++ String
cmd forall a. [a] -> [a] -> [a]
++ String
" $(cabal exec -- sh -c 'command -v propellor-config') " forall a. [a] -> [a] -> [a]
++ ShowS
shellEscape String
dest
, String
"else " forall a. [a] -> [a] -> [a]
++ String
cmd forall a. [a] -> [a] -> [a]
++ String
" dist/build/propellor-config/propellor-config " forall a. [a] -> [a] -> [a]
++ ShowS
shellEscape String
dest
, String
"fi"
]
checkDepsCommand :: Bootstrapper -> Maybe System -> ShellCommand
checkDepsCommand :: Bootstrapper -> Maybe System -> String
checkDepsCommand Bootstrapper
bs Maybe System
sys = Builder -> String
go (Bootstrapper -> Builder
getBuilder Bootstrapper
bs)
where
go :: Builder -> String
go Builder
Cabal = String
"if ! cabal configure >/dev/null 2>&1; then " forall a. [a] -> [a] -> [a]
++ Bootstrapper -> Maybe System -> String
depsCommand Bootstrapper
bs Maybe System
sys forall a. [a] -> [a] -> [a]
++ String
"; fi"
go Builder
Stack = String
"if ! stack build --dry-run >/dev/null 2>&1; then " forall a. [a] -> [a] -> [a]
++ Bootstrapper -> Maybe System -> String
depsCommand Bootstrapper
bs Maybe System
sys forall a. [a] -> [a] -> [a]
++ String
"; fi"
data Dep = Dep String | OptDep String | OldDep String
depsCommand :: Bootstrapper -> Maybe System -> ShellCommand
depsCommand :: Bootstrapper -> Maybe System -> String
depsCommand Bootstrapper
bs Maybe System
msys = String
"( " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
" ; " (Bootstrapper -> [String]
go Bootstrapper
bs) forall a. [a] -> [a] -> [a]
++ String
") || true"
where
go :: Bootstrapper -> [String]
go (Robustly Builder
Cabal) = Builder -> [String]
osinstall Builder
Cabal forall a. [a] -> [a] -> [a]
++
[ String
"cabal update"
, String
"cabal install --only-dependencies"
]
go (Robustly Builder
Stack) = Builder -> [String]
osinstall Builder
Stack forall a. [a] -> [a] -> [a]
++
[ String
"stack setup"
, String
"stack build --only-dependencies :propellor-config"
]
go Bootstrapper
OSOnly = Builder -> [String]
osinstall Builder
Cabal
osinstall :: Builder -> [String]
osinstall Builder
builder = case Maybe System
msys of
Just (System (FreeBSD FreeBSDRelease
_) Architecture
_) -> forall a b. (a -> b) -> [a] -> [b]
map ShowS
pkginstall (Builder -> [String]
fbsddeps Builder
builder)
Just (System (Distribution
ArchLinux) Architecture
_) -> forall a b. (a -> b) -> [a] -> [b]
map ShowS
pacmaninstall (Builder -> [String]
archlinuxdeps Builder
builder)
Just (System (Debian DebianKernel
_ DebianSuite
_) Architecture
_) -> Builder -> [String]
useapt Builder
builder
Just (System (Buntish String
_) Architecture
_) -> Builder -> [String]
useapt Builder
builder
Maybe System
Nothing -> Builder -> [String]
useapt Builder
builder
useapt :: Builder -> [String]
useapt Builder
builder = String
"apt-get update" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Dep -> String
aptinstall (Builder -> [Dep]
debdeps Builder
builder)
aptinstall :: Dep -> String
aptinstall (Dep String
p) = String
"DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " forall a. [a] -> [a] -> [a]
++ String
p
aptinstall (OptDep String
p) = String
"if LANG=C apt-cache policy " forall a. [a] -> [a] -> [a]
++ String
p forall a. [a] -> [a] -> [a]
++ String
"| grep -q Candidate:; then " forall a. [a] -> [a] -> [a]
++ Dep -> String
aptinstall (String -> Dep
Dep String
p) forall a. [a] -> [a] -> [a]
++ String
"; fi"
aptinstall (OldDep String
p) = Dep -> String
aptinstall (String -> Dep
OptDep String
p)
pkginstall :: ShowS
pkginstall String
p = String
"ASSUME_ALWAYS_YES=yes pkg install " forall a. [a] -> [a] -> [a]
++ String
p
pacmaninstall :: ShowS
pacmaninstall String
p = String
"pacman -S --noconfirm --needed " forall a. [a] -> [a] -> [a]
++ String
p
debdeps :: Builder -> [Dep]
debdeps Builder
Cabal =
[ String -> Dep
Dep String
"gnupg"
, String -> Dep
Dep String
"ghc"
, String -> Dep
Dep String
"cabal-install"
, String -> Dep
Dep String
"libghc-async-dev"
, String -> Dep
Dep String
"libghc-split-dev"
, String -> Dep
Dep String
"libghc-hslogger-dev"
, String -> Dep
Dep String
"libghc-unix-compat-dev"
, String -> Dep
Dep String
"libghc-ansi-terminal-dev"
, String -> Dep
Dep String
"libghc-ifelse-dev"
, String -> Dep
Dep String
"libghc-network-dev"
, String -> Dep
Dep String
"libghc-mtl-dev"
, String -> Dep
Dep String
"libghc-transformers-dev"
, String -> Dep
Dep String
"libghc-exceptions-dev"
, String -> Dep
Dep String
"libghc-text-dev"
, String -> Dep
Dep String
"libghc-hashable-dev"
, String -> Dep
OptDep String
"libghc-type-errors-dev"
, String -> Dep
OldDep String
"libghc-stm-dev"
]
debdeps Builder
Stack =
[ String -> Dep
Dep String
"gnupg"
, String -> Dep
Dep String
"haskell-stack"
]
fbsddeps :: Builder -> [String]
fbsddeps Builder
Cabal =
[ String
"gnupg"
, String
"ghc"
, String
"hs-cabal-install"
, String
"hs-async"
, String
"hs-split"
, String
"hs-hslogger"
, String
"hs-unix-compat"
, String
"hs-ansi-terminal"
, String
"hs-IfElse"
, String
"hs-network"
, String
"hs-mtl"
, String
"hs-transformers-base"
, String
"hs-exceptions"
, String
"hs-stm"
, String
"hs-text"
, String
"hs-hashable"
]
fbsddeps Builder
Stack =
[ String
"gnupg"
, String
"stack"
]
archlinuxdeps :: Builder -> [String]
archlinuxdeps Builder
Cabal =
[ String
"gnupg"
, String
"ghc"
, String
"cabal-install"
, String
"haskell-async"
, String
"haskell-split"
, String
"haskell-hslogger"
, String
"haskell-unix-compat"
, String
"haskell-ansi-terminal"
, String
"haskell-hackage-security"
, String
"haskell-ifelse"
, String
"haskell-network"
, String
"haskell-mtl"
, String
"haskell-transformers-base"
, String
"haskell-exceptions"
, String
"haskell-stm"
, String
"haskell-text"
, String
"haskell-hashable"
, String
"haskell-type-errors"
]
archlinuxdeps Builder
Stack =
[ String
"gnupg"
, String
"stack"
]
installGitCommand :: Maybe System -> ShellCommand
installGitCommand :: Maybe System -> String
installGitCommand Maybe System
msys = case Maybe System
msys of
(Just (System (Debian DebianKernel
_ DebianSuite
_) Architecture
_)) -> [String] -> String
use [String]
apt
(Just (System (Buntish String
_) Architecture
_)) -> [String] -> String
use [String]
apt
(Just (System (FreeBSD FreeBSDRelease
_) Architecture
_)) -> [String] -> String
use
[ String
"ASSUME_ALWAYS_YES=yes pkg update"
, String
"ASSUME_ALWAYS_YES=yes pkg install git"
]
(Just (System (Distribution
ArchLinux) Architecture
_)) -> [String] -> String
use
[ String
"pacman -S --noconfirm --needed git"]
Maybe System
Nothing -> [String] -> String
use [String]
apt
where
use :: [String] -> String
use [String]
cmds = String
"if ! git --version >/dev/null 2>&1; then " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
" && " [String]
cmds forall a. [a] -> [a] -> [a]
++ String
"; fi"
apt :: [String]
apt =
[ String
"apt-get update"
, String
"DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git"
]
buildPropellor :: Maybe Host -> IO ()
buildPropellor :: Maybe Host -> IO ()
buildPropellor Maybe Host
mh = forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage String
"Propellor build" IO Bool
build) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage String
"Propellor build failed!"
where
msys :: Maybe System
msys = case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. IsInfo v => Info -> v
fromInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Info
hostInfo) Maybe Host
mh of
Just (InfoVal System
sys) -> forall a. a -> Maybe a
Just System
sys
Maybe (InfoVal System)
_ -> forall a. Maybe a
Nothing
build :: IO Bool
build = forall (m :: * -> *). MonadCatch m => m Bool -> m Bool
catchBoolIO forall a b. (a -> b) -> a -> b
$ do
case forall v. IsInfo v => Info -> v
fromInfo (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Host -> Info
hostInfo Maybe Host
mh) of
InfoVal Bootstrapper
NoInfoVal -> do
Maybe String
bs <- String -> IO (Maybe String)
getGitConfigValue String
"propellor.buildsystem"
case Maybe String
bs of
Just String
"stack" -> Maybe System -> IO Bool
stackBuild Maybe System
msys
Maybe String
_ -> Maybe System -> IO Bool
cabalBuild Maybe System
msys
InfoVal Bootstrapper
bs -> case Bootstrapper -> Builder
getBuilder Bootstrapper
bs of
Builder
Cabal -> Maybe System -> IO Bool
cabalBuild Maybe System
msys
Builder
Stack -> Maybe System -> IO Bool
stackBuild Maybe System
msys
cabalBuild :: Maybe System -> IO Bool
cabalBuild :: Maybe System -> IO Bool
cabalBuild Maybe System
msys = do
String -> [String] -> IO Bool -> IO ()
make String
"configured" [String
"propellor.cabal"] IO Bool
cabal_configure
forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM IO Bool
cabal_build forall a b. (a -> b) -> a -> b
$
forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (IO Bool
cabal_configure forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> IO Bool
cabal_build) forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => String -> a
error String
"cabal build failed"
let safetycopy :: String
safetycopy = String
"propellor.built"
let cpcmd :: String
cpcmd = String
"cp -pfL" String -> ShowS
`commandCabalBuildTo` String
safetycopy
forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystem String
"sh" [String -> CommandParam
Param String
"-c", String -> CommandParam
Param String
cpcmd]) forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => String -> a
error String
"cp of binary failed"
String -> String -> IO ()
rename String
safetycopy String
"propellor"
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where
cabal_configure :: IO Bool
cabal_configure = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM ([String] -> IO Bool
cabal [String
"configure"])
( do
String -> String -> IO ()
writeFile String
"configured" String
""
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
, case Maybe System
msys of
Maybe System
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just System
sys ->
String -> [CommandParam] -> IO Bool
boolSystem String
"sh" [String -> CommandParam
Param String
"-c", String -> CommandParam
Param (Bootstrapper -> Maybe System -> String
depsCommand (Builder -> Bootstrapper
Robustly Builder
Cabal) (forall a. a -> Maybe a
Just System
sys))]
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> [String] -> IO Bool
cabal [String
"configure"]
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> (String -> String -> IO ()
writeFile String
"configured" String
"" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
)
cabal_build :: IO Bool
cabal_build = [String] -> IO Bool
cabal [String
"build", String
"-j1", String
"propellor-config"]
stackBuild :: Maybe System -> IO Bool
stackBuild :: Maybe System -> IO Bool
stackBuild Maybe System
_msys = do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
builddest
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM ([String] -> IO Bool
stack [String]
buildparams)
( do
String -> IO ()
symlinkPropellorBin (String
builddest String -> ShowS
</> String
"propellor-config")
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
, forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
)
where
builddest :: String
builddest = String
".built"
buildparams :: [String]
buildparams =
[ String
"--local-bin-path", String
builddest
, String
"build"
, String
":propellor-config"
, String
"--copy-bins"
]
symlinkPropellorBin :: FilePath -> IO ()
symlinkPropellorBin :: String -> IO ()
symlinkPropellorBin String
bin = do
String -> String -> IO ()
createSymbolicLink String
bin (ShowS
tmpfor String
dest)
String -> String -> IO ()
rename (ShowS
tmpfor String
dest) String
dest
where
dest :: String
dest = String
"propellor"
tmpfor :: FilePath -> FilePath
tmpfor :: ShowS
tmpfor String
f = String
f forall a. [a] -> [a] -> [a]
++ String
".propellortmp"
make :: FilePath -> [FilePath] -> IO Bool -> IO ()
make :: String -> [String] -> IO Bool -> IO ()
make String
dest [String]
srcs IO Bool
builder = do
Maybe UTCTime
dt <- String -> IO (Maybe UTCTime)
getmtime String
dest
[Maybe UTCTime]
st <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe UTCTime)
getmtime [String]
srcs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe UTCTime
dt forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> a -> Bool
> Maybe UTCTime
dt) [Maybe UTCTime]
st) forall a b. (a -> b) -> a -> b
$
forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM IO Bool
builder forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"failed to make " forall a. [a] -> [a] -> [a]
++ String
dest
where
getmtime :: String -> IO (Maybe UTCTime)
getmtime = forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO UTCTime
getModificationTime
cabal :: [String] -> IO Bool
cabal :: [String] -> IO Bool
cabal = String -> [CommandParam] -> IO Bool
boolSystem String
"cabal" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> CommandParam
Param
stack :: [String] -> IO Bool
stack :: [String] -> IO Bool
stack = String -> [CommandParam] -> IO Bool
boolSystem String
"stack" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> CommandParam
Param