From 9c71a73775ddb2965fd2f792321900a87d2d5592 Mon Sep 17 00:00:00 2001
From: Fabian Kirchner <kirchner@posteo.de>
Date: Mon, 12 Aug 2024 18:03:00 +0200
Subject: feat: add weather forecast

---
 app/Main.hs      |  1 +
 app/Pretty.hs    |  6 +++++
 app/Sensor.hs    | 67 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 astatusbar.cabal |  2 ++
 4 files changed, 76 insertions(+)

diff --git a/app/Main.hs b/app/Main.hs
index 0ed59de..42ce113 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -194,6 +194,7 @@ createWindow args = do
               [pure (lit (if args.icons then "\xf0200  " else "net ")), lit <$> net],
               [pure (lit " "), lit <$> Sensor.snd],
               [pure (lit " "), lit <$> bat],
+              [pure (lit " "), lit <$> weatherForecast],
               [pure (lit " "), lit <$> date, pure (lit ", "), lit <$> time],
               []
             ]
diff --git a/app/Pretty.hs b/app/Pretty.hs
index 8621a41..07b3296 100644
--- a/app/Pretty.hs
+++ b/app/Pretty.hs
@@ -36,6 +36,12 @@ instance Pretty String where
 instance Pretty Float where
   pretty = pretty . Diagram 1 . (: [])
 
+instance (Pretty a) => Pretty (Maybe a) where
+  pretty maybeA =
+    case maybeA of
+      Nothing -> Lit Nothing "n/a"
+      Just a -> pretty a
+
 data Diagram a = Diagram Int a deriving (Functor, Show)
 
 diagram :: Int -> a -> Diagram a
diff --git a/app/Sensor.hs b/app/Sensor.hs
index d0b8a0c..84f5b88 100644
--- a/app/Sensor.hs
+++ b/app/Sensor.hs
@@ -26,6 +26,7 @@ module Sensor
     date,
     time,
     wmName,
+    weatherForecast,
     wmWorkspaces,
   )
 where
@@ -34,6 +35,7 @@ import Control.Arrow
 import Control.DeepSeq
 import Control.Monad
 import Control.Monad.Reader
+import Data.Aeson
 import Data.Char
 import Data.Dynamic
 import Data.Functor.WithIndex
@@ -41,12 +43,14 @@ import Data.List
 import Data.Maybe
 import Data.Sensor qualified as S
 import Data.Set qualified as S
+import Data.String
 import Data.Time.Clock
 import Data.Time.Format
 import Data.Time.LocalTime
 import GHC.Generics (Generic)
 import Graphics.X11 qualified as X
 import Graphics.X11.Xlib.Extras qualified as X
+import Network.HTTP.Simple (addRequestHeader, getResponseBody, httpJSON)
 import Pretty qualified as P
 import Process.Shell (sh)
 import Safe
@@ -295,6 +299,69 @@ diskStat = S.sensor DiskStat
 disk :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float])
 disk = diagram 1 diskStat
 
+data WeatherForecast = WeatherForecast deriving (Show)
+
+data Forecast = Forecast
+  { properties :: ForecastProperties
+  }
+  deriving (Generic)
+
+instance FromJSON Forecast
+
+data ForecastProperties = ForecastProperties
+  { timeseries :: [ForecastTimeserie]
+  }
+  deriving (Generic)
+
+instance FromJSON ForecastProperties
+
+data ForecastTimeserie = ForecastTimeserie
+  { data_ :: ForecastData
+  }
+  deriving (Generic)
+
+data ForecastData = ForecastData
+  { next_6_hours :: Maybe Next6Hours
+  }
+  deriving (Generic)
+
+instance FromJSON ForecastData
+
+data Next6Hours = Next6Hours
+  { summary :: Summary
+  }
+  deriving (Generic)
+
+instance FromJSON Next6Hours
+
+data Summary = Summary
+  { symbol_code :: String
+  }
+  deriving (Generic)
+
+instance FromJSON Summary
+
+instance FromJSON ForecastTimeserie where
+  parseJSON value =
+    fmap ForecastTimeserie (withObject "ForecastTimeserie" (\v -> v .: fromString "data") value)
+
+instance (S.MonadSensor m) => S.Aggregate m WeatherForecast (Maybe String) where
+  aggregate _ = forever do
+    forecast <- liftIO getForecast
+    S.yield (fmap ((.symbol_code) . (.summary)) (head forecast.properties.timeseries).data_.next_6_hours)
+    threadDelay (5 * 60 * 10 ^ 6)
+
+getForecast :: IO Forecast
+getForecast = handle (\(e :: SomeException) -> print e >> throwIO e) do
+  response <- httpJSON (addUserAgent (fromString "https://api.met.no/weatherapi/locationforecast/2.0/complete?lat=52.3759&lon=9.7320"))
+  return (getResponseBody response)
+  where
+    addUserAgent req = addRequestHeader (fromString "user-agent") (fromString "astatusbar") req
+
+weatherForecast :: (S.MonadSensor m) => S.Sensor m () (Maybe String)
+weatherForecast =
+  S.sensor WeatherForecast
+
 data CurrentTime = CurrentTime deriving (Show)
 
 instance (S.MonadSensor m) => S.Aggregate m CurrentTime UTCTime where
diff --git a/astatusbar.cabal b/astatusbar.cabal
index 8f7c9cc..b97b2fb 100644
--- a/astatusbar.cabal
+++ b/astatusbar.cabal
@@ -20,12 +20,14 @@ executable astatusbar
     default-language: GHC2021
     ghc-options:      -Wall -threaded -O1
     build-depends:
+        aeson,
         base,
         containers,
         data-default,
         deepseq,
         directory,
         filepath,
+        http-conduit,
         indexed-traversable,
         linux-inotify,
         mtl,
-- 
cgit v1.2.3