From ce8d34d094be30e1432ecaaae81b188671180624 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 18:39:50 -0400 Subject: ported more Ssh is WIP and failing to compile quite badly --- src/Propellor/Property/Ssh.hs | 167 +++++++++++++++++++++--------------------- 1 file changed, 85 insertions(+), 82 deletions(-) (limited to 'src/Propellor/Property/Ssh.hs') diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 26cdbeb7..12c06919 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-} module Propellor.Property.Ssh ( installed, @@ -47,10 +47,10 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.List -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["ssh"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "ssh" sshBool :: Bool -> String @@ -62,10 +62,10 @@ sshdConfig = "/etc/ssh/sshd_config" type ConfigKeyword = String -setSshdConfigBool :: ConfigKeyword -> Bool -> Property NoInfo +setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed) -setSshdConfig :: ConfigKeyword -> String -> Property NoInfo +setSshdConfig :: ConfigKeyword -> String -> Property DebianLike setSshdConfig setting val = File.fileProperty desc f sshdConfig `onChange` restarted where @@ -84,19 +84,19 @@ data RootLogin | WithoutPassword -- ^ disable password authentication for root, while allowing other authentication methods | ForcedCommandsOnly -- ^ allow root login with public-key authentication, but only if a forced command has been specified for the public key -permitRootLogin :: RootLogin -> Property NoInfo +permitRootLogin :: RootLogin -> Property DebianLike permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password" permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only" -passwordAuthentication :: Bool -> Property NoInfo +passwordAuthentication :: Bool -> Property DebianLike passwordAuthentication = setSshdConfigBool "PasswordAuthentication" -- | Configure ssh to not allow password logins. -- -- To prevent lock-out, this is done only once root's -- authorized_keys is in place. -noPasswords :: Property NoInfo +noPasswords :: Property DebianLike noPasswords = check (hasAuthorizedKeys (User "root")) $ passwordAuthentication False @@ -114,7 +114,7 @@ dotFile f user = do -- ports it is configured to listen on. -- -- Revert to prevent it listening on a particular port. -listenPort :: Port -> RevertableProperty NoInfo +listenPort :: Port -> RevertableProperty DebianLike DebianLike listenPort port = enable disable where portline = "Port " ++ fromPort port @@ -133,16 +133,17 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys" -- | Blows away existing host keys and make new ones. -- Useful for systems installed from an image that might reuse host keys. -- A flag file is used to only ever do this once. -randomHostKeys :: Property NoInfo +randomHostKeys :: Property DebianLike randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restarted where - prop = property "ssh random host keys" $ do + prop :: Property UnixLike + prop = property' "ssh random host keys" $ \w -> do void $ liftIO $ boolSystem "sh" [ Param "-c" , Param "rm -f /etc/ssh/ssh_host_*" ] - ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] + ensureProperty w $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] `assume` MadeChange -- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI" @@ -153,8 +154,8 @@ type PubKeyText = String -- The corresponding private keys come from the privdata. -- -- Any host keys that are not in the list are removed from the host. -hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo -hostKeys ctx l = propertyList desc $ catMaybes $ +hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike) +hostKeys ctx l = propertyList desc $ toProps $ catMaybes $ map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup] where desc = "ssh host keys configured " ++ typelist (map fst l) @@ -162,34 +163,36 @@ hostKeys ctx l = propertyList desc $ catMaybes $ alltypes = [minBound..maxBound] staletypes = let have = map fst l in filter (`notElem` have) alltypes removestale b = map (File.notPresent . flip keyFile b) staletypes + cleanup :: Maybe (Property DebianLike) cleanup | null staletypes || null l = Nothing - | otherwise = Just $ toProp $ - property ("any other ssh host keys removed " ++ typelist staletypes) $ - ensureProperty $ - combineProperties desc (removestale True ++ removestale False) - `onChange` restarted + | otherwise = Just $ + combineProperties ("any other ssh host keys removed " ++ typelist staletypes) + (toProps $ removestale True ++ removestale False) + `onChange` restarted -- | Installs a single ssh host key of a particular type. -- -- The public key is provided to this function; -- the private key comes from the privdata; -hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo -hostKey context keytype pub = combineProperties desc - [ hostPubKey keytype pub - , toProp $ property desc $ install File.hasContent True (lines pub) - , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> - property desc $ getkey $ - install File.hasContentProtected False . privDataLines - ] - `onChange` restarted +hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike) +hostKey context keytype pub = combineProperties desc (props + & hostPubKey keytype pub + & installpub + & installpriv + ) `onChange` restarted where desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")" - install writer ispub keylines = do + install w writer ispub keylines = do let f = keyFile keytype ispub - ensureProperty $ writer f (keyFileContent keylines) + ensureProperty w $ writer f (keyFileContent keylines) keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext) ("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey") + installpub = property' desc $ \w -> install w File.hasContent True (lines pub) + installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> + property' desc $ \w -> getkey $ + install w File.hasContentProtected False . privDataLines + -- Make sure that there is a newline at the end; -- ssh requires this for some types of private keys. @@ -204,7 +207,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ -- | Indicates the host key that is used by a Host, but does not actually -- configure the host to use it. Normally this does not need to be used; -- use 'hostKey' instead. -hostPubKey :: SshKeyType -> PubKeyText -> Property HasInfo +hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike) hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText) @@ -224,7 +227,7 @@ instance Monoid HostKeyInfo where -- parameter when there is a duplicate key HostKeyInfo (new `M.union` old) -userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property HasInfo +userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $ UserKeyInfo (M.singleton u (S.fromList l)) @@ -248,8 +251,8 @@ instance Monoid UserKeyInfo where -- -- The public keys are added to the Info, so other properties like -- `authorizedKeysFrom` can use them. -userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property HasInfo -userKeys user@(User name) context ks = combineProperties desc $ +userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) +userKeys user@(User name) context ks = combineProperties desc $ toProps $ userPubKeys user ks : map (userKeyAt Nothing user context) ks where desc = unwords @@ -264,7 +267,7 @@ userKeys user@(User name) context ks = combineProperties desc $ -- A file can be specified to write the key to somewhere other than -- the default locations. Allows a user to have multiple keys for -- different roles. -userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property HasInfo +userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property (HasInfo + UnixLike) userKeyAt dest user@(User u) context (keytype, pubkeytext) = combineProperties desc $ props & pubkey @@ -276,17 +279,16 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) = , dest , Just $ "(" ++ fromKeyType keytype ++ ")" ] - pubkey = property desc $ install File.hasContent ".pub" [pubkeytext] + pubkey = property' desc $ \w -> install w File.hasContent ".pub" [pubkeytext] privkey = withPrivData (SshPrivKey keytype u) context $ \getkey -> - property desc $ getkey $ - install File.hasContentProtected "" . privDataLines - install writer ext key = do + property' desc $ \w -> getkey $ + install w File.hasContentProtected "" . privDataLines + install w writer ext key = do f <- liftIO $ keyfile ext - ensureProperty $ combineProperties desc - [ writer f (keyFileContent key) - , File.ownerGroup f user (userGroup user) - , File.ownerGroup (takeDirectory f) user (userGroup user) - ] + ensureProperty w $ combineProperties desc $ props + & writer f (keyFileContent key) + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) keyfile ext = case dest of Nothing -> do home <- homeDirectory <$> getUserEntryForName u @@ -301,33 +303,34 @@ fromKeyType SshEd25519 = "ed25519" -- | Puts some host's ssh public key(s), as set using `hostPubKey` -- or `hostKey` into the known_hosts file for a user. -knownHost :: [Host] -> HostName -> User -> Property NoInfo -knownHost hosts hn user@(User u) = property desc $ - go =<< knownHostLines hosts hn +knownHost :: [Host] -> HostName -> User -> Property UnixLike +knownHost hosts hn user@(User u) = property' desc $ \w -> + go w =<< knownHostLines hosts hn where desc = u ++ " knows ssh key for " ++ hn - go [] = do + go _ [] = do warningMessage $ "no configured ssh host keys for " ++ hn return FailedChange - go ls = do + go w ls = do f <- liftIO $ dotFile "known_hosts" user - modKnownHost user f $ + ensureProperty w $ modKnownHost user f $ f `File.containsLines` ls `requires` File.dirExists (takeDirectory f) -- | Reverts `knownHost` -unknownHost :: [Host] -> HostName -> User -> Property NoInfo -unknownHost hosts hn user@(User u) = property desc $ - go =<< knownHostLines hosts hn +unknownHost :: [Host] -> HostName -> User -> Property UnixLike +unknownHost hosts hn user@(User u) = property' desc $ \w -> + go w =<< knownHostLines hosts hn where desc = u ++ " does not know ssh key for " ++ hn - go [] = return NoChange - go ls = do + go w [] = return NoChange + go w ls = do f <- liftIO $ dotFile "known_hosts" user ifM (liftIO $ doesFileExist f) - ( modKnownHost user f $ f `File.lacksLines` ls + ( ensureProperty w $ modKnownHost user f $ + f `File.lacksLines` ls , return NoChange ) @@ -337,8 +340,8 @@ knownHostLines hosts hn = keylines <$> fromHost hosts hn getHostPubKey keylines (Just m) = map (\k -> hn ++ " " ++ k) (M.elems m) keylines Nothing = [] -modKnownHost :: User -> FilePath -> Property NoInfo -> Propellor Result -modKnownHost user f p = ensureProperty $ p +modKnownHost :: User -> FilePath -> Property UnixLike -> Property UnixLike +modKnownHost user f p = p `requires` File.ownerGroup f user (userGroup user) `requires` File.ownerGroup (takeDirectory f) user (userGroup user) @@ -348,30 +351,30 @@ modKnownHost user f p = ensureProperty $ p -- The ssh keys of the remote user can be set using `keysImported` -- -- Any other lines in the authorized_keys file are preserved as-is. -authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo +authorizedKeysFrom :: User -> (User, Host) -> Property UnixLike localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) = - property desc (go =<< authorizedKeyLines remoteuser remotehost) + property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost) where remote = rn ++ "@" ++ hostName remotehost desc = ln ++ " authorized_keys from " ++ remote - go [] = do + go _ [] = do warningMessage $ "no configured ssh user keys for " ++ remote return FailedChange - go ls = ensureProperty $ combineProperties desc $ - map (authorizedKey localuser) ls + go w ls = ensureProperty w $ combineProperties desc $ toProps $ + map (setupRevertableProperty . authorizedKey localuser) ls -- | Reverts `authorizedKeysFrom` -unauthorizedKeysFrom :: User -> (User, Host) -> Property NoInfo +unauthorizedKeysFrom :: User -> (User, Host) -> Property UnixLike localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) = - property desc (go =<< authorizedKeyLines remoteuser remotehost) + property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost) where remote = rn ++ "@" ++ hostName remotehost desc = ln ++ " unauthorized_keys from " ++ remote - go [] = return NoChange - go ls = ensureProperty $ combineProperties desc $ - map (revert . authorizedKey localuser) ls + go _ [] = return NoChange + go w ls = ensureProperty w $ combineProperties desc $ toProps $ + map (undoRevertableProperty . authorizedKey localuser) ls authorizedKeyLines :: User -> Host -> Propellor [File.Line] authorizedKeyLines remoteuser remotehost = @@ -380,37 +383,37 @@ authorizedKeyLines remoteuser remotehost = -- | Makes a user have authorized_keys from the PrivData -- -- This removes any other lines from the file. -authorizedKeys :: IsContext c => User -> c -> Property HasInfo +authorizedKeys :: IsContext c => User -> c -> Property (HasInfo + UnixLike) authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get -> - property desc $ get $ \v -> do + property' desc $ \w -> get $ \v -> do f <- liftIO $ dotFile "authorized_keys" user - ensureProperty $ combineProperties desc - [ File.hasContentProtected f (keyFileContent (privDataLines v)) - , File.ownerGroup f user (userGroup user) - , File.ownerGroup (takeDirectory f) user (userGroup user) - ] + ensureProperty w $ combineProperties desc $ props + & File.hasContentProtected f (keyFileContent (privDataLines v)) + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) where desc = u ++ " has authorized_keys" -- | Ensures that a user's authorized_keys contains a line. -- Any other lines in the file are preserved as-is. -authorizedKey :: User -> String -> RevertableProperty NoInfo +authorizedKey :: User -> String -> RevertableProperty UnixLike UnixLike authorizedKey user@(User u) l = add remove where - add = property (u ++ " has authorized_keys") $ do + add = property' (u ++ " has authorized_keys") $ \w -> do f <- liftIO $ dotFile "authorized_keys" user - modAuthorizedKey f user $ + ensureProperty w $ modAuthorizedKey f user $ f `File.containsLine` l `requires` File.dirExists (takeDirectory f) - remove = property (u ++ " lacks authorized_keys") $ do + remove = property' (u ++ " lacks authorized_keys") $ \w -> do f <- liftIO $ dotFile "authorized_keys" user ifM (liftIO $ doesFileExist f) - ( modAuthorizedKey f user $ f `File.lacksLine` l + ( ensureProperty w $ modAuthorizedKey f user $ + f `File.lacksLine` l , return NoChange ) -modAuthorizedKey :: FilePath -> User -> Property NoInfo -> Propellor Result -modAuthorizedKey f user p = ensureProperty $ p +modAuthorizedKey :: FilePath -> User -> Property UnixLike -> Property UnixLike +modAuthorizedKey f user p = p `before` File.mode f (combineModes [ownerWriteMode, ownerReadMode]) `before` File.ownerGroup f user (userGroup user) `before` File.ownerGroup (takeDirectory f) user (userGroup user) -- cgit v1.3-2-g0d8e From 2962f5c783db7a0f7014a8745768948c15d6a8ea Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 13:50:38 -0400 Subject: fixed type checking of Ssh --- debian/changelog | 12 +++++++++ src/Propellor/Property/Ssh.hs | 61 +++++++++++++++++++++++++------------------ 2 files changed, 48 insertions(+), 25 deletions(-) (limited to 'src/Propellor/Property/Ssh.hs') diff --git a/debian/changelog b/debian/changelog index b27559bd..1bbc1f0e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -25,6 +25,18 @@ propellor (3.0.0) UNRELEASED; urgency=medium "Property Debian" - It's also possible make a property support a set of OS's, for example: "Property (Debian + FreeBSD)" + - Removed `infoProperty` and `simpleProperty` constructors, instead use + `property` to construct a Property. + - Due to the polymorphic type returned by `property`, additional type + signatures tend to be needed when using it. For example, this will + fail to type check, because the type checker cannot guess what type + you intend the intermediate property "go" to have: + foo :: Property UnixLike + foo = go `requires` bar + where + go = property "foo" (return NoChange) + To fix, specify the type of go: + go :: Property UnixLike - `ensureProperty` now needs to be passed information about the property it's used in. change this: foo = property desc $ ... ensureProperty bar diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 12c06919..dc4b7a75 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -155,18 +155,21 @@ type PubKeyText = String -- -- Any host keys that are not in the list are removed from the host. hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike) -hostKeys ctx l = propertyList desc $ toProps $ catMaybes $ - map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup] +hostKeys ctx l = go `before` cleanup where desc = "ssh host keys configured " ++ typelist (map fst l) + go :: Property (HasInfo + DebianLike) + go = propertyList desc $ toProps $ catMaybes $ + map (\(t, pub) -> Just $ hostKey ctx t pub) l typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")" alltypes = [minBound..maxBound] staletypes = let have = map fst l in filter (`notElem` have) alltypes - removestale b = map (File.notPresent . flip keyFile b) staletypes - cleanup :: Maybe (Property DebianLike) + removestale :: Bool -> [Property DebianLike] + removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes + cleanup :: Property DebianLike cleanup - | null staletypes || null l = Nothing - | otherwise = Just $ + | null staletypes || null l = tightenTargets doNothing + | otherwise = combineProperties ("any other ssh host keys removed " ++ typelist staletypes) (toProps $ removestale True ++ removestale False) `onChange` restarted @@ -176,23 +179,26 @@ hostKeys ctx l = propertyList desc $ toProps $ catMaybes $ -- The public key is provided to this function; -- the private key comes from the privdata; hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike) -hostKey context keytype pub = combineProperties desc (props - & hostPubKey keytype pub - & installpub - & installpriv - ) `onChange` restarted +hostKey context keytype pub = go `onChange` restarted where + go = combineProperties desc $ props + & hostPubKey keytype pub + & installpub + & installpriv desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")" - install w writer ispub keylines = do - let f = keyFile keytype ispub - ensureProperty w $ writer f (keyFileContent keylines) keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext) ("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey") - installpub = property' desc $ \w -> install w File.hasContent True (lines pub) + installpub :: Property UnixLike + installpub = keywriter File.hasContent True (lines pub) + installpriv :: Property (HasInfo + UnixLike) installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> property' desc $ \w -> getkey $ - install w File.hasContentProtected False . privDataLines - + ensureProperty w + . keywriter File.hasContentProtected False + . privDataLines + keywriter p ispub keylines = do + let f = keyFile keytype ispub + p f (keyFileContent keylines) -- Make sure that there is a newline at the end; -- ssh requires this for some types of private keys. @@ -207,7 +213,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ -- | Indicates the host key that is used by a Host, but does not actually -- configure the host to use it. Normally this does not need to be used; -- use 'hostKey' instead. -hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike) +hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + UnixLike) hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText) @@ -279,13 +285,18 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) = , dest , Just $ "(" ++ fromKeyType keytype ++ ")" ] - pubkey = property' desc $ \w -> install w File.hasContent ".pub" [pubkeytext] - privkey = withPrivData (SshPrivKey keytype u) context $ \getkey -> - property' desc $ \w -> getkey $ - install w File.hasContentProtected "" . privDataLines - install w writer ext key = do + pubkey :: Property UnixLike + pubkey = property' desc $ \w -> + ensureProperty w =<< installprop File.hasContent ".pub" [pubkeytext] + privkey :: Property (HasInfo + UnixLike) + privkey = withPrivData (SshPrivKey keytype u) context privkey' + privkey' :: ((PrivData -> Propellor Result) -> Propellor Result) -> Property (HasInfo + UnixLike) + privkey' getkey = property' desc $ \w -> getkey $ \k -> + ensureProperty w + =<< installprop File.hasContentProtected "" (privDataLines k) + installprop writer ext key = do f <- liftIO $ keyfile ext - ensureProperty w $ combineProperties desc $ props + return $ combineProperties desc $ props & writer f (keyFileContent key) & File.ownerGroup f user (userGroup user) & File.ownerGroup (takeDirectory f) user (userGroup user) @@ -325,7 +336,7 @@ unknownHost hosts hn user@(User u) = property' desc $ \w -> where desc = u ++ " does not know ssh key for " ++ hn - go w [] = return NoChange + go _ [] = return NoChange go w ls = do f <- liftIO $ dotFile "known_hosts" user ifM (liftIO $ doesFileExist f) -- cgit v1.3-2-g0d8e From 46fc5467e633a9c1f149cb0cd7ee03af1e9e0aa1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 21:38:39 -0400 Subject: ported docker Also, implemented modifyHostProps to add properties to an existing host. Using it bypasses some type safety. Its use in docker is safe though. But, in Conductor, the use of it was not really safe, because it was used with a DebianLike property. Fixed that by making Ssh.installed target all unix's, although it will fail on non-DebianLike ones. --- config-simple.hs | 7 -- src/Propellor/Container.hs | 6 +- src/Propellor/PropAccum.hs | 18 ++++ src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/Conductor.hs | 21 ++-- src/Propellor/Property/DiskImage.hs | 16 +-- src/Propellor/Property/Docker.hs | 111 ++++++++++++--------- .../Property/HostingProvider/CloudAtCost.hs | 33 +++--- src/Propellor/Property/Hostname.hs | 21 ++-- src/Propellor/Property/Ssh.hs | 9 +- 10 files changed, 137 insertions(+), 107 deletions(-) (limited to 'src/Propellor/Property/Ssh.hs') diff --git a/config-simple.hs b/config-simple.hs index 277e2edd..42b3d838 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -4,14 +4,8 @@ import Propellor import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt -import qualified Propellor.Property.Network as Network ---import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Cron as Cron -import Propellor.Property.Scheduled ---import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User ---import qualified Propellor.Property.Hostname as Hostname ---import qualified Propellor.Property.Tor as Tor main :: IO () main = defaultMain hosts @@ -31,6 +25,5 @@ mybox = host "mybox.example.com" $ props & Apt.installed ["etckeeper"] & Apt.installed ["ssh"] & User.hasSomePassword (User "root") - & Network.ipv6to4 & File.dirExists "/var/www" & Cron.runPropellor (Cron.Times "30 * * * *") diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs index 6e974efd..832faf9c 100644 --- a/src/Propellor/Container.hs +++ b/src/Propellor/Container.hs @@ -7,11 +7,11 @@ import Propellor.Types.MetaTypes import Propellor.Types.Info import Propellor.PrivData -class Container c where +class IsContainer c where containerProperties :: c -> [ChildProperty] containerInfo :: c -> Info -instance Container Host where +instance IsContainer Host where containerProperties = hostProperties containerInfo = hostInfo @@ -28,7 +28,7 @@ propagateContainer -- Since the children being added probably have info, -- require the Property's metatypes to have info. ( IncludesInfo metatypes ~ 'True - , Container c + , IsContainer c ) => String -> c diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index af362ca7..1212ef7a 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -12,6 +12,8 @@ module Propellor.PropAccum , (&) , (&^) , (!) + , hostProps + , modifyHostProps ) where import Propellor.Types @@ -30,6 +32,16 @@ import Prelude host :: HostName -> Props metatypes -> Host host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) +-- | Note that the metatype of a Host's properties is not retained, +-- so this defaults to UnixLike. So, using this with modifyHostProps can +-- add properties to a Host that conflict with properties already in it. +-- Use caution when using this. +hostProps :: Host -> Props UnixLike +hostProps = Props . hostProperties + +modifyHostProps :: Host -> Props metatypes -> Host +modifyHostProps h ps = host (hostName h) ps + -- | Props is a combination of a list of properties, with their combined -- metatypes. data Props metatypes = Props [ChildProperty] @@ -81,3 +93,9 @@ Props c &^ p = Props (toChildProperty p : c) -> RevertableProperty (MetaTypes y) (MetaTypes z) -> Props (MetaTypes (Combine x z)) Props c ! p = Props (c ++ [toChildProperty (revert p)]) + +-- addPropsHost :: Host -> [Prop] -> Host +-- addPropsHost (Host hn ps i) p = Host hn ps' i' +-- where +-- ps' = ps ++ [toChildProperty p] +-- i' = i <> getInfoRecursive p diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index a0f3aca8..ddadc763 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -41,7 +41,7 @@ import System.Console.Concurrent data Chroot where Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot -instance Container Chroot where +instance IsContainer Chroot where containerProperties (Chroot _ _ h) = containerProperties h containerInfo (Chroot _ _ h) = containerInfo h diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index 8fe607bc..005fc804 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -83,7 +83,7 @@ import qualified Data.Set as S -- | Class of things that can be conducted. class Conductable c where - conducts :: c -> RevertableProperty (HasInfo + DebianLike) (HasInfo + UnixLike) + conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike) instance Conductable Host where -- | Conduct the specified host. @@ -219,8 +219,8 @@ orchestrate hs = map go hs os = extractOrchestras hs removeold h = foldl removeold' h (oldconductorsof h) - removeold' h oldconductor = addPropHost h $ - undoRevertableProperty $ conductedBy oldconductor + removeold' h oldconductor = modifyHostProps h $ hostProps h + ! conductedBy oldconductor oldconductors = zip hs (map (fromInfo . hostInfo) hs) oldconductorsof h = flip mapMaybe oldconductors $ @@ -233,22 +233,17 @@ orchestrate' :: Host -> Orchestra -> Host orchestrate' h (Conducted _) = h orchestrate' h (Conductor c l) | sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l) - | any (sameHost h) (map topHost l) = cont $ addPropHost h $ - setupRevertableProperty $ conductedBy c + | any (sameHost h) (map topHost l) = cont $ + modifyHostProps h $ hostProps h + & conductedBy c | otherwise = cont h where cont h' = foldl orchestrate' h' l -addPropHost :: Host -> Property i -> Host -addPropHost (Host hn ps i) p = Host hn ps' i' - where - ps' = ps ++ [toChildProperty p] - i' = i <> getInfoRecursive p - -- The host this property is added to becomes the conductor for the -- specified Host. Note that `orchestrate` must be used for this property -- to have any effect. -conductorFor :: Host -> Property (HasInfo + DebianLike) +conductorFor :: Host -> Property (HasInfo + UnixLike) conductorFor h = go `addInfoProperty` (toInfo (ConductorFor [h])) `requires` setupRevertableProperty (conductorKnownHost h) @@ -302,7 +297,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h') -- Use this property to let the specified conductor ssh in and run propellor. -conductedBy :: Host -> RevertableProperty DebianLike UnixLike +conductedBy :: Host -> RevertableProperty UnixLike UnixLike conductedBy h = (setup teardown) `describe` ("conducted by " ++ hostName h) where diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 6200f856..48df7fab 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -76,16 +76,16 @@ type DiskImage = FilePath -- chroot while the disk image is being built, which should prevent any -- daemons that are included from being started on the system that is -- building the disk image. -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux imageBuilt = imageBuilt' False -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed. -imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux imageBuilt' rebuild img mkchroot tabletype final partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot @@ -109,7 +109,7 @@ imageBuilt' rebuild img mkchroot tabletype final partspec = & Apt.cacheCleaned -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg where desc = img ++ " built from " ++ chrootdir @@ -135,7 +135,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg imageFinalized final mnts mntopts devs parttable rmimg = File.notPresent img -partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo +partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs where desc = "partitions populated from " ++ chrootdir @@ -203,7 +203,7 @@ getMountSz szm l (Just mntpt) = -- 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. -imageExists :: FilePath -> ByteSize -> Property NoInfo +imageExists :: FilePath -> ByteSize -> Property Linux imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do ms <- catchMaybeIO $ getFileStatus img case ms of @@ -226,9 +226,9 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do -- -- It's ok if the second property leaves additional things mounted -- in the partition tree. -type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo)) +type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) -imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo +imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = property "disk image finalized" $ withTmpDir "mnt" $ \top -> diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index fe1e3b18..041e1987 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} -- | Docker support for propellor -- @@ -50,6 +50,7 @@ import Propellor.Types.Docker import Propellor.Types.Container import Propellor.Types.CmdLine import Propellor.Types.Info +import Propellor.Container import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cmd as Cmd @@ -71,11 +72,12 @@ installed = Apt.installed ["docker.io"] -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional. -configured :: Property DebianLike +configured :: Property (HasInfo + DebianLike) configured = prop `requires` installed where + prop :: Property (HasInfo + DebianLike) prop = withPrivData src anyContext $ \getcfg -> - property "docker configured" $ getcfg $ \cfg -> ensureProperty $ + property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $ "/root/.dockercfg" `File.hasContent` privDataLines cfg src = PrivDataSourceFileFromCommand DockerAuthentication "/root/.dockercfg" "docker login" @@ -88,6 +90,10 @@ type ContainerName = String -- | A docker container. data Container = Container Image Host +instance IsContainer Container where + containerProperties (Container _ h) = containerProperties h + containerInfo (Container _ h) = containerInfo h + class HasImage a where getImageName :: a -> Image @@ -104,7 +110,7 @@ instance HasImage Container where -- > & publish "80:80" -- > & Apt.installed {"apache2"] -- > & ... -container :: ContainerName -> Image -> Props -> Container +container :: ContainerName -> Image -> Props metatypes -> Container container cn image (Props ps) = Container image (Host cn ps info) where info = dockerInfo mempty <> mconcat (map getInfoRecursive ps) @@ -119,7 +125,7 @@ container cn image (Props ps) = Container image (Host cn ps info) -- -- Reverting this property ensures that the container is stopped and -- removed. -docked :: Container -> RevertableProperty HasInfo +docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) docked ctr@(Container _ h) = (propagateContainerInfo ctr (go "docked" setup)) @@ -127,11 +133,12 @@ docked ctr@(Container _ h) = where cn = hostName h - go desc a = property (desc ++ " " ++ cn) $ do + go desc a = property' (desc ++ " " ++ cn) $ \w -> do hn <- asks hostName let cid = ContainerId hn cn - ensureChildProperties [a cid (mkContainerInfo cid ctr)] + ensureProperty w $ a cid (mkContainerInfo cid ctr) + setup :: ContainerId -> ContainerInfo -> Property Linux setup cid (ContainerInfo image runparams) = provisionContainer cid `requires` @@ -139,8 +146,9 @@ docked ctr@(Container _ h) = `requires` installed + teardown :: ContainerId -> ContainerInfo -> Property Linux teardown cid (ContainerInfo image _runparams) = - combineProperties ("undocked " ++ fromContainerId cid) + combineProperties ("undocked " ++ fromContainerId cid) $ toProps [ stoppedContainer cid , property ("cleaned up " ++ fromContainerId cid) $ liftIO $ report <$> mapM id @@ -151,31 +159,31 @@ docked ctr@(Container _ h) = -- | Build the image from a directory containing a Dockerfile. imageBuilt :: HasImage c => FilePath -> c -> Property Linux -imageBuilt directory ctr = describe built msg +imageBuilt directory ctr = built `describe` msg where msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory - built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir - `assume` MadeChange + built :: Property Linux + built = tightenTargets $ + Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir + `assume` MadeChange workDir p = p { cwd = Just directory } image = getImageName ctr -- | Pull the image from the standard Docker Hub registry. imagePulled :: HasImage c => c -> Property Linux -imagePulled ctr = describe pulled msg +imagePulled ctr = pulled `describe` msg where msg = "docker image " ++ (imageIdentifier image) ++ " pulled" - pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] - `assume` MadeChange + pulled :: Property Linux + pulled = tightenTargets $ + Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] + `assume` MadeChange image = getImageName ctr -propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property (HasInfo + Linux) -propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p' +propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) +propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ + p `addInfoProperty'` dockerinfo where - p' = infoProperty - (getDesc p) - (getSatisfy p) - (getInfo p <> dockerinfo) - (propertyChildren p) dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } cn = hostName h @@ -187,7 +195,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = runparams = map (\(DockerRunParam mkparam) -> mkparam hn) (_dockerRunParams info) info = fromInfo $ hostInfo h' - h' = h + h' = modifyHostProps h $ hostProps h -- Restart by default so container comes up on -- boot or when docker is upgraded. &^ restartAlways @@ -209,8 +217,10 @@ garbageCollected = propertyList "docker garbage collected" $ props & gccontainers & gcimages where + gccontainers :: Property Linux gccontainers = property "docker containers garbage collected" $ liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) + gcimages :: Property Linux gcimages = property "docker images garbage collected" $ liftIO $ report <$> (mapM removeImage =<< listImages) @@ -220,7 +230,7 @@ garbageCollected = propertyList "docker garbage collected" $ props -- the pam config, to work around -- which affects docker 1.2.0. tweaked :: Property Linux -tweaked = cmdProperty "sh" +tweaked = tightenTargets $ cmdProperty "sh" [ "-c" , "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*" ] @@ -234,9 +244,10 @@ tweaked = cmdProperty "sh" -- -- Only takes effect after reboot. (Not automated.) memoryLimited :: Property DebianLike -memoryLimited = "/etc/default/grub" `File.containsLine` cfg - `describe` "docker memory limited" - `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) +memoryLimited = tightenTargets $ + "/etc/default/grub" `File.containsLine` cfg + `describe` "docker memory limited" + `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) where cmdline = "cgroup_enable=memory swapaccount=1" cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\"" @@ -294,15 +305,15 @@ instance ImageIdentifier ImageUID where imageIdentifier (ImageUID uid) = uid -- | Set custom dns server for container. -dns :: String -> Property HasInfo +dns :: String -> Property (HasInfo + Linux) dns = runProp "dns" -- | Set container host name. -hostname :: String -> Property HasInfo +hostname :: String -> Property (HasInfo + Linux) hostname = runProp "hostname" -- | Set name of container. -name :: String -> Property HasInfo +name :: String -> Property (HasInfo + Linux) name = runProp "name" class Publishable p where @@ -316,15 +327,15 @@ instance Publishable String where toPublish = id -- | Publish a container's port to the host -publish :: Publishable p => p -> Property HasInfo +publish :: Publishable p => p -> Property (HasInfo + Linux) publish = runProp "publish" . toPublish -- | Expose a container's port without publishing it. -expose :: String -> Property HasInfo +expose :: String -> Property (HasInfo + Linux) expose = runProp "expose" -- | Username or UID for container. -user :: String -> Property HasInfo +user :: String -> Property (HasInfo + Linux) user = runProp "user" class Mountable p where @@ -340,17 +351,17 @@ instance Mountable String where toMount = id -- | Mount a volume -volume :: Mountable v => v -> Property HasInfo +volume :: Mountable v => v -> Property (HasInfo + Linux) volume = runProp "volume" . toMount -- | Mount a volume from the specified container into the current -- container. -volumes_from :: ContainerName -> Property HasInfo +volumes_from :: ContainerName -> Property (HasInfo + Linux) volumes_from cn = genProp "volumes-from" $ \hn -> fromContainerId (ContainerId hn cn) -- | Work dir inside the container. -workdir :: String -> Property HasInfo +workdir :: String -> Property (HasInfo + Linux) workdir = runProp "workdir" -- | Memory limit for container. @@ -358,18 +369,18 @@ workdir = runProp "workdir" -- -- Note: Only takes effect when the host has the memoryLimited property -- enabled. -memory :: String -> Property HasInfo +memory :: String -> Property (HasInfo + Linux) memory = runProp "memory" -- | CPU shares (relative weight). -- -- By default, all containers run at the same priority, but you can tell -- the kernel to give more CPU time to a container using this property. -cpuShares :: Int -> Property HasInfo +cpuShares :: Int -> Property (HasInfo + Linux) cpuShares = runProp "cpu-shares" . show -- | Link with another container on the same host. -link :: ContainerName -> ContainerAlias -> Property HasInfo +link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux) link linkwith calias = genProp "link" $ \hn -> fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias @@ -381,24 +392,24 @@ type ContainerAlias = String -- propellor; as well as keeping badly behaved containers running, -- it ensures that containers get started back up after reboot or -- after docker is upgraded. -restartAlways :: Property HasInfo +restartAlways :: Property (HasInfo + Linux) restartAlways = runProp "restart" "always" -- | Docker will restart the container if it exits nonzero. -- If a number is provided, it will be restarted only up to that many -- times. -restartOnFailure :: Maybe Int -> Property HasInfo +restartOnFailure :: Maybe Int -> Property (HasInfo + Linux) restartOnFailure Nothing = runProp "restart" "on-failure" restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n) -- | Makes docker not restart a container when it exits -- Note that this includes not restarting it on boot! -restartNever :: Property HasInfo +restartNever :: Property (HasInfo + Linux) restartNever = runProp "restart" "no" -- | Set environment variable with a tuple composed by the environment -- variable name and its value. -environment :: (String, String) -> Property HasInfo +environment :: (String, String) -> Property (HasInfo + Linux) environment (k, v) = runProp "env" $ k ++ "=" ++ v -- | A container is identified by its name, and the host @@ -501,6 +512,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope retry (n-1) a _ -> return v + go :: ImageIdentifier i => i -> Propellor Result go img = liftIO $ do clearProvisionedFlag cid createDirectoryIfMissing True (takeDirectory $ identFile cid) @@ -592,14 +604,15 @@ startContainer :: ContainerId -> IO Bool startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] stoppedContainer :: ContainerId -> Property Linux -stoppedContainer cid = containerDesc cid $ property' desc $ \o -> +stoppedContainer cid = containerDesc cid $ property' desc $ \w -> ifM (liftIO $ elem cid <$> listContainers RunningContainers) - ( liftIO cleanup `after` ensureProperty o - (property desc $ liftIO $ toResult <$> stopContainer cid) + ( liftIO cleanup `after` ensureProperty w stop , return NoChange ) where desc = "stopped" + stop :: Property Linux + stop = property desc $ liftIO $ toResult <$> stopContainer cid cleanup = do nukeFile $ identFile cid removeDirectoryRecursive $ shimdir cid @@ -643,14 +656,14 @@ listContainers status = listImages :: IO [ImageUID] listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> Property HasInfo -runProp field val = pureInfoProperty (param) $ +runProp :: String -> RunParam -> Property (HasInfo + Linux) +runProp field val = tightenTargets $ pureInfoProperty (param) $ mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } where param = field++"="++val -genProp :: String -> (HostName -> RunParam) -> Property HasInfo -genProp field mkval = pureInfoProperty field $ +genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux) +genProp field mkval = tightenTargets $ pureInfoProperty field $ mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] } dockerInfo :: DockerInfo -> Info diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs index bfe3ae17..5c4788e2 100644 --- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -6,19 +6,24 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.User as User -- Clean up a system as installed by cloudatcost.com -decruft :: Property NoInfo -decruft = propertyList "cloudatcost cleanup" - [ Hostname.sane - , "worked around grub/lvm boot bug #743126" ==> +decruft :: Property DebianLike +decruft = propertyList "cloudatcost cleanup" $ props + & Hostname.sane + & grubbugfix + & nukecruft + where + grubbugfix :: Property DebianLike + grubbugfix = tightenTargets $ "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" - `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) - `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange) - , combineProperties "nuked cloudatcost cruft" - [ File.notPresent "/etc/rc.local" - , File.notPresent "/etc/init.d/S97-setup.sh" - , File.notPresent "/zang-debian.sh" - , File.notPresent "/bin/npasswd" - , User.nuked (User "user") User.YesReallyDeleteHome - ] - ] + `describe` "worked around grub/lvm boot bug #743126" + `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) + `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange) + nukecruft :: Property Linux + nukecruft = tightenTargets $ + combineProperties "nuked cloudatcost cruft" $ props + & File.notPresent "/etc/rc.local" + & File.notPresent "/etc/init.d/S97-setup.sh" + & File.notPresent "/zang-debian.sh" + & File.notPresent "/bin/npasswd" + & User.nuked (User "user") User.YesReallyDeleteHome diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs index 7ab350ae..e1342d91 100644 --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -22,20 +22,20 @@ import Data.List.Utils -- Also, the 127.0.0.1 line is set to localhost. Putting any -- other hostnames there is not best practices and can lead to annoying -- messages from eg, apache. -sane :: Property NoInfo +sane :: Property UnixLike sane = sane' extractDomain -sane' :: ExtractDomain -> Property NoInfo -sane' extractdomain = property ("sane hostname") $ - ensureProperty . setTo' extractdomain =<< asks hostName +sane' :: ExtractDomain -> Property UnixLike +sane' extractdomain = property' ("sane hostname") $ \w -> + ensureProperty w . setTo' extractdomain =<< asks hostName -- Like `sane`, but you can specify the hostname to use, instead -- of the default hostname of the `Host`. -setTo :: HostName -> Property NoInfo +setTo :: HostName -> Property UnixLike setTo = setTo' extractDomain -setTo' :: ExtractDomain -> HostName -> Property NoInfo -setTo' extractdomain hn = combineProperties desc +setTo' :: ExtractDomain -> HostName -> Property UnixLike +setTo' extractdomain hn = combineProperties desc $ toProps [ "/etc/hostname" `File.hasContent` [basehost] , hostslines $ catMaybes [ if null domain @@ -65,11 +65,12 @@ setTo' extractdomain hn = combineProperties desc -- | Makes contain search and domain lines for -- the domain that the hostname is in. -searchDomain :: Property NoInfo +searchDomain :: Property UnixLike searchDomain = searchDomain' extractDomain -searchDomain' :: ExtractDomain -> Property NoInfo -searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName) +searchDomain' :: ExtractDomain -> Property UnixLike +searchDomain' extractdomain = property' desc $ \w -> + (ensureProperty w . go =<< asks hostName) where desc = "resolv.conf search and domain configured" go hn = diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index dc4b7a75..05409593 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -47,8 +47,13 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.List -installed :: Property DebianLike -installed = Apt.installed ["ssh"] +installed :: Property UnixLike +installed = withOS "ssh installed" $ \w o -> + let aptinstall = ensureProperty w $ Apt.installed ["ssh"] + in case o of + (Just (System (Debian _) _)) -> aptinstall + (Just (System (Buntish _) _)) -> aptinstall + _ -> unsupportedOS restarted :: Property DebianLike restarted = Service.restarted "ssh" -- cgit v1.3-2-g0d8e From 0b0ea182ab3301ade8b87b1be1cdecc3464cd1da Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 16:10:43 -0400 Subject: ported DiskImage Unfortunately, DiskImage needs to add properties to the Chroot it's presented with, and the metatypes are not included in the Chroot, so it can't guarantee that the properties it's adding match the OS in the Chroot. I partially worked around this by making the properties that DiskImage adds check the OS, so they don't assume Debian. It would be nicer to parameterize the Chroot type with the metatypes of the inner OS. I worked for several hours on a patch along those lines, but it doesn't quite compile. Failed at the final hurdle :/ The patch is below for later.. --- src/Propellor/Property/Chroot.hs 2016-03-27 16:06:44.285464820 -0400 +++ /home/joey/Chroot.hs 2016-03-27 15:32:29.073416143 -0400 @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DataKinds #-} module Propellor.Property.Chroot ( debootstrapped, bootstrapped, - provisioned, + --provisioned, Chroot(..), ChrootBootstrapper(..), Debootstrapped(..), @@ -11,7 +11,7 @@ noServices, inChroot, -- * Internal use - provisioned', + --provisioned', propagateChrootInfo, propellChroot, chain, @@ -20,6 +20,7 @@ import Propellor.Base import Propellor.Container +import Propellor.Types.MetaTypes import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info @@ -38,27 +39,29 @@ -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. -data Chroot where - Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot - -instance IsContainer Chroot where - containerProperties (Chroot _ _ h) = containerProperties h - containerInfo (Chroot _ _ h) = containerInfo h - setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) +-- +-- The inner and outer type variables are the metatypes of the inside of +-- the chroot and the system it runs in. +data Chroot inner outer where + Chroot :: ChrootBootstrapper b inner outer => FilePath -> b -> Host -> (inner, outer) -> Chroot inner outer + +instance IsContainer (Chroot inner outer) where + containerProperties (Chroot _ _ h _) = containerProperties h + containerInfo (Chroot _ _ h _) = containerInfo h -chrootSystem :: Chroot -> Maybe System +chrootSystem :: Chroot inner outer -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo -instance Show Chroot where - show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) +instance Show (Chroot inner outer) where + show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. -class ChrootBootstrapper b where +class ChrootBootstrapper b inner outer where -- | Do initial bootstrapping of an operating system in a chroot. -- If the operating System is not supported, return -- Left error message. - buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux) + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property outer) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -68,9 +71,8 @@ -- detect automatically. data ChrootTarball = ChrootTarball FilePath -instance ChrootBootstrapper ChrootTarball where - buildchroot (ChrootTarball tb) _ loc = Right $ - tightenTargets $ extractTarball loc tb +instance ChrootBootstrapper ChrootTarball UnixLike UnixLike where + buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb extractTarball :: FilePath -> FilePath -> Property UnixLike extractTarball target src = check (unpopulated target) $ @@ -88,7 +90,7 @@ -- | Use this to bootstrap a chroot with debootstrap. data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig -instance ChrootBootstrapper Debootstrapped where +instance ChrootBootstrapper Debootstrapped DebianLike Linux where buildchroot (Debootstrapped cf) system loc = case system of (Just s@(System (Debian _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s @@ -107,13 +109,22 @@ -- > & osDebian Unstable "amd64" -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... -debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot +-- debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot DebianLike +debootstrapped + :: (SingI inner, SingI outer, ChrootBootstrapper Debootstrapped (MetaTypes inner) (MetaTypes outer)) + => Debootstrap.DebootstrapConfig + -> FilePath + -> Chroot (MetaTypes inner) (MetaTypes outer) debootstrapped conf = bootstrapped (Debootstrapped conf) -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper. -bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot -bootstrapped bootstrapper location = Chroot location bootstrapper h +bootstrapped + :: (SingI inner, SingI outer, ChrootBootstrapper b (MetaTypes inner) (MetaTypes outer)) + => b + -> FilePath + -> Chroot (MetaTypes inner) (MetaTypes outer) +bootstrapped bootstrapper location = Chroot location bootstrapper h (sing, sing) where h = Host location [] mempty @@ -123,45 +134,79 @@ -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. -provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux +-- provisioned :: SingI outer => Chroot inner outer -> RevertableProperty (HasInfo + MetaTypes outer) Linux +provisioned + :: + ( SingI outer + , SingI metatypes + , Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + , (HasInfo + outer) ~ MetaTypes metatypes + , CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer + , IncludesInfo (MetaTypes metatypes) ~ 'True) + => Chroot inner outer -> RevertableProperty (HasInfo + outer) Linux provisioned c = provisioned' (propagateChrootInfo c) c False provisioned' - :: (Property Linux -> Property (HasInfo + Linux)) - -> Chroot + :: + ( Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + , CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer + , SingI outer + ) + => (Property outer -> Property (HasInfo + outer)) + -> Chroot inner outer -> Bool - -> RevertableProperty (HasInfo + Linux) Linux -provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = - (propigator $ setup `describe` chrootDesc c "exists") + -> RevertableProperty (HasInfo + outer) Linux +provisioned' propigator c systemdonly = + (propigator $ setup c systemdonly `describe` chrootDesc c "exists") - (teardown `describe` chrootDesc c "removed") - where - setup :: Property Linux - setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly - `requires` built - - built = case buildchroot bootstrapper (chrootSystem c) loc of - Right p -> p - Left e -> cantbuild e - - cantbuild e = property (chrootDesc c "built") (error e) - - teardown :: Property Linux - teardown = check (not <$> unpopulated loc) $ - property ("removed " ++ loc) $ - makeChange (removeChroot loc) - -propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) -propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `addInfoProperty` chrootInfo c + (teardown c `describe` chrootDesc c "removed") -chrootInfo :: Chroot -> Info -chrootInfo (Chroot loc _ h) = mempty `addInfo` +-- chroot removal code is currently linux specific.. +teardown :: Chroot inner outer -> Property Linux +teardown (Chroot loc _ _ _) = check (not <$> unpopulated loc) $ + property ("removed " ++ loc) $ + makeChange (removeChroot loc) + +setup + :: + ( SingI outer + , Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + ) + => Chroot inner outer + -> Bool + -> CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) +setup c systemdonly = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly + `requires` built c + +built :: (SingI outer, ChrootBootstrapper b inner outer) => Chroot inner outer -> Property (MetaTypes outer) +built c@(Chroot loc bootstrapper _ _) = + case buildchroot bootstrapper (chrootSystem c) loc of + Right p -> error "FOO" -- p + Left e -> error "FOO" -- cantbuild c e + +cantbuild :: Chroot inner outer -> String -> Property UnixLike +cantbuild c e = property (chrootDesc c "built") (error e) + +propagateChrootInfo + :: + ( SingI metatypes + , (HasInfo + outer) ~ MetaTypes metatypes + , IncludesInfo (MetaTypes metatypes) ~ 'True + ) + => Chroot inner outer + -> Property outer + -> Property (MetaTypes metatypes) +propagateChrootInfo c@(Chroot location _ _ _) p = + propagateContainer location c $ + p `addInfoProperty` chrootInfo c + +chrootInfo :: Chroot inner outer -> Info +chrootInfo (Chroot loc _ h _) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. -propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike -propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do +propellChroot :: SingI outer => Chroot inner outer -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property (MetaTypes outer) +propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" shim <- liftIO $ ifM (doesDirectoryExist d) @@ -199,8 +244,8 @@ liftIO cleanup return r -toChain :: HostName -> Chroot -> Bool -> IO CmdLine -toChain parenthost (Chroot loc _ _) systemdonly = do +toChain :: HostName -> Chroot inner outer -> Bool -> IO CmdLine +toChain parenthost (Chroot loc _ _ _) systemdonly = do onconsole <- isConsole <$> getMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole @@ -224,8 +269,8 @@ putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" -inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) -inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do +inChrootProcess :: Bool -> Chroot inner outer -> [String] -> IO (CreateProcess, IO ()) +inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do mountproc return (proc "chroot" (loc:cmd), cleanup) where @@ -244,26 +289,24 @@ provisioningLock :: FilePath -> FilePath provisioningLock containerloc = "chroot" mungeloc containerloc ++ ".lock" -shimdir :: Chroot -> FilePath -shimdir (Chroot loc _ _) = "chroot" mungeloc loc ++ ".shim" +shimdir :: Chroot inner outer -> FilePath +shimdir (Chroot loc _ _ _) = "chroot" mungeloc loc ++ ".shim" mungeloc :: FilePath -> String mungeloc = replace "/" "_" -chrootDesc :: Chroot -> String -> String -chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc +chrootDesc :: Chroot inner outer -> String -> String +chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc --- src/Propellor/Container.hs | 18 ++++++++- src/Propellor/PropAccum.hs | 12 ------ src/Propellor/Property.hs | 2 +- src/Propellor/Property/Chroot.hs | 11 +++-- src/Propellor/Property/Conductor.hs | 7 ++-- src/Propellor/Property/DiskImage.hs | 81 ++++++++++++++++++++++--------------- src/Propellor/Property/Grub.hs | 11 +++-- src/Propellor/Property/Ssh.hs | 2 +- src/Propellor/Types/MetaTypes.hs | 2 +- 9 files changed, 87 insertions(+), 59 deletions(-) (limited to 'src/Propellor/Property/Ssh.hs') diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs index 832faf9c..4cd46ae5 100644 --- a/src/Propellor/Container.hs +++ b/src/Propellor/Container.hs @@ -6,14 +6,28 @@ import Propellor.Types import Propellor.Types.MetaTypes import Propellor.Types.Info import Propellor.PrivData +import Propellor.PropAccum class IsContainer c where containerProperties :: c -> [ChildProperty] containerInfo :: c -> Info + setContainerProperties :: c -> [ChildProperty] -> c instance IsContainer Host where - containerProperties = hostProperties - containerInfo = hostInfo + containerProperties = hostProperties + containerInfo = hostInfo + setContainerProperties h ps = host (hostName h) (Props ps) + +-- | Note that the metatype of a container's properties is not retained, +-- so this defaults to UnixLike. So, using this with setContainerProps can +-- add properties to a container that conflict with properties already in it. +-- Use caution when using this; only add properties that do not have +-- restricted targets. +containerProps :: IsContainer c => c -> Props UnixLike +containerProps = Props . containerProperties + +setContainerProps :: IsContainer c => c -> Props metatypes -> c +setContainerProps c (Props ps) = setContainerProperties c ps -- | Adjust the provided Property, adding to its -- propertyChidren the properties of the provided container. diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 1212ef7a..856f2e8e 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -12,8 +12,6 @@ module Propellor.PropAccum , (&) , (&^) , (!) - , hostProps - , modifyHostProps ) where import Propellor.Types @@ -32,16 +30,6 @@ import Prelude host :: HostName -> Props metatypes -> Host host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Note that the metatype of a Host's properties is not retained, --- so this defaults to UnixLike. So, using this with modifyHostProps can --- add properties to a Host that conflict with properties already in it. --- Use caution when using this. -hostProps :: Host -> Props UnixLike -hostProps = Props . hostProperties - -modifyHostProps :: Host -> Props metatypes -> Host -modifyHostProps h ps = host (hostName h) ps - -- | Props is a combination of a list of properties, with their combined -- metatypes. data Props metatypes = Props [ChildProperty] diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 9fa29888..70583edc 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -308,7 +308,7 @@ makeChange a = liftIO a >> return MadeChange noChange :: Propellor Result noChange = return NoChange -doNothing :: Property UnixLike +doNothing :: SingI t => Property (MetaTypes t) doNothing = property "noop property" noChange -- | Registers an action that should be run at the very end, after diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index ddadc763..b29da7f9 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -44,6 +44,7 @@ data Chroot where instance IsContainer Chroot where containerProperties (Chroot _ _ h) = containerProperties h containerInfo (Chroot _ _ h) = containerInfo h + setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) chrootSystem :: Chroot -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo @@ -256,11 +257,13 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc -- from being started, which is often something you want to prevent when -- building a chroot. -- --- This is accomplished by installing a script --- that does not let any daemons be started by packages that use +-- On Debian, this is accomplished by installing a +-- script that does not let any daemons be started by packages that use -- invoke-rc.d. Reverting the property removes the script. -noServices :: RevertableProperty DebianLike DebianLike -noServices = tightenTargets setup tightenTargets teardown +-- +-- This property has no effect on non-Debian systems. +noServices :: RevertableProperty UnixLike UnixLike +noServices = setup teardown where f = "/usr/sbin/policy-rc.d" script = [ "#!/bin/sh", "exit 101" ] diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index 005fc804..ab747acc 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -74,6 +74,7 @@ module Propellor.Property.Conductor ( ) where import Propellor.Base +import Propellor.Container import Propellor.Spin (spin') import Propellor.PrivData.Paths import Propellor.Types.Info @@ -219,7 +220,7 @@ orchestrate hs = map go hs os = extractOrchestras hs removeold h = foldl removeold' h (oldconductorsof h) - removeold' h oldconductor = modifyHostProps h $ hostProps h + removeold' h oldconductor = setContainerProps h $ containerProps h ! conductedBy oldconductor oldconductors = zip hs (map (fromInfo . hostInfo) hs) @@ -234,7 +235,7 @@ orchestrate' h (Conducted _) = h orchestrate' h (Conductor c l) | sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l) | any (sameHost h) (map topHost l) = cont $ - modifyHostProps h $ hostProps h + setContainerProps h $ containerProps h & conductedBy c | otherwise = cont h where @@ -268,7 +269,7 @@ conductorFor h = go -- Reverts conductorFor. notConductorFor :: Host -> Property (HasInfo + UnixLike) -notConductorFor h = doNothing +notConductorFor h = (doNothing :: Property UnixLike) `addInfoProperty` (toInfo (NotConductorFor [h])) `describe` desc `requires` undoRevertableProperty (conductorKnownHost h) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 48df7fab..8c027b05 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -2,6 +2,8 @@ -- -- This module is designed to be imported unqualified. +{-# LANGUAGE TypeFamilies #-} + module Propellor.Property.DiskImage ( -- * Partition specification module Propellor.Property.DiskImage.PartSpec, @@ -30,6 +32,7 @@ import Propellor.Property.Parted import Propellor.Property.Mount import Propellor.Property.Partition import Propellor.Property.Rsync +import Propellor.Container import Utility.Path import Data.List (isPrefixOf, isInfixOf, sortBy) @@ -51,7 +54,8 @@ type DiskImage = FilePath -- -- > import Propellor.Property.DiskImage -- --- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d +-- > let chroot d = Chroot.debootstrapped mempty d +-- > & osDebian Unstable "amd64" -- > & Apt.installed ["linux-image-amd64"] -- > & User.hasPassword (User "root") -- > & User.accountFor (User "demo") @@ -89,31 +93,44 @@ imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finaliz imageBuilt' rebuild img mkchroot tabletype final partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot - `requires` (cleanrebuild doNothing) + `requires` (cleanrebuild (doNothing :: Property UnixLike)) `describe` desc where desc = "built disk image " ++ img + cleanrebuild :: Property Linux cleanrebuild | rebuild = property desc $ do liftIO $ removeChroot chrootdir return MadeChange | otherwise = doNothing chrootdir = img ++ ".chroot" - chroot = mkchroot chrootdir - -- Before ensuring any other properties of the chroot, avoid - -- starting services. Reverted by imageFinalized. - &^ Chroot.noServices - -- First stage finalization. - & fst final - -- Avoid wasting disk image space on the apt cache - & Apt.cacheCleaned + chroot = + let c = mkchroot chrootdir + in setContainerProps c $ containerProps c + -- Before ensuring any other properties of the chroot, + -- avoid starting services. Reverted by imageFinalized. + &^ Chroot.noServices + -- First stage finalization. + & fst final + & cachesCleaned + +-- | This property is automatically added to the chroot when building a +-- 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 -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg where desc = img ++ " built from " ++ chrootdir - mkimg = property desc $ do + mkimg = property' desc $ \w -> do -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir @@ -123,7 +140,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg -- tie the knot! let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ map (calcsz mnts) mnts - ensureProperty $ + ensureProperty w $ imageExists img (partTableSize parttable) `before` partitioned YesReallyDeleteDiskContents img parttable @@ -136,16 +153,17 @@ 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 $ mconcat $ zipWith3 go mnts mntopts devs +partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> + mconcat $ zipWith3 (go w) mnts mntopts devs where desc = "partitions populated from " ++ chrootdir - go Nothing _ _ = noChange - go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket + go _ Nothing _ _ = noChange + go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) (const $ liftIO $ umountLazy tmpdir) $ \ismounted -> if ismounted - then ensureProperty $ + then ensureProperty w $ syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir else return FailedChange @@ -230,15 +248,15 @@ type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = - property "disk image finalized" $ + property' "disk image finalized" $ \w -> withTmpDir "mnt" $ \top -> - go top `finally` liftIO (unmountall top) + go w top `finally` liftIO (unmountall top) where - go top = do + go w top = do liftIO $ mountall top liftIO $ writefstab top liftIO $ allowservices top - ensureProperty $ final top devs + ensureProperty w $ final top devs -- Ordered lexographically by mount point, so / comes before /usr -- comes before /usr/local @@ -280,27 +298,26 @@ noFinalization = (doNothing, \_ _ -> doNothing) grubBooted :: Grub.BIOS -> Finalization grubBooted bios = (Grub.installed' bios, boots) where - boots mnt loopdevs = combineProperties "disk image boots using grub" + boots mnt loopdevs = combineProperties "disk image boots using grub" $ props -- bind mount host /dev so grub can access the loop devices - [ bindMount "/dev" (inmnt "/dev") - , mounted "proc" "proc" (inmnt "/proc") mempty - , mounted "sysfs" "sys" (inmnt "/sys") mempty + & bindMount "/dev" (inmnt "/dev") + & mounted "proc" "proc" (inmnt "/proc") mempty + & mounted "sysfs" "sys" (inmnt "/sys") mempty -- update the initramfs so it gets the uuid of the root partition - , inchroot "update-initramfs" ["-u"] + & inchroot "update-initramfs" ["-u"] `assume` MadeChange -- work around for http://bugs.debian.org/802717 - , check haveosprober $ inchroot "chmod" ["-x", osprober] - , inchroot "update-grub" [] + & check haveosprober (inchroot "chmod" ["-x", osprober]) + & inchroot "update-grub" [] `assume` MadeChange - , check haveosprober $ inchroot "chmod" ["+x", osprober] - , inchroot "grub-install" [wholediskloopdev] + & check haveosprober (inchroot "chmod" ["+x", osprober]) + & inchroot "grub-install" [wholediskloopdev] `assume` MadeChange -- sync all buffered changes out to the disk image -- may not be necessary, but seemed needed sometimes -- when using the disk image right away. - , cmdProperty "sync" [] + & cmdProperty "sync" [] `assume` NoChange - ] where -- cannot use since the filepath is absolute inmnt f = mnt ++ f diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 09255587..b8dc5f9e 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -29,10 +29,15 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" [] `assume` MadeChange -- | Installs grub; does not run update-grub. -installed' :: BIOS -> Property DebianLike -installed' bios = Apt.installed [pkg] `describe` "grub package installed" +installed' :: BIOS -> Property Linux +installed' bios = withOS "grub package installed" $ \w o -> + let apt = ensureProperty w (Apt.installed [debpkg]) + in case o of + (Just (System (Debian _) _)) -> apt + (Just (System (Buntish _) _)) -> apt + _ -> unsupportedOS where - pkg = case bios of + debpkg = case bios of PC -> "grub-pc" EFI64 -> "grub-efi-amd64" EFI32 -> "grub-efi-ia32" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 05409593..7048de3b 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -173,7 +173,7 @@ hostKeys ctx l = go `before` cleanup removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes cleanup :: Property DebianLike cleanup - | null staletypes || null l = tightenTargets doNothing + | null staletypes || null l = doNothing | otherwise = combineProperties ("any other ssh host keys removed " ++ typelist staletypes) (toProps $ removestale True ++ removestale False) diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs index ce2b1411..3e89e28d 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -36,7 +36,7 @@ type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targe -- | Any linux system type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] -- | Debian and derivatives. -type DebianLike = Debian + Buntish +type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] type Debian = MetaTypes '[ 'Targeting 'OSDebian ] type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ] type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ] -- cgit v1.3-2-g0d8e 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/Ssh.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.3-2-g0d8e From 434b3e8b325be7cd04c4130e80be19dc57f27d0f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 04:48:06 -0400 Subject: last withOS that can be converted to pickOS is converted --- src/Propellor/Property/Ssh.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'src/Propellor/Property/Ssh.hs') diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 369999b7..6e1690d2 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -48,12 +48,10 @@ import qualified Data.Set as S import Data.List installed :: Property UnixLike -installed = withOS "ssh installed" $ \w o -> - let aptinstall = ensureProperty w $ Apt.installed ["ssh"] - in case o of - (Just (System (Debian _) _)) -> aptinstall - (Just (System (Buntish _) _)) -> aptinstall - _ -> unsupportedOS' +installed = "ssh installed" ==> (aptinstall `pickOS` unsupportedOS) + where + aptinstall :: Property DebianLike + aptinstall = Apt.installed ["ssh"] restarted :: Property DebianLike restarted = Service.restarted "ssh" -- cgit v1.3-2-g0d8e