-
Notifications
You must be signed in to change notification settings - Fork 22
/
Copy pathBackgroundProcessing.hs
139 lines (129 loc) · 6.76 KB
/
BackgroundProcessing.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}
module BackgroundProcessing ( pcWriterThread
, scheduleWatcher
) where
import Data.Monoid
import Data.Aeson
import Control.Monad
import Control.Monad.Writer
import Control.Lens
import Control.Concurrent.STM
import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.LocalTime
import qualified Data.HashMap.Strict as HM
import Util
import Trace
import PersistConfig
import WebUIREST
-- Every N seconds we wake up and see if the configuration data we want to persist has
-- been changed. If so, we write it to disk to make sure we don't lose all data in case
-- of a crash
--
-- TODO: Risk of data corruption when being interrupted while saving at our interval
--
pcWriterThread :: TVar PersistConfig -> IO ()
pcWriterThread tvPC = loop defaultPersistConfig
where loop lastCfg = do
waitNSec intervalSec
currentCfg <- atomically $ readTVar tvPC
when (currentCfg /= lastCfg) $ do
traceS TLInfo $ "Configuration data has changed in the last " <> show intervalSec <>
"s, persisting to disk..."
storeConfig configFilePath currentCfg
loop currentCfg
intervalSec = 900 -- 15min
-- Schedule related processing
-- This thread executes the scene activations for our schedules
scheduleWatcher :: TVar PersistConfig -> IO ()
scheduleWatcher tvPC = loop =<< (localDay . zonedTimeToLocalTime <$> getZonedTime)
where loop startDay = do
curTime <- zonedTimeToLocalTime <$> getZonedTime
-- Need to reset triggers when a new day starts
when (diffDays (localDay curTime) startDay /= 0) $ do
traceS TLInfo "Day has changed, resetting all triggers for the new day"
atomically . modifyTVar' tvPC $ pcSchedules . traversed . sTrigStatus %~
(\ts -> if ts == STAlreadyTriggered then STPending else ts)
-- Inspect all schedules, update them and assemble list of
-- IO actions to perform, all as a single transaction
(ioActions :: [IO ()]) <- atomically . execWriterT $ do
pc <- lift $ readTVar tvPC
-- Debug print schedule state, disabled
-- tell [ print $ pc ^. pcSchedules ]
forM_ (pc ^. pcSchedules . to HM.toList) $ \(schedName, sched) -> do
case sched ^. sTrigStatus of
STJustCreated ->
-- We just added this, either by adding it through the UI or by loading
-- it from the configuration, decide what to do with it
if triggerPassed sched curTime
then -- Already to late for this schedule today, mark as triggered
lift . modifyTVar' tvPC $
pcSchedules . at schedName . _Just . sTrigStatus .~ STAlreadyTriggered
else -- Still happening later today, mark as pending
lift . modifyTVar' tvPC $
pcSchedules . at schedName . _Just . sTrigStatus .~ STPending
STAlreadyTriggered ->
-- Has already been triggered today, nothing left to do
return ()
STPending ->
-- Has not yet been triggered, see if we are past the trigger time
when (triggerPassed sched curTime) $ do
-- Check week day
let curDayIdx = (toWeekDate (localDay curTime) ^. _3) - 1;
days = sched ^. sDays
safeIdxDays idx | idx >= length days = False
| otherwise = days !! idx
if safeIdxDays curDayIdx
then
-- Active day. Does the scene exist?
case HM.lookup (sched ^. sScene) (pc ^. pcScenes) of
Nothing ->
-- Invalid scene
tell
[ traceS TLWarn $ "Schedule '" <> schedName <>
"' tried to trigger non-existent scene '"
<> (sched ^. sScene) <> "'"
]
Just scene ->
-- Trigger scene
tell
[ case sched ^. sAction of
SAActivate ->
lightsSetScene (pc ^. pcBridgeIP) (pc ^. pcBridgeUserID) scene
SAActivateSlow -> -- 15s transition time
lightsSetScene (pc ^. pcBridgeIP) (pc ^. pcBridgeUserID) $
scene & traversed . _2 . at "transitiontime" ?~ Number 150
SATurnOff ->
lightsSwitchOnOff (pc ^. pcBridgeIP)
(pc ^. pcBridgeUserID)
(map fst scene)
False
SABlink ->
lightsBreatheCycle (pc ^. pcBridgeIP)
(pc ^. pcBridgeUserID)
(map fst scene)
, traceS TLInfo $ "Schedule '" <> schedName <>
"' has triggered scene '" <> (sched ^. sScene)
<> "'"
]
else
-- Not today
tell
[ traceS TLInfo $ "Schedule '" <> schedName <>
"' skipped, not active today"
]
-- Mark as triggered
lift . modifyTVar' tvPC $
pcSchedules . at schedName . _Just . sTrigStatus .~ STAlreadyTriggered
-- Execute all pending actions, sleep for a while and start again
sequence_ ioActions
waitNSec 10 -- TODO: All our schedules trigger on the full minute, just wait till then?
loop $ localDay curTime
-- Did we already pass the trigger time of the schedule today?
triggerPassed :: Schedule -> LocalTime -> Bool
triggerPassed sched now =
localTimeOfDay now > timeOfDayFromSchedule sched
-- Time since midnight, useful for comparing the day time with the trigger time
timeOfDayFromSchedule :: Schedule -> TimeOfDay
timeOfDayFromSchedule Schedule { .. } =
TimeOfDay _sHour _sMinute $ fromIntegral (0 :: Int)