diff options
Diffstat (limited to 'src')
25 files changed, 406 insertions, 151 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 79b0b43f..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\"]" @@ -354,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) @@ -397,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..a99fbefa 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' @@ -161,7 +161,7 @@ installed' params ps = robustly $ check (isInstallable ps) go 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) @@ -257,7 +257,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/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 |