From 4598b3824246c5d1862b82373a789b4d521a9d32 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 9 Oct 2018 20:07:50 +0200 Subject: [PATCH] Cron --- src/Cron.hs | 222 ++++++++++++++++++++++++++++++++++++ src/Cron/Types.hs | 74 ++++++++++++ src/Import/NoFoundation.hs | 4 + src/Jobs/Types.hs | 10 +- src/Model.hs | 4 +- src/Model/Types.hs | 2 +- test.sh | 14 +++ test/CronSpec.hs | 40 +++++++ test/Handler/ProfileSpec.hs | 8 +- test/TestImport.hs | 29 ++++- 10 files changed, 393 insertions(+), 14 deletions(-) create mode 100644 src/Cron.hs create mode 100644 src/Cron/Types.hs create mode 100755 test.sh create mode 100644 test/CronSpec.hs diff --git a/src/Cron.hs b/src/Cron.hs new file mode 100644 index 000000000..0b28fa81f --- /dev/null +++ b/src/Cron.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , PatternGuards + , ViewPatterns + , DeriveFunctor + , TemplateHaskell + , NamedFieldPuns + #-} + +module Cron + ( matchesCron + , CronNextMatch(..) + , nextCronMatch + ) where + +import ClassyPrelude +import Prelude (lcm) +import Cron.Types + +import Data.Time +import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid) +import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate, fromWeekDateValid) +import Data.Time.Zones + +import Numeric.Natural +import Data.Ratio ((%)) + +import qualified Data.Set as Set + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty + +import Utils.Lens.TH +import Control.Lens + + +data CronDate = CronDate + { cdYear, cdWeekOfYear, cdDayOfYear + , cdMonth, cdWeekOfMonth, cdDayOfMonth + , cdDayOfWeek + , cdHour, cdMinute, cdSecond :: Natural + } deriving (Eq, Show, Read) + +makeLenses_ ''CronDate + + +evalCronMatch :: CronMatch -> Natural -> Bool +evalCronMatch CronMatchAny _ = True +evalCronMatch CronMatchNone _ = False +evalCronMatch (CronMatchSome set) x = Set.member x $ toNullable set +evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0 +evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to +evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x +evalCronMatch (CronMatchUnion a b) x = evalCronMatch a x || evalCronMatch b x + +toCronDate :: LocalTime -> CronDate +toCronDate LocalTime{..} = CronDate{..} + where + (fromInteger -> cdYear, fromIntegral -> cdMonth, fromIntegral -> cdDayOfMonth) + = toGregorian localDay + (_, fromIntegral -> cdDayOfYear) + = toOrdinalDate localDay + (_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek) + = toWeekDate localDay + cdWeekOfMonth = go 1 localDay + where + go :: Natural -> Day -> Natural + go n day + | dow /= 4 = go n $ fromWeekDate y w 4 -- According to ISO week of month is determined by Thursday + | m == m' = go (succ n) day' + | otherwise = n + where + (y, w, dow) = toWeekDate day + day' + | w /= 0 = fromWeekDate y (pred w) dow + | otherwise = fromWeekDate (pred y) 53 dow + (_, m, _) = toGregorian day + (_, m', _) = toGregorian day' + TimeOfDay + { todHour = fromIntegral -> cdHour + , todMin = fromIntegral -> cdMinute + , todSec = round -> cdSecond + } = localTimeOfDay + +consistentCronDate :: CronDate -> Bool +consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do + gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth) + wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek) + guard $ gDay == wDay + oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear) + guard $ wDay == oDay + guard $ ((==) `on` cdWeekOfMonth) cd (toCronDate $ LocalTime wDay (error "TimeOfDay inspected in toCronDate")) + return True + + +data CronNextMatch a = MatchAsap | MatchAt a | MatchNone + deriving (Eq, Ord, Show, Read, Functor) + +instance Applicative CronNextMatch where + pure = MatchAt + _ <*> MatchNone = MatchNone + MatchNone <*> _ = MatchNone + _ <*> MatchAsap = MatchAsap + MatchAsap <*> _ = MatchAsap + MatchAt f <*> MatchAt x = MatchAt $ f x + +instance Alternative CronNextMatch where + empty = MatchNone + x <|> MatchNone = x + MatchNone <|> x = x + _ <|> MatchAsap = MatchAsap + MatchAsap <|> _ = MatchAsap + (MatchAt a) <|> (MatchAt _) = MatchAt a + + +listToMatch :: [a] -> CronNextMatch a +listToMatch [] = MatchNone +listToMatch (t:_) = MatchAt t + +genMatch :: Int -- ^ Period + -> Natural -- ^ Start value + -> CronMatch + -> [Natural] +genMatch p st CronMatchAny = take p [st..] +genMatch _ _ CronMatchNone = [] +genMatch p _ (CronMatchSome set) = take p . Set.toAscList $ toNullable set +genMatch p st (CronMatchStep step) = do + start <- [st..st + step] + guard $ (start `mod` step) == 0 + take (ceiling $ fromIntegral p % step) [start,start + step..] +genMatch p st (CronMatchContiguous from to) = take p $ [max st from..to] +genMatch _ _ (CronMatchIntersect CronMatchNone _) = [] +genMatch _ _ (CronMatchIntersect _ CronMatchNone) = [] +genMatch p st (CronMatchIntersect CronMatchAny other) = genMatch p st other +genMatch p st (CronMatchIntersect other CronMatchAny) = genMatch p st other +genMatch p st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2)) + = genMatch p st . CronMatchStep $ lcm st1 st2 +genMatch p st (CronMatchIntersect aGen bGen) + | [] <- as' = [] + | (a:as) <- as' = mergeAnd (a:as) (genMatch p a bGen) + where + as' = genMatch p st aGen + mergeAnd [] _ = [] + mergeAnd _ [] = [] + mergeAnd (a:as) (b:bs) + | a < b = mergeAnd as (b:bs) + | a == b = a : mergeAnd as bs + | a > b = mergeAnd (a:as) bs +genMatch p st (CronMatchUnion CronMatchNone other) = genMatch p st other +genMatch p st (CronMatchUnion other CronMatchNone) = genMatch p st other +genMatch p st (CronMatchUnion CronMatchAny _) = genMatch p st CronMatchAny +genMatch p st (CronMatchUnion _ CronMatchAny) = genMatch p st CronMatchAny +genMatch p st (CronMatchUnion aGen bGen) = merge (genMatch p st aGen) (genMatch p st bGen) + where + merge [] bs = bs + merge as [] = as + merge (a:as) (b:bs) + | a < b = a : merge as (b:bs) + | a == b = a : merge as bs + | a > b = b : merge (a:as) bs + +nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry + -> Maybe UTCTime -- ^ Time of last execution of the job + -> UTCTime -- ^ Current time, used only for `CronCalendar` + -> Cron + -> CronNextMatch UTCTime +nextCronMatch tz mPrev now c@Cron{..} + | isNothing mPrev + = execRef now False cronInitial + | isJust mPrev + , isNothing cronRepeat + = MatchNone + | Just prevT <- mPrev + , Just CronPeriod{..} <- cronRepeat + = case cronNext of + CronAsap + | addUTCTime cronMinInterval prevT <= now + -> MatchAsap + | otherwise + -> MatchAt $ addUTCTime cronMinInterval prevT + cronNext -> execRef (addUTCTime cronMinInterval prevT) True cronNext + where + execRef ref wasExecd cronAbsolute = case cronAbsolute of + CronAsap -> MatchAsap + CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts } + | ref <= ts -> MatchAt ts + | not wasExecd -> MatchAsap + | otherwise -> MatchNone + CronCalendar{..} -> listToMatch $ do + let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref + cronYear <- genMatch 400 cdYear cronYear + cronWeekOfYear <- genMatch 53 cdWeekOfYear cronWeekOfYear + cronDayOfYear <- genMatch 366 cdDayOfYear cronDayOfYear + cronMonth <- genMatch 12 cdMonth cronMonth + cronWeekOfMonth <- genMatch 5 cdWeekOfMonth cronWeekOfMonth + cronDayOfMonth <- genMatch 31 cdDayOfMonth cronDayOfMonth + cronDayOfWeek <- genMatch 7 cdDayOfWeek cronDayOfWeek + cronHour <- genMatch 24 cdHour cronHour + cronMinute <- genMatch 60 cdMinute cronMinute + cronSecond <- genMatch 60 cdSecond cronSecond + guard $ consistentCronDate CronDate{..} + localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) + let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) + return $ localTimeToUTCTZ tz LocalTime{..} + +matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry + -> Maybe UTCTime -- ^ Previous execution of the job + -> NominalDiffTime -- ^ Approximate time until next check + -> UTCTime -- ^ "Current" time + -> Cron + -> Bool +-- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron` +-- specification @c@ should match @now@, under the assumption that the next +-- check will occur no earlier than @now + prec@. +matchesCron tz mPrev prec now cron@Cron{cronOffset} = case nextCronMatch tz mPrev now cron of + MatchAsap -> True + MatchNone -> False + MatchAt ts -> ts < toT + where + toT = case cronOffset of + CronScheduleBefore -> addUTCTime prec now + CronScheduleAfter -> now diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs new file mode 100644 index 000000000..b1172bde0 --- /dev/null +++ b/src/Cron/Types.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + , DuplicateRecordFields + #-} + +module Cron.Types + ( Cron(..), Crontab + , CronScheduleOffset(..) + , CronMatch(..) + , CronAbsolute(..) + , CronPeriod(..) + ) where + +import ClassyPrelude + +import Utils.Lens.TH +import Control.Lens + +import Data.Time + +import Numeric.Natural + + +-- | When the scheduled time for a job falls between two wakeups of the timing +-- thread, execute the job on the wakeup before or after the scheduled time +data CronScheduleOffset + = CronScheduleBefore | CronScheduleAfter + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +makePrisms ''CronScheduleOffset + +data CronMatch + = CronMatchAny + | CronMatchNone + | CronMatchSome (NonNull (Set Natural)) + | CronMatchStep Natural + | CronMatchContiguous Natural Natural + | CronMatchIntersect CronMatch CronMatch + | CronMatchUnion CronMatch CronMatch + deriving (Show, Read) + +data CronAbsolute + = CronAsap + | CronTimestamp + { cronTimestamp :: LocalTime + } + | CronCalendar + { cronYear, cronWeekOfYear, cronDayOfYear + , cronMonth, cronWeekOfMonth, cronDayOfMonth + , cronDayOfWeek + , cronHour, cronMinute, cronSecond :: CronMatch + } + deriving (Show, Read) + +makeLenses_ ''CronAbsolute + +data CronPeriod = CronPeriod + { cronMinInterval :: NominalDiffTime + , cronNext :: CronAbsolute + } + deriving (Show) + +makeLenses_ ''CronPeriod + +data Cron = Cron + { cronInitial :: CronAbsolute + , cronRepeat :: Maybe CronPeriod + , cronOffset :: CronScheduleOffset + } + deriving (Show) + +makeLenses_ ''Cron + +type Crontab a = Map a Cron diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index e1d2dfe37..531535806 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -29,3 +29,7 @@ import Data.Pool as Import (Pool) import Network.HaskellNet.SMTP as Import (SMTPConnection) import Mail as Import + +import Data.Data as Import (Data) +import Data.Typeable as Import (Typeable) +import GHC.Generics as Import (Generic) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 552d37211..a27ad355a 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell , NoImplicitPrelude + , DeriveGeneric + , DeriveDataTypeable #-} module Jobs.Types @@ -15,9 +17,9 @@ import Data.Aeson.TH (deriveJSON) data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } | JobSendTestEmail { jEmail :: Text, jLanguages :: MailLanguages } - deriving (Eq, Ord, Show, Read) -data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId, nTimestamp :: UTCTime } - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show, Read, Generic, Typeable) +data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } + deriving (Eq, Ord, Show, Read, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel @@ -36,4 +38,4 @@ deriveJSON defaultOptions data JobCtl = JobCtlFlush | JobCtlPerform QueuedJobId - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Model.hs b/src/Model.hs index a6d297443..5d3b51e3f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -16,6 +16,7 @@ module Model ( module Model , module Model.Types + , module Cron.Types ) where import ClassyPrelude.Yesod @@ -23,6 +24,7 @@ import Database.Persist.Quasi -- import Data.Time -- import Data.ByteString import Model.Types +import Cron.Types import Data.Aeson (Value) import Data.Aeson.TH (deriveJSON, defaultOptions) @@ -39,7 +41,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only deriving instance Eq (Unique Course) - + data PWEntry = PWEntry { pwUser :: User , pwHash :: Text diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 701659dff..59ceba0f0 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -452,7 +452,7 @@ deriveJSON defaultOptions } ''NotificationSettings derivePersistFieldJSON ''NotificationSettings - + -- Type synonyms type Email = Text diff --git a/test.sh b/test.sh new file mode 100755 index 000000000..9e3db3ebe --- /dev/null +++ b/test.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +move-back() { + mv -v .stack-work .stack-work-test + [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work +} + +if [[ -d .stack-work-test ]]; then + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run + mv -v .stack-work-test .stack-work + trap move-back EXIT +fi + +stack test --flag uniworx:dev --flag uniworx:library-only ${@} diff --git a/test/CronSpec.hs b/test/CronSpec.hs new file mode 100644 index 000000000..af942ea77 --- /dev/null +++ b/test/CronSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module CronSpec where + +import TestImport + +import Cron +import Numeric.Natural + +import Data.Time +import Data.Time.Clock.System +import Data.Time.Zones + +import Data.List (iterate) + + +baseTime :: UTCTime +baseTime = UTCTime (addDays 58400 systemEpochDay) 50000 + + +sampleCron :: Natural -> Cron -> [UTCTime] +sampleCron n = go n baseTime Nothing + where + go 0 _ _ _ = [] + go n t mPrev cron = case nextCronMatch utcTZ mPrev t cron of + MatchAsap -> t : go (pred n) t (Just t) cron + MatchAt t' -> t' : go (pred n) t' (Just t') cron + MatchNone -> [] + + +spec :: Spec +spec = do + describe "Cron" $ do + it "generates correct example series" . mapM_ seriesExample $ + [ (Cron CronAsap Nothing CronScheduleBefore, [baseTime]) + , (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime) + ] + +seriesExample :: (Cron, [UTCTime]) -> Expectation +seriesExample (cron, res) = example $ sampleCron 10 cron `shouldBe` take 10 res diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs index dff41b58b..e0f8ed5c2 100644 --- a/test/Handler/ProfileSpec.hs +++ b/test/Handler/ProfileSpec.hs @@ -4,6 +4,8 @@ module Handler.ProfileSpec (spec) where import TestImport +import qualified Data.CaseInsensitive as CI + spec :: Spec spec = withApp $ do @@ -13,16 +15,16 @@ spec = withApp $ do statusIs 403 it "asserts access to my-account for authenticated users" $ do - userEntity <- createUser "dummy" "foo" + userEntity <- createUser "foo" authenticateAs userEntity get ProfileR statusIs 200 it "asserts user's information is shown" $ do - userEntity <- createUser "dummy" "bar" + userEntity <- createUser "bar" authenticateAs userEntity get ProfileR let (Entity _ user) = userEntity - htmlAnyContain ".username" . unpack $ userIdent user + htmlAnyContain ".username" . unpack . CI.original $ userIdent user diff --git a/test/TestImport.hs b/test/TestImport.hs index 29f09bdc6..bf7f56729 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -25,6 +25,13 @@ import Test.QuickCheck.Gen as X import Data.Default as X import Test.QuickCheck.Instances as X + +import Settings + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + + runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do app <- getTestYesod @@ -79,12 +86,24 @@ authenticateAs :: Entity User -> YesodExample UniWorX () authenticateAs (Entity _ User{..}) = do request $ do setMethod "POST" - addPostParam "ident" $ userPlugin <> ":" <> userIdent + addPostParam "ident" $ CI.original userIdent setUrl $ AuthR $ PluginR "dummy" [] -- | Create a user. The dummy email entry helps to confirm that foreign-key -- checking is switched off in wipeDB for those database backends which need it. -createUser :: Text -> Text -> YesodExample UniWorX (Entity User) -createUser userPlugin userIdent = runDB $ insertEntity User{..} - where - userMatrikelnummer = "DummyMatrikelnummer" +createUser :: CI Text -> YesodExample UniWorX (Entity User) +createUser userIdent = do + UserDefaultConf{..} <- appUserDefaults . appSettings <$> getTestYesod + let + userMatrikelnummer = Nothing + userAuthentication = AuthLDAP + userEmail = "dummy@example.invalid" + userDisplayName = "Dummy Example" + userSurname = "Example" + userTheme = userDefaultTheme + userMaxFavourites = userDefaultMaxFavourites + userDateTimeFormat = userDefaultDateTimeFormat + userDateFormat = userDefaultDateFormat + userTimeFormat = userDefaultTimeFormat + userDownloadFiles = userDefaultDownloadFiles + runDB $ insertEntity User{..}