Cron

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

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

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)

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)

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

src/Model/Types.hs

@@ -452,7 +452,7 @@ deriveJSON defaultOptions
   } ''NotificationSettings
 derivePersistFieldJSON ''NotificationSettings
 
-  
+
 -- Type synonyms
 
 type Email           = Text

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 ${@}

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

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

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{..}