From a57022deb88ca0216b01791f4325d4aace6de8f3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Apr 2014 01:52:12 -0400 Subject: propellor spin --- Propellor/Exception.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Propellor/Exception.hs b/Propellor/Exception.hs index bd9212a8..f6fd15f1 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 -- cgit v1.2.3 From ba6e87cde965dface863742cf84a59782ae29aee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Apr 2014 01:53:37 -0400 Subject: propellor spin --- Propellor/Property/Scheduled.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs index 8341765e..769a3931 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 -- cgit v1.2.3 -- cgit v1.2.3 From be01532282bdca11e6fc97114206e44872d16eea Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Apr 2014 02:03:51 -0400 Subject: foo --- Propellor/PrivData.hs | 3 +++ Propellor/Property.hs | 1 + 2 files changed, 4 insertions(+) diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs index 5adc9e94..c7af1aac 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 3a3c1cb1..83e19a73 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) -- cgit v1.2.3 From 99ec97db855bbcb7e72b5519193275ac1161bcf9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Apr 2014 15:00:27 -0400 Subject: Merge scheduler bug fix from git-annex. --- Utility/Scheduled.hs | 46 +++++++++++++++++++++++----------------------- debian/changelog | 6 ++++++ 2 files changed, 29 insertions(+), 23 deletions(-) diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index 11e3b569..2b7cae2b 100644 --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -108,65 +108,65 @@ 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 = 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 <$> lastday, 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 -> + | maybe True (\old -> mnum candidate > mnum old && mday candidate >= (mday old `mod` minmday)) lastday -> -- Window only covers current month, -- in case there is a Divisible requirement. - Just $ window day (endOfMonth day) + 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 (\old -> ynum candidate > ynum old && yday candidate >= (yday old `mod` minyday)) lastday -> + 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 diff --git a/debian/changelog b/debian/changelog index c6ea2ebd..29f1787e 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. -- cgit v1.2.3 From 12b2ccaccbe9b1bfc17d576fd65806ec9d09782a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 12 Apr 2014 13:32:04 -0400 Subject: merge from git-annex --- Utility/Scheduled.hs | 80 ++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 59 insertions(+), 21 deletions(-) diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index 2b7cae2b..d3ae0620 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,27 +110,31 @@ calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime window startd endd = NextTimeWindow (LocalTime startd nexttime) (LocalTime endd (TimeOfDay 23 59 0)) - findfrom r afterday candidate = 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 candidate | otherwise -> Just $ exactly candidate Weekly Nothing | afterday -> skip 1 - | otherwise -> case (wday <$> lastday, wday candidate) of + | otherwise -> case (wday <$> lastrun, wday candidate) of (Nothing, _) -> Just $ window candidate (addDays 6 candidate) (Just old, curr) | old == curr -> Just $ window candidate (addDays 6 candidate) | otherwise -> skip 1 Monthly Nothing | afterday -> skip 1 - | maybe True (\old -> mnum candidate > mnum old && mday candidate >= (mday old `mod` minmday)) lastday -> - -- Window only covers current month, - -- in case there is a Divisible requirement. + | maybe True (candidate `oneMonthPast`) lastrun -> Just $ window candidate (endOfMonth candidate) | otherwise -> skip 1 Yearly Nothing | afterday -> skip 1 - | maybe True (\old -> ynum candidate > ynum old && yday candidate >= (yday old `mod` minyday)) lastday -> + | maybe True (candidate `oneYearPast`) lastrun -> Just $ window candidate (endOfYear candidate) | otherwise -> skip 1 Weekly (Just w) @@ -170,6 +176,18 @@ calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime 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) -- cgit v1.2.3 From d9668a5d9af2cfe1905c90ee4b14d1d6d62e2dd1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 12 Apr 2014 13:32:12 -0400 Subject: fun --- config-joey.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/config-joey.hs b/config-joey.hs index cd0583fb..5f88191f 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,8 +80,11 @@ hosts = -- gitweb -- downloads.kitenet.net setup (including ssh key to turtle) - -------------------------------------------------------------------- - -- Docker Containers ----------------------------------- \o/ ----- + + ----- ----- ---- ::. + ------------------------------------ (\./) .-""-. -----------\o/--- + --- Docker ---------------------- `\'-'` \ ---------------- + --- containers ------------------------ '.___,_^__/ ---------------- -------------------------------------------------------------------- -- Simple web server, publishing the outside host's /var/www -- cgit v1.2.3 From b3af5e44d0683033043511fefa3c5fc0ca2a4073 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 12 Apr 2014 14:14:09 -0400 Subject: improved art courtesy paroneayea --- config-joey.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/config-joey.hs b/config-joey.hs index 5f88191f..8a585451 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -80,12 +80,13 @@ hosts = -- gitweb -- downloads.kitenet.net setup (including ssh key to turtle) - - ----- ----- ---- ::. - ------------------------------------ (\./) .-""-. -----------\o/--- - --- Docker ---------------------- `\'-'` \ ---------------- - --- containers ------------------------ '.___,_^__/ ---------------- - -------------------------------------------------------------------- + --' __|II| ,. +---- __|II|II|__ ( \_,/\ +-----'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'- +--------------------- | [Docker] / ---------------------- +--------------------- : / ----------------------- +---------------------- \____, o ,' ------------------------ +----------------------- '--,___________,' ------------------------- -- Simple web server, publishing the outside host's /var/www , standardContainer "webserver" Stable "amd64" -- cgit v1.2.3