diff options
| -rw-r--r-- | app/Main.hs | 1 | ||||
| -rw-r--r-- | app/Pretty.hs | 6 | ||||
| -rw-r--r-- | app/Sensor.hs | 67 | ||||
| -rw-r--r-- | astatusbar.cabal | 2 |
4 files changed, 76 insertions, 0 deletions
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, |