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