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

1 files changed, 150 insertions, 0 deletions

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))