vigilance-0.1.0.0: src/Utils/Vigilance/TableOps.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Utils.Vigilance.TableOps ( allWatches
, allWatchesEvent
, AllWatchesEvent(..)
, allWatchesS
, createWatch
, createWatchEvent
, CreateWatchEvent(..)
, createWatchS
, deleteWatch
, deleteWatchEvent
, DeleteWatchEvent(..)
, deleteWatchS
, deleteFailedByWatch
, deleteExcept
, findWatch
, findWatchEvent
, FindWatchEvent(..)
, findWatchS
, pauseWatch
, pauseWatchEvent
, PauseWatchEvent(..)
, pauseWatchS
, unPauseWatch
, unPauseWatchEvent
, UnPauseWatchEvent(..)
, unPauseWatchS
, checkInWatch
, checkInWatchEvent
, CheckInWatchEvent(..)
, checkInWatchS
, watchLens
, sweepTable
, sweepTableEvent
, SweepTableEvent(..)
, sweepTableS
, getNotifying
, getNotifyingEvent
, GetNotifyingEvent(..)
, getNotifyingS
, completeNotifying
, completeNotifyingEvent
, CompleteNotifyingEvent(..)
, completeNotifyingS
, mergeStaticWatches
, mergeStaticWatchesEvent
, MergeStaticWatchesEvent(..)
, mergeStaticWatchesS
, addFailedNotificationsEvent
, AddFailedNotificationsEvent(..)
, addFailedNotificationsS
, allFailedNotificationsEvent
, AllFailedNotificationsEvent(..)
, allFailedNotificationsS
, setFailedNotificationsEvent
, SetFailedNotificationsEvent(..)
, setFailedNotificationsS
, fromList
, getId
, sWatchId
, sWatchName
, sWatchInterval
, sWatchWState
, sWatchNotifications
, emptyTable) where
import ClassyPrelude hiding (fromList)
import Control.Lens
import Data.Acid
import Data.Acid.Advanced (update', query')
import Data.List (foldl')
import Data.Store.Lens (with)
import Data.Store ((.==), (:.)(..), (.&&), (./=))
import qualified Data.Store as S
import qualified Data.Store.Storable as SS
import qualified Data.Store.Selection as SEL
import Data.Time.Clock.POSIX (POSIXTime)
import Utils.Vigilance.Sweeper (sweepWatch)
import Utils.Vigilance.Types
-- Selections
sWatchId :: (WatchStoreTag, S.N0)
sWatchId = (WatchStoreTag, S.n0)
sWatchName :: (WatchStoreTag, S.N1)
sWatchName = (WatchStoreTag, S.n1)
sWatchInterval :: (WatchStoreTag, S.N2)
sWatchInterval = (WatchStoreTag, S.n2)
sWatchWState :: (WatchStoreTag, S.N3)
sWatchWState = (WatchStoreTag, S.n3)
sWatchNotifications :: (WatchStoreTag, S.N4)
sWatchNotifications = (WatchStoreTag, S.n4)
allWatches :: WatchTable -> [EWatch]
allWatches = map ewatch . S.toList
-- Helpers
getId :: (ID :. t1) -> ID
getId (wid :. _) = wid
ewatch :: (ID :. i, NewWatch) -> EWatch
ewatch (k, w) = w & watchId .~ getId k -- stateful?
-- API
createWatch :: NewWatch -> WatchTable -> (EWatch, WatchTable)
createWatch w s = (w & watchId .~ getId k, s')
where (k, s') = SS.insert' w s
deleteWatch :: WatchName -> WatchTable -> WatchTable
deleteWatch n = S.delete (sWatchName .== n)
deleteFailedByWatch :: WatchName -> [FailedNotification] -> [FailedNotification]
deleteFailedByWatch n = filter ((/=n) . getName)
where getName = view $ failedWatch . watchName
deleteExcept :: [WatchName] -> WatchTable -> WatchTable
deleteExcept [] = id
deleteExcept names = S.delete nameScope
where nameScope = SEL.all $ map (sWatchName ./=) names
findWatch :: WatchName -> WatchTable -> Maybe EWatch
findWatch n = listToMaybe . map ewatch . S.lookup (sWatchName .== n)
watchLens :: (NewWatch -> NewWatch) -> WatchName -> WatchTable -> WatchTable
watchLens f n table = table & with (sWatchName .== n) %~ over mapped f
checkInWatch :: POSIXTime -> WatchName -> WatchTable -> WatchTable
checkInWatch time = watchLens doCheckIn
where doCheckIn w = w & watchWState .~ (Active time)
pauseWatch :: WatchName -> WatchTable -> WatchTable
pauseWatch = watchLens pause
where pause w = w & watchWState .~ Paused
unPauseWatch :: POSIXTime -> WatchName -> WatchTable -> WatchTable
unPauseWatch t = watchLens unPause
where unPause w = w & watchWState %~ updateState
updateState (Active newTime) = Active newTime
updateState _ = Active t
sweepTable :: POSIXTime -> WatchTable -> WatchTable
sweepTable time = SS.map sweep
where sweep = sweepWatch time
getNotifying :: WatchTable -> [EWatch]
getNotifying = map ewatch . S.lookup (sWatchWState .== Notifying)
completeNotifying :: [WatchName] -> WatchTable -> WatchTable
completeNotifying [] table = table
completeNotifying names table = SS.update' (Just . updateState) scope table
where updateState w = w & watchWState .~ Triggered
scope = nameScope .&& isNotifyingScope
nameScope = SEL.any $ map (sWatchName .==) names
isNotifyingScope = sWatchWState .== Notifying
mergeStaticWatches :: [NewWatch] -> WatchTable -> WatchTable
mergeStaticWatches [] = const emptyTable
mergeStaticWatches watches = mergeWatches . removeUnMentioned
where removeUnMentioned = deleteExcept names
names = map (view watchName) watches
mergeWatches table = foldl' mergeWatchIn table watches
mergeWatchIn table' staticW = fromMaybe forceUpdate tryInsert
where forceUpdate = SS.update' (Just . mergeWatch)
(sWatchName .== (staticW ^. watchName))
table'
mergeWatch eWatch = eWatch & watchInterval .~ (staticW ^. watchInterval)
& watchNotifications .~ (staticW ^. watchNotifications)
tryInsert = snd <$> SS.insert staticW table'
emptyTable :: WatchTable
emptyTable = S.empty
fromList :: [NewWatch] -> WatchTable
fromList = SS.fromList'
-- ACID State
allWatchesEvent :: Query AppState [EWatch]
allWatchesEvent = view (wTable . to allWatches)
createWatchEvent :: NewWatch -> Update AppState EWatch
createWatchEvent w = wTable %%= createWatch w
deleteWatchEvent :: WatchName -> Update AppState ()
deleteWatchEvent n = wTable %= deleteWatch n >>
failed %= deleteFailedByWatch n
findWatchEvent :: WatchName -> Query AppState (Maybe EWatch)
findWatchEvent i = view (wTable . findWatch')
where findWatch' = to $ findWatch i
checkInWatchEvent :: POSIXTime -> WatchName -> Update AppState ()
checkInWatchEvent t i = wTable %= checkInWatch t i
pauseWatchEvent :: WatchName -> Update AppState ()
pauseWatchEvent i = wTable %= pauseWatch i
unPauseWatchEvent :: POSIXTime -> WatchName -> Update AppState ()
unPauseWatchEvent t i = wTable %= unPauseWatch t i
sweepTableEvent :: POSIXTime -> Update AppState ()
sweepTableEvent t = wTable %= sweepTable t
getNotifyingEvent :: Query AppState [EWatch]
getNotifyingEvent = view (wTable . to getNotifying)
completeNotifyingEvent :: [WatchName] -> Update AppState ()
completeNotifyingEvent is = wTable %= completeNotifying is
mergeStaticWatchesEvent :: [NewWatch] -> Update AppState ()
mergeStaticWatchesEvent watches = wTable %= mergeStaticWatches watches
addFailedNotificationsEvent :: [FailedNotification] -> Update AppState ()
addFailedNotificationsEvent ns = failed <>= ns
allFailedNotificationsEvent :: Query AppState [FailedNotification]
allFailedNotificationsEvent = view failed
setFailedNotificationsEvent :: [FailedNotification] -> Update AppState ()
setFailedNotificationsEvent ns = failed .= ns
$(makeAcidic ''AppState [ 'allWatchesEvent
, 'createWatchEvent
, 'deleteWatchEvent
, 'findWatchEvent
, 'checkInWatchEvent
, 'pauseWatchEvent
, 'unPauseWatchEvent
, 'sweepTableEvent
, 'getNotifyingEvent
, 'completeNotifyingEvent
, 'mergeStaticWatchesEvent
, 'addFailedNotificationsEvent
, 'allFailedNotificationsEvent
, 'setFailedNotificationsEvent ])
allWatchesS :: (QueryEvent AllWatchesEvent, MonadIO m)
=> AcidState (EventState AllWatchesEvent)
-> m [EWatch]
allWatchesS acid = query' acid AllWatchesEvent
createWatchS :: (UpdateEvent CreateWatchEvent, MonadIO m)
=> AcidState (EventState CreateWatchEvent)
-> NewWatch
-> m EWatch
createWatchS acid = update' acid . CreateWatchEvent
deleteWatchS :: (UpdateEvent DeleteWatchEvent, MonadIO m)
=> AcidState (EventState DeleteWatchEvent)
-> WatchName
-> m ()
deleteWatchS acid = update' acid . DeleteWatchEvent
findWatchS :: (QueryEvent FindWatchEvent, MonadIO m)
=> AcidState (EventState FindWatchEvent)
-> WatchName
-> m (Maybe EWatch)
findWatchS acid = query' acid . FindWatchEvent
checkInWatchS :: (UpdateEvent CheckInWatchEvent, MonadIO m)
=> AcidState (EventState CheckInWatchEvent)
-> POSIXTime
-> WatchName
-> m ()
checkInWatchS acid t = update' acid . CheckInWatchEvent t
pauseWatchS :: (UpdateEvent PauseWatchEvent, MonadIO m)
=> AcidState (EventState PauseWatchEvent)
-> WatchName
-> m ()
pauseWatchS acid = update' acid . PauseWatchEvent
unPauseWatchS :: (UpdateEvent UnPauseWatchEvent, MonadIO m)
=> AcidState (EventState UnPauseWatchEvent)
-> POSIXTime
-> WatchName
-> m ()
unPauseWatchS acid t = update' acid . UnPauseWatchEvent t
sweepTableS :: (UpdateEvent SweepTableEvent, MonadIO m)
=> AcidState (EventState SweepTableEvent)
-> POSIXTime
-> m ()
sweepTableS acid = update' acid . SweepTableEvent
getNotifyingS :: (QueryEvent GetNotifyingEvent, MonadIO m)
=> AcidState (EventState GetNotifyingEvent)
-> m [EWatch]
getNotifyingS acid = query' acid GetNotifyingEvent
completeNotifyingS :: (UpdateEvent CompleteNotifyingEvent, MonadIO m)
=> AcidState (EventState CompleteNotifyingEvent)
-> [WatchName]
-> m ()
completeNotifyingS acid = update' acid . CompleteNotifyingEvent
mergeStaticWatchesS :: (UpdateEvent CompleteNotifyingEvent, MonadIO m)
=> AcidState (EventState MergeStaticWatchesEvent)
-> [NewWatch]
-> m ()
mergeStaticWatchesS acid = update' acid . MergeStaticWatchesEvent
addFailedNotificationsS :: (UpdateEvent AddFailedNotificationsEvent, MonadIO m)
=> AcidState (EventState AddFailedNotificationsEvent)
-> [FailedNotification]
-> m ()
addFailedNotificationsS acid = update' acid . AddFailedNotificationsEvent
allFailedNotificationsS :: (QueryEvent AllFailedNotificationsEvent, MonadIO m)
=> AcidState (EventState AllFailedNotificationsEvent)
-> m [FailedNotification]
allFailedNotificationsS acid = query' acid AllFailedNotificationsEvent
setFailedNotificationsS :: (UpdateEvent SetFailedNotificationsEvent, MonadIO m)
=> AcidState (EventState SetFailedNotificationsEvent)
-> [FailedNotification]
-> m ()
setFailedNotificationsS acid = update' acid . SetFailedNotificationsEvent