872023716d1cd12ecd43af9e6bcca7e76b2eed8f
[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 System.Locale
18 import System.Time
19 import Network.CGI
20 import Database.MySQL.Simple
21
22 main = runCGI $ handleErrors cgiMain
23
24 cgiMain :: CGI CGIResult
25 cgiMain = do
26   conf <- liftIO $ readConf "/etc/watermeter.db"
27   conn <- liftIO $ connect defaultConnectInfo { connectHost = host conf
28                                               , connectUser = user conf
29                                               , connectPassword = pass conf
30                                               , connectDatabase = dbnm conf
31                                               }
32   today <- liftIO getClockTime
33   let tomorrow = addToClockTime (noTimeDiff {tdDay = 1}) today
34       daystart x = (toUTCTime x) { ctHour = 0, ctMin = 0
35                                  , ctSec = 0, ctPicosec = 0}
36       dtstr x = formatCalendarTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" x
37       dlo = dtstr $ daystart today
38       dhi = dtstr $ daystart tomorrow
39   ilo <- getInput "lo"
40   ihi <- getInput "hi"
41   -- _ <- liftIO $ putStrLn $ " dlo=" ++ show dlo ++ " ilo=" ++ show ilo
42   --                      ++ " dhi=" ++ show dhi ++ " ihi=" ++ show ihi
43   let slo = fromMaybe dlo ilo :: String
44       shi = fromMaybe dhi ihi :: String
45   [(olo, ohi)] <- liftIO $ query conn "select to_seconds(?), to_seconds(?);"
46                          [slo, shi]
47   cold <- liftIO $ query conn
48     "select to_seconds(timestamp) as time, value+adj as value from \
49        \(select c.timestamp timestamp, c.value value, \
50          \(select sum(value) from coldadj a where a.timestamp <= c.timestamp \
51          \) adj from coldcnt c \
52            \where timestamp between ? and ? order by timestamp \
53        \) t;" (slo, shi)
54   hot <- liftIO $ query conn
55     "select to_seconds(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 \
59            \where timestamp between ? and ? order by timestamp \
60        \) t;" (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
68
69   setHeader "Content-type" "application/json"
70   output $ "{\"range\": {\"lo\": " ++ show (olo :: Int)
71           ++ ", \"hi\": " ++ show (ohi :: Int)
72           ++ "}, \"current\": {\"cold\": " ++ show (floor (ccold :: Double))
73           ++ ", \"hot\": " ++ show (floor (chot :: Double))
74           ++ "}}, \"cold\": [" ++ showjson cold
75           ++ "], \"hot\": [" ++ showjson hot ++ "]}\n"
76
77 showjson :: [(Int, Double)] -> String
78 showjson l = intercalate "," $ map (\(t, c) -> "[" ++ show t ++ "," ++ show (floor c) ++ "]") l
79
80 data Conf = Conf { host :: String
81                  , user :: String
82                  , pass :: String
83                  , dbnm :: String
84                  }
85
86 readConf :: String -> IO Conf
87 readConf fn =
88   readFile fn >>= return . (foldr parseLine (Conf "" "" "" "")) . lines
89   where
90     parseLine :: String -> Conf -> Conf
91     parseLine l sum =
92       case words l of
93         [k, v] ->
94           case k of
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 ++ "\""