packages feed

vigilance (empty) → 0.1.0.0

raw patch · 26 files changed

+2442/−0 lines, 26 filesdep +HUnitdep +QuickCheckdep +acid-statesetup-changed

Dependencies added: HUnit, QuickCheck, acid-state, aeson, async, attoparsec, base, blaze-builder, bytestring, classy-prelude, configurator, containers, data-store, derive, directory, either, entropy, errors, fast-logger, hspec, hspec-expectations, http-streams, http-types, interpolatedstring-perl6, io-streams, lens, mime-mail, monad-logger, monad-loops, mtl, optparse-applicative, quickcheck-properties, safecopy, stm, template-haskell, text, time, transformers, unix, unordered-containers, vector, wai, wai-extra, warp, yesod, yesod-core, yesod-platform

Files

+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2013, Michael Xavier. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,166 @@+# Vigilance+[![Build Status](https://travis-ci.org/MichaelXavier/vigilance.png?branch=master)](https://travis-ci.org/MichaelXavier/vigilance)++Vigilance is a [dead man's switch](https://en.wikipedia.org/wiki/Dead_man%27s_switch)+(or vigilance switch). You define named **watches** that you expect to happen+and how long to wait inbetween before it's time to worry. You then instrument+your periodical tasks, whatever they are, to report to vigilance via a simple+HTTP POST or with the included client. You can then configure notifications+that will fire when a watch fails to check in.++# Concepts+A *watch* is a named task that you expect to happen periodically. Watches have+an interval at which they are expected to check in at the latest, i.e. every 5+minutes. Watches can be in several states:++* *Active* - The clock is ticking but this watch has not yet triggered.+* *Paused* - The clock is not ticking. **Watches start out in this state.**+  That means that you must unpause or check-in the watch to start the watch.+* *Notifying* - The watch has failed to check in and will notify soon.+* *Triggered* - The watch has failed to check in and has notified. It will not+  notify until it is dealt with, either by pausing, checkin in on removal.++Watches are configured in the server's config file and managed via the rest API+or the vigilance client. The configuration file can be reloaded to account for+changes/additions/removals of watches.++Watches can be configured with multiple *notifications* to fire when the watch+fails to check in. Right now the supported notification options are:++* Email - currently uses a local sendmail service.+* HTTP POST++# vigilance-server+vigilance-server is the server component of vigilance. It is responsible for+tracking what watches there are, their state, notifications, etc.++## Usage+Simply run `vigilance-server path/to/config.cfg`. If you don't specify a+config, it will look in `~/.vigilance/server.conf`++## Configuration+The configuration file is in+[configurator](http://hackage.haskell.org/package/configurator) format. Here's+an example config++### Example Config++    vigilance {+      port = 9999+      from_email = "vigilance@example.com"+      max_retries = 5+      log {+        verbose = on+        path = "log/vigilance.log"+      }+      watches {+        foo {+          interval = [2, "seconds"]+          notifications = [+            ["http", "http://localhost:4567/notify"],+            ["email", "ohno@example.com"]+          ]+        }++        bar {+          interval = [3, "minutes"]+        }+      }+    }++Note that all of these options have reasonable defaults, so you don't need to+specify them unless you need something other than the default.++Note that like the standard capabilities configurator has to expand env+variables and  load external config files apply:++    vigilance {+      acid_path  = "$(HOME)/alternative-vigilance-path"++      watches {+        import "only_watches.conf"+      }+    }++### Limited Config Reload Support+Sending a `HUP` signal to the process (`kill -HUP pid_of_vigilance`) will+reload the config. Reloading while running can currently update the following+settings:++1. Log verbosity.+2. List of watches+3. Log location++### Config Fields++| Field                          | Default                     | Description                                                 | Reloadable |+| ------------------------------ | --------------------------- | ---------------------------------------------------------   | ---------- |+| port                           | 3000                        | Server port                                                 | No         |+| from_email                     | None                        | Email  to send from. If missing, no email notifications     | No         |+| max_retries                    | 3                           | Max retries for notifications                               | No         |+| log.acid_path                  | ~/.vigilance/state/AppState |                                                             | No         |+| log.verbose                    | no                          | Verbose logging                                             | Yes        |+| log.path                       | ~/.vigilance/vigilance.log  |                                                             | Yes        |+| watches.*name*.interval        | None. Required for a watch  | Pair of number and seconds/minutes/hours/days/weeks/years   | Yes        |+| watches.*name*.notifications   | Empty                       | List of pairs ["http", "url"] or ["email", "a@example.com"] | Yes        |++## REST API+Vigilance exposes a REST API for managing watches.++| Path                    | Method | Description                                                                                  |+| ----------------------- | ------ | -------------------------------------------------------------------------------------------- |+| /watches                | GET    | Get the list of watches in JSON.                                                             |+| /watches/*name*         | GET    | Get info for a watch by name                                                                 |+| /watches/*name*         | DELETE | Delete a watch. Make sure to remove it from the config or it will return on config (re)load. |+| /watches/*name*/pause   | POST   | Take a watch out of operation.                                                               |+| /watches/*name*/unpause | POST   | Put a watch back in operation.                                                               |+| /watches/*name*/checkin | POST   | Check in a watch. Unpauses if it is paused.                                                  |+| /watches/*name*/test    | POST   | Synchronously fire a watch's notifications. Returns a list of failures in JSON.              |++# Vigilance Client+Vigilance Client is available under the `vigilance` binary. It allows you to+interact with a vigilance server over HTTP in a concise way. The idea behind+this is that it should make it very easy to insert check-ins in crontabs and+shell scripts. You can imagine a crontab entry like:+`@daily run_backups.sh && vigilance checkin backups`.+++# Configuration+Vigilance by default looks for a `.vigilance` file in your home directory,+which looks like:++    vigilance+    {+      host = "localhost"+      port = 3000+    }++# Usage+Run `vigilance --help` for help:++    vigilance - tool for managing vigilance watches locally or remotely.++    Usage: vigilance COMMAND [-c|--config FILE]++    Available options:+      -h,--help                Show this help text+      -c,--config FILE         Config file. Defaults to ~/.vigilance++    Available commands:+      list                     List watches+      pause                    Pause watch+      unpause                  Unpause watch+      checkin                  Check in watch+      info                     Get info about a watch+      test                     Test the notifications for a watch++All commands except `list` take a name argument for the watch like: `vigilance+pause foo`.++## Status+Gearing up for release. Nothing in the TODO necessitates holding up the+release.++## License+Vigilance is released under the MIT license. See the `LICENSE` file for more+info.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TODO.md view
@@ -0,0 +1,5 @@+Issues+* better use of lens. I'm using a lot of nasty hacks, using map/foldl when I'm+  sure there's a combinator for it.+* see if config reload can spawn the email worker+* see if retry count cant be reloaded
+ src/Utils/Vigilance/Client/Client.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE QuasiQuotes       #-}+module Utils.Vigilance.Client.Client ( getList+                                     , getInfo+                                     , pause+                                     , unPause+                                     , checkIn+                                     , test+                                     , displayList+                                     , displayWatch+                                     , displayWatchInfo+                                     , displayFailedNotifications+                                     -- for testing+                                     , renderList+                                     , renderWatch+                                     , renderWatchInfo+                                     , renderFailedNotifications+                                     , VError(..) ) where++import ClassyPrelude+import Control.Lens+import Control.Monad.Trans.Reader (asks)+import Data.Aeson ( FromJSON+                  , json+                  , Result(..)+                  , fromJSON )+import Blaze.ByteString.Builder (Builder)+import Data.Ix (inRange)+import Network.Http.Client ( Method(GET, POST)+                           , Response+                           , emptyBody+                           , withConnection+                           , openConnection+                           , http+                           , setAccept+                           , setHeader+                           , buildRequest+                           , sendRequest+                           , receiveResponse+                           , RequestBuilder+                           , getStatusCode+                           , StatusCode )+import System.IO.Streams.Attoparsec (parseFromStream)+import qualified System.IO.Streams as S+import Text.InterpolatedString.Perl6 (qc)++import Utils.Vigilance.Client.Config+import Utils.Vigilance.Types+++displayList :: [EWatch] -> IO ()+displayList = putStrLn . renderList++renderList :: [EWatch] -> Text+renderList = unlines' . map renderWatch++displayWatch :: EWatch -> IO ()+displayWatch = putStrLn . renderWatch++renderWatch :: EWatch -> Text+renderWatch w = [qc|{name} ({i}) - {interval} - {state}|]+  where name     = w ^. watchName . unWatchName+        i        = w ^. watchId . unID+        interval = w ^. watchInterval+        state    = w ^. watchWState . to renderState++displayWatchInfo :: EWatch -> IO ()+displayWatchInfo = putStrLn . renderWatchInfo++displayFailedNotifications :: [FailedNotification] -> IO ()+displayFailedNotifications = putStrLn . renderFailedNotifications++renderFailedNotifications :: [FailedNotification] -> Text+renderFailedNotifications []  = "All notifications sent successfully."+renderFailedNotifications fns = unlines' . (header:) . map render $ fns+  where header = "The following errors were encountered when testing:"+        render fn = [qc|- {pref} for {wn} ({wid}): {err}|]+          where pref = fn ^. failedPref . to renderNotificationPref+                wn   = fn ^. failedWatch . watchName . unWatchName+                wid  = fn ^. failedWatch . watchId . unID+                err  = fn ^. failedLastError . to renderNotificationError++renderNotificationPref :: NotificationPreference -> Text+renderNotificationPref (HTTPNotification u)                 = [qc|HTTP Notification ({u})|]+renderNotificationPref (EmailNotification (EmailAddress a)) = [qc|Email Notification ({a})|]++renderNotificationError :: NotificationError -> Text+renderNotificationError (FailedByCode c)      = [qc|Failed with status code {c}|]+renderNotificationError (FailedByException e) = [qc|Failed with exception "{e}"|]++renderWatchInfo :: EWatch -> Text+renderWatchInfo w = [qc|{renderedWatch}++Notifications:+{renderedNotifications}|]+  where renderedWatch = renderWatch w+        notifications = w ^. watchNotifications+        renderedNotifications+          | null notifications = bullet "none"+          | otherwise          = unlines' . map (bullet . renderNotification) $ notifications++renderNotification :: NotificationPreference -> Text+renderNotification (EmailNotification (EmailAddress a)) = [qc|Email: {a}|]+renderNotification (HTTPNotification u)                 = [qc|HTTP: {u}|]++renderState :: WatchState -> Text+renderState (Active t) = [qc|Active {t}|]+renderState x          = show x++bullet :: Text -> Text+bullet x = [qc| - {x}|]++getList :: ClientCtxT IO (VigilanceResponse [EWatch])+getList = makeRequest GET "/watches" emptyBody++getInfo :: WatchName -> ClientCtxT IO (VigilanceResponse EWatch)+getInfo n = makeRequest GET (watchRoute n) emptyBody++pause :: WatchName -> ClientCtxT IO (VigilanceResponse ())+pause n = makeRequest_ POST (watchRoute n <> "/pause") emptyBody++unPause :: WatchName -> ClientCtxT IO (VigilanceResponse ())+unPause n = makeRequest_ POST (watchRoute n <> "/unpause") emptyBody++checkIn :: WatchName -> ClientCtxT IO (VigilanceResponse ())+checkIn n = makeRequest_ POST (watchRoute n <> "/checkin") emptyBody++test :: WatchName -> ClientCtxT IO (VigilanceResponse [FailedNotification])+test n = makeRequest POST (watchRoute n <> "/test") emptyBody++watchRoute :: WatchName -> ByteString+watchRoute (WatchName n) = "/watches/" <> encodeUtf8 n+++makeRequest_ :: Method+                -> ByteString+                -> (S.OutputStream Builder -> IO b)+                -> ClientCtxT IO (VigilanceResponse ())+makeRequest_ = makeRequest' unitResponseHandler++makeRequest :: FromJSON a+               => Method+               -> ByteString+               -> (S.OutputStream Builder -> IO b)+               -> ClientCtxT IO (VigilanceResponse a)+makeRequest = makeRequest' jsonResponseHandler++makeRequest':: (Response -> S.InputStream ByteString -> IO (VigilanceResponse a))+               -> Method+               -> ByteString+               -> (S.OutputStream Builder -> IO b)+               -> ClientCtxT IO (VigilanceResponse a)+makeRequest' handler m p body = do+  host <- asks serverHost+  port <- asks serverPort+  lift $ withConnection (openConnection host port) $ \c -> do +      req <- buildRequest $ do+              http m p+              setAccept "application/json"+              setUserAgent defaultUserAgent+      void $ sendRequest c req body+      receiveResponse c handler++setUserAgent :: ByteString -> RequestBuilder ()+setUserAgent = setHeader "User-Agent"++defaultUserAgent :: ByteString+defaultUserAgent = "vigilance client"++unitResponseHandler :: Response+                       -> S.InputStream ByteString+                       -> IO (VigilanceResponse ())+unitResponseHandler = responseHandler (const $ return $ Right ())++jsonResponseHandler :: FromJSON a+                       => Response+                       -> S.InputStream ByteString+                       -> IO (VigilanceResponse a)+jsonResponseHandler = responseHandler handleJSONBody++responseHandler :: (S.InputStream ByteString -> IO (VigilanceResponse a))+                   -> Response+                   -> S.InputStream ByteString+                   -> IO (VigilanceResponse a)+responseHandler successHandler resp stream+  | responseOk        = successHandler stream+  | notFound          = return . Left $ NotFound +  | otherwise         = return . Left $ StatusError statusCode+  where statusCode        = getStatusCode resp+        responseOk        = inRange (200, 299) statusCode+        notFound          = statusCode == 404+  ++handleJSONBody :: FromJSON a => S.InputStream ByteString -> IO (VigilanceResponse a)+handleJSONBody stream = coerceParsed <$> parseJSONBody stream++data VError = NotFound        |+              ParseError Text |+              StatusError StatusCode deriving (Show, Eq)++parseJSONBody :: FromJSON a => S.InputStream ByteString -> IO (Result a)+parseJSONBody = parseFromStream parser+  where parser = fmap fromJSON json++type VigilanceResponse a = Either VError a++coerceParsed :: Result a -> VigilanceResponse a+coerceParsed (Success a) = Right a+coerceParsed (Error e)   = Left $ ParseError $ pack e++unlines' :: [Text] -> Text+unlines' = intercalate "\n"
+ src/Utils/Vigilance/Client/Config.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Utils.Vigilance.Client.Config ( Command(..)+                                     , Options(..)+                                     , ClientConfig(..)+                                     , ClientCtxT+                                     , defaultHost+                                     , readClientConfig+                                     , defaultPort'+                                     , defaultConfigPath ) where++import Prelude (FilePath)+import ClassyPrelude hiding (FilePath)+import Control.Monad ((<=<))+import Control.Monad.Trans.Reader+import Data.Configurator (load, Worth(Optional))+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as CT+import Network.Http.Client ( Hostname+                           , Port )+import Utils.Vigilance.Types++data Command = List              |+               Pause WatchName   |+               UnPause WatchName |+               CheckIn WatchName |+               Info WatchName    |+               Test WatchName deriving (Show, Eq)++data Options = Options { optCommand :: Command+                       , configPath :: FilePath } deriving (Show, Eq)++defaultConfigPath :: FilePath+defaultConfigPath = vigilanceDir <> "/client.conf"++data ClientConfig = ClientConfig { serverHost :: Hostname+                                 , serverPort :: Port } deriving (Show, Eq)++type ClientCtxT m a = ReaderT ClientConfig m a++defaultHost :: Hostname+defaultHost = "localhost"++defaultPort' :: Port+defaultPort' = fromInteger . toInteger $ defaultPort++readClientConfig :: FilePath -> IO ClientConfig+readClientConfig = convertClientConfig <=< loadConfig++loadConfig :: FilePath -> IO CT.Config+loadConfig pth = load [Optional pth]++convertClientConfig :: CT.Config -> IO ClientConfig+convertClientConfig cfg = ClientConfig <$> lookupHost <*> lookupPort+  where lookupHost = C.lookupDefault defaultHost cfg "vigilance.host"+        lookupPort = C.lookupDefault defaultPort' cfg "vigilance.port"
+ src/Utils/Vigilance/Client/Main.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Main (main) where++import Prelude (FilePath)+import ClassyPrelude hiding (FilePath)+import Control.Monad.Trans.Reader (runReaderT)+import Options.Applicative+import Options.Applicative.Builder.Internal ( CommandFields+                                            , Mod )+import System.Exit ( exitSuccess+                   , exitFailure)++import Utils.Vigilance.Client.Client+import Utils.Vigilance.Client.Config+import Utils.Vigilance.Types++main :: IO ()+main = runOptions =<< execParser opts++runOptions :: Options -> IO ()+runOptions Options {..} = runReaderT (runCommand optCommand) =<< readClientConfig configPath++runCommand :: Command -> ClientCtxT IO ()+runCommand List        = withErrorHandling displayList                  getList+runCommand (Pause n)   = withErrorHandling doNothing                  $ pause n+runCommand (UnPause n) = withErrorHandling doNothing                  $ unPause n+runCommand (CheckIn n) = withErrorHandling doNothing                  $ checkIn n+runCommand (Info n)    = withErrorHandling displayWatchInfo           $ getInfo n+runCommand (Test n)    = withErrorHandling handleTestResults          $ test n++handleTestResults :: [FailedNotification] -> IO ()+handleTestResults failures = do displayFailedNotifications failures+                                if null failures+                                  then exitSuccess+                                  else exitFailure++doNothing :: a -> IO ()+doNothing = const $ return ()++withErrorHandling :: (a -> IO ()) -> ClientCtxT IO (Either VError a) -> ClientCtxT IO ()+withErrorHandling display act = either (lift . displayError) (lift . display) =<< act++displayError :: VError -> IO ()+displayError e = putStrLn (message e) >> exitFailure+  where message NotFound           = "Watch not found"+        message (ParseError msg)   = "Parse error: " <> msg+        message (StatusError code) = "Server returned error status: " <> show code++opts :: ParserInfo Options+opts = info (helper <*> optionsParser) banner+  where banner = fullDesc <>+                 header "vigilance - tool for managing vigilance watches locally or remotely."++optionsParser :: Parser Options+optionsParser = Options <$> subparser commandParser+               <*> pathParser++pathParser :: Parser FilePath+pathParser = parser <|> pure defaultConfigPath+  where parser = strOption $ long "config"  <>+                             short 'c'      <>+                             metavar "FILE" <>+                             help (mconcat ["Config file. Defaults to ", pack vigilanceDir])+++commandParser :: Mod CommandFields Command+commandParser = listParser    <>+                pauseParser   <>+                unPauseParser <>+                checkInParser <>+                infoParser    <>+                testParser+  where listParser    = command "list"   $+                        info (pure List) $+                        progDesc "List watches"+        pauseParser   = command "pause"                            $+                        info (Pause . wn <$> argument str wnLabel) $+                        progDesc "Pause watch"+        unPauseParser = command "unpause"                            $+                        info (UnPause . wn <$> argument str wnLabel) $+                        progDesc "Unpause watch"+        checkInParser = command "checkin"                            $+                        info (CheckIn . wn <$> argument str wnLabel) $+                        progDesc "Check in watch"+        infoParser    = command "info"                               $+                        info (Info . wn <$> argument str wnLabel) $+                        progDesc "Get info about a watch"+        testParser    = command "test"                               $+                        info (Test . wn <$> argument str wnLabel) $+                        progDesc "Test the notifications for a watch"+        wn            = WatchName . pack+        wnLabel       = metavar "WATCH_NAME"
+ src/Utils/Vigilance/Config.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Utils.Vigilance.Config ( configNotifiers+                              , convertConfig+                              , reloadConfig+                              , loadRawConfig+                              , loadConfig) where++import ClassyPrelude hiding (FilePath)+import Control.Monad ((<=<))+import Control.Lens+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as CT+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Data.Time.Clock.POSIX ( POSIXTime+                             , getPOSIXTime )+import GHC.IO (FilePath)+import qualified Utils.Vigilance.Notifiers.HTTP as H+import qualified Utils.Vigilance.Notifiers.Email as E+import qualified Utils.Vigilance.Notifiers.Log   as L+import Utils.Vigilance.Types++configNotifiers :: Config -> NotifierGroup+configNotifiers cfg = NotifierGroup en H.notify L.notify+  where en = E.notify . E.EmailContext <$> cfg ^. configFromEmail++loadRawConfig :: FilePath -> IO CT.Config+loadRawConfig = C.load . pure . CT.Required++loadConfig :: FilePath -> IO Config+loadConfig = convertConfig <=< loadRawConfig++-- basically no point to this mappend at present+convertConfig :: CT.Config -> IO Config+convertConfig cfg = mempty <> Config <$> lud defaultAcidPath "vigilance.acid_path"+                                     <*> (toEmailAddress <$> lu "vigilance.from_email")+                                     <*> lud defaultPort "vigilance.port"+                                     <*> parseLogCfg+                                     <*> (parseWatches <$> getPOSIXTime <*> C.getMap cfg)+                                     <*> lud defaultMaxRetries "vigilance.max_retries"+  where lu             = C.lookup cfg+        lud d          = C.lookupDefault d cfg+        toEmailAddress = fmap (EmailAddress . pack)+        parseLogCfg = LogCfg <$> lud defaultLogPath "vigilance.log.path"+                             <*> lud False          "vigilance.log.verbose"++reloadConfig :: CT.Config -> IO ()+reloadConfig = C.reload++-- probably want to make this an either to fail on parse failures+parseWatches :: POSIXTime -> HashMap CT.Name CT.Value -> [NewWatch]+parseWatches time globalCfg = HM.foldrWithKey (addWatch time) [] rawWatches -- probably use a traverse+  where rawWatches :: HashMap Text WatchAttrs+        rawWatches = HM.foldrWithKey appendGroup mempty globalCfg++type WatchAttrs = HashMap CT.Name CT.Value++appendGroup :: CT.Name -> CT.Value -> HashMap Text WatchAttrs -> HashMap Text WatchAttrs+appendGroup fullKey val acc+  | nnull wName && nnull wAttr = HM.insertWith mappend wName (HM.singleton wAttr val) acc+  | otherwise                  = acc+  where (_, localKey)                = T.breakOnEnd "vigilance.watches." fullKey+        (wName, wAttrWithLeadingDot) = T.breakOn "." localKey+        wAttr                        = T.drop 1 wAttrWithLeadingDot+        nnull = not . null++addWatch :: POSIXTime -> Text -> WatchAttrs -> [NewWatch] -> [NewWatch]+addWatch time wName attrs = mappend watches+  where watches = maybeToList $ buildWatch time (WatchName wName) attrs++buildWatch :: POSIXTime -> WatchName -> WatchAttrs -> Maybe NewWatch+buildWatch time wName attrs = Watch <$> pure ()+                                    <*> pure wName+                                    <*> (parseInterval =<< lu "interval")+                                    <*> pure (Active time)+                                    <*> (pure . parseNotifications $ lud noNotifications "notifications") -- ehh, list of lists not that great, but making arbitrary names for notifications is dumb too+  where lu k            = HM.lookup k attrs+        lud d k         = HM.lookupDefault d k attrs+        noNotifications = CT.List []++parseNotifications :: CT.Value -> [NotificationPreference]+parseNotifications (CT.List vs) = mapMaybe parseNotification vs+parseNotifications _            = []++parseNotification :: CT.Value -> Maybe NotificationPreference+parseNotification (CT.List [CT.String "email", CT.String a]) = Just . EmailNotification . EmailAddress $ a+parseNotification (CT.List [CT.String "http",  CT.String u]) = Just . HTTPNotification . encodeUtf8 $ u+parseNotification _                                          = Nothing++parseInterval :: CT.Value -> Maybe WatchInterval+parseInterval (CT.List [CT.Number n, CT.String unit]) = Every <$> (pure . truncate $ n) +                                                              <*> txtToTimeUnit unit+parseInterval _                                       = Nothing
+ src/Utils/Vigilance/Logger.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+module Utils.Vigilance.Logger ( createLogChan+                              , runInLogCtx+                              , renameLogCtx+                              , pushLog+                              , vLog+                              , vLogs+                              , pushLogs ) where++import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan ( writeTChan+                                    , newTChan )+import Control.Lens+import Control.Monad.Reader ( runReaderT+                            , asks+                            , withReaderT )+import Control.Monad.Trans (lift)+import Data.Monoid ( Monoid+                   , mconcat)+import Data.Text (Text)++import Utils.Vigilance.Types++createLogChan :: IO LogChan+createLogChan = atomically newTChan++pushLogs :: [Text] -> LogCtxT IO ()+pushLogs = pushLogs' . map LogMessage++vLogs :: [Text] -> LogCtxT IO ()+vLogs = pushLogs' . map VerboseLogMessage++pushLog :: Text -> LogCtxT IO ()+pushLog = pushLogs' . return . LogMessage++vLog :: Text -> LogCtxT IO ()+vLog = pushLogs' . return . VerboseLogMessage++pushLogs' :: [LogMessage] -> LogCtxT IO ()+pushLogs' ls = do n        <- asks (view ctxName)+                  logChan  <- asks (view ctxChan)+                  lift $ atomically $ writeTChan logChan $ map (fmt n) ls+  where fmt n (LogMessage s)        = LogMessage $ fmt' n s+        fmt n (VerboseLogMessage s) = VerboseLogMessage $ fmt' n s+        fmt' n s                    = mconcat ["[", n, "] ", s, "\n"] -- why must i add newlines you dick?+++runInLogCtx :: LogCtx -> LogCtxT m a -> m a+runInLogCtx = flip runReaderT++renameLogCtx :: Text -> LogCtxT m a -> LogCtxT m a+renameLogCtx newName = withReaderT rename+  where rename ctx = ctx & ctxName .~ newName
+ src/Utils/Vigilance/Main.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+module Main (main) where++import ClassyPrelude hiding ( FilePath+                            , getArgs+                            , fromList )+import Control.Concurrent (forkIO)+import Control.Concurrent.Async ( waitAnyCatchCancel+                                , cancel+                                , Async+                                , async )+import Control.Concurrent.STM ( atomically+                              , newBroadcastTChan+                              , TChan+                              , writeTChan+                              , dupTChan )+import Control.Lens+import Control.Monad.Reader ( ask+                            , asks )+import Data.Acid ( AcidState+                 , openLocalStateFrom+                 , createCheckpoint+                 , closeAcidState )+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as CT+import Prelude (FilePath)+import System.Environment (getArgs)+import System.Exit ( ExitCode(..)+                   , exitWith )+import System.Posix.Signals ( installHandler+                            , sigHUP+                            , sigINT+                            , sigTERM+                            , Handler(Catch) )+import Text.InterpolatedString.Perl6 (qc)++import Utils.Vigilance.Config ( loadRawConfig+                              , convertConfig+                              , configNotifiers )+import Utils.Vigilance.Logger ( createLogChan+                              , runInLogCtx+                              , renameLogCtx+                              , vLog+                              , pushLogs+                              , pushLog )+import Utils.Vigilance.TableOps (fromList)+import Utils.Vigilance.Types+import Utils.Vigilance.Utils ( bindM2+                             , newWakeSig+                             , waitForWake+                             , expandHome+                             , wakeUp )+import Utils.Vigilance.Worker ( workForeverWithDelayed+                              , workForeverWith )+import Utils.Vigilance.Web.Yesod (runServer, WebApp(..))+import qualified Utils.Vigilance.Workers.LoggerWorker as LW+import qualified Utils.Vigilance.Workers.NotificationWorker as NW+import qualified Utils.Vigilance.Workers.NotificationRetryWorker as RW+import qualified Utils.Vigilance.Workers.StaticWatchWorker as WW+import qualified Utils.Vigilance.Workers.SweeperWorker as SW++main :: IO ()+main = runWithConfigPath =<< getConfigPath++getConfigPath :: IO FilePath+getConfigPath = fromMaybe defaultPath . listToMaybe <$> getArgs+  where defaultPath = vigilanceDir <> "/server.conf"++runWithConfigPath :: FilePath -> IO ()+runWithConfigPath path = bindM2 runInMainLogCtx (loadRawConfig path) createLogChan++runInMainLogCtx :: CT.Config -> TChan [LogMessage] -> IO ()+runInMainLogCtx rCfg logChan = do let ctx = LogCtx "Main" logChan+                                  runInLogCtx ctx $ runWithConfig rCfg++runWithConfig :: CT.Config -> LogCtxT IO ()+runWithConfig rCfg = do cfg      <- lift $ convertConfig rCfg+                        lCtx     <- ask+                        logChan  <- asks (view ctxChan)+                        acidPath <- lift $ expandHome $ cfg ^. configAcidPath++                        (configChanW, configChanR, configChanR') <- lift $ atomically $ do w  <- newBroadcastTChan+                                                                                           r  <- dupTChan w+                                                                                           r' <- dupTChan w+                                                                                           return (w, r, r')++                        let notifiers = configNotifiers cfg+                        acid      <- lift $ openLocalStateFrom acidPath (AppState (initialState cfg) mempty)+                        quitSig   <- lift newWakeSig++                        let sweeperH       = errorLogger "Sweeper" lCtx+                        let notifierH      = errorLogger "Notifier" lCtx+                        let loggerH        = errorLogger "Logger" lCtx+                        let staticH        = errorLogger "Config Reload" lCtx+                        let retryH         = errorLogger "Retry" lCtx+                        let sweeperWorker  = runInLogCtx lCtx $ SW.runWorker acid+                        let notifierWorker = runInLogCtx lCtx $ NW.runWorker acid notifiers+                        let retryWorker    = runInLogCtx lCtx $ RW.runWorker acid (cfg ^. configMaxRetries) notifiers+                        let loggerWorker   = LW.runWorker logChan cfg configChanR+                        let watchWorker    = runInLogCtx lCtx $ WW.runWorker acid configChanR'+                        let webApp         = WebApp acid cfg logChan++                        vLog "Starting logger" -- TIME PARADOX++                        logger <- lift $ async $ workForeverWith loggerH loggerWorker++                        vLog "Starting sweeper"++                        sweeper <- lift $ async $ workForeverWithDelayed sweeperDelay sweeperH sweeperWorker++                        vLog "Sweeper started"+                        vLog "Starting notifier"++                        nworker <- lift $ async $ workForeverWithDelayed notifierDelay notifierH notifierWorker++                        vLog "Notifier started"++                        vLog "Starting retry worker"++                        rworker <- lift $ async $ workForeverWithDelayed retryDelay retryH retryWorker++                        vLog "Retry worker started"++                        vLog "Starting web server"+                        server <- lift $ async $ runServer webApp++                        static <- lift $ async $ workForeverWith staticH watchWorker++                        let workers = [ server+                                      , sweeper+                                      , nworker+                                      , rworker+                                      , static ]++                        vLog "configuring signal handlers"++                        lift $ do+                          void $ installHandler sigHUP  (Catch $ broadcastCfgReload rCfg configChanW) Nothing+                          void $ installHandler sigINT  (Catch $ wakeUp quitSig ExitSuccess) Nothing+                          void $ installHandler sigTERM (Catch $ wakeUp quitSig ExitSuccess) Nothing++                        vLog "waiting for any process to fail"++                        void . lift . forkIO $ do+                          void $ waitAnyCatchCancel (logger:workers)+                          wakeUp quitSig (ExitFailure 1)++                        vLog "waiting for quit signal"+                        code <- lift $ waitForWake quitSig++                        cleanUp acid workers code+  where initialState :: Config -> WatchTable+        initialState cfg = fromList $ cfg ^. configWatches++broadcastCfgReload :: CT.Config -> TChan Config -> IO ()+broadcastCfgReload rCfg chan = C.reload rCfg >> broadcast+  where broadcast = atomically . writeTChan chan =<< convertConfig rCfg++errorLogger :: Text -> LogCtx -> SomeException -> IO ()+errorLogger name ctx e =  runInLogCtx ctx $ renameLogCtx name $ pushLog errMsg+  where errMsg = [qc|Error: {e}|] :: Text++sweeperDelay :: Int+sweeperDelay = 5 -- arbitrary++notifierDelay :: Int+notifierDelay = 5 -- arbitrary++retryDelay :: Int+--retryDelay = 30+retryDelay = 10++cleanUp :: AcidState AppState -> [Async ()] -> ExitCode -> LogCtxT IO ()+cleanUp acid workers code = do pushLogs ["cleaning up", "killing workers"]+                               lift $ mapM_ cancel workers+                               pushLog "creating checkpoint"+                               lift $ createCheckpoint acid+                               pushLog "closing acid"+                               lift $ closeAcidState acid >> exitWith code
+ src/Utils/Vigilance/Notifiers/Email.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TemplateHaskell   #-}+module Utils.Vigilance.Notifiers.Email ( notify+                                       , generateEmails+                                       , EmailContext(..)+                                       , HasEmailContext(..)+                                       , NotificationMail(..)+                                       , HasNotificationMail(..)+                                       , Address(..)) where++import ClassyPrelude+import Control.Lens hiding (from)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map.Lazy as M+import Text.InterpolatedString.Perl6 (qc)+import Network.Mail.Mime ( Address(..)+                         , emptyMail+                         , Part(..)+                         , renderSendMail+                         , Encoding( QuotedPrintableText )+                         , Mail(..))++import Utils.Vigilance.Logger ( pushLog+                              , renameLogCtx )+import Utils.Vigilance.Types+import Utils.Vigilance.Utils (concatMapM)++data EmailContext = EmailContext { _fromEmail :: EmailAddress } deriving (Show, Eq)++makeClassy ''EmailContext++data NotificationMail = NotificationMail { _nmWatches :: [EWatch]+                                         , _nmMail    :: Mail }++makeClassy ''NotificationMail++notify :: EmailContext -> EmailNotifier+notify ctx = EmailNotifier notifierBody+  where notifierBody watches = renameLogCtx "Email Notifier" $ concatMapM renderSendMail' mails+          where mails = generateEmails watches ctx++renderSendMail' :: NotificationMail -> LogCtxT IO [FailedNotification]+renderSendMail' (NotificationMail ws mail) = do+  pushLog [qc|Sending email notification to {emailList}|]+  lift $ handleAny buildFailures $ renderSendMail mail >> return []+  where emailList = intercalate ", " emails+        emails    = map addressEmail . mailTo $ mail+        addrs     = map EmailAddress emails+        buildFailures e = return [ FailedNotification w n (FailedByException $ show e) 0+                                 | w <- ws+                                 , n@(EmailNotification addr) <- w ^. watchNotifications+                                 , addr `elem` addrs ]++generateEmails :: [EWatch] -> EmailContext -> [NotificationMail]+generateEmails watches ctx = M.elems $ M.mapWithKey createMail groupedByEmail -- ehhhhh+  where groupedByEmail = M.fromListWith mappend $ concatMap watchesWithEmails watches+        createMail toAddr ws = NotificationMail ws mail+          where mail = (emptyMail from) { mailTo      = [e2a toAddr]+                                        , mailHeaders = [("Subject", subject)]+                                        , mailParts   = [[mailPart ws]] }+                subject = [qc|Vigilence notification {watchCount} activated|] :: Text+                watchCount = length ws+        from :: Address+        from = ctx ^. fromEmail . to e2a++mailPart :: [EWatch] -> Part+mailPart ws =  Part "text/plain; charset=utf-8" QuotedPrintableText Nothing [] (bodyLBS ws)++bodyLBS :: [EWatch] -> LBS.ByteString+bodyLBS ws = [qc|+The following watches were triggered:++{watchSummary}++Sincerely,+Vigilence+  |]+  where watchSummary = mconcat $ map summarize ws+        summarize w  = [qc|- {name} ({interval})|] :: LBS.ByteString+          where interval = w ^. watchInterval+                name     = w ^. watchName . unWatchName . to unpack++watchesWithEmails :: EWatch -> [(EmailAddress, [EWatch])]+watchesWithEmails w = zip emails (repeat [w] :: [[EWatch]])+  where emails = mapMaybe extractEmail $ w ^. watchNotifications+        extractEmail (EmailNotification e) = Just e+        extractEmail _                     = Nothing++e2a :: EmailAddress -> Address+e2a = Address Nothing . view unEmailAddress
+ src/Utils/Vigilance/Notifiers/HTTP.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE QuasiQuotes       #-}+module Utils.Vigilance.Notifiers.HTTP ( notify+                                      , watchesWithNotifications ) where++import ClassyPrelude+import Control.Lens+import Blaze.ByteString.Builder (Builder)+import Data.Aeson ( ToJSON+                  , encode )+import Data.Ix (inRange)+import Network.Http.Client ( URL+                           , inputStreamBody+                           , getStatusCode+                           , post )+import qualified System.IO.Streams as S+import Text.InterpolatedString.Perl6 (qc)+import Utils.Vigilance.Logger ( renameLogCtx+                              , pushLog+                              , vLog )+import Utils.Vigilance.Types++notify :: HTTPNotifier+notify = HTTPNotifier notifierBody+  where notifierBody watches = renameLogCtx "HTTP Notifier" $ catMaybes <$> mapM (uncurry makeRequest) notifications+          where notifications = watchesWithNotifications watches++watchesWithNotifications :: [EWatch] -> [(EWatch, URL)]+watchesWithNotifications = concatMap extractUrls+  where extractUrls w = zip (repeat w :: [EWatch]) urls+          where urls = [ u | HTTPNotification u <- w ^. watchNotifications]++makeRequest :: EWatch -> URL -> LogCtxT IO (Maybe FailedNotification)+makeRequest w url = do+  inputStream <- lift $ jsonBodyStream w+  vLog [qc|Notifying {w ^. watchName} at {url}|]+  result <- lift . tryAny $ post url "application/json" inputStream skipResponse+  either failedByException handleCode result+  where skipResponse r _ = return $ getStatusCode r+        handleCode code+          | inRange (200, 299) code = success code+          | otherwise               = failure code+        success code = vLog [qc|{url} returned {code}|] >> return Nothing+        failure code = pushLog [qc|{url} failed with {code}|] >> failedByCode code+        failedByException e = return . Just $ FailedNotification w notif (FailedByException $ show e) 0+        failedByCode code   = return . Just $ FailedNotification w notif (FailedByCode code) 0+        notif = HTTPNotification url++jsonBodyStream :: ToJSON a => a -> IO (S.OutputStream Builder -> IO ())+jsonBodyStream = fmap inputStreamBody . S.fromLazyByteString . encode
+ src/Utils/Vigilance/Notifiers/Log.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+module Utils.Vigilance.Notifiers.Log ( notify ) where++import ClassyPrelude+import Control.Lens+import Text.InterpolatedString.Perl6 (qc)++import Utils.Vigilance.Logger+import Utils.Vigilance.Types++notify :: LogNotifier+notify = LogNotifier notifierBody+  where notifierBody watches = renameLogCtx "Log Notifier" $ pushLogs formattedWatches >> return []+          where formattedWatches = map format watches+                format :: EWatch -> Text+                format w = [qc|Watch {w ^. watchName ^. unWatchName} notified.|]
+ src/Utils/Vigilance/Sweeper.hs view
@@ -0,0 +1,33 @@+module Utils.Vigilance.Sweeper ( expired+                               , sweepWatch ) where++import Control.Lens++import Data.Time.Clock.POSIX (POSIXTime)++import Utils.Vigilance.Types+++expired :: POSIXTime -> Watch i -> Bool+expired now w@Watch { _watchWState = Active lst } = now > cutoff+  where cutoff       = lst + interval+        interval     = fromInteger $ secondsInterval (w ^. watchInterval)+expired _ _                                        = False++expireWatch :: Watch i -> Watch i+expireWatch w = w & watchWState %~ bumpState+  where bumpState Triggered = Triggered+        bumpState _         = Notifying++sweepWatch :: Show i => POSIXTime -> Watch i -> Watch i+sweepWatch t w+  | expired t w = expireWatch w+  | otherwise   = w++secondsInterval :: WatchInterval -> Integer+secondsInterval (Every n Seconds) = n+secondsInterval (Every n Minutes) = n * 60+secondsInterval (Every n Hours)   = n * 3600+secondsInterval (Every n Days)    = n * 86400+secondsInterval (Every n Weeks)   = n * 604800+secondsInterval (Every n Years)   = n * 31536000
+ src/Utils/Vigilance/TableOps.hs view
@@ -0,0 +1,328 @@+{-# 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
+ src/Utils/Vigilance/Types.hs view
@@ -0,0 +1,385 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+module Utils.Vigilance.Types where++import Prelude (FilePath)+import ClassyPrelude hiding (FilePath)+import Control.Concurrent.STM.TChan (TChan)+import Control.Monad (mzero)+import Control.Monad.Reader (ReaderT)+import Control.Lens hiding ((.=))+import Data.Aeson+import qualified Data.Attoparsec.Number as N+import Data.SafeCopy ( base+                     , SafeCopy+                     , deriveSafeCopy)+import           Data.Store ( M+                            , O+                            , (:.)+                            , Store )+import qualified Data.Store as S+import           Data.Store.Storable (Storable(..))+import Data.Time.Clock.POSIX (POSIXTime)+import qualified Data.Vector as V+import Network.Http.Client ( URL+                           , StatusCode )+import System.Log.FastLogger ( ToLogStr(..) )+import Text.InterpolatedString.Perl6 (qc)+import Yesod.Core.Dispatch (PathPiece)++newtype ID = ID { _unID :: Int } deriving ( Show+                                          , Eq+                                          , Enum+                                          , Read+                                          , PathPiece+                                          , Ord+                                          , Num+                                          , SafeCopy+                                          , FromJSON+                                          , ToJSON+                                          , Typeable)++makeClassy ''ID++instance Bounded ID where+  minBound = ID 1+  maxBound = ID maxBound++--TODO: somewhere have to handle the case of <= 0+data WatchInterval = Every Integer TimeUnit deriving (Show, Eq, Typeable, Ord)++instance ToJSON WatchInterval where+  toJSON (Every n u) = Array $ V.fromList [toJSON n, toJSON u]+  +instance FromJSON WatchInterval where+  parseJSON = withArray "WatchInterval" $ parseWatchInterval . V.toList+    where parseWatchInterval [Number (N.I n), s@(String _)]+            | n > 0     = Every <$> pure n <*> parseJSON s -- just get it out of the N.I and call pure?+            | otherwise = fail "interval must be > 0"+          parseWatchInterval _                              = fail "expecting a pair of integer and string"++data TimeUnit = Seconds |+                Minutes |+                Hours   |+                Days    |+                Weeks   |+                Years deriving (Show, Eq, Ord)++instance ToJSON TimeUnit where+  toJSON Seconds = String "seconds"+  toJSON Minutes = String "minutes"+  toJSON Hours   = String "hours"+  toJSON Days    = String "days"+  toJSON Weeks   = String "weeks"+  toJSON Years   = String "years"++txtToTimeUnit :: Text -> Maybe TimeUnit+txtToTimeUnit "seconds" = Just Seconds+txtToTimeUnit "minutes" = Just Minutes+txtToTimeUnit "hours"   = Just Hours+txtToTimeUnit "days"    = Just Days+txtToTimeUnit "weeks"   = Just Weeks+txtToTimeUnit "years"   = Just Years+txtToTimeUnit _         = Nothing++instance FromJSON TimeUnit where+  parseJSON = withText "TimeUnit" parseTimeUnit+    where parseTimeUnit txt = maybe unknown return $ txtToTimeUnit txt+          unknown           = fail "unknown time unit"++newtype EmailAddress = EmailAddress { _unEmailAddress :: Text } deriving ( Show+                                                                         , Eq+                                                                         , Ord+                                                                         , SafeCopy+                                                                         , Typeable+                                                                         , ToJSON+                                                                         , FromJSON)++makeClassy ''EmailAddress++data NotificationPreference = EmailNotification EmailAddress |+                              HTTPNotification URL deriving (Show, Eq, Ord)++instance ToJSON NotificationPreference where+  toJSON (EmailNotification a) = object [ "type"    .= String "email"+                                        , "address" .= String (a ^. unEmailAddress)]+  toJSON (HTTPNotification u) = object [ "type"    .= String "http"+                                       , "url"     .= String (decodeUtf8 u)]++instance FromJSON NotificationPreference where+  parseJSON v = parseEmailNotification v <|>+                parseHTTPNotification v+    where parseEmailNotification = withObject "EmailNotification" parseEmail+          parseEmail obj = do t <- obj .: "type"+                              case t of+                                String "email" -> EmailNotification <$> obj .: "address"+                                _              -> mzero+          parseHTTPNotification = withObject "HTTPNotification" parseHttp+          parseHttp obj = do t <- obj .: "type"+                             case t of+                               String "http" -> HTTPNotification <$> obj .: "url"+                               _             -> mzero++newtype POSIXWrapper = POSIXWrapper { unPOSIXWrapper :: POSIXTime }++instance FromJSON POSIXWrapper where+  parseJSON = withNumber "POSIXTime" parsePOSIXTime+    where parsePOSIXTime (N.I i) = pure . POSIXWrapper . fromIntegral $ i+          parsePOSIXTime _       = fail "Expected integer"++instance ToJSON POSIXWrapper where+  toJSON = Number . N.I . truncate . toRational . unPOSIXWrapper++data WatchState = Active { _lastCheckIn :: POSIXTime } |+                  Paused                               |+                  Notifying                            |+                  Triggered deriving (Show, Eq, Ord) -- ehhhhhh++makeClassy ''WatchState++instance Monoid WatchState where+  mempty                = Paused+  mappend Paused Paused = Paused+  mappend x      Paused = x+  mappend _      y      = y++instance ToJSON WatchState where+  toJSON (Active t) = object [ "name"          .= String "active"+                             , "last_check_in" .= POSIXWrapper t ]+  toJSON Paused     = object [ "name"          .= String "paused" ]+  toJSON Notifying  = object [ "name"          .= String "notifying" ]+  toJSON Triggered  = object [ "name"          .= String "triggered" ]++instance FromJSON WatchState where+  parseJSON = withObject "WatchState" parseWatchState+    where parseWatchState obj = withText "state name" (parseStateFromName obj) =<< (obj .: "name")+          parseStateFromName _ "paused"    = pure Paused+          parseStateFromName _ "notifying" = pure Notifying+          parseStateFromName _ "triggered" = pure Triggered+          parseStateFromName obj "active" = Active <$> (unPOSIXWrapper <$> obj .: "last_check_in")+          parseStateFromName _ _           = fail "Invalid value"+++newtype WatchName = WatchName { _unWatchName :: Text } deriving ( Show+                                                                , Eq+                                                                , Ord+                                                                , FromJSON+                                                                , ToJSON+                                                                , IsString+                                                                , Read+                                                                , PathPiece ) -- not so sure about the isstring++makeLenses ''WatchName++data Watch i = Watch { _watchId            :: i+                     , _watchName          :: WatchName+                     , _watchInterval      :: WatchInterval+                     , _watchWState        :: WatchState+                     , _watchNotifications :: [NotificationPreference] } deriving (Show, Eq, Typeable, Ord)++makeLenses ''Watch++type NewWatch = Watch ()+type EWatch   = Watch ID++instance ToJSON EWatch where+  toJSON w = object [ "id"            .= (w ^. watchId)+                    , "name"          .= (w ^. watchName)+                    , "interval"      .= (w ^. watchInterval)+                    , "state"         .= (w ^. watchWState)+                    , "notifications" .= (w ^. watchNotifications)+                    , "name"          .= (w ^. watchName) ]+++instance FromJSON EWatch where+  parseJSON = withObject "Watch" parseNewWatch+    where parseNewWatch obj = Watch <$> obj .: "id"+                                    <*> obj .: "name"+                                    <*> obj .: "interval"+                                    <*> obj .: "state"+                                    <*> obj .: "notifications"++instance ToJSON NewWatch where+  toJSON w = object [ "name"          .= (w ^. watchName)+                    , "interval"      .= (w ^. watchInterval)+                    , "state"         .= (w ^. watchWState)+                    , "notifications" .= (w ^. watchNotifications)+                    , "name"          .= (w ^. watchName) ]+++instance FromJSON NewWatch where+  parseJSON = withObject "Watch" parseNewWatch+    where parseNewWatch obj = Watch <$> pure ()+                                    <*> obj .: "name"+                                    <*> obj .: "interval"+                                    <*> obj .: "state"+                                    <*> obj .: "notifications"++data WatchStoreTag = WatchStoreTag++-- tagspec+instance Storable NewWatch where+  type StoreTS   NewWatch = ID :. WatchName :. WatchInterval :. WatchState :. NotificationPreference+  type StoreKRS  NewWatch = O  :. O         :. O             :. O          :. M+  type StoreIRS  NewWatch = O  :. O         :. M             :. M          :. M++  key (Watch _ wn wi ws wns) = +    S.dimA    S..:+    S.dimO wn S..:+    S.dimO wi S..:+    S.dimO ws S..:.+    S.dimM wns++type WatchTable = Store WatchStoreTag (StoreKRS NewWatch) (StoreIRS NewWatch) (StoreTS NewWatch) NewWatch++data NotificationError = FailedByCode StatusCode |+                         FailedByException Text deriving (Eq, Show, Typeable)++instance ToJSON NotificationError where+  toJSON (FailedByCode c) = object [ "error"       .= String "code_error"+                                   , "status_code" .= c+                                   , "message"     .= String [qc|Failed with status code {c}|] ]+  toJSON (FailedByException e) = object [ "error"     .= String "exception"+                                        , "exception" .= e+                                        , "message"   .= String [qc|Failed with exception {e}|] ]++instance FromJSON NotificationError where+  parseJSON = withObject "NotificationError" parseNotificationError+    where parseNotificationError obj = do+            err <- obj .: "error"+            case err of+              String "code_error" -> FailedByCode      <$> obj .: "status_code"+              String "exception"  -> FailedByException <$> obj .: "exception"+              _                   -> mzero++data FailedNotification = FailedNotification { _failedWatch     :: EWatch+                                             , _failedPref      :: NotificationPreference+                                             , _failedLastError :: NotificationError+                                             , _retries         :: Int } deriving (Typeable, Show, Eq)++instance ToJSON FailedNotification where+  toJSON FailedNotification{..} = object [ "failed_watch"        .= _failedWatch+                                         , "failed_notification" .= _failedPref+                                         , "last_error"          .= _failedLastError+                                         , "retries"             .= _retries ]++instance FromJSON FailedNotification where+  parseJSON = withObject "FailedNotification" parseFailedNotification+    where parseFailedNotification obj = FailedNotification <$> obj .: "failed_watch"+                                                           <*> obj .: "failed_notification"+                                                           <*> obj .: "last_error"+                                                           <*> obj .: "retries"++makeClassy ''FailedNotification++data AppState = AppState { _wTable :: WatchTable+                         , _failed :: [FailedNotification] } deriving (Typeable)++makeLenses ''AppState++data LogCfg = LogCfg { _logCfgPath    :: FilePath+                     , _logCfgVerbose :: Bool } deriving (Show, Eq)++makeClassy ''LogCfg++data Config = Config { _configAcidPath   :: FilePath+                     , _configFromEmail  :: Maybe EmailAddress+                     , _configPort       :: Int+                     , _configLogCfg     :: LogCfg+                     , _configWatches    :: [NewWatch]+                     , _configMaxRetries :: Int } deriving (Show, Eq)++makeClassy ''Config++-- this is unsound+instance Monoid Config where+  mempty = Config defaultAcidPath Nothing defaultPort defaultLogCfg mempty defaultMaxRetries+  Config apa ea pa la wa ra `mappend` Config apb eb pb lb wb rb = Config (nonDefault defaultAcidPath apa apb)+                                                                         (chooseJust ea eb)+                                                                         (nonDefault defaultPort pa pb)+                                                                         (nonDefault defaultLogCfg la lb)+                                                                         (mappend wa wb)+                                                                         (nonDefault defaultMaxRetries ra rb)+    where chooseJust a@(Just _) _ = a+          chooseJust _ b          = b+          nonDefault defValue a b+            | a == defValue = b+            | b == defValue = a+            | otherwise     = b++defaultMaxRetries :: Int+defaultMaxRetries = 3++defaultLogCfg :: LogCfg+defaultLogCfg = LogCfg defaultLogPath False++defaultLogPath :: FilePath+defaultLogPath = vigilanceDir <> "/vigilance.log"++defaultAcidPath :: FilePath+defaultAcidPath = vigilanceDir <> "/state/AppState"++defaultPort :: Int+defaultPort = 3000++vigilanceDir :: FilePath+vigilanceDir = "$(HOME)/.vigilance"++data LogMessage = LogMessage        Text |+                  VerboseLogMessage Text deriving (Show, Eq)++instance ToLogStr LogMessage where+  toLogStr (LogMessage x)        = toLogStr x+  toLogStr (VerboseLogMessage x) = toLogStr x++-- should i use chan, tmchan?+type LogChan = TChan [LogMessage]++-- maybe need a local ctx that can name the context and then nest a chan?+data LogCtx = LogCtx { _ctxName    :: Text+                     , _ctxChan    :: LogChan }++makeClassy ''LogCtx++type LogCtxT m a = ReaderT LogCtx m a++type Notifier = [EWatch] -> LogCtxT IO [FailedNotification]++newtype EmailNotifier = EmailNotifier { _emailNotifier :: Notifier }++makeFields ''EmailNotifier++newtype HTTPNotifier = HTTPNotifier { _httpNotifier :: Notifier }++makeFields ''HTTPNotifier++newtype LogNotifier = LogNotifier { _logNotifier  :: Notifier }++makeFields ''LogNotifier++data NotifierGroup = NotifierGroup { _ngEmail :: Maybe EmailNotifier +                                   , _ngHTTP  :: HTTPNotifier+                                   , _ngLog   :: LogNotifier }++makeClassy ''NotifierGroup++deriveSafeCopy 0 'base ''WatchName+deriveSafeCopy 0 'base ''WatchState+deriveSafeCopy 0 'base ''TimeUnit+deriveSafeCopy 0 'base ''WatchInterval+deriveSafeCopy 0 'base ''Watch+deriveSafeCopy 0 'base ''NotificationPreference+deriveSafeCopy 0 'base ''NotificationError+deriveSafeCopy 0 'base ''FailedNotification+deriveSafeCopy 0 'base ''AppState
+ src/Utils/Vigilance/Utils.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Utils.Vigilance.Utils ( watchIntervalSeconds+                             , WakeSig+                             , newWakeSig+                             , wakeUp+                             , waitForWake+                             , concatMapM+                             , tryReadTChan+                             , expandHome+                             , bindM3+                             , bindM2) where++import ClassyPrelude hiding (FilePath)+import Prelude (FilePath)+import Control.Monad ( liftM3+                     , liftM2 )++import Control.Monad.STM ( atomically+                         , orElse+                         , STM )+import Control.Concurrent.STM.TChan ( TChan+                                    , readTChan )+import Control.Concurrent.STM.TMVar ( TMVar+                                    , newEmptyTMVarIO+                                    , takeTMVar+                                    , putTMVar)+import qualified Data.Text as T+import System.Directory (getHomeDirectory)+import Utils.Vigilance.Types++watchIntervalSeconds :: WatchInterval -> Integer+watchIntervalSeconds (Every n Seconds) = n+watchIntervalSeconds (Every n Minutes) = n * 60+watchIntervalSeconds (Every n Hours)   = n * 60 * 60+watchIntervalSeconds (Every n Days)    = n * 60 * 60 * 24+watchIntervalSeconds (Every n Weeks)   = n * 60 * 60 * 24 * 7+watchIntervalSeconds (Every n Years)   = n * 60 * 60 * 24 * 365+++concatMapM :: (Monad m, Applicative m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f = (concat <$>) . mapM f++bindM2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c+bindM2 f m1 m2  = join $ liftM2 f m1 m2++bindM3 :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d+bindM3 f m1 m2 m3  = join $ liftM3 f m1 m2 m3++type WakeSig a = TMVar a++newWakeSig :: IO (WakeSig a)+newWakeSig = newEmptyTMVarIO++waitForWake :: WakeSig a -> IO a+waitForWake = atomically . takeTMVar++wakeUp :: WakeSig a -> a -> IO ()+wakeUp sig = atomically . putTMVar sig++tryReadTChan :: TChan a -> STM (Maybe a)+tryReadTChan c = (Just <$> readTChan c) `orElse` return Nothing++expandHome :: FilePath -> IO FilePath+expandHome path = do home <- pack <$> getHomeDirectory+                     return . unpack . T.replace homeVar home . pack $ path+  where homeVar = "$(HOME)"
+ src/Utils/Vigilance/Web/Yesod.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE QuasiQuotes               #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoImplicitPrelude         #-}+-- thanks, yesod :(+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+module Utils.Vigilance.Web.Yesod ( runServer+                                 , WebApp(..) ) where++import ClassyPrelude+import Control.Lens+import Control.Monad ( (<=<) )+import Data.Acid (AcidState)+import Data.Time.Clock.POSIX ( getPOSIXTime+                             , POSIXTime )+import qualified Network.Wai as W+import Network.Wai.Handler.Warp (run)+import Network.HTTP.Types.Status (noContent204)+import Network.Wai.Middleware.Autohead+import Network.Wai.Middleware.AcceptOverride+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.MethodOverride+++import Utils.Vigilance.Config (configNotifiers)+import Utils.Vigilance.Logger ( runInLogCtx+                              , vLog )+import Utils.Vigilance.TableOps+import Utils.Vigilance.Types+import Utils.Vigilance.Workers.NotificationWorker (sendNotifications)+import Utils.Vigilance.Utils (bindM3)++import System.Log.FastLogger (LogStr(..))+import Yesod++data WebApp = WebApp { _acid    :: AcidState AppState+                     , _cfg     :: Config+                     , _logChan :: LogChan }++makeClassy ''WebApp++logCtxName :: Text+logCtxName = "Web"++-- stolen form yesod implementation. this needs to be public++lSToT :: LogStr -> Text+lSToT (LS s) = pack s+lSToT (LB s) = decodeUtf8 s++instance Yesod WebApp where+  makeSessionBackend = const $ return Nothing++mkYesod "WebApp" [parseRoutes|+  /watches                    WatchesR      GET+  /watches/#WatchName         WatchR        GET DELETE+  /watches/#WatchName/pause   PauseWatchR   POST+  /watches/#WatchName/unpause UnPauseWatchR POST+  /watches/#WatchName/checkin CheckInWatchR POST+  /watches/#WatchName/test    TestWatchR    POST+|]++getWatchesR :: Handler Value+getWatchesR = returnJson =<< allWatchesS =<< getDb++getWatchR :: WatchName -> Handler Value+getWatchR =  jsonOrNotFound <=< onWatch findWatchS++deleteWatchR :: WatchName -> Handler Value+deleteWatchR name = onWatchExists deleteWatchS name >> noContent++postPauseWatchR :: WatchName -> Handler Value+postPauseWatchR name = onWatchExists pauseWatchS name >> noContent++postUnPauseWatchR :: WatchName -> Handler Value+postUnPauseWatchR name = onWatchExists unPause name >> noContent+  where unPause db n = liftIO $ bindM3 unPauseWatchS (return db) getPOSIXTime (return n)++postCheckInWatchR :: WatchName -> Handler Value+postCheckInWatchR name = onWatchExists checkIn name >> noContent+  where checkIn db n = liftIO $ bindM3 checkInWatchS (return db) getPOSIXTime (return n)++postTestWatchR :: WatchName -> Handler Value+postTestWatchR = maybe notFound doTest <=< onWatch findWatchS+  where doTest w = do notifiers <- configNotifiers <$> getConfig+                      returnJson =<< inWebLogCtx (sendNotifications [w] notifiers)++noContent :: Handler Value+noContent = sendResponseStatus noContent204 ()++alwaysNoContent :: a -> Handler Value+alwaysNoContent = const noContent++jsonOrNotFound :: ToJSON a => Maybe a -> Handler Value+jsonOrNotFound = maybe notFound returnJson++runServer :: WebApp -> IO ()+runServer w = run port =<< toWaiApp' w+  where port = w ^. cfg . configPort++toWaiApp' :: WebApp -> IO W.Application+toWaiApp' site = do+  let ctx = LogCtx logCtxName $ site ^. logChan+  middleware <- mkDefaultMiddlewares' ctx+  middleware <$> toWaiAppPlain site++mkDefaultMiddlewares' :: LogCtx -> IO W.Middleware+mkDefaultMiddlewares' ctx = do+    logWare <- mkRequestLogger def+        { destination = Callback cb+        , outputFormat = Apache FromSocket+        }+    return $ logWare+           . acceptOverride+           . autohead+           . gzip def+           . methodOverride+  where cb = runInLogCtx ctx . vLog . mconcat . map lSToT++getDb :: HandlerT WebApp IO (AcidState AppState)+getDb = view acid <$> getYesod++inWebLogCtx :: LogCtxT IO a -> HandlerT WebApp IO a+inWebLogCtx action = do+  ctx <- LogCtx <$> pure logCtxName <*> getLogChan+  liftIO $ runInLogCtx ctx action++getLogChan :: HandlerT WebApp IO LogChan+getLogChan = view logChan <$> getYesod++getConfig :: HandlerT WebApp IO Config+getConfig = view cfg <$> getYesod++onWatch :: (AcidState AppState -> WatchName -> HandlerT WebApp IO b) -> WatchName -> HandlerT WebApp IO b+onWatch f n = join $ f <$> getDb <*> pure n++onWatchExists :: (AcidState AppState -> WatchName -> HandlerT WebApp IO b) -> WatchName -> HandlerT WebApp IO b+onWatchExists f n = maybe notFound goAhead =<< checkExistence+  where checkExistence = do db <- getDb+                            liftIO $ findWatchS db n+        goAhead        = const $ onWatch f n++getPOSIXTime' :: MonadIO m => m POSIXTime+getPOSIXTime' = liftIO getPOSIXTime
+ src/Utils/Vigilance/Worker.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Utils.Vigilance.Worker ( workForeverWith+                              , workForeverWithDelayed+                              , workForever) where++import ClassyPrelude+import Control.Concurrent (threadDelay)++workForeverWithDelayed :: Int -> (SomeException -> IO ()) -> IO () -> IO ()+workForeverWithDelayed d handler action = workForeverWith handler doAction+  where doAction     = action >> threadDelay microseconds+        microseconds = d * 1000000++workForeverWith :: (SomeException -> IO ()) -> IO () -> IO ()+workForeverWith handler = forever . handleAny handler++-- eats errors+workForever :: IO () -> IO ()+workForever = workForeverWith (const $ return ())
+ src/Utils/Vigilance/Workers/LoggerWorker.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Utils.Vigilance.Workers.LoggerWorker (runWorker) where++import Prelude (FilePath)+import ClassyPrelude hiding (FilePath)+import Control.Concurrent.STM (orElse, atomically, STM)+import Control.Concurrent.STM.TChan ( readTChan+                                    , TChan )+import Control.Lens+import Control.Monad ( (<=<) )+import System.IO ( openFile+                 , IOMode(AppendMode) )+import System.Log.FastLogger ( Logger+                             , LogStr(..)+                             , mkLogger+                             , rmLogger+                             , toLogStr+                             , loggerDate+                             , loggerPutStr )++import Utils.Vigilance.Types+import Utils.Vigilance.Utils (expandHome)++-- lift into the either monad?+-- liftM Foo (takeTMVar fooTMVar) `orElse` liftM Bar (readTChan barTChan) +runWorker :: LogChan -> Config -> TChan Config -> IO ()+runWorker q Config { _configLogCfg = cfg } cfgChan = do+  logger <- openLogger $ cfg ^. logCfgPath+  logOrReconfigure logger q cfgChan $ cfg ^. logCfgVerbose++logOrReconfigure :: Logger -> LogChan -> TChan Config -> Bool -> IO ()+logOrReconfigure logger q cfgChan verbose = do+  res <- atomically $ popOrGetCfg q cfgChan+  case res of+    Left msgs -> logMessages logger verbose msgs >> recurse+    Right cfg -> rmLogger logger                 >> runWorker q cfg cfgChan+  where recurse = logOrReconfigure logger q cfgChan verbose++popOrGetCfg :: LogChan -> TChan Config -> STM (Either [LogMessage] Config)+popOrGetCfg q cfgChan = pop `orElse` getCfg+  where pop    = Left <$> readTChan q+        getCfg = Right <$> readTChan cfgChan++logMessages :: Logger -> Bool -> [LogMessage] -> IO ()+logMessages logger verbose = loggerPutStr logger <=< addTime logger . map toLogStr . filter keep+  where keep (LogMessage _)        = True+        keep (VerboseLogMessage _) = verbose++openLogger :: FilePath -> IO Logger+openLogger path = do path' <- expandHome path+                     h     <- openFile path' AppendMode+                     mkLogger flushEveryLine h+  where flushEveryLine = True+++addTime :: Logger -> [LogStr] -> IO [LogStr]+addTime logger = mapM fmt +  where fmt str = do date <- loggerDate logger+                     return . LB $ mconcat ["[", date ,"] ", toBS str]+        toBS (LB bs) = bs+        toBS (LS s)  = encodeUtf8 . pack $ s
+ src/Utils/Vigilance/Workers/NotificationRetryWorker.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+module Utils.Vigilance.Workers.NotificationRetryWorker ( runWorker+                                                       , failuresToRetry+                                                       , notifyOrBump+                                                       , renderFail ) where++import ClassyPrelude+import Control.Lens+import Data.Acid (AcidState)+import Text.InterpolatedString.Perl6 (qc)+import Utils.Vigilance.Logger ( pushLog+                              , renameLogCtx+                              , vLog )+import Utils.Vigilance.TableOps+import Utils.Vigilance.Types++-- | Intended to be exclusive+runWorker :: AcidState AppState -> Int -> NotifierGroup -> LogCtxT IO ()+runWorker acid maxRetries notifiers = renameLogCtx "Notification Retry Worker" $ do+  fails  <- lift $ allFailedNotificationsS acid+  unless (null fails) $ vLog [qc|Retrying failed notifications for {startLog fails}|]+  fails' <- catMaybes <$> mapM (notify notifiers) fails+  mapM_ logFail fails'+  let toRetry = failuresToRetry maxRetries fails'+  lift $ setFailedNotificationsS acid toRetry+  where startLog fails = intercalate ", " $ map (\w -> w ^. failedWatch . watchName . unWatchName) fails++notifyOrBump :: Notifier -> FailedNotification -> LogCtxT IO (Maybe FailedNotification)+notifyOrBump n fn = do+  vLog logMsg+  fn' <- listToMaybe <$> n [watch]+  maybe retrySuccessful retryFailed fn'+  where retrySuccessful = return Nothing+        retryFailed fn' = return . Just $ fn' & retries .~ (fn ^. retries + 1)+        watch           = fn ^. failedWatch+        wn              = watch ^. watchName . unWatchName+        logMsg = [qc|Retrying notification {fn ^. failedPref} for {wn} after {fn ^. retries} retries|]++notify :: NotifierGroup -> FailedNotification -> LogCtxT IO (Maybe FailedNotification)+notify NotifierGroup { _ngEmail = Just n}+       fn@FailedNotification { _failedPref = (EmailNotification _)} = notifyOrBump (n ^. notifier) fn+notify NotifierGroup {_ngHTTP}+       fn@FailedNotification { _failedPref = (HTTPNotification _)} = notifyOrBump (_ngHTTP ^. notifier) fn+notify _ fn = pushLog [qc|No notifier configured for {fn}|] >> return Nothing++logFail :: FailedNotification -> LogCtxT IO ()+logFail = pushLog . renderFail++renderFail :: FailedNotification -> Text+renderFail FailedNotification {..} = [qc|Watch {wn} failed to notify after {_retries} retries on {pref}: {_failedLastError}|]+  where wn = _failedWatch ^. watchName . unWatchName+        pref = renderPref _failedPref++renderPref :: NotificationPreference -> Text+renderPref (EmailNotification (EmailAddress a)) = [qc|EmailNotification {a}|]+renderPref (HTTPNotification u)                 = [qc|HTTPNotification {u}|]++failuresToRetry :: Int -> [FailedNotification] -> [FailedNotification]+failuresToRetry maxRetries = filter underLimit+  where underLimit fn = fn ^. retries < maxRetries
+ src/Utils/Vigilance/Workers/NotificationWorker.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Utils.Vigilance.Workers.NotificationWorker ( runWorker+                                                  , sendNotifications+                                                  , sendNotificationsWithRetry) where++import ClassyPrelude+import Control.Lens+import Data.Acid (AcidState)++import Utils.Vigilance.Logger+import Utils.Vigilance.TableOps+import Utils.Vigilance.Types+import Utils.Vigilance.Utils (concatMapM)++sendNotifications :: [EWatch] -> NotifierGroup -> LogCtxT IO [FailedNotification]+sendNotifications ws ns = concatMapM ($ ws) $ extractNotifiers ns++sendNotificationsWithRetry :: AcidState AppState -> [EWatch] -> NotifierGroup -> LogCtxT IO ()+sendNotificationsWithRetry acid watches notifiers = do+  failures <- sendNotifications watches notifiers+  addFailedNotificationsS acid failures++runWorker :: AcidState AppState -> NotifierGroup -> LogCtxT IO ()+runWorker acid notifiers = renameLogCtx "Notifier Worker" $ do+                              watches <- getNotifyingS acid+                              sendNotificationsWithRetry acid watches notifiers+                              unless (null watches) $ pushLog $ notifyingMsg watches+                              completeNotifyingS acid $ map (view watchName) watches++notifyingMsg :: [EWatch] -> Text+notifyingMsg watches = mconcat ["Notifying for ", length' watches, " watches: ", names]+  where length' = show . length+        names   = intercalate ", " $ map (view (watchName . unWatchName)) watches++extractNotifiers :: NotifierGroup -> [Notifier]+extractNotifiers NotifierGroup {..} = catMaybes [ view notifier <$> _ngEmail+                                                , Just $ _ngLog ^. notifier+                                                , Just $ _ngHTTP ^. notifier]
+ src/Utils/Vigilance/Workers/StaticWatchWorker.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+module Utils.Vigilance.Workers.StaticWatchWorker (runWorker) where++import Data.Acid (AcidState)+import Control.Concurrent.STM ( TChan+                              , atomically+                              , readTChan )+import Control.Monad.Trans (lift)+import Control.Lens+import Utils.Vigilance.Logger ( pushLog+                              , renameLogCtx )+import Utils.Vigilance.TableOps (mergeStaticWatchesS)+import Utils.Vigilance.Types++runWorker :: AcidState AppState -> TChan Config -> LogCtxT IO ()+runWorker acid cfgChan = renameLogCtx "Watch Config Monitor" $ do+  pushLog "Waiting for new watches"+  cfg <- lift $ atomically $ readTChan cfgChan+  pushLog "Merging new static watches"+  lift $ mergeStaticWatchesS acid $ cfg ^. configWatches+  pushLog "Static watches merged"
+ src/Utils/Vigilance/Workers/SweeperWorker.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+module Utils.Vigilance.Workers.SweeperWorker (runWorker) where++import Control.Monad.Trans (lift)+import Data.Acid (AcidState)+import Data.Time.Clock.POSIX (getPOSIXTime)++import Utils.Vigilance.Logger+import Utils.Vigilance.TableOps+import Utils.Vigilance.Types++runWorker :: AcidState AppState -> LogCtxT IO ()+runWorker acid = renameLogCtx "Sweeper Worker" $ do+                   vLog "Sweeping"+                   lift $ sweepTableS acid =<< getPOSIXTime
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ vigilance.cabal view
@@ -0,0 +1,209 @@+Name:                vigilance+Version:             0.1.0.0+Synopsis:            An extensible dead-man's switch system+Description:         Vigilance is a dead man's switch (See <https://en.wikipedia.org/wiki/Dead_man%27s_switch>)+                     (or vigilance switch). You define named @watches that you expect to happen+                     and how long to wait inbetween before it's time to worry. You then instrument+                     your periodical tasks, whatever they are, to report to vigilance via a simple+                     HTTP POST or with the included client. You can then+                     configure notifications that will fire when a watch fails+                     to check in.++                     View the README on the homepage for more details.++                     Install notes:++                     On client installs where you may not want to install the+                     server component, configure like:+                     .+                     > cabal configure -fno-server+                     .++                     On client installs where you may not want to install the+                     client component, configure like:+                     .+                     > cabal configure -fno-client+                     .++License:             MIT+License-File:        LICENSE+Author:              Michael Xavier+Maintainer:          michael@michaelxavier.net+Copyright:           (c) 2013 Michael Xavier+Category:            Utils+Build-Type:          Simple+Cabal-Version:       >=1.10+Homepage:            http://github.com/michaelxavier/vigilance+Bug-Reports:         http://github.com/michaelxavier/vigilance/issues+Extra-Source-Files:  README.md+                     TODO.md++Flag no-server+  Description: Omit the server component. Installs on client machines can and should pass this.+  Default:     False++Flag no-client+  Description: Omit the client component. Install on the server may pass this if desired.+  Default:     False++Executable vigilance-server+  Hs-Source-Dirs:     src+  Main-Is: Utils/Vigilance/Main.hs+  if flag(no-server)+    Buildable: False+  else+    Build-Depends:      base >=4.5 && <4.7,+                        async == 2.*,+                        aeson >=0.6 && <1.0,+                        attoparsec,+                        blaze-builder,+                        bytestring,+                        acid-state,+                        classy-prelude >=0.5.8 && <1.0,+                        configurator >=0.2 && <1.0,+                        containers,+                        data-store >= 0.3.0.7 && <1.0,+                        directory,+                        either == 3.4.1,+                        entropy >= 0.2.2.2,+                        errors >= 1.4.2 && <2.0,+                        fast-logger >= 0.3.2 && < 1.0,+                        http-streams >= 0.6.1.1 && <= 1.0,+                        http-types,+                        io-streams,+                        interpolatedstring-perl6 >=0.9.0 && <1.0,+                        lens >=3.9 && < 4.0,+                        mime-mail >= 0.4.2 && <1.0,+                        monad-loops >= 0.4.2 && <1.0,+                        monad-logger,+                        mtl,+                        safecopy,+                        stm >=2.4.2 && <3.0,+                        time,+                        template-haskell,+                        text,+                        transformers,+                        unix >=2.6.0.1 && <3.0,+                        unordered-containers,+                        vector,+                        wai,+                        wai-extra,+                        warp,+                        yesod,+                        yesod-core,+                        yesod-platform >= 1.2.3 && < 2.0+    Default-Language:    Haskell2010+    Ghc-Options: -threaded -O3 -rtsopts -Wall -Werror+    Other-Modules: Utils.Vigilance.Config+                   Utils.Vigilance.Logger+                   Utils.Vigilance.TableOps+                   Utils.Vigilance.Types+                   Utils.Vigilance.Utils+                   Utils.Vigilance.Worker+                   Utils.Vigilance.Web.Yesod+                   Utils.Vigilance.Workers.LoggerWorker+                   Utils.Vigilance.Workers.NotificationWorker+                   Utils.Vigilance.Workers.NotificationRetryWorker+                   Utils.Vigilance.Workers.StaticWatchWorker+                   Utils.Vigilance.Workers.SweeperWorker+                   Utils.Vigilance.Sweeper+                   Utils.Vigilance.Notifiers.HTTP+                   Utils.Vigilance.Notifiers.Email+                   Utils.Vigilance.Notifiers.Log++Executable vigilance+  Hs-Source-Dirs:     src+  Main-Is: Utils/Vigilance/Client/Main.hs+  if flag(no-client)+    Buildable: False+  else+    Build-Depends:      base >=4.5 && <4.7,+                        async == 2.*,+                        aeson >=0.6 && <1.0,+                        attoparsec,+                        blaze-builder,+                        bytestring,+                        acid-state,+                        classy-prelude >=0.5.8 && <1.0,+                        configurator >=0.2 && <1.0,+                        containers,+                        data-store >= 0.3.0.7 && <1.0,+                        directory,+                        either == 3.4.1,+                        entropy >= 0.2.2.2,+                        errors >= 1.4.2 && <2.0,+                        fast-logger >= 0.3.2 && < 1.0,+                        http-streams >= 0.6.1.1 && <= 1.0,+                        http-types,+                        io-streams,+                        interpolatedstring-perl6 >=0.9.0 && <1.0,+                        lens >=3.9 && < 4.0,+                        mime-mail >= 0.4.2 && <1.0,+                        monad-loops >= 0.4.2 && <1.0,+                        mtl,+                        optparse-applicative >= 0.5.2.1 && < 1.0,+                        safecopy,+                        stm >=2.4.2 && <3.0,+                        time,+                        text,+                        transformers,+                        unix >=2.6.0.1 && <3.0,+                        unordered-containers,+                        vector,+                        warp,+                        yesod,+                        yesod-core,+                        yesod-platform >= 1.2.3 && < 2.0+    Default-Language:    Haskell2010+    Ghc-Options: -threaded -O3 -rtsopts -Wall -Werror+    Other-Modules: Utils.Vigilance.Client.Client+                   Utils.Vigilance.Client.Config+                   Utils.Vigilance.Types++Test-Suite test-vigilance+  default-language:    Haskell2010+  Type: exitcode-stdio-1.0+  hs-source-dirs:     src,test+  Main-Is: Spec.hs+  ghc-options: -threaded -O3 -rtsopts+  build-depends:       base   >=4.5 && <4.7,+                       async == 2.*,+                       aeson >=0.6 && <1.0,+                       attoparsec,+                       blaze-builder,+                       bytestring,+                       acid-state,+                       classy-prelude >=0.5.8 && <1.0,+                       configurator >=0.2 && <1.0,+                       containers,+                       data-store >= 0.3.0.7 && <1.0,+                       directory,+                       entropy >= 0.2.2.2,+                       errors >= 1.4.2 && <2.0,+                       fast-logger >= 0.3.2 && < 1.0,+                       http-streams >= 0.6.0.2 && <= 1.0,+                       http-types,+                       hspec  >= 1.6 && < 2.0,+                       hspec-expectations,+                       HUnit>=1.2.5,+                       interpolatedstring-perl6 >=0.9.0 && <1.0,+                       io-streams,+                       QuickCheck>=1.2.5,+                       quickcheck-properties,+                       lens >=3.9 && < 4.0,+                       derive >=2.5.11 && < 3.0,+                       mime-mail >= 0.4.2 && <1.0,+                       monad-loops >= 0.4.2 && <1.0,+                       mtl,+                       safecopy,+                       stm >=2.4.2 && <3.0,+                       time,+                       text,+                       transformers,+                       unix >=2.6.0.1 && <3.0,+                       unordered-containers,+                       vector,+                       warp,+                       yesod,+                       yesod-core,+                       yesod-platform >= 1.2.3 && < 2.0