Log exceptions to a logger provided when creating.

Closes #1.

Author: dbp

periodic.cabal

@@ -26,10 +26,9 @@ library
 
 test-suite periodic-test
   type:                exitcode-stdio-1.0
-  hs-source-dirs:      test
+  hs-source-dirs:      test, src
   main-is:             Spec.hs
   build-depends:       base
-                     , periodic
                      , text
                      , time
                      , hedis

src/System/Periodic.hs

@@ -30,16 +30,24 @@ newtype Name = Name Text
 newtype CheckInterval = CheckInterval Seconds
 newtype LockTimeout = LockTimeout Seconds
 
+type Logger = Text -> IO ()
 data Scheduler = Scheduler { schedulerName          :: Name
                            , schedulerRedisConn     :: R.Connection
                            , schedulerTasks         :: MVar [(Text, Period, IO ())]
                            , schedulerCheckInterval :: CheckInterval
                            , schedulerLockTimout    :: LockTimeout
+                           , schedulerLogger        :: Logger
                            }
 
-create :: Name -> R.Connection -> CheckInterval -> LockTimeout -> IO Scheduler
-create name rconn check lock = do mv <- newMVar []
-                                  return $ Scheduler name rconn mv check lock
+create :: Name
+       -> R.Connection
+       -> CheckInterval
+       -> LockTimeout
+       -> (Text -> IO ())
+       -> IO Scheduler
+create name rconn check lock logger =
+  do mv <- newMVar []
+     return $ Scheduler name rconn mv check lock logger
 
 addTask :: Scheduler -> Text -> Period -> IO () -> IO ()
 addTask scheduler job when act =
@@ -49,10 +57,10 @@ addTask scheduler job when act =
 lockTimeout = 10 * 3600
 
 run :: Scheduler -> IO ()
-run (Scheduler (Name nm) rconn mv (CheckInterval (Seconds check)) lock) = forever $
+run (Scheduler (Name nm) rconn mv (CheckInterval (Seconds check)) lock logger) = forever $
     do now <- getCurrentTime
        tasks <- readMVar mv
-       mapM_ (tryRunTask lock nm rconn now) tasks
+       mapM_ (tryRunTask logger lock nm rconn now) tasks
        threadDelay (check * 1000000)
 
 lastStartedKey pname name =
@@ -61,7 +69,7 @@ lockedKey pname name =
   T.encodeUtf8 $ pname <> "-" <> name <> "-running-at"
 
 destroy :: Scheduler -> IO ()
-destroy (Scheduler (Name nm) rconn mv _ _) =
+destroy (Scheduler (Name nm) rconn mv _ _ _) =
   do tasks <- readMVar mv
      R.runRedis rconn $
        R.del (concatMap (\(tnm,_,_) ->
@@ -80,7 +88,6 @@ collapseNumberBoolFalse (Right (Just 1)) = True
 collapseNumberBoolFalse (Right (Just 0)) = False
 
 
-
 parseUnixTime s = let Right (n, d) = decode s in posixSecondsToUTCTime $ fromRational $ n % d
 
 renderUnixTime t = let r =  toRational . utcTimeToPOSIXSeconds $ t in encode (numerator r, denominator r)
@@ -103,8 +110,8 @@ shouldRun _ (Every (Seconds n)) (Just last) locked now
 shouldRun lock period last locked now = False
 
 
-tryRunTask :: LockTimeout -> Text -> R.Connection -> UTCTime -> (Text, Period, IO ()) -> IO ()
-tryRunTask timeout pname rconn now (name, period, task) =
+tryRunTask :: Logger -> LockTimeout -> Text -> R.Connection -> UTCTime -> (Text, Period, IO ()) -> IO ()
+tryRunTask logger timeout pname rconn now (name, period, task) =
   do lastStarted <- fmap parseUnixTime . collapseError <$>
                     R.runRedis rconn
                                (R.get (lastStartedKey pname name))
@@ -134,7 +141,12 @@ tryRunTask timeout pname rconn now (name, period, task) =
                                       putMVar x (Just e)))
                res <- takeMVar x
                case res of
-                 Just e -> print $ "Exception raised: " <> show e
+                 Just e -> logger $ T.concat ["periodic["
+                                             ,pname
+                                             ,"::"
+                                             ,name
+                                             ,"] error: "
+                                             ,T.pack (show e)]
                  Nothing -> return ()
                R.runRedis rconn $ R.del [lockedKey pname name]
                return ()

test/Spec.hs

@@ -23,6 +23,14 @@ runNThreads :: Int -> Int -> Scheduler -> IO ()
 runNThreads n delay sched = do threads <- replicateM n (forkIO $ run sched)
                                threadDelay delay
                                mapM_ killThread threads
