From 341064ea8cfaeb04ec4129239edc096a314de036 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 15:03:56 -0400 Subject: more porting --- src/Propellor/Property/OS.hs | 43 +++++++++++++++++++++++++++---------------- 1 file changed, 27 insertions(+), 16 deletions(-) (limited to 'src/Propellor/Property/OS.hs') diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index e5da0921..42504453 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -64,7 +64,7 @@ import Control.Exception (throw) -- > & User.accountFor "joey" -- > & User.hasSomePassword "joey" -- > -- rest of system properties here -cleanInstallOnce :: Confirmation -> Property NoInfo +cleanInstallOnce :: Confirmation -> Property Linux cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ go `requires` confirmed "clean install confirmed" confirmation where @@ -83,12 +83,16 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ `requires` osbootstrapped - osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of - (Just d@(System (Debian _) _)) -> debootstrap d - (Just u@(System (Buntish _) _)) -> debootstrap u + osbootstrapped :: Property Linux + osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of + (Just d@(System (Debian _) _)) -> ensureProperty w $ + debootstrap d + (Just u@(System (Buntish _) _)) -> ensureProperty w $ + debootstrap u _ -> unsupportedOS - debootstrap targetos = ensureProperty $ + debootstrap :: System -> Property Linux + debootstrap targetos = -- Ignore the os setting, and install debootstrap from -- source, since we don't know what OS we're running in yet. Debootstrap.built' Debootstrap.sourceInstall @@ -100,6 +104,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ -- sync instead? -- This is the fun bit. + flipped :: Property Linux flipped = property (newOSDir ++ " moved into place") $ liftIO $ do -- First, unmount most mount points, lazily, so -- they don't interfere with moving things around. @@ -137,6 +142,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ return MadeChange + propellorbootstrapped :: Property UnixLike propellorbootstrapped = property "propellor re-debootstrapped in new os" $ return NoChange -- re-bootstrap propellor in /usr/local/propellor, @@ -145,6 +151,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ -- be present in /old-os's /usr/local/propellor) -- TODO + finalized :: Property UnixLike finalized = property "clean OS installed" $ do liftIO $ writeFile flagfile "" return MadeChange @@ -179,7 +186,7 @@ massRename = go [] data Confirmation = Confirmed HostName -confirmed :: Desc -> Confirmation -> Property NoInfo +confirmed :: Desc -> Confirmation -> Property UnixLike confirmed desc (Confirmed c) = property desc $ do hostname <- asks hostName if hostname /= c @@ -191,25 +198,26 @@ confirmed desc (Confirmed c) = property desc $ do -- | is configured to bring up the network -- interface that currently has a default route configured, using -- the same (static) IP address. -preserveNetwork :: Property NoInfo +preserveNetwork :: Property DebianLike preserveNetwork = go `requires` Network.cleanInterfacesFile where - go = property "preserve network configuration" $ do + go :: Property DebianLike + go = property' "preserve network configuration" $ \w -> do ls <- liftIO $ lines <$> readProcess "ip" ["route", "list", "scope", "global"] case words <$> headMaybe ls of Just ("default":"via":_:"dev":iface:_) -> - ensureProperty $ Network.static iface + ensureProperty w $ Network.static iface _ -> do warningMessage "did not find any default ipv4 route" return FailedChange -- | is copied from the old OS -preserveResolvConf :: Property NoInfo +preserveResolvConf :: Property Linux preserveResolvConf = check (fileExist oldloc) $ - property (newloc ++ " copied from old OS") $ do + property' (newloc ++ " copied from old OS") $ \w -> do ls <- liftIO $ lines <$> readFile oldloc - ensureProperty $ newloc `File.hasContent` ls + ensureProperty w $ newloc `File.hasContent` ls where newloc = "/etc/resolv.conf" oldloc = oldOSDir ++ newloc @@ -217,20 +225,23 @@ preserveResolvConf = check (fileExist oldloc) $ -- | has added to it any ssh keys that -- were authorized in the old OS. Any other contents of the file are -- retained. -preserveRootSshAuthorized :: Property NoInfo +preserveRootSshAuthorized :: Property UnixLike preserveRootSshAuthorized = check (fileExist oldloc) $ - property (newloc ++ " copied from old OS") $ do + property' desc $ \w -> do ks <- liftIO $ lines <$> readFile oldloc - ensureProperties (map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks) + ensureProperty w $ combineProperties desc $ + toProps $ map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks where + desc = newloc ++ " copied from old OS" newloc = "/root/.ssh/authorized_keys" oldloc = oldOSDir ++ newloc -- Removes the old OS's backup from -oldOSRemoved :: Confirmation -> Property NoInfo +oldOSRemoved :: Confirmation -> Property UnixLike oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $ go `requires` confirmed "old OS backup removal confirmed" confirmation where + go :: Property UnixLike go = property "old OS backup removed" $ do liftIO $ removeDirectoryRecursive oldOSDir return MadeChange -- cgit v1.2.3 From e4ac94860bcc4511370e878e14ef9d45b60aeb2a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 15:35:55 -0400 Subject: remove `os` property The new properties let the type checker know what the target OS is. --- config-freebsd.hs | 7 +++--- config-simple.hs | 2 +- debian/changelog | 2 ++ doc/haskell_newbie.mdwn | 4 ++-- src/Propellor/Info.hs | 51 ++++++++++++++++++++++++++++++++++------ src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/OS.hs | 2 +- 7 files changed, 54 insertions(+), 16 deletions(-) (limited to 'src/Propellor/Property/OS.hs') diff --git a/config-freebsd.hs b/config-freebsd.hs index b6334c31..07aeb391 100644 --- a/config-freebsd.hs +++ b/config-freebsd.hs @@ -28,7 +28,7 @@ hosts = -- An example freebsd host. freebsdbox :: Host freebsdbox = host "freebsdbox.example.com" - & os (System (FreeBSD (FBSDProduction FBSD102)) "amd64") + & osFreeBSD (FBSDProduction FBSD102) "amd64" & Pkg.update & Pkg.upgrade & Poudriere.poudriere poudriereZFS @@ -44,7 +44,7 @@ poudriereZFS = Poudriere.defaultConfig -- An example linux host. linuxbox :: Host linuxbox = host "linuxbox.example.com" - & os (System (Debian Unstable) "amd64") + & osDebian Unstable "amd64" & Apt.stdSourcesList & Apt.unattendedUpgrades & Apt.installed ["etckeeper"] @@ -59,9 +59,8 @@ linuxbox = host "linuxbox.example.com" -- A generic webserver in a Docker container. webserverContainer :: Docker.Container webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") - & os (System (Debian (Stable "jessie")) "amd64") + & osDebian (Stable "jessie") "amd64" & Apt.stdSourcesList & Docker.publish "80:80" & Docker.volume "/var/www:/var/www" & Apt.serviceInstalledRunning "apache2" - diff --git a/config-simple.hs b/config-simple.hs index da1580c6..277e2edd 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -25,7 +25,7 @@ hosts = -- An example host. mybox :: Host mybox = host "mybox.example.com" $ props - & os (System (Debian Unstable) "amd64") + & osDebian Unstable "amd64" & Apt.stdSourcesList & Apt.unattendedUpgrades & Apt.installed ["etckeeper"] diff --git a/debian/changelog b/debian/changelog index 562eccd7..df518753 100644 --- a/debian/changelog +++ b/debian/changelog @@ -10,6 +10,8 @@ propellor (3.0.0) UNRELEASED; urgency=medium lists of properties. (If you have such a list, use `toProps`.) - And similarly, Chroot and Docker need `props` to be used to combine together the properies used inside them. + - The `os` property is removed. Instead use `osDebian`, `osBuntish`, + or `osFreeBSD`. These tell the type checker the target OS of a host. - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to diff --git a/doc/haskell_newbie.mdwn b/doc/haskell_newbie.mdwn index a150b202..bd343cd6 100644 --- a/doc/haskell_newbie.mdwn +++ b/doc/haskell_newbie.mdwn @@ -48,12 +48,12 @@ Finally, you need to define the configuration for each host in the list: [[!format haskell """ mylaptop :: Host mylaptop = host "mylaptop.example.com" - & os (System (Debian Unstable) "amd64") + & osDebian Unstable "amd64" & Apt.stdSourcesList myserver :: Host myserver = host "server.example.com" - & os (System (Debian (Stable "jessie")) "amd64") + & osDebian (Stable "jessie") "amd64" & Apt.stdSourcesList & Apt.installed ["ssh"] """]] diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index 071bf4c2..725a02ad 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -1,6 +1,24 @@ {-# LANGUAGE PackageImports #-} -module Propellor.Info where +module Propellor.Info ( + osDebian, + osBuntish, + osFreeBSD, + pureInfoProperty, + pureInfoProperty', + askInfo, + getOS, + ipv4, + ipv6, + alias, + addDNS, + hostMap, + aliasMap, + findHost, + findHostNoAlias, + getAddresses, + hostAddresses, +) where import Propellor.Types import Propellor.Types.Info @@ -26,10 +44,32 @@ pureInfoProperty' desc i = addInfoProperty p i askInfo :: (IsInfo v) => Propellor v askInfo = asks (getInfo . hostInfo) --- | Specifies the operating system of a host. +-- | Specifies that a host's operating system is Debian, +-- and further indicates the suite and architecture. +-- +-- This provides info for other Properties, so they can act +-- conditionally on the details of the OS. -- --- This only provides info for other Properties, so they can act --- conditionally on the os. +-- It also lets the type checker know that all the properties of the +-- host must support Debian. +-- +-- > & osDebian (Stable "jessie") "amd64" +osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian) +osDebian suite arch = tightenTargets $ os (System (Debian suite) arch) + +-- | Specifies that a host's operating system is a well-known Debian +-- derivative founded by a space tourist. +-- +-- (The actual name of this distribution is not used in Propellor per +-- ) +osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish) +osBuntish release arch = tightenTargets $ os (System (Buntish release) arch) + +-- | Specifies that a host's operating system is FreeBSD +-- and further indicates the release and architecture. +osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD) +osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch) + os :: System -> Property (HasInfo + UnixLike) os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system) @@ -105,6 +145,3 @@ getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn) - -addHostInfo ::IsInfo v => Host -> v -> Host -addHostInfo h v = h { hostInfo = addInfo (hostInfo h) v } diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index bf6f2083..4480f98d 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -102,7 +102,7 @@ instance ChrootBootstrapper Debootstrapped where -- add the `os` property to specify the operating system to bootstrap. -- -- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" --- > & os (System (Debian Unstable) "amd64") +-- > & osDebian Unstable "amd64" -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index 42504453..72753248 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -46,7 +46,7 @@ import Control.Exception (throw) -- install succeeds, to bootstrap from the cleanly installed system to -- a fully working system. For example: -- --- > & os (System (Debian Unstable) "amd64") +-- > & osDebian Unstable "amd64" -- > & cleanInstallOnce (Confirmed "foo.example.com") -- > `onChange` propertyList "fixing up after clean install" -- > [ preserveNetwork -- cgit v1.2.3 From 5f41492d8afe6ac6ee3cc280c3e2f252bcc91817 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 04:46:21 -0400 Subject: propellor spin --- src/Propellor/Property.hs | 18 ++++++++---------- src/Propellor/Property/Apt.hs | 6 +++--- src/Propellor/Property/Debootstrap.hs | 19 +++++-------------- src/Propellor/Property/Grub.hs | 2 +- src/Propellor/Property/OS.hs | 2 +- src/Propellor/Property/Ssh.hs | 2 +- 6 files changed, 19 insertions(+), 30 deletions(-) (limited to 'src/Propellor/Property/OS.hs') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 7878912b..55c39ee2 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -28,6 +28,7 @@ module Propellor.Property ( , pickOS , withOS , unsupportedOS + , unsupportedOS' , makeChange , noChange , doNothing @@ -292,7 +293,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] then getSatisfy a else if matching o b then getSatisfy b - else unsupportedOS + else unsupportedOS' matching Nothing _ = False matching (Just o) p = Targeting (systemToTargetOS o) @@ -307,7 +308,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] -- > myproperty = withOS "foo installed" $ \w o -> case o of -- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ... -- > (Just (System (Debian suite) arch)) -> ensureProperty w ... --- > _ -> unsupportedOS +-- > _ -> unsupportedOS' -- -- Note that the operating system specifics may not be declared for all hosts, -- which is where Nothing comes in. @@ -324,21 +325,18 @@ withOS desc a = property desc $ a dummyoutermetatypes =<< getOS dummyoutermetatypes :: OuterMetaTypesWitness ('[]) dummyoutermetatypes = OuterMetaTypesWitness sing -class UnsupportedOS a where - unsupportedOS :: a +-- | A property that always fails with an unsupported OS error. +unsupportedOS :: Property UnixLike +unsupportedOS = property "unsupportedOS" unsupportedOS' -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS. -instance UnsupportedOS (Propellor a) where - unsupportedOS = go =<< getOS +unsupportedOS' :: Propellor Result +unsupportedOS' = go =<< getOS where go Nothing = error "Unknown host OS is not supported by this property." go (Just o) = error $ "This property is not implemented for " ++ show o --- | A property that always fails with an unsupported OS error. -instance UnsupportedOS (Property UnixLike) where - unsupportedOS = property "unsupportedOS" unsupportedOS - -- | Undoes the effect of a RevertableProperty. revert :: RevertableProperty setup undo -> RevertableProperty undo setup revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 2199d950..1a15f72c 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -84,7 +84,7 @@ stdSourcesList :: Property Debian stdSourcesList = withOS "standard sources.list" $ \w o -> case o of (Just (System (Debian suite) _)) -> ensureProperty w $ stdSourcesListFor suite - _ -> unsupportedOS + _ -> unsupportedOS' stdSourcesListFor :: DebianSuite -> Property Debian stdSourcesListFor suite = stdSourcesList' suite [] @@ -160,11 +160,11 @@ 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 - Nothing -> unsupportedOS + Nothing -> unsupportedOS' Just bs -> ensureProperty w $ runApt (["install", "-t", bs, "-y"] ++ ps) `changesFile` dpkgStatus - _ -> unsupportedOS + _ -> unsupportedOS' where desc = unwords ("apt installed backport":ps) diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index fd5f6c96..e0c56966 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -101,21 +101,12 @@ extractSuite (System (FreeBSD _) _) = Nothing installed :: RevertableProperty Linux Linux installed = install remove where - install = withOS "debootstrap installed" $ \w o -> - ifM (liftIO $ isJust <$> programPath) - ( return NoChange - , ensureProperty w (installon o) - ) - - installon (Just (System (Debian _) _)) = aptinstall - installon (Just (System (Buntish _) _)) = aptinstall - installon _ = sourceInstall + install = check (isJust <$> programPath) $ + (aptinstall `pickOS` sourceInstall) + `describe` "debootstrap installed" - remove = withOS "debootstrap removed" $ \w o -> - ensureProperty w (removefrom o) - removefrom (Just (System (Debian _) _)) = aptremove - removefrom (Just (System (Buntish _) _)) = aptremove - removefrom _ = sourceRemove + remove = (aptremove `pickOS` sourceRemove) + `describe` "debootstrap removed" aptinstall = Apt.installed ["debootstrap"] aptremove = Apt.removed ["debootstrap"] diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 85d098ed..a03fc5a0 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -30,7 +30,7 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" [] -- | Installs grub; does not run update-grub. installed' :: BIOS -> Property Linux -installed' bios = (aptinstall `pickOS` aptinstall) +installed' bios = (aptinstall `pickOS` unsupportedOS) `describe` "grub package installed" where aptinstall :: Property DebianLike diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index 72753248..7d0a10ca 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -89,7 +89,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ debootstrap d (Just u@(System (Buntish _) _)) -> ensureProperty w $ debootstrap u - _ -> unsupportedOS + _ -> unsupportedOS' debootstrap :: System -> Property Linux debootstrap targetos = diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 7048de3b..369999b7 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -53,7 +53,7 @@ installed = withOS "ssh installed" $ \w o -> in case o of (Just (System (Debian _) _)) -> aptinstall (Just (System (Buntish _) _)) -> aptinstall - _ -> unsupportedOS + _ -> unsupportedOS' restarted :: Property DebianLike restarted = Service.restarted "ssh" -- cgit v1.2.3 From 1bd062c5336db6aff3b6128f7821f8ebed6b6ca0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 04:56:42 -0400 Subject: one more --- src/Propellor/Property/DiskImage.hs | 9 +++------ src/Propellor/Property/OS.hs | 4 ++-- 2 files changed, 5 insertions(+), 8 deletions(-) (limited to 'src/Propellor/Property/OS.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 8c027b05..718768c2 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -118,12 +118,9 @@ imageBuilt' rebuild img mkchroot tabletype final partspec = -- disk image. It cleans any caches of information that can be omitted; -- eg the apt cache on Debian. cachesCleaned :: Property UnixLike -cachesCleaned = withOS "cache cleaned" $ \w o -> - let aptclean = ensureProperty w Apt.cacheCleaned - in case o of - (Just (System (Debian _) _)) -> aptclean - (Just (System (Buntish _) _)) -> aptclean - _ -> noChange +cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit) + where + skipit = doNothing :: Property UnixLike -- | Builds a disk image from the contents of a chroot. imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index 7d0a10ca..5a3ccc70 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -93,8 +93,8 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ debootstrap :: System -> Property Linux debootstrap targetos = - -- Ignore the os setting, and install debootstrap from - -- source, since we don't know what OS we're running in yet. + -- 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.. -- cgit v1.2.3