summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Propellor/PrivData.hs1
-rw-r--r--Propellor/Property/Scheduled.hs58
-rw-r--r--TODO2
-rw-r--r--Utility/QuickCheck.hs52
-rw-r--r--Utility/Scheduled.hs358
-rw-r--r--config-joey.hs8
-rw-r--r--config-simple.hs3
-rw-r--r--debian/changelog1
-rw-r--r--propellor.cabal10
9 files changed, 484 insertions, 9 deletions
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 <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)
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 <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
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 <joeyh@debian.org> 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