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 where timestamp between ? and ? \
  52        \) t order by timestamp;" (slo, shi)
  53   hot <- liftIO $ query conn
  54     "select to_seconds(timestamp) as time, value+adj as value from \
  55        \(select c.timestamp timestamp, c.value value, \
  56          \(select sum(value) from hotadj a where a.timestamp <= c.timestamp \
  57          \) adj from hotcnt c where timestamp between ? and ? \
  58        \) t order by timestamp;" (slo, shi)
  59   [(ccold, chot)] <- liftIO $ query_ conn
  60     "select lcold+acold as cold, lhot+ahot as hot from \
  61     \(select value as lcold from coldcnt order by timestamp desc limit 1) cc, \
  62     \(select sum(value) as acold from coldadj) ac, \
  63     \(select value as lhot from hotcnt order by timestamp desc limit 1) ch, \
  64     \(select sum(value) as ahot from hotadj) ah;"
  65   _ <- liftIO $ close conn
  66
  67   setHeader "Content-type" "application/json"
  68   output $ "{\"range\": {\"lo\": " ++ show (olo :: Int)
  69           ++ ", \"hi\": " ++ show (ohi :: Int)
  70           ++ "}, \"current\": {\"cold\": " ++ show (floor (ccold :: Double))
  71           ++ ", \"hot\": " ++ show (floor (chot :: Double))
  72           ++ "}, \"cold\": [" ++ showjson cold
  73           ++ "], \"hot\": [" ++ showjson hot ++ "]}\n"
  74
  75 showjson :: [(Int, Double)] -> String
  76 showjson l = intercalate "," $ map (\(t, c) -> "[" ++ show t ++ "," ++ show (floor c) ++ "]") l
  77
  78 data Conf = Conf { host :: String
  79                  , user :: String
  80                  , pass :: String
  81                  , dbnm :: String
  82                  }
  83
  84 readConf :: String -> IO Conf
  85 readConf fn =
  86   readFile fn >>= return . (foldr parseLine (Conf "" "" "" "")) . lines
  87   where
  88     parseLine :: String -> Conf -> Conf
  89     parseLine l sum =
  90       case words l of
  91         [k, v] ->
  92           case k of
  93             "host" -> sum { host = v }
  94             "user" -> sum { user = v }
  95             "password" -> sum { pass = v }
  96             "database" -> sum { dbnm = v }
  97             _ -> error $ "bad key in config line \"" ++ l ++ "\""
  98         _ -> error $ "bad config line \"" ++ l ++ "\""