diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -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 diff --git a/src/Utils/Vigilance/Client/Client.hs b/src/Utils/Vigilance/Client/Client.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Client/Client.hs @@ -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" diff --git a/src/Utils/Vigilance/Client/Config.hs b/src/Utils/Vigilance/Client/Config.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Client/Config.hs @@ -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" diff --git a/src/Utils/Vigilance/Client/Main.hs b/src/Utils/Vigilance/Client/Main.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Client/Main.hs @@ -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" diff --git a/src/Utils/Vigilance/Config.hs b/src/Utils/Vigilance/Config.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Config.hs @@ -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 diff --git a/src/Utils/Vigilance/Logger.hs b/src/Utils/Vigilance/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Logger.hs @@ -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 diff --git a/src/Utils/Vigilance/Main.hs b/src/Utils/Vigilance/Main.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Main.hs @@ -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 diff --git a/src/Utils/Vigilance/Notifiers/Email.hs b/src/Utils/Vigilance/Notifiers/Email.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Notifiers/Email.hs @@ -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 diff --git a/src/Utils/Vigilance/Notifiers/HTTP.hs b/src/Utils/Vigilance/Notifiers/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Notifiers/HTTP.hs @@ -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 diff --git a/src/Utils/Vigilance/Notifiers/Log.hs b/src/Utils/Vigilance/Notifiers/Log.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Notifiers/Log.hs @@ -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.|] diff --git a/src/Utils/Vigilance/Sweeper.hs b/src/Utils/Vigilance/Sweeper.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Sweeper.hs @@ -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 diff --git a/src/Utils/Vigilance/TableOps.hs b/src/Utils/Vigilance/TableOps.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/TableOps.hs @@ -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 diff --git a/src/Utils/Vigilance/Types.hs b/src/Utils/Vigilance/Types.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Types.hs @@ -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 diff --git a/src/Utils/Vigilance/Utils.hs b/src/Utils/Vigilance/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Utils.hs @@ -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)" diff --git a/src/Utils/Vigilance/Web/Yesod.hs b/src/Utils/Vigilance/Web/Yesod.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Web/Yesod.hs @@ -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 diff --git a/src/Utils/Vigilance/Worker.hs b/src/Utils/Vigilance/Worker.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Worker.hs @@ -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 ()) diff --git a/src/Utils/Vigilance/Workers/LoggerWorker.hs b/src/Utils/Vigilance/Workers/LoggerWorker.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Workers/LoggerWorker.hs @@ -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 diff --git a/src/Utils/Vigilance/Workers/NotificationRetryWorker.hs b/src/Utils/Vigilance/Workers/NotificationRetryWorker.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Workers/NotificationRetryWorker.hs @@ -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 diff --git a/src/Utils/Vigilance/Workers/NotificationWorker.hs b/src/Utils/Vigilance/Workers/NotificationWorker.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Workers/NotificationWorker.hs @@ -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] diff --git a/src/Utils/Vigilance/Workers/StaticWatchWorker.hs b/src/Utils/Vigilance/Workers/StaticWatchWorker.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Workers/StaticWatchWorker.hs @@ -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" diff --git a/src/Utils/Vigilance/Workers/SweeperWorker.hs b/src/Utils/Vigilance/Workers/SweeperWorker.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Vigilance/Workers/SweeperWorker.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/vigilance.cabal b/vigilance.cabal new file mode 100644 --- /dev/null +++ b/vigilance.cabal @@ -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 ) + (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