blob: 95abd66f715c81b50e2e9c665cb1339f4d374e58 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
{-# 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 Xmobar.Plugins.Monitors.UVMeter where
import Xmobar.Plugins.Monitors.Common
import qualified Control.Exception as CE
import Network.HTTP.Conduit
( Manager
, httpLbs
, parseRequest
, responseBody
)
import Network.HTTP.Client.TLS (getGlobalManager)
import Data.ByteString.Lazy.Char8 as B
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(Option))
import Text.Read (readMaybe)
import Text.Parsec
import Text.Parsec.String
import Control.Monad (void)
-- | Options the user may specify.
newtype UVMeterOpts = UVMeterOpts
{ useManager :: Bool
}
-- | Default values for options.
defaultOpts :: UVMeterOpts
defaultOpts = UVMeterOpts
{ useManager = True
}
-- | Apply options.
options :: [OptDescr (UVMeterOpts -> UVMeterOpts)]
options =
[ Option "m" ["useManager"] (ReqArg (\m o -> o { useManager = read m }) "") ""
]
uvConfig :: IO MConfig
uvConfig = mkMConfig
"<station>" -- template
["station" -- available replacements
]
newtype UvInfo = UV { index :: String }
deriving (Show)
uvURL :: String
uvURL = "https://uvdata.arpansa.gov.au/xml/uvvalues.xml"
-- | Get the UV data from the given url.
getData ::Manager -> IO String
getData man = CE.catch
(do request <- parseRequest uvURL
res <- httpLbs request man
return $ B.unpack $ responseBody res)
errHandler
where
errHandler :: CE.SomeException -> 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
-- | Start the uvmeter monitor, create a new 'Maybe Manager', should the user have
-- chosen to use one.
startUVMeter
:: String -- ^ Station
-> [String] -- ^ User supplied arguments
-> Int -- ^ Update rate
-> (String -> IO ())
-> IO ()
startUVMeter station args = runM (station : args) uvConfig runUVMeter
runUVMeter :: [String] -> Monitor String
runUVMeter [] = return "N.A."
runUVMeter (s:_) = do
man <- io getGlobalManager
resp <- io $ getData man
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
newtype 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
void $ manyTill anyToken (string "<?xml") -- ignore the byte order mark
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))
|
