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