From 969f01eb73cee1e49faf0195de5c784182349261 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Apr 2014 21:28:15 -0400 Subject: todo --- TODO | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'TODO') diff --git a/TODO b/TODO index 3b816ad3..40bbd01e 100644 --- a/TODO +++ b/TODO @@ -14,3 +14,9 @@ * Should properties be a tree rather than a list? * Only make docker garbage collection run once a day or something to avoid GC after a temp fail. +* Need a way for a dns server host to look at the properties of + the other hosts and generate a zone file. For example, mapping + openid.kitenet.net to a CNAME to clam.kitenet.net, which is where + the docker container for that service is located. Moving containers + to a different host, or duplicating a container on multiple hosts + would then update DNS too -- cgit v1.3-2-g0d8e From 064cdd8fc575e5a16fa20bf382387560e9e4c580 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 9 Apr 2014 00:54:27 -0400 Subject: propellor spin --- Propellor/PrivData.hs | 1 + Propellor/Property/Scheduled.hs | 58 +++++++ TODO | 2 - Utility/QuickCheck.hs | 52 ++++++ Utility/Scheduled.hs | 358 ++++++++++++++++++++++++++++++++++++++++ config-joey.hs | 8 +- config-simple.hs | 3 +- debian/changelog | 1 + propellor.cabal | 10 +- 9 files changed, 484 insertions(+), 9 deletions(-) create mode 100644 Propellor/Property/Scheduled.hs create mode 100644 Utility/QuickCheck.hs create mode 100644 Utility/Scheduled.hs (limited to 'TODO') diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs index e768ae9e..2897d425 100644 --- a/Propellor/PrivData.hs +++ b/Propellor/PrivData.hs @@ -23,6 +23,7 @@ withPrivData field a = maybe missing a =<< getPrivData field where missing = do warningMessage $ "Missing privdata " ++ show field + putStrLn $ "Fix this by running: propellor --set $hostname '" ++ show field ++ "'" return FailedChange getPrivData :: PrivDataField -> IO (Maybe String) diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs new file mode 100644 index 00000000..42ff0068 --- /dev/null +++ b/Propellor/Property/Scheduled.hs @@ -0,0 +1,58 @@ +module Propellor.Property.Scheduled + ( period + , Recurrance(..) + , WeekDay + , MonthDay + , YearDay + ) where + +import Propellor +import Utility.Scheduled + +import Data.Time.Clock +import Data.Time.LocalTime +import qualified Data.Map as M + +-- | Makes a Property only be checked every so often. +-- +-- This uses the description of the Property to keep track of when it was +-- last run. +period :: Property -> Recurrance -> Property +period prop recurrance = Property desc $ do + lasttime <- getLastChecked (propertyDesc prop) + nexttime <- fmap startTime <$> nextTime schedule lasttime + t <- localNow + if Just t >= nexttime + then do + r <- ensureProperty prop + setLastChecked t (propertyDesc prop) + return r + else noChange + where + schedule = Schedule recurrance AnyTime + desc = propertyDesc prop ++ " (period " ++ show recurrance ++ ")" + +lastCheckedFile :: FilePath +lastCheckedFile = localdir ".lastchecked" + +getLastChecked :: Desc -> IO (Maybe LocalTime) +getLastChecked desc = M.lookup desc <$> readLastChecked + +localNow :: IO LocalTime +localNow = do + now <- getCurrentTime + tz <- getTimeZone now + return $ utcToLocalTime tz now + +setLastChecked :: LocalTime -> Desc -> IO () +setLastChecked time desc = do + m <- readLastChecked + writeLastChecked (M.insert desc time m) + +readLastChecked :: IO (M.Map Desc LocalTime) +readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go + where + go = readish <$> readFile lastCheckedFile + +writeLastChecked :: M.Map Desc LocalTime -> IO () +writeLastChecked = writeFile lastCheckedFile . show diff --git a/TODO b/TODO index 40bbd01e..a1f1c689 100644 --- a/TODO +++ b/TODO @@ -12,8 +12,6 @@ says they are unchanged even when they changed and triggered a reprovision. * Should properties be a tree rather than a list? -* Only make docker garbage collection run once a day or something - to avoid GC after a temp fail. * Need a way for a dns server host to look at the properties of the other hosts and generate a zone file. For example, mapping openid.kitenet.net to a CNAME to clam.kitenet.net, which is where diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs new file mode 100644 index 00000000..7f7234c7 --- /dev/null +++ b/Utility/QuickCheck.hs @@ -0,0 +1,52 @@ +{- QuickCheck with additional instances + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Utility.QuickCheck + ( module X + , module Utility.QuickCheck + ) where + +import Test.QuickCheck as X +import Data.Time.Clock.POSIX +import System.Posix.Types +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Applicative + +instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where + arbitrary = M.fromList <$> arbitrary + +instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where + arbitrary = S.fromList <$> arbitrary + +{- Times before the epoch are excluded. -} +instance Arbitrary POSIXTime where + arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral + +instance Arbitrary EpochTime where + arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral + +{- Pids are never negative, or 0. -} +instance Arbitrary ProcessID where + arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) + +{- Inodes are never negative. -} +instance Arbitrary FileID where + arbitrary = nonNegative arbitrarySizedIntegral + +{- File sizes are never negative. -} +instance Arbitrary FileOffset where + arbitrary = nonNegative arbitrarySizedIntegral + +nonNegative :: (Num a, Ord a) => Gen a -> Gen a +nonNegative g = g `suchThat` (>= 0) + +positive :: (Num a, Ord a) => Gen a -> Gen a +positive g = g `suchThat` (> 0) diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs new file mode 100644 index 00000000..6b0609d8 --- /dev/null +++ b/Utility/Scheduled.hs @@ -0,0 +1,358 @@ +{- scheduled activities + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Scheduled ( + Schedule(..), + Recurrance(..), + ScheduledTime(..), + NextTime(..), + WeekDay, + MonthDay, + YearDay, + nextTime, + startTime, + fromSchedule, + fromScheduledTime, + toScheduledTime, + fromRecurrance, + toRecurrance, + toSchedule, + parseSchedule, + prop_schedule_roundtrips +) where + +import Utility.Data +import Utility.QuickCheck +import Utility.PartialPrelude +import Utility.Misc + +import Control.Applicative +import Data.List +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate +import Data.Time.Calendar.OrdinalDate +import Data.Tuple.Utils +import Data.Char + +{- Some sort of scheduled event. -} +data Schedule = Schedule Recurrance ScheduledTime + deriving (Eq, Read, Show, Ord) + +data Recurrance + = Daily + | Weekly (Maybe WeekDay) + | Monthly (Maybe MonthDay) + | Yearly (Maybe YearDay) + -- ^ Days, Weeks, or Months of the year evenly divisible by a number. + -- (Divisible Year is years evenly divisible by a number.) + | Divisible Int Recurrance + deriving (Eq, Read, Show, Ord) + +type WeekDay = Int +type MonthDay = Int +type YearDay = Int + +data ScheduledTime + = AnyTime + | SpecificTime Hour Minute + deriving (Eq, Read, Show, Ord) + +type Hour = Int +type Minute = Int + +{- Next time a Schedule should take effect. The NextTimeWindow is used + - when a Schedule is allowed to start at some point within the window. -} +data NextTime + = NextTimeExactly LocalTime + | NextTimeWindow LocalTime LocalTime + deriving (Eq, Read, Show) + +startTime :: NextTime -> LocalTime +startTime (NextTimeExactly t) = t +startTime (NextTimeWindow t _) = t + +nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime) +nextTime schedule lasttime = do + now <- getCurrentTime + tz <- getTimeZone now + return $ calcNextTime schedule lasttime $ utcToLocalTime tz now + +{- Calculate the next time that fits a Schedule, based on the + - last time it occurred, and the current time. -} +calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime +calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime + | scheduledtime == AnyTime = do + next <- findfromtoday True + return $ case next of + NextTimeWindow _ _ -> next + NextTimeExactly t -> window (localDay t) (localDay t) + | otherwise = NextTimeExactly . startTime <$> findfromtoday False + where + findfromtoday anytime = findfrom recurrance afterday today + where + today = localDay currenttime + afterday = sameaslastday || toolatetoday + toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime + sameaslastday = lastday == Just today + lastday = localDay <$> lasttime + nexttime = case scheduledtime of + AnyTime -> TimeOfDay 0 0 0 + SpecificTime h m -> TimeOfDay h m 0 + exactly d = NextTimeExactly $ LocalTime d nexttime + window startd endd = NextTimeWindow + (LocalTime startd nexttime) + (LocalTime endd (TimeOfDay 23 59 0)) + findfrom r afterday day = case r of + Daily + | afterday -> Just $ exactly $ addDays 1 day + | otherwise -> Just $ exactly day + Weekly Nothing + | afterday -> skip 1 + | otherwise -> case (wday <$> lastday, wday day) of + (Nothing, _) -> Just $ window day (addDays 6 day) + (Just old, curr) + | old == curr -> Just $ window day (addDays 6 day) + | otherwise -> skip 1 + Monthly Nothing + | afterday -> skip 1 + | maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday -> + -- Window only covers current month, + -- in case there is a Divisible requirement. + Just $ window day (endOfMonth day) + | otherwise -> skip 1 + Yearly Nothing + | afterday -> skip 1 + | maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday -> + Just $ window day (endOfYear day) + | otherwise -> skip 1 + Weekly (Just w) + | w < 0 || w > maxwday -> Nothing + | w == wday day -> if afterday + then Just $ exactly $ addDays 7 day + else Just $ exactly day + | otherwise -> Just $ exactly $ + addDays (fromIntegral $ (w - wday day) `mod` 7) day + Monthly (Just m) + | m < 0 || m > maxmday -> Nothing + -- TODO can be done more efficiently than recursing + | m == mday day -> if afterday + then skip 1 + else Just $ exactly day + | otherwise -> skip 1 + Yearly (Just y) + | y < 0 || y > maxyday -> Nothing + | y == yday day -> if afterday + then skip 365 + else Just $ exactly day + | otherwise -> skip 1 + Divisible n r'@Daily -> handlediv n r' yday (Just maxyday) + Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum) + Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum) + Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing + Divisible _ r'@(Divisible _ _) -> findfrom r' afterday day + where + skip n = findfrom r False (addDays n day) + handlediv n r' getval mmax + | n > 0 && maybe True (n <=) mmax = + findfromwhere r' (divisible n . getval) afterday day + | otherwise = Nothing + findfromwhere r p afterday day + | maybe True (p . getday) next = next + | otherwise = maybe Nothing (findfromwhere r p True . getday) next + where + next = findfrom r afterday day + getday = localDay . startTime + divisible n v = v `rem` n == 0 + +endOfMonth :: Day -> Day +endOfMonth day = + let (y,m,_d) = toGregorian day + in fromGregorian y m (gregorianMonthLength y m) + +endOfYear :: Day -> Day +endOfYear day = + let (y,_m,_d) = toGregorian day + in endOfMonth (fromGregorian y maxmnum 1) + +-- extracting various quantities from a Day +wday :: Day -> Int +wday = thd3 . toWeekDate +wnum :: Day -> Int +wnum = snd3 . toWeekDate +mday :: Day -> Int +mday = thd3 . toGregorian +mnum :: Day -> Int +mnum = snd3 . toGregorian +yday :: Day -> Int +yday = snd . toOrdinalDate +ynum :: Day -> Int +ynum = fromIntegral . fst . toOrdinalDate + +{- Calendar max and mins. -} +maxyday :: Int +maxyday = 366 -- with leap days +minyday :: Int +minyday = 365 +maxwnum :: Int +maxwnum = 53 -- some years have more than 52 +maxmday :: Int +maxmday = 31 +minmday :: Int +minmday = 28 +maxmnum :: Int +maxmnum = 12 +maxwday :: Int +maxwday = 7 + +fromRecurrance :: Recurrance -> String +fromRecurrance (Divisible n r) = + fromRecurrance' (++ "s divisible by " ++ show n) r +fromRecurrance r = fromRecurrance' ("every " ++) r + +fromRecurrance' :: (String -> String) -> Recurrance -> String +fromRecurrance' a Daily = a "day" +fromRecurrance' a (Weekly n) = onday n (a "week") +fromRecurrance' a (Monthly n) = onday n (a "month") +fromRecurrance' a (Yearly n) = onday n (a "year") +fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used + +onday :: Maybe Int -> String -> String +onday (Just n) s = "on day " ++ show n ++ " of " ++ s +onday Nothing s = s + +toRecurrance :: String -> Maybe Recurrance +toRecurrance s = case words s of + ("every":"day":[]) -> Just Daily + ("on":"day":sd:"of":"every":something:[]) -> withday sd something + ("every":something:[]) -> noday something + ("days":"divisible":"by":sn:[]) -> + Divisible <$> getdivisor sn <*> pure Daily + ("on":"day":sd:"of":something:"divisible":"by":sn:[]) -> + Divisible + <$> getdivisor sn + <*> withday sd something + ("every":something:"divisible":"by":sn:[]) -> + Divisible + <$> getdivisor sn + <*> noday something + (something:"divisible":"by":sn:[]) -> + Divisible + <$> getdivisor sn + <*> noday something + _ -> Nothing + where + constructor "week" = Just Weekly + constructor "month" = Just Monthly + constructor "year" = Just Yearly + constructor u + | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u + | otherwise = Nothing + withday sd u = do + c <- constructor u + d <- readish sd + Just $ c (Just d) + noday u = do + c <- constructor u + Just $ c Nothing + getdivisor sn = do + n <- readish sn + if n > 0 + then Just n + else Nothing + +fromScheduledTime :: ScheduledTime -> String +fromScheduledTime AnyTime = "any time" +fromScheduledTime (SpecificTime h m) = + show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm + where + pad n s = take (n - length s) (repeat '0') ++ s + (h', ampm) + | h == 0 = (12, "AM") + | h < 12 = (h, "AM") + | h == 12 = (h, "PM") + | otherwise = (h - 12, "PM") + +toScheduledTime :: String -> Maybe ScheduledTime +toScheduledTime "any time" = Just AnyTime +toScheduledTime v = case words v of + (s:ampm:[]) + | map toUpper ampm == "AM" -> + go s h0 + | map toUpper ampm == "PM" -> + go s (\h -> (h0 h) + 12) + | otherwise -> Nothing + (s:[]) -> go s id + _ -> Nothing + where + h0 h + | h == 12 = 0 + | otherwise = h + go :: String -> (Int -> Int) -> Maybe ScheduledTime + go s adjust = + let (h, m) = separate (== ':') s + in SpecificTime + <$> (adjust <$> readish h) + <*> if null m then Just 0 else readish m + +fromSchedule :: Schedule -> String +fromSchedule (Schedule recurrance scheduledtime) = unwords + [ fromRecurrance recurrance + , "at" + , fromScheduledTime scheduledtime + ] + +toSchedule :: String -> Maybe Schedule +toSchedule = eitherToMaybe . parseSchedule + +parseSchedule :: String -> Either String Schedule +parseSchedule s = do + r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right + (toRecurrance recurrance) + t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right + (toScheduledTime scheduledtime) + Right $ Schedule r t + where + (rws, tws) = separate (== "at") (words s) + recurrance = unwords rws + scheduledtime = unwords tws + +instance Arbitrary Schedule where + arbitrary = Schedule <$> arbitrary <*> arbitrary + +instance Arbitrary ScheduledTime where + arbitrary = oneof + [ pure AnyTime + , SpecificTime + <$> choose (0, 23) + <*> choose (1, 59) + ] + +instance Arbitrary Recurrance where + arbitrary = oneof + [ pure Daily + , Weekly <$> arbday + , Monthly <$> arbday + , Yearly <$> arbday + , Divisible + <$> positive arbitrary + <*> oneof -- no nested Divisibles + [ pure Daily + , Weekly <$> arbday + , Monthly <$> arbday + , Yearly <$> arbday + ] + ] + where + arbday = oneof + [ Just <$> nonNegative arbitrary + , pure Nothing + ] + +prop_schedule_roundtrips :: Schedule -> Bool +prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s diff --git a/config-joey.hs b/config-joey.hs index 3b796ce7..6c4507d6 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -2,6 +2,7 @@ import Propellor import Propellor.CmdLine +import Propellor.Property.Scheduled import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network @@ -38,21 +39,22 @@ host hostname@"clam.kitenet.net" = standardSystem Unstable $ props & JoeySites.oldUseNetshellBox & Docker.docked container hostname "openid-provider" & Docker.configured - & Docker.garbageCollected + & Docker.garbageCollected `period` Daily -- Orca is the main git-annex build box. host hostname@"orca.kitenet.net" = standardSystem Unstable $ props & Hostname.set hostname & Apt.unattendedUpgrades & Docker.configured - & Apt.buildDep ["git-annex"] + & 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.garbageCollected + & Docker.garbageCollected `period` Daily -- My laptop host _hostname@"darkstar.kitenet.net" = Just $ props & Docker.configured + & Apt.buildDep ["git-annex"] `period` Daily -- add more hosts here... --host "foo.example.com" = diff --git a/config-simple.hs b/config-simple.hs index 5e43b467..6784f76c 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -3,6 +3,7 @@ import Propellor import Propellor.CmdLine +import Propellor.Property.Scheduled import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network @@ -34,7 +35,7 @@ host hostname@"mybox.example.com" = Just $ props & Network.ipv6to4 & File.dirExists "/var/www" & Docker.docked container hostname "webserver" - & Docker.garbageCollected + & Docker.garbageCollected `period` Daily & Cron.runPropellor "30 * * * *" -- add more hosts here... --host "foo.example.com" = diff --git a/debian/changelog b/debian/changelog index 4b04fb30..d83b6ad8 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,7 @@ propellor (0.2.4) UNRELEASED; urgency=medium * ipv6to4: Ensure interface is brought up automatically on boot. * Enabling unattended upgrades now ensures that cron is installed and running to perform them. + * Properties can be scheduled to only be checked after a given time period. -- Joey Hess Tue, 08 Apr 2014 18:07:12 -0400 diff --git a/propellor.cabal b/propellor.cabal index 0869ef58..c3f4f4c0 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -38,7 +38,7 @@ 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 + containers, network, async, time, QuickCheck if (! os(windows)) Build-Depends: unix @@ -48,7 +48,7 @@ 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 + containers, network, async, time, QuickCheck if (! os(windows)) Build-Depends: unix @@ -57,7 +57,7 @@ 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 + containers, network, async, time, QuickCheck if (! os(windows)) Build-Depends: unix @@ -73,6 +73,8 @@ Library Propellor.Property.File Propellor.Property.Network Propellor.Property.Reboot + Propellor.Property.Scheduled + Propellor.Property.Service Propellor.Property.Ssh Propellor.Property.Sudo Propellor.Property.Tor @@ -103,9 +105,11 @@ Library Utility.PosixFiles Utility.Process Utility.SafeCommand + Utility.Scheduled Utility.ThreadScheduler Utility.Tmp Utility.UserInfo + Utility.QuickCheck source-repository head type: git -- cgit v1.3-2-g0d8e From cf73387300bd66ab05ffd2632aed7903e0ffbb96 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 9 Apr 2014 18:37:11 -0400 Subject: updat --- TODO | 3 +++ 1 file changed, 3 insertions(+) (limited to 'TODO') diff --git a/TODO b/TODO index a1f1c689..6f0de948 100644 --- a/TODO +++ b/TODO @@ -18,3 +18,6 @@ the docker container for that service is located. Moving containers to a different host, or duplicating a container on multiple hosts would then update DNS too +* There is no way for a property of a docker container to require + some property be met outside the container. For example, some servers + need ntp installed for a good date source. -- cgit v1.3-2-g0d8e From 13a4d4889c48fc3ee44956440a87f4656da7fcc9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 10 Apr 2014 16:03:49 -0400 Subject: Use ssh connection caching, especially when bootstrapping. --- Propellor/CmdLine.hs | 27 ++++++++++++++++++++------- TODO | 3 --- debian/changelog | 1 + 3 files changed, 21 insertions(+), 10 deletions(-) (limited to 'TODO') diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index e4cab86c..e32ccdbe 100644 --- a/Propellor/CmdLine.hs +++ b/Propellor/CmdLine.hs @@ -16,6 +16,7 @@ import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Docker.Shim as DockerShim import Utility.FileMode import Utility.SafeCommand +import Utility.UserInfo usage :: IO a usage = do @@ -167,9 +168,10 @@ spin host = do url <- getUrl void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] void $ boolSystem "git" [Param "push"] - go url =<< gpgDecrypt (privDataFile host) + cacheparams <- toCommand <$> sshCachingParams host + go cacheparams url =<< gpgDecrypt (privDataFile host) where - go url privdata = withBothHandles createProcessSuccess (proc "ssh" [user, bootstrapcmd]) $ \(toh, fromh) -> do + go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do let finish = do senddata toh (privDataFile host) privDataMarker privdata hClose toh @@ -185,7 +187,7 @@ spin host = do hClose toh hClose fromh sendGitClone host url - go url privdata + go cacheparams url privdata user = "root@"++host @@ -221,12 +223,11 @@ spin host = do sendGitClone :: HostName -> String -> IO () sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ do branch <- getCurrentBranch + cacheparams <- sshCachingParams host withTmpFile "propellor.git" $ \tmp _ -> allM id - -- TODO: ssh connection caching, or better push method - -- with less connections. [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] - , boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)] - , boolSystem "ssh" [Param ("root@"++host), Param $ unpackcmd branch] + , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++host++":"++remotebundle)] + , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++host), Param $ unpackcmd branch] ] where remotebundle = "/usr/local/propellor.git" @@ -341,3 +342,15 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" updateGlobalLogger rootLoggerName $ setLevel DEBUG . setHandlers [f] go _ = noop + +-- Parameters can be passed to both ssh and scp. +sshCachingParams :: HostName -> IO [CommandParam] +sshCachingParams hostname = do + home <- myHomeDir + let cachedir = home ".ssh" "propellor" + createDirectoryIfMissing False cachedir + let socketfile = cachedir hostname ++ ".sock" + return + [ Param "-o", Param ("ControlPath=" ++ socketfile) + , Params "-o ControlMaster=auto -o ControlPersist=yes" + ] diff --git a/TODO b/TODO index 6f0de948..0cc8db1b 100644 --- a/TODO +++ b/TODO @@ -2,9 +2,6 @@ run it once for the whole. For example, may want to restart apache, but only once despite many config changes being made to satisfy properties. onChange is a poor substitute. -* --spin needs 4 ssh connections when bootstrapping a new host - that does not have the git repo yet. Should be possible to get that - down to 1. * Currently only Debian and derivatives are supported by most Properties. One way to improve that would be to parameterize Properties with a Distribution witness. diff --git a/debian/changelog b/debian/changelog index ed882cf2..55043d5b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -7,6 +7,7 @@ propellor (0.2.4) UNRELEASED; urgency=medium * Fix bootstrapping of dependencies. * Fix compilation on Debian stable. * Include security updates in sources.list for stable and testing. + * Use ssh connection caching, especially when bootstrapping. -- Joey Hess Tue, 08 Apr 2014 18:07:12 -0400 -- 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 'TODO') 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