From 1c3d0e5ab315d5e6e52eb044da2b088df8acfcb2 Mon Sep 17 00:00:00 2001 From: Roman Joost Date: Fri, 13 Mar 2015 11:11:11 +1000 Subject: uvmeter: new plugin showing UV data (Australia) This patch adds a new optional plugin showing UV data for Australian users. The data is aquired by simple HTTP request from the Australian Radiation Protection and Nuclear Safety Agencies XML data feed. The uvmeter plugin can be configured ovserving multiple different station across the country. The alias now defaults to 'uv '. --- src/Plugins/Monitors.hs | 12 ++++ src/Plugins/Monitors/UVMeter.hs | 150 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 162 insertions(+) create mode 100644 src/Plugins/Monitors/UVMeter.hs (limited to 'src') diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs index bee3c06..84eceb2 100644 --- a/src/Plugins/Monitors.hs +++ b/src/Plugins/Monitors.hs @@ -36,6 +36,9 @@ import Plugins.Monitors.Disk import Plugins.Monitors.Top import Plugins.Monitors.Uptime import Plugins.Monitors.CatInt +#ifdef UVMETER +import Plugins.Monitors.UVMeter +#endif #ifdef IWLIB import Plugins.Monitors.Wireless #endif @@ -71,6 +74,9 @@ data Monitors = Weather Station Args Rate | TopMem Args Rate | Uptime Args Rate | CatInt Int FilePath Args Rate +#ifdef UVMETER + | UVMeter Station Args Rate +#endif #ifdef IWLIB | Wireless Interface Args Rate #endif @@ -119,6 +125,9 @@ instance Exec Monitors where alias (DiskIO {}) = "diskio" alias (Uptime _ _) = "uptime" alias (CatInt n _ _ _) = "cat" ++ show n +#ifdef UVMETER + alias (UVMeter s _ _) = "uv " ++ s +#endif #ifdef IWLIB alias (Wireless i _ _) = i ++ "wi" #endif @@ -155,6 +164,9 @@ instance Exec Monitors where start (DiskIO s a r) = startDiskIO s a r start (Uptime a r) = runM a uptimeConfig runUptime r start (CatInt _ s a r) = runM a catIntConfig (runCatInt s) r +#ifdef UVMETER + start (UVMeter s a r) = runM (a ++ [s]) uvConfig runUVMeter r +#endif #ifdef IWLIB start (Wireless i a r) = runM a wirelessConfig (runWireless i) r #endif diff --git a/src/Plugins/Monitors/UVMeter.hs b/src/Plugins/Monitors/UVMeter.hs new file mode 100644 index 0000000..5fa0b82 --- /dev/null +++ b/src/Plugins/Monitors/UVMeter.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.UVMeter +-- Copyright : (c) Róman Joost +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Róman Joost +-- Stability : unstable +-- Portability : unportable +-- +-- An australian uv monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.UVMeter where + +import Plugins.Monitors.Common + +import qualified Control.Exception as CE +import Control.Applicative hiding ((<|>),many) +import Network.HTTP +import Text.Read (readMaybe) +import Text.Parsec +import Text.Parsec.String + + +uvConfig :: IO MConfig +uvConfig = mkMConfig + "" -- template + ["station" -- available replacements + ] + +data UvInfo = UV { index :: String } + deriving (Show) + +uvURL :: String +uvURL = "http://www.arpansa.gov.au/uvindex/realtime/xml/uvvalues.xml" + +getData :: IO String +getData = do + let request = getRequest uvURL + CE.catch (simpleHTTP request >>= getResponseBody) errHandler + where errHandler :: CE.IOException -> IO String + errHandler _ = return "" + +textToXMLDocument :: String -> Either ParseError [XML] +textToXMLDocument = parse document "" + +formatUVRating :: Maybe Float -> Monitor String +formatUVRating Nothing = getConfigValue naString +formatUVRating (Just x) = do + uv <- showWithColors show x + parseTemplate [uv] + +getUVRating :: String -> [XML] -> Maybe Float +getUVRating locID (Element "stations" _ y:_) = getUVRating locID y +getUVRating locID (Element "location" [Attribute attr] ys:xs) + | locID == snd attr = getUVRating locID ys + | otherwise = getUVRating locID xs +getUVRating _ (Element "index" [] [Body rate]:_) = readMaybe rate +getUVRating locID (_:xs) = getUVRating locID xs +getUVRating _ [] = Nothing + + +runUVMeter :: [String] -> Monitor String +runUVMeter [] = return "N.A." +runUVMeter (s:_) = do + resp <- io getData + case textToXMLDocument resp of + Right doc -> formatUVRating (getUVRating s doc) + Left _ -> getConfigValue naString + +-- | XML Parsing code comes here. +-- This is a very simple XML parser to just deal with the uvvalues.xml +-- provided by ARPANSA. If you work on a new plugin which needs an XML +-- parser perhaps consider using a real XML parser and refactor this +-- plug-in to us it as well. +-- +-- Note: This parser can not deal with short tags. +-- +-- Kudos to: Charlie Harvey for his article about writing an XML Parser +-- with Parsec. +-- + +type AttrName = String +type AttrValue = String + +data Attribute = Attribute (AttrName, AttrValue) + deriving (Show) + +data XML = Element String [Attribute] [XML] + | Decl String + | Body String + deriving (Show) + +-- | parse the document +-- +document :: Parser [XML] +document = do + spaces + y <- try xmlDecl <|> tag + spaces + x <- many tag + spaces + return (y : x) + +-- | parse any tags +-- +tag :: Parser XML +tag = do + char '<' + spaces + name <- many (letter <|> digit) + spaces + attr <- many attribute + spaces + string ">" + eBody <- many elementBody + endTag name + spaces + return (Element name attr eBody) + +xmlDecl :: Parser XML +xmlDecl = do + string "") + string "?>" + return (Decl decl) + +elementBody :: Parser XML +elementBody = spaces *> try tag <|> text + +endTag :: String -> Parser String +endTag str = string " string str <* char '>' + +text :: Parser XML +text = Body <$> many1 (noneOf "><") + +attribute :: Parser Attribute +attribute = do + name <- many (noneOf "= />") + spaces + char '=' + spaces + char '"' + value <- many (noneOf "\"") + char '"' + spaces + return (Attribute (name, value)) -- cgit v1.2.3