summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Bootstrap.hs8
-rw-r--r--src/Propellor/DotDir.hs19
-rw-r--r--src/Propellor/Exception.hs25
-rw-r--r--src/Propellor/Info.hs10
-rw-r--r--src/Propellor/Message.hs20
-rw-r--r--src/Propellor/Property/Apt.hs41
-rw-r--r--src/Propellor/Property/Borg.hs2
-rw-r--r--src/Propellor/Property/Ccache.hs3
-rw-r--r--src/Propellor/Property/Chroot.hs4
-rw-r--r--src/Propellor/Property/ConfFile.hs18
-rw-r--r--src/Propellor/Property/DebianMirror.hs2
-rw-r--r--src/Propellor/Property/Debootstrap.hs4
-rw-r--r--src/Propellor/Property/DiskImage.hs38
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs11
-rw-r--r--src/Propellor/Property/HostingProvider/DigitalOcean.hs27
-rw-r--r--src/Propellor/Property/HostingProvider/Exoscale.hs37
-rw-r--r--src/Propellor/Property/LetsEncrypt.hs4
-rw-r--r--src/Propellor/Property/Mount.hs2
-rw-r--r--src/Propellor/Property/OS.hs26
-rw-r--r--src/Propellor/Property/Reboot.hs116
-rw-r--r--src/Propellor/Property/Sbuild.hs40
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs30
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs36
-rw-r--r--src/Propellor/Property/Systemd.hs10
-rw-r--r--src/Propellor/Types/Exception.hs21
-rw-r--r--src/Propellor/Types/OS.hs61
26 files changed, 445 insertions, 170 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 29175a67..2c8fa95a 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -60,7 +60,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
where
osinstall = case msys of
Just (System (FreeBSD _) _) -> map pkginstall fbsddeps
- Just (System (Debian _) _) -> useapt
+ Just (System (Debian _ _) _) -> useapt
Just (System (Buntish _) _) -> useapt
-- assume a debian derived system when not specified
Nothing -> useapt
@@ -115,7 +115,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
installGitCommand :: Maybe System -> ShellCommand
installGitCommand msys = case msys of
- (Just (System (Debian _) _)) -> use apt
+ (Just (System (Debian _ _) _)) -> use apt
(Just (System (Buntish _) _)) -> use apt
(Just (System (FreeBSD _) _)) -> use
[ "ASSUME_ALWAYS_YES=yes pkg update"
@@ -125,7 +125,7 @@ installGitCommand msys = case msys of
Nothing -> use apt
where
use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi"
- apt =
+ apt =
[ "apt-get update"
, "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git"
]
@@ -177,7 +177,7 @@ cabalBuild msys = do
( return True
, case msys of
Nothing -> return False
- Just sys ->
+ Just sys ->
boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))]
<&&> cabal ["configure"]
)
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
index f32b52a4..c73420b0 100644
--- a/src/Propellor/DotDir.hs
+++ b/src/Propellor/DotDir.hs
@@ -166,7 +166,7 @@ setup = do
buildPropellor Nothing
sayLn ""
sayLn "Great! Propellor is bootstrapped."
-
+
section
sayLn "Propellor can use gpg to encrypt private data about the systems it manages,"
sayLn "and to sign git commits."
@@ -273,7 +273,7 @@ minimalConfig = do
, " Extensions: TypeOperators"
, " Build-Depends: propellor >= 3.0, base >= 3"
]
- configcontent =
+ configcontent =
[ "-- This is the main configuration file for Propellor, and is used to build"
, "-- the propellor program. https://propellor.branchable.com/"
, ""
@@ -295,7 +295,7 @@ minimalConfig = do
, "-- An example host."
, "mybox :: Host"
, "mybox = host \"mybox.example.com\" $ props"
- , " & osDebian Unstable \"amd64\""
+ , " & osDebian Unstable X86_64"
, " & Apt.stdSourcesList"
, " & Apt.unattendedUpgrades"
, " & Apt.installed [\"etckeeper\"]"
@@ -308,13 +308,16 @@ minimalConfig = do
stackcontent =
-- This should be the same resolver version in propellor's
-- own stack.yaml
- [ "resolver: lts-5.10"
+ [ "resolver: " ++ stackResolver
, "packages:"
, "- '.'"
, "extra-deps:"
, "- propellor-" ++ showVersion Package.version
]
+stackResolver :: String
+stackResolver = "lts-5.10"
+
fullClone :: IO Result
fullClone = do
d <- dotPropellor
@@ -351,7 +354,7 @@ checkRepoUpToDate :: IO ()
checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do
headrev <- takeWhile (/= '\n') <$> readFile disthead
changeWorkingDirectory =<< dotPropellor
- headknown <- catchMaybeIO $
+ headknown <- catchMaybeIO $
withQuietOutput createProcessSuccess $
proc "git" ["log", headrev]
if (headknown == Nothing)
@@ -394,19 +397,19 @@ setupUpstreamMaster newref = do
let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo
cleantmprepo
git ["clone", "--quiet", ".", tmprepo]
-
+
changeWorkingDirectory tmprepo
git ["fetch", distrepo, "--quiet"]
git ["reset", "--hard", oldref, "--quiet"]
git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"]
-
+
void $ fetchUpstreamBranch tmprepo
cleantmprepo
warnoutofdate True
getoldrev = takeWhile (/= '\n')
<$> readProcess "git" ["show-ref", upstreambranch, "--hash"]
-
+
git = run "git"
run cmd ps = unlessM (boolSystem cmd (map Param ps)) $
error $ "Failed to run " ++ cmd ++ " " ++ show ps
diff --git a/src/Propellor/Exception.hs b/src/Propellor/Exception.hs
index 2b38af0c..3ab783bf 100644
--- a/src/Propellor/Exception.hs
+++ b/src/Propellor/Exception.hs
@@ -1,18 +1,31 @@
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Propellor.Exception where
import Propellor.Types
+import Propellor.Types.Exception
import Propellor.Message
import Utility.Exception
-import Control.Exception (IOException)
+import Control.Exception (AsyncException)
+import Control.Monad.Catch
+import Control.Monad.IO.Class (MonadIO)
--- | Catches IO exceptions and returns FailedChange.
-catchPropellor :: Propellor Result -> Propellor Result
+-- | Catches all exceptions (except for `StopPropellorException` and
+-- `AsyncException`) and returns FailedChange.
+catchPropellor :: (MonadIO m, MonadCatch m) => m Result -> m Result
catchPropellor a = either err return =<< tryPropellor a
where
err e = warningMessage (show e) >> return FailedChange
-tryPropellor :: Propellor a -> Propellor (Either IOException a)
-tryPropellor = try
+catchPropellor' :: MonadCatch m => m a -> (SomeException -> m a) -> m a
+catchPropellor' a onerr = a `catches`
+ [ Handler (\ (e :: AsyncException) -> throwM e)
+ , Handler (\ (e :: StopPropellorException) -> throwM e)
+ , Handler (\ (e :: SomeException) -> onerr e)
+ ]
+
+-- | Catches all exceptions (except for `StopPropellorException` and
+-- `AsyncException`).
+tryPropellor :: MonadCatch m => m a -> m (Either SomeException a)
+tryPropellor a = (Right <$> a) `catchPropellor'` (pure . Left)
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index b87369c3..e9218291 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -77,9 +77,15 @@ askInfo = asks (fromInfo . hostInfo)
-- It also lets the type checker know that all the properties of the
-- host must support Debian.
--
--- > & osDebian (Stable "jessie") "amd64"
+-- > & osDebian (Stable "jessie") X86_64
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
-osDebian suite arch = tightenTargets $ os (System (Debian suite) arch)
+osDebian = osDebian' Linux
+
+-- Use to specify a different `DebianKernel` than the default `Linux`
+--
+-- > & osDebian' KFreeBSD (Stable "jessie") X86_64
+osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
+osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)
-- | Specifies that a host's operating system is a well-known Debian
-- derivative founded by a space tourist.
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 32625e6a..f728e143 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -13,6 +13,7 @@ module Propellor.Message (
warningMessage,
infoMessage,
errorMessage,
+ stopPropellorMessage,
processChainOutput,
messagesDone,
createProcessConcurrent,
@@ -29,6 +30,7 @@ import Control.Applicative
import Prelude
import Propellor.Types
+import Propellor.Types.Exception
import Utility.PartialPrelude
import Utility.Monad
import Utility.Exception
@@ -105,11 +107,29 @@ warningMessage s = liftIO $
infoMessage :: MonadIO m => [String] -> m ()
infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
+-- | Displays the error message in red, and throws an exception.
+--
+-- When used inside a property, the exception will make the current
+-- property fail. Propellor will continue to the next property.
errorMessage :: MonadIO m => String -> m a
errorMessage s = liftIO $ do
outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
+ -- Normally this exception gets caught and is not displayed,
+ -- and propellor continues. So it's only displayed if not
+ -- caught, and so we say, cannot continue.
error "Cannot continue!"
+-- | Like `errorMessage`, but throws a `StopPropellorException`,
+-- preventing propellor from continuing to the next property.
+--
+-- Think twice before using this. Is the problem so bad that propellor
+-- cannot try to ensure other properties? If not, use `errorMessage`
+-- instead.
+stopPropellorMessage :: MonadIO m => String -> m a
+stopPropellorMessage s = liftIO $ do
+ outputConcurrent =<< colorLine Vivid Red ("** fatal error: " ++ s)
+ throwM $ StopPropellorException "Cannot continue!"
+
colorLine :: ColorIntensity -> Color -> String -> IO String
colorLine intensity color msg = concat <$> sequence
[ whenConsole $
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 5e185a0e..196fb345 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -82,7 +82,7 @@ securityUpdates suite
-- kernel.org.
stdSourcesList :: Property Debian
stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
- (Just (System (Debian suite) _)) ->
+ (Just (System (Debian _ suite) _)) ->
ensureProperty w $ stdSourcesListFor suite
_ -> unsupportedOS'
@@ -154,14 +154,14 @@ installed :: [Package] -> Property DebianLike
installed = installed' ["-y"]
installed' :: [String] -> [Package] -> Property DebianLike
-installed' params ps = robustly $ check (isInstallable ps) go
+installed' params ps = robustly $ check (not <$> isInstalled' ps) go
`describe` unwords ("apt installed":ps)
where
go = runApt (params ++ ["install"] ++ ps)
installedBackport :: [Package] -> Property Debian
installedBackport ps = withOS desc $ \w o -> case o of
- (Just (System (Debian suite) _)) -> case backportSuite suite of
+ (Just (System (Debian _ suite) _)) -> case backportSuite suite of
Nothing -> unsupportedOS'
Just bs -> ensureProperty w $
runApt (["install", "-t", bs, "-y"] ++ ps)
@@ -175,7 +175,8 @@ installedMin :: [Package] -> Property DebianLike
installedMin = installed' ["--no-install-recommends", "-y"]
removed :: [Package] -> Property DebianLike
-removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps))
+removed ps = check (any (== IsInstalled) <$> getInstallStatus ps)
+ (runApt (["-y", "remove"] ++ ps))
`describe` unwords ("apt removed":ps)
buildDep :: [Package] -> Property DebianLike
@@ -200,24 +201,24 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
robustly :: Property DebianLike -> Property DebianLike
robustly p = p `fallback` (update `before` p)
-isInstallable :: [Package] -> IO Bool
-isInstallable ps = do
- l <- isInstalled' ps
- return $ elem False l && not (null l)
-
isInstalled :: Package -> IO Bool
-isInstalled p = (== [True]) <$> isInstalled' [p]
-
--- | Note that the order of the returned list will not always
--- correspond to the order of the input list. The number of items may
--- even vary. If apt does not know about a package at all, it will not
--- be included in the result list.
-isInstalled' :: [Package] -> IO [Bool]
-isInstalled' ps = (mapMaybe parse . lines) <$> policy
+isInstalled p = isInstalled' [p]
+
+isInstalled' :: [Package] -> IO Bool
+isInstalled' ps = all (== IsInstalled) <$> getInstallStatus ps
+
+data InstallStatus = IsInstalled | NotInstalled
+ deriving (Show, Eq)
+
+{- Returns the InstallStatus of packages that are installed
+ - or known and not installed. If a package is not known at all to apt
+ - or dpkg, it is not included in the list. -}
+getInstallStatus :: [Package] -> IO [InstallStatus]
+getInstallStatus ps = mapMaybe parse . lines <$> policy
where
parse l
- | "Installed: (none)" `isInfixOf` l = Just False
- | "Installed: " `isInfixOf` l = Just True
+ | "Installed: (none)" `isInfixOf` l = Just NotInstalled
+ | "Installed: " `isInfixOf` l = Just IsInstalled
| otherwise = Nothing
policy = do
environ <- addEntry "LANG" "C" <$> getEnvironment
@@ -257,7 +258,7 @@ unattendedUpgrades = enable <!> disable
enableupgrading = withOS "unattended upgrades configured" $ \w o ->
case o of
-- the package defaults to only upgrading stable
- (Just (System (Debian suite) _))
+ (Just (System (Debian _ suite) _))
| not (isStable suite) -> ensureProperty w $
unattendedconfig
`File.containsLine`
diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs
index f5842115..16030562 100644
--- a/src/Propellor/Property/Borg.hs
+++ b/src/Propellor/Property/Borg.hs
@@ -23,7 +23,7 @@ type BorgRepo = FilePath
installed :: Property DebianLike
installed = withOS desc $ \w o -> case o of
- (Just (System (Debian (Stable "jessie")) _)) -> ensureProperty w $
+ (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $
Apt.installedBackport ["borgbackup"]
_ -> ensureProperty w $
Apt.installed ["borgbackup"]
diff --git a/src/Propellor/Property/Ccache.hs b/src/Propellor/Property/Ccache.hs
index f2246fe1..34ed6761 100644
--- a/src/Propellor/Property/Ccache.hs
+++ b/src/Propellor/Property/Ccache.hs
@@ -66,8 +66,7 @@ path `hasLimits` limit = go `requires` installed
cmdPropertyEnv "ccache" params' [("CCACHE_DIR", path)]
`changesFileContent` (path </> "ccache.conf")
| otherwise = property "couldn't parse ccache limits" $
- sequence_ (errorMessage <$> errors)
- >> return FailedChange
+ errorMessage $ unlines errors
params = limitToParams limit
(errors, params') = partitionEithers params
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 09047ce5..cb693a73 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -91,7 +91,7 @@ data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
instance ChrootBootstrapper Debootstrapped where
buildchroot (Debootstrapped cf) system loc = case system of
- (Just s@(System (Debian _) _)) -> Right $ debootstrap s
+ (Just s@(System (Debian _ _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
Nothing -> Left "Cannot debootstrap; OS not specified"
@@ -105,7 +105,7 @@ instance ChrootBootstrapper Debootstrapped where
-- to bootstrap.
--
-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & Apt.installed ["ghc", "haskell-platform"]
-- > & ...
debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs
index 270e04f1..d91c7724 100644
--- a/src/Propellor/Property/ConfFile.hs
+++ b/src/Propellor/Property/ConfFile.hs
@@ -9,6 +9,7 @@ module Propellor.Property.ConfFile (
IniSection,
IniKey,
containsIniSetting,
+ hasIniSection,
lacksIniSection,
) where
@@ -24,7 +25,7 @@ type SectionStart = Line -> Bool
type SectionPast = Line -> Bool
-- | run on all lines in the section, including the SectionStart line;
-- can add, delete, and modify lines, or even delete entire section
-type AdjustSection = [Line] -> [Line]
+type AdjustSection = [Line] -> [Line]
-- | if SectionStart does not find the section in the file, this is used to
-- insert the section somewhere within it
type InsertSection = [Line] -> [Line]
@@ -92,6 +93,21 @@ containsIniSetting f (header, key, value) =
go (l:ls) = if isKeyVal l then confline : ls else l : (go ls)
isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key]
+-- | Ensures that a .ini file exists and contains a section
+-- with a given key=value list of settings.
+hasIniSection :: FilePath -> IniSection -> [(IniKey, String)] -> Property UnixLike
+hasIniSection f header keyvalues =
+ adjustIniSection
+ ("set " ++ f ++ " section [" ++ header ++ "]")
+ header
+ go
+ (++ [confheader] ++ conflines) -- add missing section at end
+ f
+ where
+ confheader = iniHeader header
+ conflines = map (\(key, value) -> key ++ "=" ++ value) keyvalues
+ go _ = conflines
+
-- | Ensures that a .ini file does not contain the specified section.
lacksIniSection :: FilePath -> IniSection -> Property UnixLike
lacksIniSection f header =
diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs
index b86d8e0b..d8a9c423 100644
--- a/src/Propellor/Property/DebianMirror.hs
+++ b/src/Propellor/Property/DebianMirror.hs
@@ -141,7 +141,7 @@ mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props
rsyncextraarg res = intercalate "," $ map showRsyncExtra res
args =
[ "--dist" , suitearg
- , "--arch", architecturearg $ _debianMirrorArchitectures mirror'
+ , "--arch", architecturearg $ map architectureToDebianArchString (_debianMirrorArchitectures mirror')
, "--section", intercalate "," $ _debianMirrorSections mirror'
, "--limit-priority", "\"" ++ priorityRegex (_debianMirrorPriorities mirror') ++ "\""
]
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 87f30776..69ac036a 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -67,7 +67,7 @@ built' installprop target system@(System _ arch) config =
Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system
Just s -> pure s
let params = toParams config ++
- [ Param $ "--arch=" ++ arch
+ [ Param $ "--arch=" ++ architectureToDebianArchString arch
, Param suite
, Param target
]
@@ -90,7 +90,7 @@ built' installprop target system@(System _ arch) config =
)
extractSuite :: System -> Maybe String
-extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
+extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s
extractSuite (System (Buntish r) _) = Just r
extractSuite (System (FreeBSD _) _) = Nothing
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index afeaa287..06dfa69c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -1,4 +1,4 @@
--- | Disk image generation.
+-- | Disk image generation.
--
-- This module is designed to be imported unqualified.
@@ -56,7 +56,7 @@ type DiskImage = FilePath
-- > import Propellor.Property.DiskImage
--
-- > let chroot d = Chroot.debootstrapped mempty d
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & Apt.installed ["linux-image-amd64"]
-- > & User.hasPassword (User "root")
-- > & User.accountFor (User "demo")
@@ -91,7 +91,7 @@ imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -
imageRebuilt = imageBuilt' True
imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
-imageBuilt' rebuild img mkchroot tabletype final partspec =
+imageBuilt' rebuild img mkchroot tabletype final partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
@@ -132,7 +132,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
-- unmount helper filesystems such as proc from the chroot
-- before getting sizes
liftIO $ unmountBelow chrootdir
- szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
+ szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
-- tie the knot!
@@ -151,7 +151,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
rmimg = File.notPresent img
partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
-partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
+partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
mconcat $ zipWith3 (go w) mnts mntopts devs
where
desc = "partitions populated from " ++ chrootdir
@@ -165,11 +165,11 @@ partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
else return FailedChange
- filtersfor mnt =
+ filtersfor mnt =
let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $
filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m)
(catMaybes mnts)
- in concatMap (\m ->
+ in concatMap (\m ->
-- Include the child mount point, but exclude its contents.
[ Include (Pattern m)
, Exclude (filesUnder m)
@@ -185,8 +185,8 @@ fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
(mounts, mountopts, sizers) = unzip3 l
parttable = PartTable tt (zipWith id sizers basesizes)
--- | Generates a map of the sizes of the contents of
--- every directory in a filesystem tree.
+-- | Generates a map of the sizes of the contents of
+-- every directory in a filesystem tree.
--
-- (Hard links are counted multiple times for simplicity)
--
@@ -201,7 +201,7 @@ dirSizes top = go M.empty top [top]
if isDirectory s
then do
subm <- go M.empty i =<< dirContents i
- let sz' = M.foldr' (+) sz
+ let sz' = M.foldr' (+) sz
(M.filterWithKey (const . subdirof i) subm)
go (M.insertWith (+) i sz' (M.union m subm)) dir is
else go (M.insertWith (+) dir sz m) dir is
@@ -209,13 +209,13 @@ dirSizes top = go M.empty top [top]
getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
getMountSz _ _ Nothing = Nothing
-getMountSz szm l (Just mntpt) =
+getMountSz szm l (Just mntpt) =
fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
where
childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l)
-- | Ensures that a disk image file of the specified size exists.
---
+--
-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
--
-- If the file is too large, truncates it down to the specified size.
@@ -223,7 +223,7 @@ imageExists :: FilePath -> ByteSize -> Property Linux
imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
- Just s
+ Just s
| toInteger (fileSize s) == toInteger sz -> return NoChange
| toInteger (fileSize s) > toInteger sz -> do
setFileSize img (fromInteger sz)
@@ -239,15 +239,15 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
-- with its populated partition tree mounted in the provided
-- location from the provided loop devices. This will typically
-- take care of installing the boot loader to the image.
---
+--
-- It's ok if the second property leaves additional things mounted
-- in the partition tree.
type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
-imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
+imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
property' "disk image finalized" $ \w ->
- withTmpDir "mnt" $ \top ->
+ withTmpDir "mnt" $ \top ->
go w top `finally` liftIO (unmountall top)
where
go w top = do
@@ -255,12 +255,12 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
liftIO $ writefstab top
liftIO $ allowservices top
ensureProperty w $ final top devs
-
+
-- Ordered lexographically by mount point, so / comes before /usr
-- comes before /usr/local
orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs)
-
+
swaps = map (SwapPartition . partitionLoopDev . snd) $
filter ((== LinuxSwap) . partFs . fst) $
zip parts devs
@@ -276,7 +276,7 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
unmountall top = do
unmountBelow top
umountLazy top
-
+
writefstab top = do
let fstab = top ++ "/etc/fstab"
old <- catchDefaultIO [] $ filter (not . unconfigured) . lines
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
index fcad9e87..58477468 100644
--- a/src/Propellor/Property/FreeBSD/Poudriere.hs
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -9,7 +9,6 @@ module Propellor.Property.FreeBSD.Poudriere where
import Propellor.Base
import Propellor.Types.Info
import Data.List
-import Data.String (IsString(..))
import qualified Propellor.Property.FreeBSD.Pkg as Pkg
import qualified Propellor.Property.ZFS as ZFS
@@ -27,7 +26,7 @@ poudriereConfigured :: PoudriereConfigured -> Bool
poudriereConfigured (PoudriereConfigured _) = True
setConfigured :: Property (HasInfo + FreeBSD)
-setConfigured = tightenTargets $
+setConfigured = tightenTargets $
pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")
poudriere :: Poudriere -> Property (HasInfo + FreeBSD)
@@ -106,10 +105,10 @@ instance Show PoudriereArch where
show I386 = "i386"
show AMD64 = "amd64"
-instance IsString PoudriereArch where
- fromString "i386" = I386
- fromString "amd64" = AMD64
- fromString _ = error "Not a valid Poudriere architecture."
+fromArchitecture :: Architecture -> PoudriereArch
+fromArchitecture X86_64 = AMD64
+fromArchitecture X86_32 = I386
+fromArchitecture _ = error "Not a valid Poudriere architecture."
yesNoProp :: Bool -> String
yesNoProp b = if b then "yes" else "no"
diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
index c1e0ffc9..053338de 100644
--- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs
+++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
@@ -7,15 +7,13 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Reboot as Reboot
-import Data.List
-
-- | Digital Ocean does not provide any way to boot
-- the kernel provided by the distribution, except using kexec.
-- Without this, some old, and perhaps insecure kernel will be used.
--
-- This property causes the distro kernel to be loaded on reboot, using kexec.
--
--- If the power is cycled, the non-distro kernel still boots up.
+-- When the power is cycled, the non-distro kernel still boots up.
-- So, this property also checks if the running kernel is present in /boot,
-- and if not, reboots immediately into a distro kernel.
distroKernel :: Property DebianLike
@@ -25,25 +23,4 @@ distroKernel = propertyList "digital ocean distro kernel hack" $ props
[ "LOAD_KEXEC=true"
, "USE_GRUB_CONFIG=true"
] `describe` "kexec configured"
- & check (not <$> runningInstalledKernel) Reboot.now
- `describe` "running installed kernel"
-
-runningInstalledKernel :: IO Bool
-runningInstalledKernel = do
- kernelver <- takeWhile (/= '\n') <$> readProcess "uname" ["-r"]
- when (null kernelver) $
- error "failed to read uname -r"
- kernelimages <- concat <$> mapM kernelsIn ["/", "/boot/"]
- when (null kernelimages) $
- error "failed to find any installed kernel images"
- findVersion kernelver <$>
- readProcess "file" ("-L" : kernelimages)
-
--- | File output looks something like this, we want to unambiguously
--- match the running kernel version:
--- Linux kernel x86 boot executable bzImage, version 3.16-3-amd64 (debian-kernel@lists.debian.org) #1 SMP Debian 3.1, RO-rootFS, swap_dev 0x2, Normal VGA
-findVersion :: String -> String -> Bool
-findVersion ver s = (" version " ++ ver ++ " ") `isInfixOf` s
-
-kernelsIn :: FilePath -> IO [FilePath]
-kernelsIn d = filter ("vmlinu" `isInfixOf`) <$> dirContents d
+ & Reboot.toDistroKernel
diff --git a/src/Propellor/Property/HostingProvider/Exoscale.hs b/src/Propellor/Property/HostingProvider/Exoscale.hs
new file mode 100644
index 00000000..18e3c42f
--- /dev/null
+++ b/src/Propellor/Property/HostingProvider/Exoscale.hs
@@ -0,0 +1,37 @@
+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
+--
+-- Properties for use on <https://www.exoscale.ch/>
+
+module Propellor.Property.HostingProvider.Exoscale (
+ distroKernel,
+) where
+
+import Propellor.Base
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Grub as Grub
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Reboot as Reboot
+
+-- | Flavor of kernel, eg "amd64" or "686"
+type KernelFlavor = String
+
+-- | The current Exoshare Debian image doesn't install GRUB, so this property
+-- makes sure GRUB is installed and correctly configured
+--
+-- In case an old, insecure kernel is running, we check for an old kernel
+-- version and reboot immediately if one is found.
+--
+-- Note that we ignore anything after the first hyphen when considering
+-- whether the running kernel's version is older than the Debian-supplied
+-- kernel's version.
+distroKernel :: KernelFlavor -> Property DebianLike
+distroKernel kernelflavor = go `flagFile` theFlagFile
+ where
+ go = combineProperties "boots distro kernel" $ props
+ & Apt.installed ["grub2", "linux-image-" ++ kernelflavor]
+ & Grub.boots "/dev/vda"
+ & Grub.mkConfig
+ -- Since we're rebooting we have to manually create the flagfile
+ & File.hasContent theFlagFile [""]
+ & Reboot.toDistroKernel
+ theFlagFile = "/etc/propellor-distro-kernel"
diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs
index 592a1e1d..9e4898dd 100644
--- a/src/Propellor/Property/LetsEncrypt.hs
+++ b/src/Propellor/Property/LetsEncrypt.hs
@@ -8,10 +8,8 @@ import qualified Propellor.Property.Apt as Apt
import System.Posix.Files
--- Not using the certbot name yet, until it reaches jessie-backports and
--- testing.
installed :: Property DebianLike
-installed = Apt.installed ["letsencrypt"]
+installed = Apt.installed ["certbot"]
-- | Tell the letsencrypt client that you agree with the Let's Encrypt
-- Subscriber Agreement. Providing an email address is recommended,
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index bb0f60a7..026509a9 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -118,7 +118,7 @@ blkidTag tag dev = catchDefaultIO Nothing $
umountLazy :: FilePath -> IO ()
umountLazy mnt =
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
- errorMessage $ "failed unmounting " ++ mnt
+ stopPropellorMessage $ "failed unmounting " ++ mnt
-- | Unmounts anything mounted inside the specified directory.
unmountBelow :: FilePath -> IO ()
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index 5a3ccc70..d974cfbc 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -22,7 +22,7 @@ import Control.Exception (throw)
-- | Replaces whatever OS was installed before with a clean installation
-- of the OS that the Host is configured to have.
---
+--
-- This is experimental; use with caution!
--
-- This can replace one Linux distribution with different one.
@@ -35,7 +35,7 @@ import Control.Exception (throw)
-- This property only runs once. The cleanly installed system will have
-- a file </etc/propellor-cleaninstall>, which indicates it was cleanly
-- installed.
---
+--
-- The files from the old os will be left in </old-os>
--
-- After the OS is installed, and if all properties of the host have
@@ -46,7 +46,7 @@ import Control.Exception (throw)
-- install succeeds, to bootstrap from the cleanly installed system to
-- a fully working system. For example:
--
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & cleanInstallOnce (Confirmed "foo.example.com")
-- > `onChange` propertyList "fixing up after clean install"
-- > [ preserveNetwork
@@ -68,7 +68,7 @@ cleanInstallOnce :: Confirmation -> Property Linux
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation
where
- go =
+ go =
finalized
`requires`
-- easy to forget and system may not boot without shadow pw!
@@ -85,19 +85,19 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
osbootstrapped :: Property Linux
osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of
- (Just d@(System (Debian _) _)) -> ensureProperty w $
+ (Just d@(System (Debian _ _) _)) -> ensureProperty w $
debootstrap d
(Just u@(System (Buntish _) _)) -> ensureProperty w $
debootstrap u
_ -> unsupportedOS'
-
+
debootstrap :: System -> Property Linux
debootstrap targetos =
-- Install debootstrap from source, since we don't know
-- what OS we're currently running in.
Debootstrap.built' Debootstrap.sourceInstall
newOSDir targetos Debootstrap.DefaultConfig
- -- debootstrap, I wish it was faster..
+ -- debootstrap, I wish it was faster..
-- TODO eatmydata to speed it up
-- Problem: Installing eatmydata on some random OS like
-- Fedora may be difficult. Maybe configure dpkg to not
@@ -120,7 +120,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
createDirectoryIfMissing True oldOSDir
massRename (renamesout ++ renamesin)
removeDirectoryRecursive newOSDir
-
+
-- Prepare environment for running additional properties,
-- overriding old OS's environment.
void $ setEnv "PATH" stdPATH True
@@ -150,15 +150,15 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
-- git repo url, which all need to be arranged to
-- be present in /old-os's /usr/local/propellor)
-- TODO
-
+
finalized :: Property UnixLike
finalized = property "clean OS installed" $ do
liftIO $ writeFile flagfile ""
return MadeChange
flagfile = "/etc/propellor-cleaninstall"
-
- trickydirs =
+
+ trickydirs =
-- /tmp can contain X's sockets, which prevent moving it
-- so it's left as-is.
[ "/tmp"
@@ -195,7 +195,7 @@ confirmed desc (Confirmed c) = property desc $ do
return FailedChange
else return NoChange
--- | </etc/network/interfaces> is configured to bring up the network
+-- | </etc/network/interfaces> is configured to bring up the network
-- interface that currently has a default route configured, using
-- the same (static) IP address.
preserveNetwork :: Property DebianLike
@@ -210,7 +210,7 @@ preserveNetwork = go `requires` Network.cleanInterfacesFile
ensureProperty w $ Network.static iface
_ -> do
warningMessage "did not find any default ipv4 route"
- return FailedChange
+ return FailedChange
-- | </etc/resolv.conf> is copied from the old OS
preserveResolvConf :: Property Linux
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index 5b854fa3..6a0626a2 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -1,12 +1,34 @@
-module Propellor.Property.Reboot where
+module Propellor.Property.Reboot (
+ now,
+ atEnd,
+ toDistroKernel,
+ toKernelNewerThan,
+ KernelVersion,
+) where
import Propellor.Base
+import Data.List
+import Data.Version
+import Text.ParserCombinators.ReadP
+
+-- | Kernel version number, in a string.
+type KernelVersion = String
+
+-- | Using this property causes an immediate reboot.
+--
+-- So, this is not a useful property on its own, but it can be useful to
+-- compose with other properties. For example:
+--
+-- > Apt.installed ["new-kernel"]
+-- > `onChange` Reboot.now
now :: Property Linux
now = tightenTargets $ cmdProperty "reboot" []
`assume` MadeChange
`describe` "reboot now"
+type Force = Bool
+
-- | Schedules a reboot at the end of the current propellor run.
--
-- The `Result` code of the entire propellor run can be checked;
@@ -14,7 +36,7 @@ now = tightenTargets $ cmdProperty "reboot" []
--
-- The reboot can be forced to run, which bypasses the init system. Useful
-- if the init system might not be running for some reason.
-atEnd :: Bool -> (Result -> Bool) -> Property Linux
+atEnd :: Force -> (Result -> Bool) -> Property Linux
atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
endAction "rebooting" atend
return NoChange
@@ -28,3 +50,93 @@ atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
rebootparams
| force = [Param "--force"]
| otherwise = []
+
+-- | Reboots immediately if a kernel other than the distro-installed kernel is
+-- running.
+--
+-- This will only work if you have taken measures to ensure that the other
+-- kernel won't just get booted again.
+-- See 'Propellor.Property.HostingProvider.DigitalOcean'
+-- for an example of how to do this.
+toDistroKernel :: Property DebianLike
+toDistroKernel = check (not <$> runningInstalledKernel) now
+ `describe` "running installed kernel"
+
+-- | Given a kernel version string @v@, reboots immediately if the running
+-- kernel version is strictly less than @v@ and there is an installed kernel
+-- version is greater than or equal to @v@. Dies if the requested kernel
+-- version is not installed.
+--
+-- For this to be useful, you need to have ensured that the installed kernel
+-- with the highest version number is the one that will be started after a
+-- reboot.
+--
+-- This is useful when upgrading to a new version of Debian where you need to
+-- ensure that a new enough kernel is running before ensuring other properties.
+toKernelNewerThan :: KernelVersion -> Property DebianLike
+toKernelNewerThan ver =
+ property' ("reboot to kernel newer than " ++ ver) $ \w -> do
+ wantV <- tryReadVersion ver
+ runningV <- tryReadVersion =<< liftIO runningKernelVersion
+ installedV <- maximum <$>
+ (mapM tryReadVersion =<< liftIO installedKernelVersions)
+ if runningV >= wantV then noChange
+ else if installedV >= wantV
+ then ensureProperty w now
+ -- Stop propellor here because other
+ -- properties may be incorrectly ensured
+ -- under a kernel version that's too old.
+ -- E.g. Sbuild.built can fail
+ -- to add the config line `union-type=overlay`
+ else stopPropellorMessage $
+ "kernel newer than "
+ ++ ver
+ ++ " not installed"
+
+runningInstalledKernel :: IO Bool
+runningInstalledKernel = do
+ kernelver <- runningKernelVersion
+ when (null kernelver) $
+ error "failed to read uname -r"
+ kernelimages <- installedKernelImages
+ when (null kernelimages) $
+ error "failed to find any installed kernel images"
+ findVersion kernelver <$>
+ readProcess "file" ("-L" : kernelimages)
+
+runningKernelVersion :: IO KernelVersion
+runningKernelVersion = takeWhile (/= '\n') <$> readProcess "uname" ["-r"]
+
+installedKernelImages :: IO [String]
+installedKernelImages = concat <$> mapM kernelsIn ["/", "/boot/"]
+
+-- | File output looks something like this, we want to unambiguously
+-- match the running kernel version:
+-- Linux kernel x86 boot executable bzImage, version 3.16-3-amd64 (debian-kernel@lists.debian.org) #1 SMP Debian 3.1, RO-rootFS, swap_dev 0x2, Normal VGA
+findVersion :: KernelVersion -> String -> Bool
+findVersion ver s = (" version " ++ ver ++ " ") `isInfixOf` s
+
+installedKernelVersions :: IO [KernelVersion]
+installedKernelVersions = do
+ kernelimages <- installedKernelImages
+ when (null kernelimages) $
+ error "failed to find any installed kernel images"
+ imageLines <- lines <$> readProcess "file" ("-L" : kernelimages)
+ return $ extractKernelVersion <$> imageLines
+
+kernelsIn :: FilePath -> IO [FilePath]
+kernelsIn d = filter ("vmlinu" `isInfixOf`) <$> dirContents d
+
+extractKernelVersion :: String -> KernelVersion
+extractKernelVersion =
+ unwords . take 1 . drop 1 . dropWhile (/= "version") . words
+
+readVersionMaybe :: KernelVersion -> Maybe Version
+readVersionMaybe ver = case map fst $ readP_to_S parseVersion ver of
+ [] -> Nothing
+ l -> Just $ maximum l
+
+tryReadVersion :: KernelVersion -> Propellor Version
+tryReadVersion ver = case readVersionMaybe ver of
+ Just x -> return x
+ Nothing -> errorMessage ("couldn't parse version " ++ ver)
diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs
index 2647e69e..50825a0c 100644
--- a/src/Propellor/Property/Sbuild.hs
+++ b/src/Propellor/Property/Sbuild.hs
@@ -9,9 +9,9 @@ Build and maintain schroots for use with sbuild.
Suggested usage in @config.hs@:
> & Apt.installed ["piuparts"]
-> & Sbuild.builtFor (System (Debian Unstable) "i386")
-> & Sbuild.piupartsConfFor (System (Debian Unstable) "i386")
-> & Sbuild.updatedFor (System (Debian Unstable) "i386") `period` Weekly 1
+> & Sbuild.builtFor (System (Debian Unstable) X86_32)
+> & Sbuild.piupartsConfFor (System (Debian Unstable) X86_32)
+> & Sbuild.updatedFor (System (Debian Unstable) X86_32) `period` Weekly 1
> & Sbuild.usableBy (User "spwhitton")
> & Sbuild.shareAptCache
> & Schroot.overlaysInTmpfs
@@ -66,6 +66,7 @@ module Propellor.Property.Sbuild (
-- blockNetwork,
installed,
keypairGenerated,
+ keypairInsecurelyGenerated,
shareAptCache,
usableBy,
) where
@@ -93,7 +94,7 @@ type Suite = String
data SbuildSchroot = SbuildSchroot Suite Architecture
instance Show SbuildSchroot where
- show (SbuildSchroot suite arch) = suite ++ "-" ++ arch
+ show (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch
-- | Build and configure a schroot for use with sbuild using a distribution's
-- standard mirror
@@ -130,7 +131,7 @@ built s@(SbuildSchroot suite arch) mirror =
make w = do
de <- liftIO standardPathEnv
let params = Param <$>
- [ "--arch=" ++ arch
+ [ "--arch=" ++ architectureToDebianArchString arch
, "--chroot-suffix=-propellor"
, "--include=eatmydata,ccache"
, suite
@@ -192,7 +193,7 @@ updated s@(SbuildSchroot suite arch) =
where
go :: Property DebianLike
go = tightenTargets $ cmdProperty
- "sbuild-update" ["-udr", suite ++ "-" ++ arch]
+ "sbuild-update" ["-udr", suite ++ "-" ++ architectureToDebianArchString arch]
`assume` MadeChange
-- Find the conf file that sbuild-createchroot(1) made when we passed it
@@ -219,7 +220,7 @@ fixConfFile s@(SbuildSchroot suite arch) =
where
new = schrootConf s
dir = takeDirectory new
- tempPrefix = dir </> suite ++ "-" ++ arch ++ "-propellor-"
+ tempPrefix = dir </> suite ++ "-" ++ architectureToDebianArchString arch ++ "-propellor-"
munge = replace "-propellor]" "-sbuild]"
-- | Create a corresponding schroot config file for use with piuparts
@@ -320,7 +321,22 @@ keypairGenerated = check (not <$> doesFileExist secKeyFile) $ go
go = tightenTargets $
cmdProperty "sbuild-update" ["--keygen"]
`assume` MadeChange
- secKeyFile = "/var/lib/sbuild/apt-keys/sbuild-key.sec"
+
+secKeyFile :: FilePath
+secKeyFile = "/var/lib/sbuild/apt-keys/sbuild-key.sec"
+
+-- | Generate the apt keys needed by sbuild using a low-quality source of
+-- randomness
+--
+-- Useful on throwaway build VMs.
+keypairInsecurelyGenerated :: Property DebianLike
+keypairInsecurelyGenerated = check (not <$> doesFileExist secKeyFile) go
+ where
+ go :: Property DebianLike
+ go = combineProperties "sbuild keyring insecurely generated" $ props
+ & Apt.installed ["rng-tools"]
+ & cmdProperty "rngd" ["-r", "/dev/urandom"] `assume` MadeChange
+ & keypairGenerated
-- another script from wiki.d.o/sbuild
ccachePrepared :: Property DebianLike
@@ -367,17 +383,17 @@ schrootFromSystem system@(System _ arch) =
>>= \suite -> return $ SbuildSchroot suite arch
stdMirror :: System -> Maybe Apt.Url
-stdMirror (System (Debian _) _) = Just "http://httpredir.debian.org/debian"
+stdMirror (System (Debian _ _) _) = Just "http://httpredir.debian.org/debian"
stdMirror (System (Buntish _) _) = Just "mirror://mirrors.ubuntu.com/"
stdMirror _ = Nothing
schrootRoot :: SbuildSchroot -> FilePath
-schrootRoot (SbuildSchroot s a) = "/srv/chroot" </> s ++ "-" ++ a
+schrootRoot (SbuildSchroot s a) = "/srv/chroot" </> s ++ "-" ++ architectureToDebianArchString a
schrootConf :: SbuildSchroot -> FilePath
schrootConf (SbuildSchroot s a) =
- "/etc/schroot/chroot.d" </> s ++ "-" ++ a ++ "-sbuild-propellor"
+ "/etc/schroot/chroot.d" </> s ++ "-" ++ architectureToDebianArchString a ++ "-sbuild-propellor"
schrootPiupartsConf :: SbuildSchroot -> FilePath
schrootPiupartsConf (SbuildSchroot s a) =
- "/etc/schroot/chroot.d" </> s ++ "-" ++ a ++ "-piuparts-propellor"
+ "/etc/schroot/chroot.d" </> s ++ "-" ++ architectureToDebianArchString a ++ "-piuparts-propellor"
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index b4812c7e..90c9c7bf 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -25,7 +25,9 @@ builddir = gitbuilderdir </> "build"
type TimeOut = String -- eg, 5h
-autobuilder :: Architecture -> Times -> TimeOut -> Property (HasInfo + DebianLike)
+type ArchString = String
+
+autobuilder :: ArchString -> Times -> TimeOut -> Property (HasInfo + DebianLike)
autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
& Apt.serviceInstalledRunning "cron"
& Cron.niceJob "gitannexbuilder" crontimes (User builduser) gitbuilderdir
@@ -47,7 +49,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
then makeChange $ writeFile pwfile want
else noChange
-tree :: Architecture -> Flavor -> Property DebianLike
+tree :: ArchString -> Flavor -> Property DebianLike
tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
& Apt.installed ["git"]
& File.dirExists gitbuilderdir
@@ -55,7 +57,7 @@ tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
& gitannexbuildercloned
& builddircloned
where
- gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $
+ gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $
userScriptProperty (User builduser)
[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
, "cd " ++ gitbuilderdir
@@ -85,7 +87,7 @@ buildDepsNoHaskellLibs = Apt.installed
]
haskellPkgsInstalled :: String -> Property DebianLike
-haskellPkgsInstalled dir = tightenTargets $
+haskellPkgsInstalled dir = tightenTargets $
flagFile go ("/haskellpkgsinstalled")
where
go = userScriptProperty (User builduser)
@@ -107,9 +109,9 @@ autoBuilderContainer :: (DebianSuite -> Architecture -> Flavor -> Property (HasI
autoBuilderContainer mkprop suite arch flavor crontime timeout =
Systemd.container name $ \d -> Chroot.debootstrapped mempty d $ props
& mkprop suite arch flavor
- & autobuilder arch crontime timeout
+ & autobuilder (architectureToDebianArchString arch) crontime timeout
where
- name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
+ name = architectureToDebianArchString arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
type Flavor = Maybe String
@@ -122,7 +124,7 @@ standardAutoBuilder suite arch flavor =
& Apt.unattendedUpgrades
& Apt.cacheCleaned
& User.accountFor (User builduser)
- & tree arch flavor
+ & tree (architectureToDebianArchString arch) flavor
stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
stackAutoBuilder suite arch flavor =
@@ -133,7 +135,7 @@ stackAutoBuilder suite arch flavor =
& Apt.unattendedUpgrades
& Apt.cacheCleaned
& User.accountFor (User builduser)
- & tree arch flavor
+ & tree (architectureToDebianArchString arch) flavor
& stackInstalled
-- Workaround https://github.com/commercialhaskell/stack/issues/2093
& Apt.installed ["libtinfo-dev"]
@@ -141,15 +143,15 @@ stackAutoBuilder suite arch flavor =
stackInstalled :: Property Linux
stackInstalled = withOS "stack installed" $ \w o ->
case o of
- (Just (System (Debian (Stable "jessie")) "i386")) ->
- ensureProperty w $ manualinstall "i386"
+ (Just (System (Debian Linux (Stable "jessie")) X86_32)) ->
+ ensureProperty w $ manualinstall X86_32
_ -> ensureProperty w $ Apt.installed ["haskell-stack"]
where
-- Warning: Using a binary downloaded w/o validation.
manualinstall :: Architecture -> Property Linux
manualinstall arch = tightenTargets $ check (not <$> doesFileExist binstack) $
propertyList "stack installed from upstream tarball" $ props
- & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar]
+ & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ architectureToDebianArchString arch, "-O", tmptar]
`assume` MadeChange
& File.dirExists tmpdir
& cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
@@ -163,7 +165,7 @@ stackInstalled = withOS "stack installed" $ \w o ->
tmpdir = "/root/stack"
armAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
-armAutoBuilder suite arch flavor =
+armAutoBuilder suite arch flavor =
propertyList "arm git-annex autobuilder" $ props
& standardAutoBuilder suite arch flavor
& buildDepsNoHaskellLibs
@@ -187,9 +189,9 @@ androidAutoBuilderContainer'
-> Times
-> TimeOut
-> Systemd.Container
-androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout =
+androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout =
Systemd.container name $ \d -> bootstrap d $ props
- & osDebian (Stable "jessie") "i386"
+ & osDebian (Stable "jessie") X86_32
& Apt.stdSourcesList
& User.accountFor (User builduser)
& File.dirExists gitbuilderdir
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index a6cb3794..652a7141 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -103,7 +103,7 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props
& oldUseNetInstalled "oldusenet-server"
& oldUseNetBackup
& spoolsymlink
- & "/etc/news/leafnode/config" `File.hasContent`
+ & "/etc/news/leafnode/config" `File.hasContent`
[ "# olduse.net configuration (deployed by propellor)"
, "expire = 1000000" -- no expiry via texpire
, "server = " -- no upstream server
@@ -134,7 +134,7 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props
, Apache.allowAll
, " </Directory>"
]
-
+
spoolsymlink :: Property UnixLike
spoolsymlink = check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool)
(property "olduse.net spool in place" $ makeChange $ do
@@ -177,7 +177,7 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
]
`assume` MadeChange
`describe` "olduse.net built"
-
+
kgbServer :: Property (HasInfo + Debian)
kgbServer = propertyList desc $ props
& installed
@@ -187,7 +187,7 @@ kgbServer = propertyList desc $ props
desc = "kgb.kitenet.net setup"
installed :: Property Debian
installed = withOS desc $ \w o -> case o of
- (Just (System (Debian Unstable) _)) ->
+ (Just (System (Debian _ Unstable) _)) ->
ensureProperty w $ propertyList desc $ props
& Apt.serviceInstalledRunning "kgb-bot"
& "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
@@ -289,7 +289,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
postupdatehook = dir </> ".git/hooks/post-update"
setup = userScriptProperty (User "joey") setupscript
`assume` MadeChange
- setupscript =
+ setupscript =
[ "cd " ++ shellEscape dir
, "git annex reinit " ++ shellEscape uuid
] ++ map addremote remotes ++
@@ -316,7 +316,7 @@ apacheSite :: HostName -> Apache.ConfigFile -> RevertableProperty DebianLike Deb
apacheSite hn middle = Apache.siteEnabled hn $ apachecfg hn middle
apachecfg :: HostName -> Apache.ConfigFile -> Apache.ConfigFile
-apachecfg hn middle =
+apachecfg hn middle =
[ "<VirtualHost *:"++show port++">"
, " ServerAdmin grue@joeyh.name"
, " ServerName "++hn++":"++show port
@@ -333,7 +333,7 @@ apachecfg hn middle =
]
where
port = 80 :: Int
-
+
gitAnnexDistributor :: Property (HasInfo + DebianLike)
gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
& Apt.installed ["rsync"]
@@ -360,7 +360,7 @@ downloads hosts = annexWebSite "/srv/git/downloads.git"
"840760dc-08f0-11e2-8c61-576b7e66acfd"
[("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")]
`requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "joey")
-
+
tmp :: Property (HasInfo + DebianLike)
tmp = propertyList "tmp.kitenet.net" $ props
& annexWebSite "/srv/git/joey/tmp.git"
@@ -384,7 +384,7 @@ twitRss = combineProperties "twitter rss" $ props
"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
compiled = userScriptProperty (User "joey")
[ "cd " ++ dir
- , "ghc --make twitRss"
+ , "ghc --make twitRss"
]
`assume` NoChange
`requires` Apt.installed
@@ -447,7 +447,7 @@ githubBackup = propertyList "github-backup box" $ props
gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")"
githubKeys :: Property (HasInfo + UnixLike)
-githubKeys =
+githubKeys =
let f = "/home/joey/.github-keys"
in File.hasPrivContent f anyContext
`onChange` File.ownerGroup f (User "joey") (Group "joey")
@@ -511,14 +511,14 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
] `onChange` Service.restarted "spamassassin"
`describe` "spamd enabled"
`requires` Apt.serviceInstalledRunning "cron"
-
+
& Apt.serviceInstalledRunning "spamass-milter"
-- Add -m to prevent modifying messages Subject or body.
& "/etc/default/spamass-milter" `File.containsLine`
"OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\""
`onChange` Service.restarted "spamass-milter"
`describe` "spamass-milter configured"
-
+
& Apt.serviceInstalledRunning "amavisd-milter"
& "/etc/default/amavisd-milter" `File.containsLines`
[ "# Propellor deployed"
@@ -642,7 +642,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
`onChange` Postfix.dedupMainCf
`onChange` Postfix.reloaded
`describe` "postfix configured"
-
+
& Apt.serviceInstalledRunning "dovecot-imapd"
& Apt.serviceInstalledRunning "dovecot-pop3d"
& "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine`
@@ -679,16 +679,18 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
, "inbox-path={localhost/novalidate-cert/NoRsh}inbox"
]
`describe` "pine configured to use local imap server"
-
+
& Apt.serviceInstalledRunning "mailman"
& Postfix.service ssmtp
+
+ & Apt.installed ["fetchmail"]
where
ctx = Context "kitenet.net"
pinescript = "/usr/local/bin/pine"
dovecotusers = "/etc/dovecot/users"
- ssmtp = Postfix.Service
+ ssmtp = Postfix.Service
(Postfix.InetService Nothing "ssmtp")
"smtpd" Postfix.defServiceOpts
@@ -825,7 +827,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
, "RewriteRule ^/joey/index.html http://www.kitenet.net/joey/ [R]"
, "RewriteRule ^/wifi http://www.kitenet.net/wifi/ [R]"
, "RewriteRule ^/wifi/index.html http://www.kitenet.net/wifi/ [R]"
-
+
, "# Old ikiwiki filenames for kitenet.net wiki."
, "rewritecond $1 !^/~"
, "rewritecond $1 !^/doc/"
@@ -912,7 +914,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
, "rewritecond $1 !.*/index$"
, "rewriterule (.+).rss$ http://joeyh.name/$1/index.rss [l]"
-
+
, "# Redirect all to joeyh.name."
, "rewriterule (.*) http://joeyh.name$1 [r]"
]
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index e11c991e..78529f73 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -204,7 +204,7 @@ machined :: Property Linux
machined = withOS "machined installed" $ \w o ->
case o of
-- Split into separate debian package since systemd 225.
- (Just (System (Debian suite) _))
+ (Just (System (Debian _ suite) _))
| not (isStable suite) -> ensureProperty w $
Apt.installed ["systemd-container"]
_ -> noChange
@@ -217,11 +217,11 @@ machined = withOS "machined installed" $ \w o ->
-- to bootstrap.
--
-- > container "webserver" $ \d -> Chroot.debootstrapped mempty d $ props
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & Apt.installedRunning "apache2"
-- > & ...
container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
-container name mkchroot =
+container name mkchroot =
let c = Container name chroot h
in setContainerProps c $ containerProps c
&^ resolvConfed
@@ -238,7 +238,7 @@ container name mkchroot =
-- to bootstrap.
--
-- > debContainer "webserver" $ props
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & Apt.installedRunning "apache2"
-- > & ...
debContainer :: MachineName -> Props metatypes -> Container
@@ -447,7 +447,7 @@ instance Publishable (Proto, Bound Port) where
-- >
-- > webserver :: Systemd.container
-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped mempty)
--- > & os (System (Debian Testing) "amd64")
+-- > & os (System (Debian Testing) X86_64)
-- > & Systemd.privateNetwork
-- > & Systemd.running Systemd.networkd
-- > & Systemd.publish (Port 80 ->- Port 8080)
diff --git a/src/Propellor/Types/Exception.hs b/src/Propellor/Types/Exception.hs
new file mode 100644
index 00000000..3a810d55
--- /dev/null
+++ b/src/Propellor/Types/Exception.hs
@@ -0,0 +1,21 @@
+module Propellor.Types.Exception where
+
+import Data.Typeable
+import Control.Exception
+
+-- | Normally when an exception is encountered while propellor is
+-- ensuring a property, the property fails, but propellor robustly
+-- continues on to the next property.
+--
+-- This is the only exception that will stop the entire propellor run,
+-- preventing any subsequent properties of the Host from being ensured.
+-- (When propellor is running in a container in a Host, this exception only
+-- stops the propellor run in the container; the outer run in the Host
+-- continues.)
+--
+-- You should only throw this exception when things are so badly messed up
+-- that it's best for propellor to not try to do anything else.
+data StopPropellorException = StopPropellorException String
+ deriving (Show, Typeable)
+
+instance Exception StopPropellorException
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index d7df5490..b569a6e8 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -4,12 +4,14 @@ module Propellor.Types.OS (
System(..),
Distribution(..),
TargetOS(..),
+ DebianKernel(..),
DebianSuite(..),
FreeBSDRelease(..),
FBSDVersion(..),
isStable,
Release,
- Architecture,
+ Architecture(..),
+ architectureToDebianArchString,
HostName,
UserName,
User(..),
@@ -29,7 +31,7 @@ data System = System Distribution Architecture
deriving (Show, Eq, Typeable)
data Distribution
- = Debian DebianSuite
+ = Debian DebianKernel DebianSuite
| Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per <http://joeyh.name/blog/entry/trademark_nonsense/>
| FreeBSD FreeBSDRelease
deriving (Show, Eq)
@@ -43,10 +45,15 @@ data TargetOS
deriving (Show, Eq, Ord)
systemToTargetOS :: System -> TargetOS
-systemToTargetOS (System (Debian _) _) = OSDebian
+systemToTargetOS (System (Debian _ _) _) = OSDebian
systemToTargetOS (System (Buntish _) _) = OSBuntish
systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD
+-- | Most of Debian ports are based on Linux. There also exist hurd-i386,
+-- kfreebsd-i386, kfreebsd-amd64 ports
+data DebianKernel = Linux | KFreeBSD | Hurd
+ deriving (Show, Eq)
+
-- | Debian has several rolling suites, and a number of stable releases,
-- such as Stable "jessie".
data DebianSuite = Experimental | Unstable | Testing | Stable Release
@@ -75,7 +82,53 @@ isStable (Stable _) = True
isStable _ = False
type Release = String
-type Architecture = String
+
+-- | Many of these architecture names are based on the names used by
+-- Debian, with a few exceptions for clarity.
+data Architecture
+ = X86_64 -- ^ 64 bit Intel, called "amd64" in Debian
+ | X86_32 -- ^ 32 bit Intel, called "i386" in Debian
+ | ARMHF
+ | ARMEL
+ | PPC
+ | PPC64
+ | SPARC
+ | SPARC64
+ | MIPS
+ | MIPSEL
+ | MIPS64EL
+ | SH4
+ | IA64 -- ^ Itanium
+ | S390
+ | S390X
+ | ALPHA
+ | HPPA
+ | M68K
+ | ARM64
+ | X32 -- ^ New Linux ABI for 64 bit CPUs using 32-bit integers. Not widely used.
+ deriving (Show, Eq)
+
+architectureToDebianArchString :: Architecture -> String
+architectureToDebianArchString X86_64 = "amd64"
+architectureToDebianArchString X86_32 = "i386"
+architectureToDebianArchString ARMHF = "armhf"
+architectureToDebianArchString ARMEL = "armel"
+architectureToDebianArchString PPC = "powerpc"
+architectureToDebianArchString PPC64 = "ppc64el"
+architectureToDebianArchString SPARC = "sparc"
+architectureToDebianArchString SPARC64 = "sparc64"
+architectureToDebianArchString MIPS = "mips"
+architectureToDebianArchString MIPSEL = "mipsel"
+architectureToDebianArchString MIPS64EL = "mips64el"
+architectureToDebianArchString SH4 = "sh"
+architectureToDebianArchString IA64 = "ia64"
+architectureToDebianArchString S390 = "s390"
+architectureToDebianArchString S390X = "s390x"
+architectureToDebianArchString ALPHA = "alpha"
+architectureToDebianArchString HPPA = "hppa"
+architectureToDebianArchString M68K = "m68k"
+architectureToDebianArchString ARM64 = "arm64"
+architectureToDebianArchString X32 = "x32"
type UserName = String