Calculates how much ice has accumulated in Jyväskylä in last week

IceAccumulation.hs

{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
module IceAccumulation where

import Control.Exception (evaluate)
import Network.Curl.Aeson
import Data.Aeson
import Data.Aeson.Types
import Control.Applicative
import Control.Monad (mzero)
import Data.Time
import Data.Time.Clock.POSIX
import Data.Scientific
import Database.HDBC
import Database.HDBC.Sqlite3

-- |Ice accumulation constant, 2 millimetres of ice per day per
-- degrees of Celsius. Source: User "visti" at
-- http://www.tiede.fi/keskustelu/57006/ketju/jaan_paksuuntumisen_laskeminen
icePerCelsiusSecond :: Double
icePerCelsiusSecond = -0.002 / (24*60*60)

data Weather = Weather { location :: String
                       , latest   :: UTCTime
                       , temps    :: [(UTCTime, Scientific)]
                       } deriving (Show)

instance FromJSON Weather where
  parseJSON (Object o) = do
    latest <- timestampify <$> o .: "latestObservationTime"
    tempRaw <- o .: "t2m"
    tempPairs <- mapM toTempPair tempRaw
    return $ Weather "" latest tempPairs
  parseJSON _ = mzero


getWeatherFmi (fmiId, location) = do
  w <- curlAesonGet $ "http://ilmatieteenlaitos.fi/observation-data?station=" ++ fmiId
  return w{location = location}

interestingFmiLocations = map getWeatherFmi [("101339", "Jyväskylä, Finland")
                                            ,("101914", "Pello, Finland")
                                            ,("101586", "Kuopio, Finland")
                                            ,("101908", "Ylitornio, Finland")
                                            ]

-- |Parses list of values into pair using timestamp as a key
toTempPair :: [Value] -> Parser (UTCTime, Scientific) 
toTempPair [ts', temp'] = do
  ts <- parseJSON ts'
  temp <- parseJSON temp'
  return (timestampify ts, temp)
toTempPair _ = mzero

-- |Converts raw scientific number to UTC Time
timestampify :: Scientific -> UTCTime
timestampify x = posixSecondsToUTCTime $ realToFrac $ x / 1000

-- |Calculates number of Celsius-seconds in given time range
heatSeconds :: (UTCTime, Scientific) -> (UTCTime, Scientific) -> Double
heatSeconds (oldTime, oldTemp) (newTime, newTemp) = (realToFrac $ diffUTCTime newTime oldTime) * (realToFrac $ oldTemp + newTemp) / 2

-- |Calculates Celsius-seconds for every element in the list. The
-- timestamps must be (strictly) increasing.
listToHeat :: [(UTCTime, Scientific)] -> [Double]
listToHeat xs = zipWith heatSeconds xs (tail xs)

-- |Converts weather to pairs of time and Celsius-seconds). Useful for testing the JSON parser
weatherToHeatPairs Weather{..} = zip (map fst temps) (listToHeat temps)

-- |Update given weather data to the database.
updateWeathers :: [Weather] -> IO ()
updateWeathers ws = do
  conn <- connectSqlite3 "temp.sqlite"
  runRaw conn "CREATE TABLE IF NOT EXISTS temp (loc TEXT, ts TEXT, t REAL, PRIMARY KEY (loc, ts))"
  ins <- prepare conn "INSERT OR IGNORE INTO temp (loc, ts, t) VALUES (?,?,?)"
  mapM (executeMany ins . weatherToSql) ws
  commit conn
  disconnect conn

weatherToSql :: Weather -> [[SqlValue]]
weatherToSql Weather{..} = map sql temps
  where sql (ts, t) = [ toSql location
                      , toSql ts
                      , toSql (realToFrac t :: Double) -- FIXME suboptimal
                      ]

sqlToHeatPair [ts, t] = (fromSql ts, realToFrac (fromSql t :: Double)) -- FIXME suboptimal typecasting

-- |Run all FMI parsers and store data to database.
updateAll :: IO ()
updateAll = sequence interestingFmiLocations >>= updateWeathers

-- Calculate ice width change on given location and time range. This operates offline using the database.
iceAccumulation :: String -> String -> String -> IO Double
iceAccumulation loc from to = do
  conn <- connectSqlite3 "temp.sqlite"
  sel <- prepare conn "SELECT ts,t FROM temp WHERE loc=? AND ts BETWEEN ? and ? ORDER BY ts"
  execute sel [toSql loc, toSql from, toSql to]
  heats <- map sqlToHeatPair <$> fetchAllRows sel
  -- Process the lazy list before disconnecting. Ice accumulation is
  -- calculated by integrating the temperature over time and
  -- multiplying by ice accumulation constant.
  ice <- evaluate $ icePerCelsiusSecond * sum (listToHeat heats)
  disconnect conn
  return $ ice