path: root/poller.hs

{-# LANGUAGE FlexibleContexts, LambdaCase #-}

-- | Polls the charge controller and other sensors and sources for data,
-- and updates the rrd files and the json for the web page.
--
-- Runs a http server which streams sensed values to clients as they
-- become available. Some data can also be posted to the http server.

import System.IO
import System.Process
import System.Directory
import System.FilePath
import Data.List
import Data.Maybe
import Data.Char
import Control.Monad
import Control.Concurrent
import Control.Concurrent.Async
import Data.Time.Clock
import Control.Exception
import System.Timeout
import System.Exit
import System.Posix.Files
import Text.Read
import Network.HTTP.Client

import Sensors
import WebServers
import DataUnits
import DhcpClient
import qualified Viasat
import Utility.ThreadScheduler
import Darksky

data FreqPair t = FreqPair
	{ frequent :: t
	, infrequent :: t
	}

data Frequency = Frequent | Infrequent
	deriving (Show)

getFrequent :: Frequency -> FreqPair t -> t
getFrequent Frequent fp = frequent fp
getFrequent Infrequent fp = infrequent fp

hours :: Int -> Seconds
hours n = Seconds (n*60*60)

days :: Int -> Seconds
days n = Seconds (n*60*60*24)

years :: Int -> Seconds
years n = Seconds (n*60*60*24*365)

newtype XFF = XFF Float

defXFF :: XFF
defXFF = XFF 0.5

newtype CombinedSteps = CombinedSteps Int

newtype Rows = Rows Int

data RRAType = Average | Min | Max | Last

formatRRAType :: RRAType -> String
formatRRAType Average = "AVERAGE"
formatRRAType Min = "Min"
formatRRAType Max = "Max"
formatRRAType Last = "Last"

data RRA = RRA RRAType XFF CombinedSteps Rows

formatRRA :: RRA -> String
formatRRA (RRA t (XFF xff) (CombinedSteps cs) (Rows rs)) = intercalate ":"
	[ "RRA"
	, formatRRAType t
	, show xff
	, show cs
	, show rs
	]

newtype StepLen = StepLen Seconds

newtype StorageSize = StorageSize Seconds

newtype Granularity = Granularity Seconds

-- | Makes an RRA that stores an average.
mkAverage :: XFF -> StorageSize -> StepLen -> Granularity -> RRA
mkAverage xff (StorageSize (Seconds storagesize)) (StepLen (Seconds steplen)) (Granularity (Seconds granularity)) = 
	RRA Average xff (CombinedSteps cs)
		(Rows (storagesize `div` steplen `div` cs))
  where
	cs = granularity `div` steplen

-- | Makes an RRA that stores each data point as-is.
mkFull :: XFF -> StorageSize -> StepLen -> RRA
mkFull xff (StorageSize (Seconds storagesize)) (StepLen (Seconds steplen)) = 
	RRA Average xff (CombinedSteps 1) (Rows (storagesize `div` steplen))

allRras :: StepLen -> [(String, [RRA])]
allRras steplen =
	-- Recent data only so the rrd file is small and can be quickly
	-- loaded in a web browser.
	[ ( "recent",
		-- Full data for three days
		[ mkFull defXFF (StorageSize (days 3)) steplen
		-- Hourly averages for one month.
		, mkAverage defXFF (StorageSize (days 31)) steplen
			(Granularity (hours 1))
		]
	  )
	-- Long-term historical data.
	, ( "historical",
		-- Full data for 2 months
		[ mkFull defXFF (StorageSize (days 60)) steplen
		-- Hourly averages for one year.
		, mkAverage defXFF (StorageSize (years 1)) steplen
			(Granularity (hours 1))
		-- Daily averages for 10 years.
		, mkAverage defXFF (StorageSize (years 10)) steplen
			(Granularity (days 1))
		-- Weekly averages for 50 years.
		, mkAverage defXFF (StorageSize (years 50)) steplen
			(Granularity (days 7))
		]
	  )
	]

data DataSource = DataSource RrdName (Maybe (String -> SensedValue)) DataSourceType Heartbeat
data DataSourceType = Gauge | Counter
newtype Heartbeat = HeartBeat Seconds
type RrdName = String

formatDataSource :: DataSource -> String
formatDataSource (DataSource name _ t (HeartBeat (Seconds h))) = intercalate ":"
	[ "DS"
	, name
	, formatDataSourceType t
	, show h
	, "U" -- unknown min
	, "U" -- unknown max
	]

formatDataSourceType :: DataSourceType -> String
formatDataSourceType Gauge = "GAUGE"
formatDataSourceType Counter = "COUNTER"

data DataSourceFrom
	= EpsolarValue String
	| OneWireSensor String
	| SI7021 String
	| AutomationValue KeySensedValue SensedValue

dataSources :: FreqPair StepLen -> FreqPair [(DataSourceFrom, DataSource)]
dataSources steplen = FreqPair
	{ frequent =
		[ mkf Gauge (EpsolarValue "Charging equipment input voltage") "input_volts" CcInputVolts 3
		, mkf Gauge (EpsolarValue "Charging equipment output voltage") "output_volts" CcOutputVolts 3
		, mkf Gauge (EpsolarValue "Charging equipment input power") "input_watts" CcInputWatts 3
		, mkf Gauge (EpsolarValue "Charging equipment output power") "output_watts" CcOutputWatts 3
		, mkf Gauge (EpsolarValue "Battery SOC") "battery_percent" CcBatteryPercent 3
		, mkf Gauge (EpsolarValue "Battery Current") "battery_amps" CcBatteryAmps 3
		, mkf Gauge (EpsolarValue "Temperature inside equipment") "cc_temp_celsius" CcTemperature 3
		, mkf Gauge (OneWireSensor "28-0000096083bf") "fridge_temp_celsius" FridgeTemperature 3
		]
	, infrequent =
		[ mki Gauge (EpsolarValue "Maximum input volt (PV) today") "max_input_volts" CcMaxInputVoltsToday 3
		, mki Gauge (EpsolarValue "Maximum battery volt today") "max_battery_volts" CcMaxBatteryVoltsToday 3
		, mki Gauge (EpsolarValue "Minimum battery volt today") "min_battery_volts" CcMinBatteryVoltsToday 3
		, mki Gauge (EpsolarValue "Generated energy today") "kwh_generated_today" CcKWHGeneratedToday 3
		, mki Gauge (EpsolarValue "Total generated energy") "kwh_generated_total" CcKWHGeneratedTotal 3
		, mki Gauge (EpsolarValue "Temperature inside equipment") "cc_temp_celsius" CcTemperature 3
		, mki Gauge (EpsolarValue "Remote battery temperature") "batt_temp_celsius" BatteryTemperature 3
		, mki Gauge (OneWireSensor "28-000008645973") "porch_temp_celsius" PorchTemperature 3
		, mki Gauge (SI7021 "Temperature") "hall_temp_celsius" HallTemperature 3
		, mki Gauge (OneWireSensor "28-0000096083bf") "fridge_temp_celsius" FridgeTemperature 3
		, mki Gauge (OneWireSensor "28-000008290227") "fridge_motor_temp" FridgeMotorTemperature 3
		, mkia Gauge AutomationFridgeRuntimeToday "fridge_hours_today"
		, mkia Gauge AutomationFridgeRunDuration "fridge_run_duration"
		, mki Gauge (OneWireSensor "28-00000996a637") "fridge_aux_temp" FridgeAuxTemperature 3
		, mki Gauge (OneWireSensor "28-000009b76d38") "spare_probe_temp" SpareProbeTemperature 3
		, mki Gauge (EpsolarValue "Charging equipment status") "cc_status_code" CcStatusCode 3
		, mkia Gauge DumpLoadWatts "dump_load_watts"
		, mki Gauge (SI7021 "Relative Humidity") "hall_humidity" HallHumidity 1
		, mkia Gauge ForecastHumidity "forecast_humidity"
		, mki Gauge (OneWireSensor "28-0000098cd429") "inverter_temp" InverterTemperature 3
		, mki Gauge (OneWireSensor "28-0000098e4058") "slab_temp" SlabTemperature 3
		, mkia Gauge SatelliteInternetSNR "satellite_snr"
		]
	}
  where
	mkf t dsf rrdname mkval p = mk (frequent steplen) t dsf rrdname (valparser mkval p)
	mki t dsf rrdname mkval p = mk (infrequent steplen) t dsf rrdname (valparser mkval p)
	mkia t f rrdname = mk (infrequent steplen) t dsf rrdname Nothing
	  where
		dsf = AutomationValue (keySensedValue f) (f defSensedValue)
	mk (StepLen (Seconds steplen')) t dsf rrdname p =
		(dsf, DataSource rrdname p t hb)
	  where
		-- Allow missing one value before it goes unknown in the rrd.
		hb = HeartBeat (Seconds (steplen' * 2))
	valparser mkval p = Just $ mkval . parseDataUnit p

createRRD :: FilePath -> StepLen -> [(DataSourceFrom, DataSource)] -> [RRA] -> IO ()
createRRD f (StepLen (Seconds steplensecs)) ds rra = do
	createDirectoryIfMissing True (takeDirectory f)
	print ps
	callProcess "rrdtool" ps
  where
	ps = concat
		[ [ "create", f, "--step=" ++ show steplensecs ]
		, map (formatDataSource . snd) ds
		, map formatRRA rra
		]

updateRRD :: FilePath -> [(DataSource, SensedValue)] -> IO ()
updateRRD f vs
	| null vs' = return ()
	| otherwise = callProcess "rrdupdate" ps
  where
	ps = [ f, "--template", template, "N:" ++ vals ]
	template = intercalate ":" (map (rrdname . fst) vs')
	vals = intercalate ":" (map snd vs')
	vs' = catMaybes $ map elim vs
	elim (ds, sv) = case formatSensedValue sv of
		Nothing -> Nothing
		Just s -> Just (ds, s)
	rrdname (DataSource n _ _ _) = n

data QueryHandle = QueryHandle QSem (MVar (Handle, Handle, ProcessHandle))

mkQueryHandle :: IO QueryHandle
mkQueryHandle = do
	lcksem <- newQSem 1 -- only one query allowed at a time
	mvar <- newEmptyMVar
	return (QueryHandle lcksem mvar)
	
oneWireSensorDataFile :: DataSourceFrom -> FilePath
oneWireSensorDataFile (OneWireSensor sid) =
	"/sys/bus/w1/devices" </> sid </> "w1_slave"
oneWireSensorDataFile _ = ""

query :: QueryHandle -> GetSensedValue -> DataSourceFrom -> DataSource -> IO SensedValue
query (QueryHandle lcksem mvar) _ (EpsolarValue req) (DataSource _ (Just mksensedvalue) _ _) =
	bracket_ lock unlock (go (2 :: Integer))
  where
	lock = waitQSem lcksem
	unlock = signalQSem lcksem

	go 0 = return $ mksensedvalue ""
	go retries = do
		-- Avoid querys too close together
		threadDelay 1500000
		(inh, outh, ph) <- getp
		let killitnretry = do
			_ <- takeMVar mvar
			void $ (try $ terminateProcess ph >> waitForProcess ph :: IO (Either IOException ExitCode))
			hPutStrLn stderr "terminated query.py"
			hFlush stderr
			go (pred retries)
		v <- timeout 3000000 (comm inh outh)
		case v of
			Just (Right r) -> do
				-- Python "None" value may slip though.
				if r == "None"
					then return $ mksensedvalue ""
					else return $ mksensedvalue r
			Just (Left e) -> do
				hPutStrLn stderr $ "query for " ++ req ++ " exception: " ++ show e
				hFlush stderr
				killitnretry
			Nothing -> do
				hPutStrLn stderr $ "query for " ++ req ++ " stalled"
				hFlush stderr
				killitnretry
	
	-- Need to use -u to prevent python buffering stdin.
	p = (proc "python" ["-u", "./query.py"])
		{ std_in = CreatePipe
		, std_out = CreatePipe 
		}

	getp = do
		v <- tryReadMVar mvar
		case v of
			Just (inh, outh, ph) -> return (inh, outh, ph)
			Nothing -> startp

	startp = do
		(Just inh, Just outh, Nothing, ph) <- createProcess p
		putMVar mvar (inh, outh, ph)
		return (inh, outh, ph)

	comm :: Handle -> Handle -> IO (Either SomeException String)
	comm inh outh = try $ do
		hPutStrLn inh req
		hFlush inh
		s <- hGetLine outh
			-- read strictly so as not to return until done
			>>= \s -> length s `seq` return s
		return $ takeWhile (/= '\n') s
query _ _ sensor@(OneWireSensor _) (DataSource _ (Just mksensedvalue) _ _) =
	loop (2 :: Int)
  where
	loop n = do
		let f = oneWireSensorDataFile sensor
		res <- timeout 3000000 (try $ readFile f :: IO (Either IOException String))
		case res of
			Nothing -> readerr $ "timeout reading " ++ f
			Just (Left e) -> readerr $ "query for " ++ f ++ " failed: " ++ show e
			Just (Right s)
				| "YES" `isInfixOf` s -> 
					case map (readMaybe . dropWhile (not . numchar)) $ filter ("t=" `isPrefixOf`) (words s) of
						(Just temp:[]) -> do
							let tempc = temp / (1000 :: Double)
							if tempc < 500 && tempc > (-500)
								then return $ mksensedvalue $ show tempc
								else readerr $ "query for " ++ f ++ " returned absurd value " ++ show tempc
						_ -> readerr $ "query for " ++ f ++ " failed parse"
				| otherwise -> readerr $ "query for " ++ f ++ " failed CRC"
	  where
		numchar c = isNumber c || c == '-'
		readerr s = do
			hPutStrLn stderr s
			hFlush stderr
			if n > 0
				then loop (n-1)
				else return $ mksensedvalue ""
query _ _ (SI7021 match) (DataSource _ (Just mksensedvalue) _ _) = 
	loop (2 :: Int)
  where
	loop n = timeout 3000000 (readProcessWithExitCode "./SI7021" [] "") >>= \case
		Nothing -> readerr "timeout reading from SI7021"
		Just (_exitcode, out, _err) ->
			case map (reverse . words) $ filter (match `isPrefixOf`) (lines out) of
				((w:_):[]) -> return $ mksensedvalue w
				_ -> readerr "SI7021 output parse failed"
	  where
		readerr s = do
			hPutStrLn stderr s
			hFlush stderr
			if n > 0
				then loop (n-1)
				else return $ mksensedvalue ""
query _ getsensedvalue (AutomationValue k defv) (DataSource _ Nothing _ _) =
	fromMaybe defv <$> getsensedvalue k
query _ _ _ _ = error "bad data source definition!"

rrdFiles :: [(String, [RRA])] -> [FreqPair ([RRA], FilePath)]
rrdFiles = map mk
  where
	mk (rdesc, rras) = FreqPair
		{ frequent = (rras, "rrds" </> rdesc </> "pv-"++rdesc++"-frequent.rrd")
		, infrequent = (rras, "rrds" </> rdesc </> "pv-"++rdesc++"-infrequent.rrd")
		}

main :: IO ()
main = do
	linkSensors
	qh <- mkQueryHandle
	let postsensedvalue = postSensedValueCallback qh
	(webserverthread, webchan, getsensedvalue) <- runPollerWebserver postsensedvalue
	prep Frequent
	prep Infrequent
	mgr <- newManager defaultManagerSettings
	_ <- go qh getsensedvalue webchan Frequent False
		`concurrently` go qh getsensedvalue webchan Infrequent True
		`concurrently` notifyDhcpClientChanges
			(webchan . DhcpClients)
		`concurrently` Viasat.pollStatus (Seconds 30) mgr
			(satcallback webchan)
		`concurrently` Darksky.pollForecast webchan
	cancel webserverthread
	return ()
  where
	prep frequency = do
		let ds = getFrequent frequency (dataSources mainStepLen)
		let fs = map (getFrequent frequency) (rrdFiles (allRras (getFrequent frequency mainStepLen)))
		forM_ fs $ \(rras, f) -> do
			e <- doesFileExist f
			if e
				then return ()
				else createRRD f (getFrequent frequency mainStepLen) ds rras

	go qh getsensedvalue webchan frequency waitbetween = do
		let dsl = getFrequent frequency (dataSources mainStepLen)
		let fs = map (getFrequent frequency) (rrdFiles (allRras (getFrequent frequency mainStepLen)))
		forM_ fs $ \(rras, f) -> do
			e <- doesFileExist f
			if e
				then return ()
				else createRRD f (getFrequent frequency mainStepLen) dsl rras

		pollstart <- getCurrentTime
		putStrLn $ show frequency ++ " query start"
		hFlush stdout
		sensed <- forM dsl $ \(esv, ds) -> do
			val <- query qh getsensedvalue esv ds
			() <- webchan val
			return (ds, val)
		pollend <- getCurrentTime
		let elapsed = pollend `diffUTCTime` pollstart
		putStrLn $ show frequency ++ " query complete"
		hFlush stdout

		forM_ fs $ \(_, f) -> do
			updateRRD f sensed

		updateJsonForWebPage frequency pollstart sensed getsensedvalue

		if waitbetween
			then do
				let (StepLen (Seconds goal)) = getFrequent frequency mainStepLen
				let delta = fromIntegral goal - elapsed
				putStrLn $ show frequency ++ " delaying: " ++ show delta
				hFlush stdout
				threadDelay $ floor $ 1000000 * delta
			else return ()

		go qh getsensedvalue webchan frequency waitbetween
	
	satcallback webchan s = do
		void $ webchan $ SatelliteInternetConnectionStatus $
			Just $ Viasat.connectionStatus s
		void $ webchan $ SatelliteInternetSNR $
			Just $ Viasat.snr s


mainStepLen :: FreqPair StepLen
mainStepLen = FreqPair
	{ frequent = StepLen (Seconds 30)
	, infrequent = StepLen (Seconds 300)
	}
	
updateJsonForWebPage :: Frequency -> UTCTime -> [(DataSource, SensedValue)] -> GetSensedValue -> IO ()
updateJsonForWebPage frequency pollstart sensed getsensedvalue = do
	let jsname = case frequency of
		Frequent -> "frequent"
		Infrequent -> "infrequent"
	let jsfile = "rrds/recent" </> "data-" ++ jsname ++ ".js"
	let datapoints = map (\(DataSource rrdname _ _ _, val) -> (rrdname, formatSensedValue val)) sensed
	automationstatus <- getsensedvalue (keySensedValue AutomationOverallStatus)
		>>= return . \case
			Just (AutomationOverallStatus l) -> l
			_ -> []
	let fridgethoughts = Just $ concat $
		flip mapMaybe automationstatus $ \case
			FridgeThoughts t -> Just t
			_ -> Nothing
	let jsondatapoints = ("fridge_thoughts", fridgethoughts) : concatMap addFahrenheit datapoints
	writeFile (jsfile ++ ".new") $
		jsondata jsname (("lastpoll", Just (takeWhile (/= '.') (show pollstart))):jsondatapoints)
	renameFile (jsfile ++ ".new") jsfile
  where
	jsondata jsname l = 
		let inner = intercalate ", " $
			map (\(k, v) -> k ++ ": " ++ show (fromMaybe "unknown" v)) l
		in jsname ++ "={" ++ inner ++ "}"

addFahrenheit :: (String, Maybe String) -> [(String, Maybe String)]
addFahrenheit (k, v)
	| "celsius" `isSuffixOf` k =
		go (reverse (drop 7 (reverse k)) ++ "fahrenheit")
	| "_temp" `isSuffixOf` k = 
		go (k ++ "_fahrenheit")
	| otherwise = [(k, v)]
  where
	go kf = [ (k, v)
		, case readMaybe =<< v of
			Nothing -> (kf, Nothing)
			Just c -> (kf, Just $ show $ celsiusToFahrenheit (TemperatureCelsius c))
		]

postSensedValueCallback :: QueryHandle -> AddSensedValue -> GetSensedValue -> SensedValue -> IO Bool
postSensedValueCallback qh addsensedvalue getsensedvalue v = case v of
	-- Turn the charge controller load on/off.
	-- This is only here because of the poor quality of the
	-- interface to the charge controller prevents putting it into
	-- controller.hs
	CcLoadSetTo p -> do
		ok <- loadControl qh addsensedvalue getsensedvalue p
		-- Forward back to the automation now that the load
		-- has been switched.
		if ok
			then addsensedvalue v
			else return ()
		return ok
	-- Let the SensedValue be forwarded back to the automation.
	-- This way, the automation can send us values for safekeeping,
	-- and when it's restarted, it can access the previous value.
	_ -> do
		addsensedvalue v
		return True

loadControl :: QueryHandle -> AddSensedValue -> GetSensedValue -> PowerSetting -> IO Bool
loadControl qh addsensedvalue getsensedvalue (PowerSetting b) = do
	let req = if b then "loadon" else "loadoff"
	let ds = DataSource req (Just parseresp) Gauge (HeartBeat (Seconds 1))
	res <- query qh getsensedvalue (EpsolarValue req) ds
	addsensedvalue res
	case res of
		CcLoadControlWorking True -> return True
		_ -> return False
  where
	-- query.py replies with "True" or "False" if it was able to
	-- control the load.
	parseresp = maybe (CcLoadControlWorking False) CcLoadControlWorking
		. readMaybe

-- | Make symlinks to sensor data files, for easy manual access.
linkSensors :: IO ()
linkSensors = do
	let ds = dataSources mainStepLen
	let w1sensors = filter (isw1 . fst) $
		getFrequent Frequent ds ++ getFrequent Infrequent ds
	createDirectoryIfMissing False "sensors"
	forM_ w1sensors $ \(sensor, DataSource name _ _ _) -> do
		let src = oneWireSensorDataFile sensor
		let dest = "sensors" </> name
		void $ try' $ removeLink dest
		createSymbolicLink src dest
  where
	isw1 (OneWireSensor _) = True
	isw1 _ = False

	try' :: IO a -> IO (Either SomeException a)
	try' = try