fix time interval selection
[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   _ <- 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
41   ilo <- getInput "lo"
42   ihi <- getInput "hi"
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(?);"
48                          [slo, shi]
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
68
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"
76
77 showjson :: [(Int, (Ratio Integer))] -> 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 ++ "\""