Merge branch 'master' of https://github.com/romanofski/xmobar

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