967127650427e5fda18d04e8a2b27d2bec937f7b
[pulsecounter.git] / web / query.cgi
1 #!/usr/bin/env runhaskell
2
3 --                                                                        --
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.                --
8 --                                                                        --
9
10 {-# LANGUAGE OverloadedStrings #-}
11
12 module Main where
13
14 import Control.Monad
15 import Data.Maybe
16 import Data.List
17 import Data.Ratio
18 import System.Locale
19 import System.Time
20 import Network.CGI
21 import Database.MySQL.Simple
22
23 main = runCGI $ handleErrors cgiMain
24
25 cgiMain :: CGI CGIResult
26 cgiMain = do
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
32                                               }
33   today <- liftIO getClockTime
34   let tomorrow = addToClockTime (noTimeDiff {tdDay = 1}) today
35       daystart x = (toUTCTime x) { ctHour = 0, ctMin = 0
36                                  , ctSec = 0, ctPicosec = 0}
37       dtstr x = formatCalendarTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" x
38       dlo = dtstr $ daystart today
39       dhi = dtstr $ daystart tomorrow
40   ilo <- getInput "lo"
41   ihi <- getInput "hi"
42   -- _ <- liftIO $ putStrLn $ " dlo=" ++ show dlo ++ " ilo=" ++ show ilo
43   --                      ++ " dhi=" ++ show dhi ++ " ihi=" ++ show ihi
44   let slo = fromMaybe dlo ilo :: String
45       shi = fromMaybe dhi ihi :: String
46   [(olo, ohi)] <- liftIO $ query conn "select unix_timestamp(?), unix_timestamp(?);"
47                          [slo, shi]
48   cold <- liftIO $ query conn
49     "select unix_timestamp(timestamp) as time, value+adj as value from \
50        \(select c.timestamp timestamp, c.value value, \
51          \(select sum(value) from coldadj a where a.timestamp <= c.timestamp \
52          \) adj from coldcnt c where timestamp between ? and ? \
53        \) t order by timestamp;" (slo, shi)
54   hot <- liftIO $ query conn
55     "select unix_timestamp(timestamp) as time, value+adj as value from \
56        \(select c.timestamp timestamp, c.value value, \
57          \(select sum(value) from hotadj a where a.timestamp <= c.timestamp \
58          \) adj from hotcnt c where timestamp between ? and ? \
59        \) t order by timestamp;" (slo, shi)
60   [(ccold, chot)] <- liftIO $ query_ conn
61     "select lcold+acold as cold, lhot+ahot as hot from \
62     \(select value as lcold from coldcnt order by timestamp desc limit 1) cc, \
63     \(select sum(value) as acold from coldadj) ac, \
64     \(select value as lhot from hotcnt order by timestamp desc limit 1) ch, \
65     \(select sum(value) as ahot from hotadj) ah;"
66   _ <- liftIO $ close conn
67
68   setHeader "Content-type" "application/json"
69   output $ "{\"range\": {\"lo\": " ++ show (floor (olo :: (Ratio Integer)))
70           ++ ", \"hi\": " ++ show (floor (ohi :: (Ratio Integer)))
71           ++ "}, \"current\": {\"cold\": " ++ show (floor (ccold :: (Ratio Integer)))
72           ++ ", \"hot\": " ++ show (floor (chot :: (Ratio Integer)))
73           ++ "}, \"cold\": [" ++ showjson cold
74           ++ "], \"hot\": [" ++ showjson hot ++ "]}\n"
75
76 showjson :: [(Int, (Ratio Integer))] -> String
77 showjson l = intercalate "," $ map (\(t, c) -> "[" ++ show t ++ "," ++ show (floor c) ++ "]") l
78
79 data Conf = Conf { host :: String
80                  , user :: String
81                  , pass :: String
82                  , dbnm :: String
83                  }
84
85 readConf :: String -> IO Conf
86 readConf fn =
87   readFile fn >>= return . (foldr parseLine (Conf "" "" "" "")) . lines
88   where
89     parseLine :: String -> Conf -> Conf
90     parseLine l sum =
91       case words l of
92         [k, v] ->
93           case k of
94             "host" -> sum { host = v }
95             "user" -> sum { user = v }
96             "password" -> sum { pass = v }
97             "database" -> sum { dbnm = v }
98             _ -> error $ "bad key in config line \"" ++ l ++ "\""
99         _ -> error $ "bad config line \"" ++ l ++ "\""