+
+createSch :: T.Text -> IO Scheduler
+createSch n = createSch' n print
+
+createSch' :: T.Text -> Logger -> IO Scheduler
+createSch' n l = do rconn <- R.connect R.defaultConnectInfo
+                    create (Name n) rconn (CheckInterval (Seconds 1)) (LockTimeout (Seconds 1000)) l
+
 main :: IO ()
 main = hspec $
   do describe "shouldRun" $
@@ -39,8 +47,7 @@ main = hspec $
      describe "simple job" $
        do it "should run " $
             do mvar <- newMVar 0
-               rconn <- R.connect R.defaultConnectInfo
-               scheduler <- create (Name "simple-1") rconn (CheckInterval (Seconds 1)) (LockTimeout (Seconds 1000))
+               scheduler <- createSch "simple-1"
                addTask scheduler "job" (Every (Seconds 100)) (modifyMVarMasked_ mvar (return . (+1)))
 
                runNThreads 1 30000 scheduler
@@ -50,17 +57,15 @@ main = hspec $
                1 `shouldBe` v
           it "should only run once per scheduled time" $
              do mvar <- newMVar 0
-                rconn <- R.connect R.defaultConnectInfo
-                scheduler <- create (Name "simple-2") rconn (CheckInterval (Seconds 1)) (LockTimeout (Seconds 1000))
+                scheduler <- createSch "simple-2"
                 addTask scheduler "job" (Every (Seconds 100)) (modifyMVarMasked_ mvar (return . (+1)))
                 runNThreads 3 100000 scheduler
                 destroy scheduler
                 v <- takeMVar mvar
                 v `shouldBe` 1
           it "should run at each time point" $
              do mvar <- newMVar 0
-                rconn <- R.connect R.defaultConnectInfo
-                scheduler <- create (Name "simple-3") rconn (CheckInterval (Seconds 1)) (LockTimeout (Seconds 1000))
+                scheduler <- createSch "simple-3"
                 addTask scheduler "job" (Every (Seconds 2)) (modifyMVarMasked_ mvar (return . (+1)))
                 runNThreads 3 4000000 scheduler
                 destroy scheduler
@@ -70,8 +75,7 @@ main = hspec $
                 (v == 3 || v == 2) `shouldBe` True
           it "should run at scheduled time" $
              do mvar <- newMVar 0
-                rconn <- R.connect R.defaultConnectInfo
-                scheduler <- create (Name "simple-4") rconn (CheckInterval (Seconds 1)) (LockTimeout (Seconds 1000))
+                scheduler <- createSch "simple-4"
                 seconds <- utctDayTime <$> getCurrentTime
                 addTask scheduler "job" (Daily (Time seconds)) (modifyMVarMasked_ mvar (return . (+1)))
                 runNThreads 1 4000000 scheduler
@@ -80,8 +84,7 @@ main = hspec $
                 v `shouldBe` 1
           it "should not run at an unscheduled time" $
              do mvar <- newMVar 0
-                rconn <- R.connect R.defaultConnectInfo
-                scheduler <- create (Name "simple-4") rconn (CheckInterval (Seconds 1)) (LockTimeout (Seconds 1000))
+                scheduler <- createSch "simple-4"
                 now <- getCurrentTime
                 let seconds = utctDayTime $ addUTCTime 3600 now
                 addTask scheduler "job" (Daily (Time seconds)) (modifyMVarMasked_ mvar (return . (+1)))
@@ -92,8 +95,7 @@ main = hspec $
      describe "error handling" $
        do it "should keep running jobs if one throws an exception" $
             do mvar <- newMVar 0
-               rconn <- R.connect R.defaultConnectInfo
-               scheduler <- create (Name "error-1") rconn (CheckInterval (Seconds 1)) (LockTimeout (Seconds 1000))
+               scheduler <- createSch' "error-1" (const $ return ())
                addTask scheduler "job-error" (Every (Seconds 100)) (error "blowing up")
                thread <- forkIO $ run scheduler
                threadDelay 300000
@@ -103,3 +105,13 @@ main = hspec $
                destroy scheduler
                v <- takeMVar mvar
                1 `shouldBe` v
+          it "should send exception to logger" $
+            do mvar <- newMVar []
+               scheduler <- createSch' "error-1" (\t -> modifyMVarMasked_ mvar (return . (t:)))
+               addTask scheduler "job-error" (Every (Seconds 100)) (error "blowing up")
+               thread <- forkIO $ run scheduler
+               threadDelay 500000
+               killThread thread
+               destroy scheduler
+               v <- takeMVar mvar
+               length v `shouldBe` 1