propellor spin

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)

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

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

Utility/QuickCheck.hs

@@ -0,0 +1,52 @@
+{- QuickCheck with additional instances
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - 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)

Utility/Scheduled.hs

@@ -0,0 +1,358 @@
+{- scheduled activities
+ - 
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - 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

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" =

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" =

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 <joeyh@debian.org>  Tue, 08 Apr 2014 18:07:12 -0400
 

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