diff --git a/Propellor/Exception.hs b/Propellor/Exception.hs index bd9212a..f6fd15f 100644 --- a/Propellor/Exception.hs +++ b/Propellor/Exception.hs @@ -4,13 +4,15 @@ module Propellor.Exception where import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M import Control.Exception -import Control.Applicative import Propellor.Types +import Propellor.Message -- | Catches IO exceptions and returns FailedChange. catchPropellor :: Propellor Result -> Propellor Result -catchPropellor a = either (\_ -> FailedChange) id <$> tryPropellor a +catchPropellor a = either err return =<< tryPropellor a + where + err e = warningMessage (show e) >> return FailedChange tryPropellor :: Propellor a -> Propellor (Either IOException a) tryPropellor = M.try diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs index 5adc9e9..c7af1aa 100644 --- a/Propellor/PrivData.hs +++ b/Propellor/PrivData.hs @@ -22,6 +22,9 @@ import Utility.Tmp import Utility.SafeCommand import Utility.Misc +-- | When the specified PrivDataField is available on the host Propellor +-- is provisioning, it provies the data to the action. Otherwise, it prints +-- a message to help the user make the necessary private data available. withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result withPrivData field a = maybe missing a =<< liftIO (getPrivData field) where diff --git a/Propellor/Property.hs b/Propellor/Property.hs index 3a3c1cb..83e19a7 100644 --- a/Propellor/Property.hs +++ b/Propellor/Property.hs @@ -105,6 +105,7 @@ 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]) (getAttr p . as) diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs index 8341765..769a393 100644 --- a/Propellor/Property/Scheduled.hs +++ b/Propellor/Property/Scheduled.hs @@ -61,7 +61,7 @@ setLastChecked time desc = do readLastChecked :: IO (M.Map Desc LocalTime) readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go where - go = readish <$> readFile lastCheckedFile + go = readish <$> readFileStrict lastCheckedFile writeLastChecked :: M.Map Desc LocalTime -> IO () writeLastChecked = writeFile lastCheckedFile . show diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index 11e3b56..d3ae062 100644 --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -1,6 +1,6 @@ {- scheduled activities - - - Copyright 2013 Joey Hess + - Copyright 2013-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,6 +14,7 @@ module Utility.Scheduled ( MonthDay, YearDay, nextTime, + calcNextTime, startTime, fromSchedule, fromScheduledTime, @@ -22,7 +23,8 @@ module Utility.Scheduled ( toRecurrance, toSchedule, parseSchedule, - prop_schedule_roundtrips + prop_schedule_roundtrips, + prop_past_sane, ) where import Utility.Data @@ -66,8 +68,8 @@ data ScheduledTime 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. -} +-- | 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 @@ -83,10 +85,10 @@ nextTime schedule lasttime = do 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. -} +-- | 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 +calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime | scheduledtime == AnyTime = do next <- findfromtoday True return $ case next of @@ -97,10 +99,10 @@ calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime findfromtoday anytime = findfrom recurrance afterday today where today = localDay currenttime - afterday = sameaslastday || toolatetoday + afterday = sameaslastrun || toolatetoday toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime - sameaslastday = lastday == Just today - lastday = localDay <$> lasttime + sameaslastrun = lastrun == Just today + lastrun = localDay <$> lasttime nexttime = case scheduledtime of AnyTime -> TimeOfDay 0 0 0 SpecificTime h m -> TimeOfDay h m 0 @@ -108,68 +110,84 @@ calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime window startd endd = NextTimeWindow (LocalTime startd nexttime) (LocalTime endd (TimeOfDay 23 59 0)) - findfrom r afterday day = case r of + findfrom r afterday candidate + | ynum candidate > (ynum (localDay currenttime)) + 100 = + -- avoid possible infinite recusion + error $ "bug: calcNextTime did not find a time within 100 years to run " ++ + show (schedule, lasttime, currenttime) + | otherwise = findfromChecked r afterday candidate + findfromChecked r afterday candidate = case r of Daily - | afterday -> Just $ exactly $ addDays 1 day - | otherwise -> Just $ exactly day + | afterday -> Just $ exactly $ addDays 1 candidate + | otherwise -> Just $ exactly candidate Weekly Nothing | afterday -> skip 1 - | otherwise -> case (wday <$> lastday, wday day) of - (Nothing, _) -> Just $ window day (addDays 6 day) + | otherwise -> case (wday <$> lastrun, wday candidate) of + (Nothing, _) -> Just $ window candidate (addDays 6 candidate) (Just old, curr) - | old == curr -> Just $ window day (addDays 6 day) + | old == curr -> Just $ window candidate (addDays 6 candidate) | 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) + | maybe True (candidate `oneMonthPast`) lastrun -> + Just $ window candidate (endOfMonth candidate) | 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) + | maybe True (candidate `oneYearPast`) lastrun -> + Just $ window candidate (endOfYear candidate) | 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 + | w == wday candidate -> if afterday + then Just $ exactly $ addDays 7 candidate + else Just $ exactly candidate | otherwise -> Just $ exactly $ - addDays (fromIntegral $ (w - wday day) `mod` 7) day + addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate Monthly (Just m) | m < 0 || m > maxmday -> Nothing -- TODO can be done more efficiently than recursing - | m == mday day -> if afterday + | m == mday candidate -> if afterday then skip 1 - else Just $ exactly day + else Just $ exactly candidate | otherwise -> skip 1 Yearly (Just y) | y < 0 || y > maxyday -> Nothing - | y == yday day -> if afterday + | y == yday candidate -> if afterday then skip 365 - else Just $ exactly day + else Just $ exactly candidate | 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 + Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate where - skip n = findfrom r False (addDays n day) + skip n = findfrom r False (addDays n candidate) handlediv n r' getval mmax | n > 0 && maybe True (n <=) mmax = - findfromwhere r' (divisible n . getval) afterday day + findfromwhere r' (divisible n . getval) afterday candidate | otherwise = Nothing - findfromwhere r p afterday day + findfromwhere r p afterday candidate | maybe True (p . getday) next = next | otherwise = maybe Nothing (findfromwhere r p True . getday) next where - next = findfrom r afterday day + next = findfrom r afterday candidate getday = localDay . startTime divisible n v = v `rem` n == 0 +-- Check if the new Day occurs one month or more past the old Day. +oneMonthPast :: Day -> Day -> Bool +new `oneMonthPast` old = fromGregorian y (m+1) d <= new + where + (y,m,d) = toGregorian old + +-- Check if the new Day occurs one year or more past the old Day. +oneYearPast :: Day -> Day -> Bool +new `oneYearPast` old = fromGregorian (y+1) m d <= new + where + (y,m,d) = toGregorian old + endOfMonth :: Day -> Day endOfMonth day = let (y,m,_d) = toGregorian day @@ -194,17 +212,13 @@ yday = snd . toOrdinalDate ynum :: Day -> Int ynum = fromIntegral . fst . toOrdinalDate -{- Calendar max and mins. -} +-- Calendar max values. 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 @@ -356,3 +370,27 @@ instance Arbitrary Recurrance where prop_schedule_roundtrips :: Schedule -> Bool prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s + +prop_past_sane :: Bool +prop_past_sane = and + [ all (checksout oneMonthPast) (mplus1 ++ yplus1) + , all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1)) + , all (checksout oneYearPast) yplus1 + , all (not . (checksout oneYearPast)) (map swap yplus1) + ] + where + mplus1 = -- new date old date, 1+ months before it + [ (fromGregorian 2014 01 15, fromGregorian 2013 12 15) + , (fromGregorian 2014 01 15, fromGregorian 2013 02 15) + , (fromGregorian 2014 02 15, fromGregorian 2013 01 15) + , (fromGregorian 2014 03 01, fromGregorian 2013 01 15) + , (fromGregorian 2014 03 01, fromGregorian 2013 12 15) + , (fromGregorian 2015 01 01, fromGregorian 2010 01 01) + ] + yplus1 = -- new date old date, 1+ years before it + [ (fromGregorian 2014 01 15, fromGregorian 2012 01 16) + , (fromGregorian 2014 01 15, fromGregorian 2013 01 14) + , (fromGregorian 2022 12 31, fromGregorian 2000 01 01) + ] + checksout cmp (new, old) = new `cmp` old + swap (a,b) = (b,a) diff --git a/config-joey.hs b/config-joey.hs index cd0583f..8a58545 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -71,7 +71,7 @@ hosts = & Apt.buildDep ["git-annex"] `period` Daily & Git.daemonRunning "/srv/git" & File.ownerGroup "/srv/git" "joey" "joey" - -- git repos restore (how?) + -- git repos restore (how?) (also make backups!) -- family annex needs family members to have accounts, -- ssh host key etc.. finesse? -- (also should upgrade git-annex-shell for it..) @@ -80,9 +80,13 @@ hosts = -- gitweb -- downloads.kitenet.net setup (including ssh key to turtle) - -------------------------------------------------------------------- - -- Docker Containers ----------------------------------- \o/ ----- - -------------------------------------------------------------------- + --' __|II| ,. +---- __|II|II|__ ( \_,/\ +-----'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'- +--------------------- | [Docker] / ---------------------- +--------------------- : / ----------------------- +---------------------- \____, o ,' ------------------------ +----------------------- '--,___________,' ------------------------- -- Simple web server, publishing the outside host's /var/www , standardContainer "webserver" Stable "amd64" diff --git a/debian/changelog b/debian/changelog index c6ea2eb..29f1787 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +propellor (0.3.1) UNRELEASED; urgency=medium + + * Merge scheduler bug fix from git-annex. + + -- Joey Hess Fri, 11 Apr 2014 15:00:11 -0400 + propellor (0.3.0) unstable; urgency=medium * ipv6to4: Ensure interface is brought up automatically on boot.