summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-04-12 14:14:20 -0400
committerJoey Hess2014-04-12 14:14:20 -0400
commit9e9d0f1d410f806b546abed6055b25ac81f7042e (patch)
tree5a13b54820988c87f3567f90a1c5280763fc885e
parent61ed9ef26c275ee8466e3d86b0a9b5ae275e3d4e (diff)
parentb3af5e44d0683033043511fefa3c5fc0ca2a4073 (diff)
Merge branch 'joeyconfig'
-rw-r--r--Propellor/Exception.hs6
-rw-r--r--Propellor/PrivData.hs3
-rw-r--r--Propellor/Property.hs1
-rw-r--r--Propellor/Property/Scheduled.hs2
-rw-r--r--Utility/Scheduled.hs118
-rw-r--r--config-joey.hs12
-rw-r--r--debian/changelog6
7 files changed, 101 insertions, 47 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
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)
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
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
index 11e3b569..d3ae0620 100644
--- a/Utility/Scheduled.hs
+++ b/Utility/Scheduled.hs
@@ -1,6 +1,6 @@
{- scheduled activities
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
-
- 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 cd0583fb..8a585451 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 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 <joeyh@debian.org> Fri, 11 Apr 2014 15:00:11 -0400
+
propellor (0.3.0) unstable; urgency=medium
* ipv6to4: Ensure interface is brought up automatically on boot.