From 0460a04474d2ea4f439708bb9f8ded24fba329ac Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Apr 2014 16:58:11 -0400 Subject: propellor spin --- Propellor/Types.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'Propellor/Types.hs') diff --git a/Propellor/Types.hs b/Propellor/Types.hs index 52c0c999..856e0ea9 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -100,6 +100,7 @@ data PrivDataField = DockerAuthentication | SshPrivKey UserName | Password UserName + | PrivFile FilePath deriving (Read, Show, Ord, Eq) -- cgit v1.3-2-g0d8e From 68028803bac71f226e03902cfdb033bb1fb2dcc9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 10 Apr 2014 00:29:47 -0400 Subject: propellor spin --- Propellor/Property/Apt.hs | 11 ++++++++++- Propellor/Types.hs | 2 +- 2 files changed, 11 insertions(+), 2 deletions(-) (limited to 'Propellor/Types.hs') diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs index ff9b3de9..937d1404 100644 --- a/Propellor/Property/Apt.hs +++ b/Propellor/Property/Apt.hs @@ -47,13 +47,22 @@ debCdn = binandsrc "http://cdn.debian.net/debian" kernelOrg :: DebianSuite -> [Line] kernelOrg = binandsrc "http://mirrors.kernel.org/debian" +-- | Only available for Stable and Testing +securityUpdates :: DebianSuite -> [Line] +securityUpdates suite + | suite == Stable || suite == Testing = + let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections + in [l, srcLine l] + | otherwise = [] + -- | Makes sources.list have a standard content using the mirror CDN, -- with a particular DebianSuite. -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. stdSourcesList :: DebianSuite -> Property -stdSourcesList suite = setSourcesList (debCdn suite ++ kernelOrg suite) +stdSourcesList suite = setSourcesList + (debCdn suite ++ kernelOrg suite ++ securityUpdates suite) `describe` ("standard sources.list for " ++ show suite) setSourcesList :: [Line] -> Property diff --git a/Propellor/Types.hs b/Propellor/Types.hs index 856e0ea9..c6be30c4 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -63,7 +63,7 @@ data Distribution deriving (Show) data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release - deriving (Show) + deriving (Show, Eq) type Release = String -- cgit v1.3-2-g0d8e From 7a0074454bbae2506c102a57add9af17a32907cc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 10 Apr 2014 03:06:35 -0400 Subject: propellor spin --- Propellor/Property/File.hs | 10 ++++++++++ Propellor/Property/Git.hs | 3 ++- Propellor/Types.hs | 1 + config-joey.hs | 1 + 4 files changed, 14 insertions(+), 1 deletion(-) (limited to 'Propellor/Types.hs') diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs index 0c1155fe..64dce66f 100644 --- a/Propellor/Property/File.hs +++ b/Propellor/Property/File.hs @@ -58,3 +58,13 @@ fileProperty desc a f = Property desc $ go =<< doesFileExist f dirExists :: FilePath -> Property dirExists d = check (not <$> doesDirectoryExist d) $ Property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d + +-- | Ensures that a file/dir has the specified owner and group. +ownerGroup :: FilePath -> UserName -> GroupName -> Property +ownerGroup f owner group = Property (f ++ " owner " ++ og) $ do + r <- ensureProperty $ cmdProperty "chown" [og, f] + if r == FailedChange + then return r + else noChange + where + og = owner ++ ":" ++ group diff --git a/Propellor/Property/Git.hs b/Propellor/Property/Git.hs index 356ff87a..c0494160 100644 --- a/Propellor/Property/Git.hs +++ b/Propellor/Property/Git.hs @@ -22,7 +22,8 @@ daemonRunning exportdir = RevertableProperty setup unsetup `requires` Apt.serviceInstalledRunning "openbsd-inetd" `onChange` - Service.reloaded "openbsd-inetd" + Service.running "openbsd-inetd" + `describe` ("git-daemon exporting " ++ exportdir) unsetup = lacksLine conf (mkl "tcp4") `requires` lacksLine conf (mkl "tcp6") diff --git a/Propellor/Types.hs b/Propellor/Types.hs index c6be30c4..3be10d3f 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -4,6 +4,7 @@ import Data.Monoid import System.Console.ANSI type HostName = String +type GroupName = String type UserName = String data Property = Property diff --git a/config-joey.hs b/config-joey.hs index b4aeebe6..d07e12b5 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -67,6 +67,7 @@ host hostname@"diatom.kitenet.net" = Just $ props & Apt.installed ["git", "git-annex", "rsync"] & Apt.buildDep ["git-annex"] `period` Daily & Git.daemonRunning "/srv/git" + & File.ownerGroup "/srv/git" "joey" "joey" -- git repos restore (how?) -- kgb installation and setup -- ssh keys for branchable and github repo hooks -- cgit v1.3-2-g0d8e From 25942fb0cca0ca90933026bf959506e099ff95a4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 10 Apr 2014 17:22:32 -0400 Subject: Propellor monad is a Reader for HostAttr So far, the hostname is only used to improve a message in withPrivData, but I anticipate using HostAttr for a lot more. --- Propellor.hs | 5 +++ Propellor/CmdLine.hs | 18 ++++++----- Propellor/Engine.hs | 23 +++++++++----- Propellor/Exception.hs | 16 ++++++++++ Propellor/Message.hs | 25 +++++++++------ Propellor/PrivData.hs | 15 ++++++--- Propellor/Property.hs | 19 ++++++----- Propellor/Property/Cmd.hs | 5 ++- Propellor/Property/Docker.hs | 37 +++++++++++----------- Propellor/Property/File.hs | 4 +-- Propellor/Property/Scheduled.hs | 10 +++--- Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 5 +-- Propellor/Property/SiteSpecific/GitHome.hs | 2 +- Propellor/Property/Ssh.hs | 2 +- Propellor/Property/Sudo.hs | 2 +- Propellor/Types.hs | 35 +++++++++++++++++++- debian/changelog | 4 ++- propellor.cabal | 12 ++++--- 18 files changed, 163 insertions(+), 76 deletions(-) create mode 100644 Propellor/Exception.hs (limited to 'Propellor/Types.hs') diff --git a/Propellor.hs b/Propellor.hs index e39fc97d..1f1d7eca 100644 --- a/Propellor.hs +++ b/Propellor.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + -- | Pulls in lots of useful modules for building and using Properties. -- -- Propellor enures that the system it's run in satisfies a list of @@ -31,6 +33,7 @@ module Propellor ( , module Propellor.Property.Cmd , module Propellor.PrivData , module Propellor.Engine + , module Propellor.Exception , module Propellor.Message , localdir @@ -43,6 +46,7 @@ import Propellor.Engine import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Message +import Propellor.Exception import Utility.PartialPrelude as X import Utility.Process as X @@ -62,6 +66,7 @@ import Control.Applicative as X import Control.Monad as X import Data.Monoid as X import Control.Monad.IfElse as X +import "mtl" Control.Monad.Reader as X -- | This is where propellor installs itself when deploying a host. localdir :: FilePath diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index 6ddf8907..2026c47a 100644 --- a/Propellor/CmdLine.hs +++ b/Propellor/CmdLine.hs @@ -66,21 +66,23 @@ defaultMain getprops = do go _ (Continue cmdline) = go False cmdline go _ (Set host field) = setPrivData host field go _ (AddKey keyid) = addKey keyid - go _ (Chain host) = withprops host $ \ps -> do - r <- ensureProperties' ps + go _ (Chain host) = withprops host $ \hostattr ps -> do + r <- runPropellor hostattr $ ensureProperties ps putStrLn $ "\n" ++ show r go _ (Docker host) = Docker.chain host go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline - go False (Spin host) = withprops host $ const $ spin host + go False (Spin host) = withprops host $ const . const $ spin host go False (Run host) = ifM ((==) 0 <$> getRealUserID) - ( onlyProcess $ withprops host ensureProperties + ( onlyProcess $ withprops host mainProperties , go True (Spin host) ) go False (Boot host) = onlyProcess $ withprops host $ boot - withprops host a = maybe (unknownhost host) a $ + withprops host a = maybe (unknownhost host) (a hostattr) $ headMaybe $ catMaybes $ map (\get -> get host) getprops + where + hostattr = mkHostAttr host onlyProcess :: IO a -> IO a onlyProcess a = bracket lock unlock (const a) @@ -275,15 +277,15 @@ fromMarked marker s len = length marker matches = filter (marker `isPrefixOf`) $ lines s -boot :: [Property] -> IO () -boot ps = do +boot :: HostAttr -> [Property] -> IO () +boot hostattr ps = do sendMarked stdout statusMarker $ show Ready reply <- hGetContentsStrict stdin makePrivDataDir maybe noop (writeFileProtected privDataLocal) $ fromMarked privDataMarker reply - ensureProperties ps + mainProperties hostattr ps addKey :: String -> IO () addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ] diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs index 1ae224ca..c527dc38 100644 --- a/Propellor/Engine.hs +++ b/Propellor/Engine.hs @@ -1,30 +1,37 @@ +{-# LANGUAGE PackageImports #-} + module Propellor.Engine where import System.Exit import System.IO import Data.Monoid import System.Console.ANSI +import "mtl" Control.Monad.Reader import Propellor.Types import Propellor.Message -import Utility.Exception +import Propellor.Exception -ensureProperty :: Property -> IO Result -ensureProperty = catchDefaultIO FailedChange . propertySatisfy +runPropellor :: HostAttr -> Propellor a -> IO a +runPropellor hostattr a = runReaderT (runWithHostAttr a) hostattr -ensureProperties :: [Property] -> IO () -ensureProperties ps = do - r <- ensureProperties' [Property "overall" $ ensureProperties' ps] +mainProperties :: HostAttr -> [Property] -> IO () +mainProperties hostattr ps = do + r <- runPropellor hostattr $ + ensureProperties [Property "overall" $ ensureProperties ps] setTitle "propellor: done" hFlush stdout case r of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess -ensureProperties' :: [Property] -> IO Result -ensureProperties' ps = ensure ps NoChange +ensureProperties :: [Property] -> Propellor Result +ensureProperties ps = ensure ps NoChange where ensure [] rs = return rs ensure (l:ls) rs = do r <- actionMessage (propertyDesc l) (ensureProperty l) ensure ls (r <> rs) + +ensureProperty :: Property -> Propellor Result +ensureProperty = catchPropellor . propertySatisfy diff --git a/Propellor/Exception.hs b/Propellor/Exception.hs new file mode 100644 index 00000000..bd9212a8 --- /dev/null +++ b/Propellor/Exception.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Exception where + +import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M +import Control.Exception +import Control.Applicative + +import Propellor.Types + +-- | Catches IO exceptions and returns FailedChange. +catchPropellor :: Propellor Result -> Propellor Result +catchPropellor a = either (\_ -> FailedChange) id <$> tryPropellor a + +tryPropellor :: Propellor a -> Propellor (Either IOException a) +tryPropellor = M.try diff --git a/Propellor/Message.hs b/Propellor/Message.hs index 5a7d8c4b..2e63061e 100644 --- a/Propellor/Message.hs +++ b/Propellor/Message.hs @@ -1,30 +1,35 @@ +{-# LANGUAGE PackageImports #-} + module Propellor.Message where import System.Console.ANSI import System.IO import System.Log.Logger +import "mtl" Control.Monad.Reader import Propellor.Types -- | Shows a message while performing an action, with a colored status -- display. -actionMessage :: ActionResult r => Desc -> IO r -> IO r +actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r actionMessage desc a = do - setTitle $ "propellor: " ++ desc - hFlush stdout + liftIO $ do + setTitle $ "propellor: " ++ desc + hFlush stdout r <- a - setTitle "propellor: running" - let (msg, intensity, color) = getActionResult r - putStr $ desc ++ " ... " - colorLine intensity color msg - hFlush stdout + liftIO $ do + setTitle "propellor: running" + let (msg, intensity, color) = getActionResult r + putStr $ desc ++ " ... " + colorLine intensity color msg + hFlush stdout return r -warningMessage :: String -> IO () -warningMessage s = colorLine Vivid Red $ "** warning: " ++ s +warningMessage :: MonadIO m => String -> m () +warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s colorLine :: ColorIntensity -> Color -> String -> IO () colorLine intensity color msg = do diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs index 2897d425..7f5a23dc 100644 --- a/Propellor/PrivData.hs +++ b/Propellor/PrivData.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + module Propellor.PrivData where import qualified Data.Map as M @@ -7,6 +9,7 @@ import System.IO import System.Directory import Data.Maybe import Control.Monad +import "mtl" Control.Monad.Reader import Propellor.Types import Propellor.Message @@ -18,13 +21,15 @@ import Utility.Tmp import Utility.SafeCommand import Utility.Misc -withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result -withPrivData field a = maybe missing a =<< getPrivData field +withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result +withPrivData field a = maybe missing a =<< liftIO (getPrivData field) where missing = do - warningMessage $ "Missing privdata " ++ show field - putStrLn $ "Fix this by running: propellor --set $hostname '" ++ show field ++ "'" - return FailedChange + host <- getHostName + liftIO $ do + warningMessage $ "Missing privdata " ++ show field + putStrLn $ "Fix this by running: propellor --set "++host++" '" ++ show field ++ "'" + return FailedChange getPrivData :: PrivDataField -> IO (Maybe String) getPrivData field = do diff --git a/Propellor/Property.hs b/Propellor/Property.hs index ca492e33..7af69ea8 100644 --- a/Propellor/Property.hs +++ b/Propellor/Property.hs @@ -1,18 +1,21 @@ +{-# LANGUAGE PackageImports #-} + module Propellor.Property where import System.Directory import Control.Monad import Data.Monoid import Control.Monad.IfElse +import "mtl" Control.Monad.Reader import Propellor.Types import Propellor.Engine import Utility.Monad -makeChange :: IO () -> IO Result -makeChange a = a >> return MadeChange +makeChange :: IO () -> Propellor Result +makeChange a = liftIO a >> return MadeChange -noChange :: IO Result +noChange :: Propellor Result noChange = return NoChange -- | Combines a list of properties, resulting in a single property @@ -20,7 +23,7 @@ noChange = return NoChange -- and print out the description of each as it's run. Does not stop -- on failure; does propigate overall success/failure. propertyList :: Desc -> [Property] -> Property -propertyList desc ps = Property desc $ ensureProperties' ps +propertyList desc ps = Property desc $ ensureProperties ps -- | Combines a list of properties, resulting in one property that -- ensures each in turn, stopping on failure. @@ -49,12 +52,12 @@ p1 `before` p2 = Property (propertyDesc p1) $ do -- Use with caution. flagFile :: Property -> FilePath -> Property flagFile property flagfile = Property (propertyDesc property) $ - go =<< doesFileExist flagfile + go =<< liftIO (doesFileExist flagfile) where go True = return NoChange go False = do r <- ensureProperty property - when (r == MadeChange) $ + when (r == MadeChange) $ liftIO $ unlessM (doesFileExist flagfile) $ writeFile flagfile "" return r @@ -76,13 +79,13 @@ infixl 1 ==> -- | Makes a Property only be performed when a test succeeds. check :: IO Bool -> Property -> Property -check c property = Property (propertyDesc property) $ ifM c +check c property = Property (propertyDesc property) $ ifM (liftIO c) ( ensureProperty property , return NoChange ) boolProperty :: Desc -> IO Bool -> Property -boolProperty desc a = Property desc $ ifM a +boolProperty desc a = Property desc $ ifM (liftIO a) ( return MadeChange , return FailedChange ) diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs index c715fd2a..875c1f9a 100644 --- a/Propellor/Property/Cmd.hs +++ b/Propellor/Property/Cmd.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + module Propellor.Property.Cmd ( cmdProperty, cmdProperty', @@ -7,6 +9,7 @@ module Propellor.Property.Cmd ( import Control.Applicative import Data.List +import "mtl" Control.Monad.Reader import Propellor.Types import Utility.Monad @@ -22,7 +25,7 @@ cmdProperty cmd params = cmdProperty' cmd params [] -- | A property that can be satisfied by running a command, -- with added environment. cmdProperty' :: String -> [String] -> [(String, String)] -> Property -cmdProperty' cmd params env = Property desc $ do +cmdProperty' cmd params env = Property desc $ liftIO $ do env' <- addEntries env <$> getEnvironment ifM (boolSystemEnv cmd (map Param params) (Just env')) ( return MadeChange diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs index b573e641..1df34251 100644 --- a/Propellor/Property/Docker.hs +++ b/Propellor/Property/Docker.hs @@ -53,7 +53,7 @@ docked findc hn cn = findContainer findc hn cn $ teardown = combineProperties ("undocked " ++ fromContainerId cid) [ stoppedContainer cid , Property ("cleaned up " ++ fromContainerId cid) $ - report <$> mapM id + liftIO $ report <$> mapM id [ removeContainer cid , removeImage image ] @@ -74,7 +74,7 @@ findContainer findc hn cn mk = case findc hn cn of where cid = ContainerId hn cn cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do - warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid + liftIO $ warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid return FailedChange -- | Causes *any* docker images that are not in use by running containers to @@ -90,9 +90,9 @@ garbageCollected = propertyList "docker garbage collected" ] where gccontainers = Property "docker containers garbage collected" $ - report <$> (mapM removeContainer =<< listContainers AllContainers) + liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) gcimages = Property "docker images garbage collected" $ do - report <$> (mapM removeImage =<< listImages) + liftIO $ report <$> (mapM removeImage =<< listImages) -- | Pass to defaultMain to add docker containers. -- You need to provide the function mapping from @@ -239,19 +239,19 @@ containerDesc cid p = p `describe` desc runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do - l <- listContainers RunningContainers + l <- liftIO $ listContainers RunningContainers if cid `elem` l then do -- Check if the ident has changed; if so the -- parameters of the container differ and it must -- be restarted. - runningident <- getrunningident + runningident <- liftIO $ getrunningident if runningident == Just ident - then return NoChange + then noChange else do - void $ stopContainer cid + void $ liftIO $ stopContainer cid restartcontainer - else ifM (elem cid <$> listContainers AllContainers) + else ifM (liftIO $ elem cid <$> listContainers AllContainers) ( restartcontainer , go image ) @@ -259,8 +259,8 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci ident = ContainerIdent image hn cn runps restartcontainer = do - oldimage <- fromMaybe image <$> commitContainer cid - void $ removeContainer cid + oldimage <- liftIO $ fromMaybe image <$> commitContainer cid + void $ liftIO $ removeContainer cid go oldimage getrunningident :: IO (Maybe ContainerIdent) @@ -280,10 +280,11 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci ] go img = do - clearProvisionedFlag cid - createDirectoryIfMissing True (takeDirectory $ identFile cid) - shim <- Shim.setup (localdir "propellor") (localdir shimdir cid) - writeFile (identFile cid) (show ident) + liftIO $ do + clearProvisionedFlag cid + createDirectoryIfMissing True (takeDirectory $ identFile cid) + shim <- liftIO $ Shim.setup (localdir "propellor") (localdir shimdir cid) + liftIO $ writeFile (identFile cid) (show ident) ensureProperty $ boolProperty "run" $ runContainer img (runps ++ ["-i", "-d", "-t"]) [shim, "--docker", fromContainerId cid] @@ -339,7 +340,7 @@ chain s = case toContainerId s of -- being run. So, retry connections to the client for up to -- 1 minute. provisionContainer :: ContainerId -> Property -provisionContainer cid = containerDesc cid $ Property "provision" $ do +provisionContainer cid = containerDesc cid $ Property "provision" $ liftIO $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing) when (r /= FailedChange) $ @@ -372,8 +373,8 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId stoppedContainer :: ContainerId -> Property stoppedContainer cid = containerDesc cid $ Property desc $ - ifM (elem cid <$> listContainers RunningContainers) - ( cleanup `after` ensureProperty + ifM (liftIO $ elem cid <$> listContainers RunningContainers) + ( liftIO cleanup `after` ensureProperty (boolProperty desc $ stopContainer cid) , return NoChange ) diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs index 64dce66f..10dee75e 100644 --- a/Propellor/Property/File.hs +++ b/Propellor/Property/File.hs @@ -38,10 +38,10 @@ notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $ makeChange $ nukeFile f fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property -fileProperty desc a f = Property desc $ go =<< doesFileExist f +fileProperty desc a f = Property desc $ go =<< liftIO (doesFileExist f) where go True = do - ls <- lines <$> readFile f + ls <- liftIO $ lines <$> readFile f let ls' = a ls if ls' == ls then noChange diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs index 827c648c..8341765e 100644 --- a/Propellor/Property/Scheduled.hs +++ b/Propellor/Property/Scheduled.hs @@ -20,13 +20,13 @@ import qualified Data.Map as M -- last run. period :: Property -> Recurrance -> Property period prop recurrance = Property desc $ do - lasttime <- getLastChecked (propertyDesc prop) - nexttime <- fmap startTime <$> nextTime schedule lasttime - t <- localNow + lasttime <- liftIO $ getLastChecked (propertyDesc prop) + nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime + t <- liftIO localNow if Just t >= nexttime then do r <- ensureProperty prop - setLastChecked t (propertyDesc prop) + liftIO $ setLastChecked t (propertyDesc prop) return r else noChange where @@ -38,7 +38,7 @@ periodParse :: Property -> String -> Property periodParse prop s = case toRecurrance s of Just recurrance -> period prop recurrance Nothing -> Property "periodParse" $ do - warningMessage $ "failed periodParse: " ++ s + liftIO $ warningMessage $ "failed periodParse: " ++ s noChange lastCheckedFile :: FilePath diff --git a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 580a52dc..204a9ca7 100644 --- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -44,12 +44,13 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder" let f = homedir "rsyncpassword" if rsyncupload then withPrivData (Password builduser) $ \p -> do - oldp <- catchDefaultIO "" $ readFileStrict f + oldp <- liftIO $ catchDefaultIO "" $ + readFileStrict f if p /= oldp then makeChange $ writeFile f p else noChange else do - ifM (doesFileExist f) + ifM (liftIO $ doesFileExist f) ( noChange , makeChange $ writeFile f "no password configured" ) diff --git a/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs index 482100ca..1ba56b94 100644 --- a/Propellor/Property/SiteSpecific/GitHome.hs +++ b/Propellor/Property/SiteSpecific/GitHome.hs @@ -8,7 +8,7 @@ import Utility.SafeCommand -- | Clones Joey Hess's git home directory, and runs its fixups script. installedFor :: UserName -> Property installedFor user = check (not <$> hasGitDir user) $ - Property ("githome " ++ user) (go =<< homedir user) + Property ("githome " ++ user) (go =<< liftIO (homedir user)) `requires` Apt.installed ["git"] where go Nothing = noChange diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs index 36766f56..59845f8f 100644 --- a/Propellor/Property/Ssh.hs +++ b/Propellor/Property/Ssh.hs @@ -53,7 +53,7 @@ uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restartSshd where prop = Property "ssh unique host keys" $ do - void $ boolSystem "sh" + void $ liftIO $ boolSystem "sh" [ Param "-c" , Param "rm -f /etc/ssh/ssh_host_*" ] diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs index 68b8d056..66ceb580 100644 --- a/Propellor/Property/Sudo.hs +++ b/Propellor/Property/Sudo.hs @@ -13,7 +13,7 @@ enabledFor :: UserName -> Property enabledFor user = Property desc go `requires` Apt.installed ["sudo"] where go = do - locked <- isLockedPassword user + locked <- liftIO $ isLockedPassword user ensureProperty $ fileProperty desc (modify locked . filter (wanted locked)) diff --git a/Propellor/Types.hs b/Propellor/Types.hs index 3be10d3f..b1632923 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -1,20 +1,53 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Propellor.Types where import Data.Monoid +import Control.Applicative import System.Console.ANSI +import "mtl" Control.Monad.Reader +import "MonadCatchIO-transformers" Control.Monad.CatchIO type HostName = String type GroupName = String type UserName = String +-- | The core data type of Propellor, this reprecents a property +-- that the system should have, and an action to ensure it has the +-- property. data Property = Property { propertyDesc :: Desc -- | must be idempotent; may run repeatedly - , propertySatisfy :: IO Result + , propertySatisfy :: Propellor Result } +-- | A property that can be reverted. data RevertableProperty = RevertableProperty Property Property +-- | Propellor's monad provides read-only access to attributes of the +-- system. +newtype Propellor a = Propellor { runWithHostAttr :: ReaderT HostAttr IO a } + deriving + ( Monad + , Functor + , Applicative + , MonadReader HostAttr + , MonadIO + , MonadCatchIO + ) + +-- | The attributes of a system. For example, its hostname. +newtype HostAttr = HostAttr + { _hostname :: HostName + } + +mkHostAttr :: HostName -> HostAttr +mkHostAttr = HostAttr + +getHostName :: Propellor HostName +getHostName = asks _hostname + class IsProp p where -- | Sets description. describe :: p -> Desc -> p diff --git a/debian/changelog b/debian/changelog index 55043d5b..a9a142df 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,4 +1,4 @@ -propellor (0.2.4) UNRELEASED; urgency=medium +propellor (0.3.0) UNRELEASED; urgency=medium * ipv6to4: Ensure interface is brought up automatically on boot. * Enabling unattended upgrades now ensures that cron is installed and @@ -8,6 +8,8 @@ propellor (0.2.4) UNRELEASED; urgency=medium * Fix compilation on Debian stable. * Include security updates in sources.list for stable and testing. * Use ssh connection caching, especially when bootstrapping. + * Properties now run in a Propellor monad, which provides access to + attributes of the host. -- Joey Hess Tue, 08 Apr 2014 18:07:12 -0400 diff --git a/propellor.cabal b/propellor.cabal index 03d14743..0c7e3494 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 0.2.3 +Version: 0.3.0 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess @@ -38,7 +38,8 @@ Executable propellor GHC-Options: -Wall Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck + containers, network, async, time, QuickCheck, mtl, + MonadCatchIO-transformers if (! os(windows)) Build-Depends: unix @@ -48,7 +49,8 @@ Executable config GHC-Options: -Wall -threaded Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck + containers, network, async, time, QuickCheck, mtl, + MonadCatchIO-transformers if (! os(windows)) Build-Depends: unix @@ -57,7 +59,8 @@ Library GHC-Options: -Wall Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck + containers, network, async, time, QuickCheck, mtl, + MonadCatchIO-transformers if (! os(windows)) Build-Depends: unix @@ -88,6 +91,7 @@ Library Propellor.Message Propellor.PrivData Propellor.Engine + Propellor.Exception Propellor.Types Other-Modules: Propellor.CmdLine -- cgit v1.3-2-g0d8e From 2372d6a3f8193145662e393aa61b585d8bafd32d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 10 Apr 2014 17:46:03 -0400 Subject: use HostAttr to simplify config file --- Propellor/Property/Docker.hs | 36 ++++++++++++++++++++---------------- Propellor/Property/Hostname.hs | 13 ++++++++----- Propellor/Types.hs | 2 +- config-joey.hs | 32 ++++++++++++++++---------------- config-simple.hs | 4 ++-- 5 files changed, 47 insertions(+), 40 deletions(-) (limited to 'Propellor/Types.hs') diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs index 1df34251..3828535c 100644 --- a/Propellor/Property/Docker.hs +++ b/Propellor/Property/Docker.hs @@ -40,36 +40,40 @@ installed = Apt.installed ["docker.io"] -- removed. docked :: (HostName -> ContainerName -> Maybe (Container)) - -> HostName -> ContainerName -> RevertableProperty -docked findc hn cn = findContainer findc hn cn $ - \(Container image containerprops) -> - let setup = provisionContainer cid - `requires` - runningContainer cid image containerprops - `requires` - installed - teardown = combineProperties ("undocked " ++ fromContainerId cid) - [ stoppedContainer cid +docked findc cn = RevertableProperty (go "docked" setup) (go "undocked" teardown) + where + go desc a = Property (desc ++ " " ++ cn) $ do + hn <- getHostName + let cid = ContainerId hn cn + ensureProperties [findContainer findc hn cn $ a cid] + + setup cid (Container image containerprops) = + provisionContainer cid + `requires` + runningContainer cid image containerprops + `requires` + installed + + teardown cid (Container image _) = + combineProperties ("undocked " ++ fromContainerId cid) + [ stoppedContainer cid , Property ("cleaned up " ++ fromContainerId cid) $ liftIO $ report <$> mapM id [ removeContainer cid , removeImage image ] ] - in RevertableProperty setup teardown - where - cid = ContainerId hn cn findContainer :: (HostName -> ContainerName -> Maybe (Container)) -> HostName -> ContainerName - -> (Container -> RevertableProperty) - -> RevertableProperty + -> (Container -> Property) + -> Property findContainer findc hn cn mk = case findc hn cn of - Nothing -> RevertableProperty cantfind cantfind + Nothing -> cantfind Just container -> mk container where cid = ContainerId hn cn diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs index 26635374..0708b3ff 100644 --- a/Propellor/Property/Hostname.hs +++ b/Propellor/Property/Hostname.hs @@ -3,14 +3,17 @@ module Propellor.Property.Hostname where import Propellor import qualified Propellor.Property.File as File --- | Sets the hostname. Configures both /etc/hostname and the current --- hostname. +-- | Ensures that the hostname is set to the HostAttr value. +-- Configures both /etc/hostname and the current hostname. -- --- When provided with a FQDN, also configures /etc/hosts, +-- When the hostname is a FQDN, also configures /etc/hosts, -- with an entry for 127.0.1.1, which is standard at least on Debian -- to set the FDQN (127.0.0.1 is localhost). -set :: HostName -> Property -set hostname = combineProperties desc go +sane :: Property +sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName) + +setTo :: HostName -> Property +setTo hostname = combineProperties desc go `onChange` cmdProperty "hostname" [host] where desc = "hostname " ++ hostname diff --git a/Propellor/Types.hs b/Propellor/Types.hs index b1632923..6a1c888a 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -27,7 +27,7 @@ data RevertableProperty = RevertableProperty Property Property -- | Propellor's monad provides read-only access to attributes of the -- system. -newtype Propellor a = Propellor { runWithHostAttr :: ReaderT HostAttr IO a } +newtype Propellor p = Propellor { runWithHostAttr :: ReaderT HostAttr IO p } deriving ( Monad , Functor diff --git a/config-joey.hs b/config-joey.hs index 2c6374c9..d1a33230 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -32,35 +32,35 @@ main = defaultMain [host, Docker.containerProperties container] -- Edit this to configure propellor! host :: HostName -> Maybe [Property] -- Clam is a tor bridge, and an olduse.net shellbox and other fun stuff. -host hostname@"clam.kitenet.net" = Just $ withSystemd $ props - & cleanCloudAtCost hostname +host "clam.kitenet.net" = Just $ withSystemd $ props + & cleanCloudAtCost & standardSystem Unstable & Apt.unattendedUpgrades & Network.ipv6to4 & Apt.installed ["git-annex", "mtr"] & Tor.isBridge & JoeySites.oldUseNetshellBox - & Docker.docked container hostname "openid-provider" + & Docker.docked container "openid-provider" `requires` Apt.installed ["ntp"] - & Docker.docked container hostname "ancient-kitenet" + & Docker.docked container "ancient-kitenet" & Docker.configured & Docker.garbageCollected `period` Daily -- Orca is the main git-annex build box. -host hostname@"orca.kitenet.net" = Just $ props -- no systemd due to #726375 +host "orca.kitenet.net" = Just $ props -- no systemd due to #726375 & standardSystem Unstable - & Hostname.set hostname + & Hostname.sane & Apt.unattendedUpgrades & Docker.configured & Apt.buildDep ["git-annex"] `period` Daily - & Docker.docked container hostname "amd64-git-annex-builder" - & Docker.docked container hostname "i386-git-annex-builder" - ! Docker.docked container hostname "armel-git-annex-builder-companion" - ! Docker.docked container hostname "armel-git-annex-builder" + & Docker.docked container "amd64-git-annex-builder" + & Docker.docked container "i386-git-annex-builder" + ! Docker.docked container "armel-git-annex-builder-companion" + ! Docker.docked container "armel-git-annex-builder" & Docker.garbageCollected `period` Daily -- Diatom is my downloads and git repos server, and secondary dns server. -host hostname@"diatom.kitenet.net" = Just $ props +host "diatom.kitenet.net" = Just $ props & standardSystem Stable - & Hostname.set hostname + & Hostname.sane & Apt.unattendedUpgrades & Apt.serviceInstalledRunning "ntp" & Dns.zones myDnsSecondary @@ -78,7 +78,7 @@ host hostname@"diatom.kitenet.net" = Just $ props -- gitweb -- downloads.kitenet.net setup (including ssh key to turtle) -- My laptop -host _hostname@"darkstar.kitenet.net" = Just $ props +host "darkstar.kitenet.net" = Just $ props & Docker.configured & Apt.buildDep ["git-annex"] `period` Daily @@ -192,9 +192,9 @@ standardContainer suite arch ps = Docker.containerFrom ] ++ ps -- Clean up a system as installed by cloudatcost.com -cleanCloudAtCost :: HostName -> Property -cleanCloudAtCost hostname = propertyList "cloudatcost cleanup" - [ Hostname.set hostname +cleanCloudAtCost :: Property +cleanCloudAtCost = propertyList "cloudatcost cleanup" + [ Hostname.sane , Ssh.uniqueHostKeys , "worked around grub/lvm boot bug #743126" ==> "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" diff --git a/config-simple.hs b/config-simple.hs index 6784f76c..8011e97e 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -25,7 +25,7 @@ main = defaultMain [host, Docker.containerProperties container] -- -- Edit this to configure propellor! host :: HostName -> Maybe [Property] -host hostname@"mybox.example.com" = Just $ props +host "mybox.example.com" = Just $ props & Apt.stdSourcesList Unstable `onChange` Apt.upgrade & Apt.unattendedUpgrades @@ -34,7 +34,7 @@ host hostname@"mybox.example.com" = Just $ props & User.hasSomePassword "root" & Network.ipv6to4 & File.dirExists "/var/www" - & Docker.docked container hostname "webserver" + & Docker.docked container "webserver" & Docker.garbageCollected `period` Daily & Cron.runPropellor "30 * * * *" -- add more hosts here... -- cgit v1.3-2-g0d8e From 50cd59cb3e6d20afe48a50fa9dc0c3a9cf9d9960 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 10 Apr 2014 21:09:20 -0400 Subject: new more expressive config.hs WIP --- Propellor.hs | 24 +++-- Propellor/Attr.hs | 47 ++++++++++ Propellor/CmdLine.hs | 65 ++++++------- Propellor/Engine.hs | 10 +- Propellor/PrivData.hs | 1 + Propellor/Property.hs | 51 +++++++++-- Propellor/Property/Apt.hs | 4 +- Propellor/Property/Hostname.hs | 12 +-- Propellor/Property/SiteSpecific/JoeySites.hs | 4 +- Propellor/Types.hs | 78 +++++++++++----- Propellor/Types/Attr.hs | 16 ++++ TODO | 4 +- config-joey.hs | 132 +++++++++++++-------------- propellor.cabal | 2 + 14 files changed, 288 insertions(+), 162 deletions(-) create mode 100644 Propellor/Attr.hs create mode 100644 Propellor/Types/Attr.hs (limited to 'Propellor/Types.hs') diff --git a/Propellor.hs b/Propellor.hs index 1f1d7eca..e6312248 100644 --- a/Propellor.hs +++ b/Propellor.hs @@ -2,8 +2,9 @@ -- | Pulls in lots of useful modules for building and using Properties. -- --- Propellor enures that the system it's run in satisfies a list of --- properties, taking action as necessary when a property is not yet met. +-- When propellor runs on a Host, it ensures that its list of Properties +-- is satisfied, taking action as necessary when a Property is not +-- currently satisfied. -- -- A simple propellor program example: -- @@ -13,15 +14,16 @@ -- > import qualified Propellor.Property.Apt as Apt -- > -- > main :: IO () --- > main = defaultMain getProperties +-- > main = defaultMain hosts -- > --- > getProperties :: HostName -> Maybe [Property] --- > getProperties "example.com" = Just --- > [ Apt.installed ["mydaemon"] --- > , "/etc/mydaemon.conf" `File.containsLine` "secure=1" --- > `onChange` cmdProperty "service" ["mydaemon", "restart"] --- > ] --- > getProperties _ = Nothing +-- > hosts :: [Host] +-- > hosts = +-- > [ host "example.com" +-- > & Apt.installed ["mydaemon"] +-- > & "/etc/mydaemon.conf" `File.containsLine` "secure=1" +-- > `onChange` cmdProperty "service" ["mydaemon", "restart"] +-- > ! Apt.installed ["unwantedpackage"] +-- > ] -- -- See config.hs for a more complete example, and clone Propellor's -- git repository for a deployable system using Propellor: @@ -31,6 +33,7 @@ module Propellor ( module Propellor.Types , module Propellor.Property , module Propellor.Property.Cmd + , module Propellor.Attr , module Propellor.PrivData , module Propellor.Engine , module Propellor.Exception @@ -47,6 +50,7 @@ import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Message import Propellor.Exception +import Propellor.Attr import Utility.PartialPrelude as X import Utility.Process as X diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs new file mode 100644 index 00000000..4bc1c2c7 --- /dev/null +++ b/Propellor/Attr.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Attr where + +import Propellor.Types +import Propellor.Types.Attr + +import "mtl" Control.Monad.Reader +import qualified Data.Set as S +import qualified Data.Map as M + +pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty +pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc) + (return NoChange) + +hostname :: HostName -> AttrProperty +hostname name = pureAttrProperty ("hostname " ++ name) $ + \d -> d { _hostname = name } + +getHostName :: Propellor HostName +getHostName = asks _hostname + +cname :: Domain -> AttrProperty +cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain) + +cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty +cnameFor domain mkp = + let p = mkp domain + in AttrProperty p (addCName domain) + +addCName :: HostName -> Attr -> Attr +addCName domain d = d { _cnames = S.insert domain (_cnames d) } + +hostnameless :: Attr +hostnameless = newAttr (error "hostname Attr not specified") + +hostAttr :: Host -> Attr +hostAttr (Host _ mkattrs) = mkattrs hostnameless + +hostProperties :: Host -> [Property] +hostProperties (Host ps _) = ps + +hostMap :: [Host] -> M.Map HostName Host +hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l + +findHost :: [Host] -> HostName -> Maybe Host +findHost l hn = M.lookup hn (hostMap l) diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index 2026c47a..5be91c4f 100644 --- a/Propellor/CmdLine.hs +++ b/Propellor/CmdLine.hs @@ -55,8 +55,8 @@ processCmdLine = go =<< getArgs else return $ Run s go _ = usage -defaultMain :: [HostName -> Maybe [Property]] -> IO () -defaultMain getprops = do +defaultMain :: [Host] -> IO () +defaultMain hostlist = do DockerShim.cleanEnv checkDebugMode cmdline <- processCmdLine @@ -64,25 +64,26 @@ defaultMain getprops = do go True cmdline where go _ (Continue cmdline) = go False cmdline - go _ (Set host field) = setPrivData host field + go _ (Set hn field) = setPrivData hn field go _ (AddKey keyid) = addKey keyid - go _ (Chain host) = withprops host $ \hostattr ps -> do - r <- runPropellor hostattr $ ensureProperties ps + go _ (Chain hn) = withprops hn $ \attr ps -> do + r <- runPropellor attr $ ensureProperties ps putStrLn $ "\n" ++ show r - go _ (Docker host) = Docker.chain host + go _ (Docker hn) = Docker.chain hn go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline - go False (Spin host) = withprops host $ const . const $ spin host - go False (Run host) = ifM ((==) 0 <$> getRealUserID) - ( onlyProcess $ withprops host mainProperties - , go True (Spin host) + go False (Spin hn) = withprops hn $ const . const $ spin hn + go False (Run hn) = ifM ((==) 0 <$> getRealUserID) + ( onlyProcess $ withprops hn mainProperties + , go True (Spin hn) ) - go False (Boot host) = onlyProcess $ withprops host $ boot + go False (Boot hn) = onlyProcess $ withprops hn boot - withprops host a = maybe (unknownhost host) (a hostattr) $ - headMaybe $ catMaybes $ map (\get -> get host) getprops - where - hostattr = mkHostAttr host + withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO () + withprops hn a = maybe + (unknownhost hn) + (\h -> a (hostAttr h) (hostProperties h)) + (findHost hostlist hn) onlyProcess :: IO a -> IO a onlyProcess a = bracket lock unlock (const a) @@ -166,16 +167,16 @@ getCurrentGitSha1 :: String -> IO String getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref] spin :: HostName -> IO () -spin host = do +spin hn = do url <- getUrl void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] void $ boolSystem "git" [Param "push"] - cacheparams <- toCommand <$> sshCachingParams host - go cacheparams url =<< gpgDecrypt (privDataFile host) + cacheparams <- toCommand <$> sshCachingParams hn + go cacheparams url =<< gpgDecrypt (privDataFile hn) where go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do let finish = do - senddata toh (privDataFile host) privDataMarker privdata + senddata toh (privDataFile hn) privDataMarker privdata hClose toh -- Display remaining output. @@ -188,10 +189,10 @@ spin host = do NeedGitClone -> do hClose toh hClose fromh - sendGitClone host url + sendGitClone hn url go cacheparams url privdata - user = "root@"++host + user = "root@"++hn bootstrapcmd = shellWrap $ intercalate " ; " [ "if [ ! -d " ++ localdir ++ " ]" @@ -202,7 +203,7 @@ spin host = do , "else " ++ intercalate " && " [ "cd " ++ localdir , "if ! test -x ./propellor; then make deps build; fi" - , "./propellor --boot " ++ host + , "./propellor --boot " ++ hn ] , "fi" ] @@ -218,18 +219,18 @@ spin host = do showremote s = putStrLn s senddata toh f marker s = void $ - actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do + actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do sendMarked toh marker s return True sendGitClone :: HostName -> String -> IO () -sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ do +sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do branch <- getCurrentBranch - cacheparams <- sshCachingParams host + cacheparams <- sshCachingParams hn withTmpFile "propellor.git" $ \tmp _ -> allM id [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] - , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++host++":"++remotebundle)] - , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++host), Param $ unpackcmd branch] + , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] + , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] ] where remotebundle = "/usr/local/propellor.git" @@ -277,15 +278,15 @@ fromMarked marker s len = length marker matches = filter (marker `isPrefixOf`) $ lines s -boot :: HostAttr -> [Property] -> IO () -boot hostattr ps = do +boot :: Attr -> [Property] -> IO () +boot attr ps = do sendMarked stdout statusMarker $ show Ready reply <- hGetContentsStrict stdin makePrivDataDir maybe noop (writeFileProtected privDataLocal) $ fromMarked privDataMarker reply - mainProperties hostattr ps + mainProperties attr ps addKey :: String -> IO () addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ] @@ -347,11 +348,11 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" -- Parameters can be passed to both ssh and scp. sshCachingParams :: HostName -> IO [CommandParam] -sshCachingParams hostname = do +sshCachingParams hn = do home <- myHomeDir let cachedir = home ".ssh" "propellor" createDirectoryIfMissing False cachedir - let socketfile = cachedir hostname ++ ".sock" + let socketfile = cachedir hn ++ ".sock" return [ Param "-o", Param ("ControlPath=" ++ socketfile) , Params "-o ControlMaster=auto -o ControlPersist=yes" diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs index c527dc38..81d979ac 100644 --- a/Propellor/Engine.hs +++ b/Propellor/Engine.hs @@ -12,12 +12,12 @@ import Propellor.Types import Propellor.Message import Propellor.Exception -runPropellor :: HostAttr -> Propellor a -> IO a -runPropellor hostattr a = runReaderT (runWithHostAttr a) hostattr +runPropellor :: Attr -> Propellor a -> IO a +runPropellor attr a = runReaderT (runWithAttr a) attr -mainProperties :: HostAttr -> [Property] -> IO () -mainProperties hostattr ps = do - r <- runPropellor hostattr $ +mainProperties :: Attr -> [Property] -> IO () +mainProperties attr ps = do + r <- runPropellor attr $ ensureProperties [Property "overall" $ ensureProperties ps] setTitle "propellor: done" hFlush stdout diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs index 7f5a23dc..5adc9e94 100644 --- a/Propellor/PrivData.hs +++ b/Propellor/PrivData.hs @@ -12,6 +12,7 @@ import Control.Monad import "mtl" Control.Monad.Reader import Propellor.Types +import Propellor.Attr import Propellor.Message import Utility.Monad import Utility.PartialPrelude diff --git a/Propellor/Property.hs b/Propellor/Property.hs index 7af69ea8..ccc060ff 100644 --- a/Propellor/Property.hs +++ b/Propellor/Property.hs @@ -9,6 +9,8 @@ import Control.Monad.IfElse import "mtl" Control.Monad.Reader import Propellor.Types +import Propellor.Types.Attr +import Propellor.Attr import Propellor.Engine import Utility.Monad @@ -94,17 +96,46 @@ boolProperty desc a = Property desc $ ifM (liftIO a) revert :: RevertableProperty -> RevertableProperty revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 --- | Starts a list of Properties -props :: [Property] -props = [] +-- | Starts accumulating the properties of a Host. +-- +-- > host "example.com" +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +host :: HostName -> Host +host hn = Host [] (\_ -> newAttr hn) + +-- | Adds a property to a Host +-- Can add Properties, RevertableProperties, and AttrProperties +(&) :: IsProp p => Host -> p -> Host +(Host ps as) & p = Host (ps ++ [toProp p]) (as . getAttr p) --- | Adds a property to the list. --- Can add both Properties and RevertableProperties. -(&) :: IsProp p => [Property] -> p -> [Property] -ps & p = ps ++ [toProp p] infixl 1 & --- | Adds a property to the list in reverted form. -(!) :: [Property] -> RevertableProperty -> [Property] -ps ! p = ps ++ [toProp $ revert p] +-- | Adds a property to the Host in reverted form. +(!) :: Host -> RevertableProperty -> Host +(Host ps as) ! p = Host (ps ++ [toProp q]) (as . getAttr q) + where + q = revert p + infixl 1 ! + +-- | Makes a propertyList of a set of properties, using the same syntax +-- used by `host`. +-- +-- > template "my template" $ props +-- & someproperty +-- ! oldproperty +-- +-- Note that none of the properties can define Attrs, because +-- they will not propigate out to the host that this is added to. +-- +-- Unfortunately, this is not currently enforced at the type level, so +-- attempting to set an Attr in here will be run time error. +template :: Desc -> Host -> Property +template desc h@(Host ps _) + | hostAttr h == hostAttr props = propertyList desc ps + | otherwise = error $ desc ++ ": template contains Attr" + +props :: Host +props = Host [] (\_ -> hostnameless) diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs index 937d1404..4da13a2f 100644 --- a/Propellor/Property/Apt.hs +++ b/Propellor/Property/Apt.hs @@ -180,8 +180,8 @@ reConfigure package vals = reconfigure `requires` setselections setselections = Property "preseed" $ makeChange $ withHandle StdinHandle createProcessSuccess (proc "debconf-set-selections" []) $ \h -> do - forM_ vals $ \(template, tmpltype, value) -> - hPutStrLn h $ unwords [package, template, tmpltype, value] + forM_ vals $ \(tmpl, tmpltype, value) -> + hPutStrLn h $ unwords [package, tmpl, tmpltype, value] hClose h reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package] diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs index 0708b3ff..03613ac9 100644 --- a/Propellor/Property/Hostname.hs +++ b/Propellor/Property/Hostname.hs @@ -13,14 +13,14 @@ sane :: Property sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName) setTo :: HostName -> Property -setTo hostname = combineProperties desc go - `onChange` cmdProperty "hostname" [host] +setTo hn = combineProperties desc go + `onChange` cmdProperty "hostname" [basehost] where - desc = "hostname " ++ hostname - (host, domain) = separate (== '.') hostname + desc = "hostname " ++ hn + (basehost, domain) = separate (== '.') hn go = catMaybes - [ Just $ "/etc/hostname" `File.hasContent` [host] + [ Just $ "/etc/hostname" `File.hasContent` [basehost] , if null domain then Nothing else Just $ File.fileProperty desc @@ -28,7 +28,7 @@ setTo hostname = combineProperties desc go ] hostip = "127.0.1.1" - hostline = hostip ++ "\t" ++ hostname ++ " " ++ host + hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost addhostline ls = hostline : filter (not . hashostip) ls hashostip l = headMaybe (words l) == Just hostip diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs index 029064dd..46373170 100644 --- a/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/Propellor/Property/SiteSpecific/JoeySites.hs @@ -6,8 +6,8 @@ module Propellor.Property.SiteSpecific.JoeySites where import Propellor import qualified Propellor.Property.Apt as Apt -oldUseNetshellBox :: Property -oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $ +oldUseNetShellBox :: Property +oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $ propertyList ("olduse.net shellbox") [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") `describe` "olduse.net build deps" diff --git a/Propellor/Types.hs b/Propellor/Types.hs index 6a1c888a..e6e02126 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -1,7 +1,33 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Propellor.Types where +{-# LANGUAGE ExistentialQuantification #-} + +module Propellor.Types + ( Host(..) + , Attr + , HostName + , UserName + , GroupName + , Propellor(..) + , Property(..) + , RevertableProperty(..) + , AttrProperty(..) + , IsProp + , describe + , toProp + , getAttr + , requires + , Desc + , Result(..) + , System(..) + , Distribution(..) + , DebianSuite(..) + , Release + , Architecture + , ActionResult(..) + , CmdLine(..) + , PrivDataField(..) + ) where import Data.Monoid import Control.Applicative @@ -9,44 +35,39 @@ import System.Console.ANSI import "mtl" Control.Monad.Reader import "MonadCatchIO-transformers" Control.Monad.CatchIO -type HostName = String -type GroupName = String -type UserName = String +import Propellor.Types.Attr --- | The core data type of Propellor, this reprecents a property --- that the system should have, and an action to ensure it has the --- property. -data Property = Property - { propertyDesc :: Desc - -- | must be idempotent; may run repeatedly - , propertySatisfy :: Propellor Result - } +data Host = Host [Property] (Attr -> Attr) --- | A property that can be reverted. -data RevertableProperty = RevertableProperty Property Property +type UserName = String +type GroupName = String -- | Propellor's monad provides read-only access to attributes of the -- system. -newtype Propellor p = Propellor { runWithHostAttr :: ReaderT HostAttr IO p } +newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p } deriving ( Monad , Functor , Applicative - , MonadReader HostAttr + , MonadReader Attr , MonadIO , MonadCatchIO ) --- | The attributes of a system. For example, its hostname. -newtype HostAttr = HostAttr - { _hostname :: HostName +-- | The core data type of Propellor, this represents a property +-- that the system should have, and an action to ensure it has the +-- property. +data Property = Property + { propertyDesc :: Desc + -- | must be idempotent; may run repeatedly + , propertySatisfy :: Propellor Result } -mkHostAttr :: HostName -> HostAttr -mkHostAttr = HostAttr +-- | A property that can be reverted. +data RevertableProperty = RevertableProperty Property Property -getHostName :: Propellor HostName -getHostName = asks _hostname +-- | A property that affects the Attr. +data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr) class IsProp p where -- | Sets description. @@ -55,6 +76,7 @@ class IsProp p where -- | Indicates that the first property can only be satisfied -- once the second one is. requires :: p -> Property -> p + getAttr :: p -> (Attr -> Attr) instance IsProp Property where describe p d = p { propertyDesc = d } @@ -64,6 +86,7 @@ instance IsProp Property where case r of FailedChange -> return FailedChange _ -> propertySatisfy x + getAttr _ = id instance IsProp RevertableProperty where -- | Sets the description of both sides. @@ -72,6 +95,13 @@ instance IsProp RevertableProperty where toProp (RevertableProperty p1 _) = p1 (RevertableProperty p1 p2) `requires` y = RevertableProperty (p1 `requires` y) p2 + getAttr _ = id + +instance IsProp AttrProperty where + describe (AttrProperty p a) d = AttrProperty (describe p d) a + toProp (AttrProperty p _) = toProp p + (AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a + getAttr (AttrProperty _ a) = a type Desc = String diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs new file mode 100644 index 00000000..20e5e631 --- /dev/null +++ b/Propellor/Types/Attr.hs @@ -0,0 +1,16 @@ +module Propellor.Types.Attr where + +import qualified Data.Set as S + +-- | The attributes of a host. For example, its hostname. +data Attr = Attr + { _hostname :: HostName + , _cnames :: S.Set Domain + } + deriving (Eq, Show) + +newAttr :: HostName -> Attr +newAttr hn = Attr hn S.empty + +type HostName = String +type Domain = String diff --git a/TODO b/TODO index 0cc8db1b..a203169c 100644 --- a/TODO +++ b/TODO @@ -3,8 +3,8 @@ but only once despite many config changes being made to satisfy properties. onChange is a poor substitute. * Currently only Debian and derivatives are supported by most Properties. - One way to improve that would be to parameterize Properties with a - Distribution witness. + This could be improved by making the Distribution of the system part + of its HostAttr. * Display of docker container properties is a bit wonky. It always says they are unchanged even when they changed and triggered a reprovision. diff --git a/config-joey.hs b/config-joey.hs index d1a33230..92aa9093 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -20,76 +20,68 @@ import qualified Propellor.Property.Git as Git import qualified Propellor.Property.SiteSpecific.GitHome as GitHome import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites -import Data.List -main :: IO () -main = defaultMain [host, Docker.containerProperties container] - --- | This is where the system's HostName, either as returned by uname --- or one specified on the command line, is converted into a list of --- Properties for that system. --- --- Edit this to configure propellor! -host :: HostName -> Maybe [Property] --- Clam is a tor bridge, and an olduse.net shellbox and other fun stuff. -host "clam.kitenet.net" = Just $ withSystemd $ props - & cleanCloudAtCost - & standardSystem Unstable - & Apt.unattendedUpgrades - & Network.ipv6to4 - & Apt.installed ["git-annex", "mtr"] - & Tor.isBridge - & JoeySites.oldUseNetshellBox - & Docker.docked container "openid-provider" - `requires` Apt.installed ["ntp"] - & Docker.docked container "ancient-kitenet" - & Docker.configured - & Docker.garbageCollected `period` Daily --- Orca is the main git-annex build box. -host "orca.kitenet.net" = Just $ props -- no systemd due to #726375 - & standardSystem Unstable - & Hostname.sane - & Apt.unattendedUpgrades - & Docker.configured - & Apt.buildDep ["git-annex"] `period` Daily - & Docker.docked container "amd64-git-annex-builder" - & Docker.docked container "i386-git-annex-builder" - ! Docker.docked container "armel-git-annex-builder-companion" - ! Docker.docked container "armel-git-annex-builder" - & Docker.garbageCollected `period` Daily --- Diatom is my downloads and git repos server, and secondary dns server. -host "diatom.kitenet.net" = Just $ props - & standardSystem Stable - & Hostname.sane - & Apt.unattendedUpgrades - & Apt.serviceInstalledRunning "ntp" - & Dns.zones myDnsSecondary - & Apt.serviceInstalledRunning "apache2" - & Apt.installed ["git", "git-annex", "rsync"] - & Apt.buildDep ["git-annex"] `period` Daily - & Git.daemonRunning "/srv/git" - & File.ownerGroup "/srv/git" "joey" "joey" - -- git repos restore (how?) - -- family annex needs family members to have accounts, - -- ssh host key etc.. finesse? - -- (also should upgrade git-annex-shell for it..) - -- kgb installation and setup - -- ssh keys for branchable and github repo hooks - -- gitweb - -- downloads.kitenet.net setup (including ssh key to turtle) --- My laptop -host "darkstar.kitenet.net" = Just $ props - & Docker.configured - & Apt.buildDep ["git-annex"] `period` Daily - --- add more hosts here... ---host "foo.example.com" = -host _ = Nothing +hosts :: [Host] +hosts = + [ host "clam.kitenet.net" + & cleanCloudAtCost + & standardSystem Unstable + & Apt.unattendedUpgrades + & Network.ipv6to4 + & Tor.isBridge + & Docker.configured + & cname "shell.olduse.net" + `requires` JoeySites.oldUseNetShellBox + & "openid.kitenet.net" + `cnameFor` Docker.docked container + `requires` Apt.installed ["ntp"] + & "ancient.kitenet.net" + `cnameFor` Docker.docked container + & Docker.garbageCollected `period` Daily + & Apt.installed ["git-annex", "mtr", "screen"] + -- Orca is the main git-annex build box. + , host "orca.kitenet.net" + & standardSystem Unstable + & Hostname.sane + & Apt.unattendedUpgrades + & Docker.configured + & Docker.docked container "amd64-git-annex-builder" + & Docker.docked container "i386-git-annex-builder" + ! Docker.docked container "armel-git-annex-builder-companion" + ! Docker.docked container "armel-git-annex-builder" + & Docker.garbageCollected `period` Daily + & Apt.buildDep ["git-annex"] `period` Daily + -- Important stuff that needs not too much memory or CPU. + , host "diatom.kitenet.net" + & standardSystem Stable + & Hostname.sane + & Apt.unattendedUpgrades + & Apt.serviceInstalledRunning "ntp" + & Dns.zones myDnsSecondary + & Apt.serviceInstalledRunning "apache2" + & Apt.installed ["git", "git-annex", "rsync"] + & Apt.buildDep ["git-annex"] `period` Daily + & Git.daemonRunning "/srv/git" + & File.ownerGroup "/srv/git" "joey" "joey" + -- git repos restore (how?) + -- family annex needs family members to have accounts, + -- ssh host key etc.. finesse? + -- (also should upgrade git-annex-shell for it..) + -- kgb installation and setup + -- ssh keys for branchable and github repo hooks + -- gitweb + -- downloads.kitenet.net setup (including ssh key to turtle) + -- My laptop + , host "darkstar.kitenet.net" + & Docker.configured + & Apt.buildDep ["git-annex"] `period` Daily + ] -- | This is where Docker containers are set up. A container -- can vary by hostname where it's used, or be the same everywhere. container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container) container _parenthost name +{- -- Simple web server, publishing the outside host's /var/www | name == "webserver" = Just $ standardContainer Stable "amd64" [ Docker.publish "8080:80" @@ -148,7 +140,7 @@ container _parenthost name & GitAnnexBuilder.builder arch "15 * * * *" True & Apt.unattendedUpgrades ] - +-} | otherwise = Nothing -- | Docker images I prefer to use. @@ -159,7 +151,7 @@ image _ = "debian-stable-official" -- does not currently exist! -- This is my standard system setup standardSystem :: DebianSuite -> Property -standardSystem suite = propertyList "standard system" $ props +standardSystem suite = template "standard system" $ props & Apt.stdSourcesList suite `onChange` Apt.upgrade & Apt.installed ["etckeeper"] & Apt.installed ["ssh"] @@ -179,9 +171,7 @@ standardSystem suite = propertyList "standard system" $ props & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] `onChange` Apt.autoRemove -withSystemd :: [Property] -> [Property] -withSystemd ps = ps ++ [Apt.installed ["systemd-sysv"] `onChange` Reboot.now] - +{- -- This is my standard container setup, featuring automatic upgrades. standardContainer :: DebianSuite -> Architecture -> [Docker.Containerized Property] -> Docker.Container standardContainer suite arch ps = Docker.containerFrom @@ -190,6 +180,7 @@ standardContainer suite arch ps = Docker.containerFrom & Apt.stdSourcesList suite & Apt.unattendedUpgrades ] ++ ps +-} -- Clean up a system as installed by cloudatcost.com cleanCloudAtCost :: Property @@ -218,3 +209,6 @@ myDnsSecondary = where master = ["80.68.85.49", "2001:41c8:125:49::10"] -- wren branchablemaster = ["66.228.46.55", "2600:3c03::f03c:91ff:fedf:c0e5"] + +main :: IO () +main = defaultMain hosts --, Docker.containerProperties container] diff --git a/propellor.cabal b/propellor.cabal index 0c7e3494..5497cc6b 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -88,12 +88,14 @@ Library Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.GitAnnexBuilder + Propellor.Attr Propellor.Message Propellor.PrivData Propellor.Engine Propellor.Exception Propellor.Types Other-Modules: + Propellor.Types.Attr Propellor.CmdLine Propellor.SimpleSh Propellor.Property.Docker.Shim -- cgit v1.3-2-g0d8e