1 #!/usr/bin/env runhaskell
4 -- I am truly sorry. I would have used servant, but it failed to install. --
5 -- I would have used sqeletto, but got thrown back by depencencies. --
6 -- I would have used some standard config file parser but they are all --
7 -- overkills. This program is a very quick and dirty hack. --
10 {-# LANGUAGE OverloadedStrings #-}
21 import Database.MySQL.Simple
23 main = runCGI $ handleErrors cgiMain
25 cgiMain :: CGI CGIResult
27 conf <- liftIO $ readConf "/etc/watermeter.db"
28 conn <- liftIO $ connect defaultConnectInfo { connectHost = host conf
29 , connectUser = user conf
30 , connectPassword = pass conf
31 , connectDatabase = dbnm conf
33 _ <- liftIO $ execute_ conn "set time_zone = '+00:00';";
34 today <- liftIO getClockTime
35 let tomorrow = addToClockTime (noTimeDiff {tdDay = 1}) today
36 daystart x = (toUTCTime x) { ctHour = 0, ctMin = 0
37 , ctSec = 0, ctPicosec = 0}
38 dtstr x = formatCalendarTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" x
39 dlo = dtstr $ daystart today
40 dhi = dtstr $ daystart tomorrow
43 -- _ <- liftIO $ putStrLn $ " dlo=" ++ show dlo ++ " ilo=" ++ show ilo
44 -- ++ " dhi=" ++ show dhi ++ " ihi=" ++ show ihi
45 let slo = fromMaybe dlo ilo :: String
46 shi = fromMaybe dhi ihi :: String
47 [(olo, ohi)] <- liftIO $ query conn "select unix_timestamp(?), unix_timestamp(?);"
49 cold <- liftIO $ query conn
50 "select unix_timestamp(timestamp) as time, value+adj as value from \
51 \(select c.timestamp timestamp, c.value value, \
52 \(select sum(value) from coldadj a where a.timestamp <= c.timestamp \
53 \) adj from coldcnt c where timestamp between ? and ? \
54 \) t order by timestamp;" (slo, shi)
55 hot <- liftIO $ query conn
56 "select unix_timestamp(timestamp) as time, value+adj as value from \
57 \(select c.timestamp timestamp, c.value value, \
58 \(select sum(value) from hotadj a where a.timestamp <= c.timestamp \
59 \) adj from hotcnt c where timestamp between ? and ? \
60 \) t order by timestamp;" (slo, shi)
61 [(ccold, chot)] <- liftIO $ query_ conn
62 "select lcold+acold as cold, lhot+ahot as hot from \
63 \(select value as lcold from coldcnt order by timestamp desc limit 1) cc, \
64 \(select sum(value) as acold from coldadj) ac, \
65 \(select value as lhot from hotcnt order by timestamp desc limit 1) ch, \
66 \(select sum(value) as ahot from hotadj) ah;"
67 _ <- liftIO $ close conn
69 setHeader "Content-type" "application/json"
70 output $ "{\"range\": {\"lo\": " ++ show (floor (olo :: (Ratio Integer)))
71 ++ ", \"hi\": " ++ show (floor (ohi :: (Ratio Integer)))
72 ++ "}, \"current\": {\"cold\": " ++ show (floor (ccold :: (Ratio Integer)))
73 ++ ", \"hot\": " ++ show (floor (chot :: (Ratio Integer)))
74 ++ "}, \"cold\": [" ++ showjson cold
75 ++ "], \"hot\": [" ++ showjson hot ++ "]}\n"
77 showjson :: [(Int, (Ratio Integer))] -> String
78 showjson l = intercalate "," $ map (\(t, c) -> "[" ++ show t ++ "," ++ show (floor c) ++ "]") l
80 data Conf = Conf { host :: String
86 readConf :: String -> IO Conf
88 readFile fn >>= return . (foldr parseLine (Conf "" "" "" "")) . lines
90 parseLine :: String -> Conf -> Conf
95 "host" -> sum { host = v }
96 "user" -> sum { user = v }
97 "password" -> sum { pass = v }
98 "database" -> sum { dbnm = v }
99 _ -> error $ "bad key in config line \"" ++ l ++ "\""
100 _ -> error $ "bad config line \"" ++ l ++ "\""