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 <stationid>'.

4 files changed, 188 insertions, 1 deletions

diff --git a/readme.md b/readme.md
index 7ecea56..7f1be52 100644
--- a/readme.md
+++ b/readme.md
@@ -157,6 +157,9 @@ Otherwise, you'll need to install them yourself.
 :    Support for xpm image file format. This will allow loading .xpm files in `<icon>`.
      Requires the [libXpm] C library.
 
+`with_uvmeter`
+:    Enables UVMeter plugin. The plugin shows UV data for Australia.
+
 `all_extensions`
 :    Enables all the extensions above.
 
@@ -1243,6 +1246,20 @@ more than one battery.
 
     Run CatInt 0 "/sys/devices/platform/thinkpad_hwmon/fan1_input" [] 50
 
+### `UVMeter`
+
+- Aliases to "uv " + station id. For example: `%uv brisbane%` or `%uv
+  alice springs%`
+- Args: default monitor arguments.
+
+- *Reminder:* Keep the refresh rate high, to avoid making unnecessary
+  requests every time the plug-in is run.
+- Station IDs can be found here:
+  http://www.arpansa.gov.au/uvindex/realtime/xml/uvvalues.xml
+- Example:
+
+        Run UVMeter "brisbane" ["-H", "3", "-L", "3", "--low", "green", "--high", "red"] 900
+
 ## Executing External Commands
 
 In order to execute an external command you can either write the
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))
diff --git a/xmobar.cabal b/xmobar.cabal
index 5694f12..d066cfe 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -74,6 +74,10 @@ flag with_threaded
   description: Use threaded runtime.
   default: False
 
+flag with_uvmeter
+  description: UVMeter only useful to australians.
+  default: False
+
 executable xmobar
     hs-source-dirs:     src
     main-is:            Main.hs
@@ -93,7 +97,8 @@ executable xmobar
       Plugins.Monitors.Swap, Plugins.Monitors.Thermal,
       Plugins.Monitors.ThermalZone, Plugins.Monitors.Top,
       Plugins.Monitors.Uptime, Plugins.Monitors.Weather,
-      Plugins.Monitors.Bright, Plugins.Monitors.CatInt
+      Plugins.Monitors.Bright, Plugins.Monitors.CatInt,
+      Plugins.Monitors.UVMeter
 
     ghc-prof-options:   -prof -auto-all
     ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind
@@ -176,3 +181,6 @@ executable xmobar
        extra-libraries: Xpm
        other-modules: XPMFile
        cpp-options: -DXPM
+
+    if flag(with_uvmeter)
+       cpp-options: -DUVMETER