diff options
Diffstat (limited to 'src/Plugins')
| -rw-r--r-- | src/Plugins/Monitors.hs | 12 | ||||
| -rw-r--r-- | src/Plugins/Monitors/UVMeter.hs | 150 |
2 files changed, 162 insertions, 0 deletions
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 + "<station>" -- 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 "<Could not retrieve data>" + +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 "<?xml" + decl <- many (noneOf "?>") + 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)) |