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 ++ "\""