Rewrite xmobar-weather in Haskell.

This adds a new binary that replaces the jenky Perl weather script.

In addition this switches the weather source to wttr.in. Before it would
always pull the weather from the same weather station, which is not what
I want.

4 files changed, 225 insertions, 103 deletions

diff --git a/extras/HOME/.xmonad/xmobar-weather b/extras/HOME/.xmonad/xmobar-weather
deleted file mode 100755
index b95fadb..0000000
--- a/extras/HOME/.xmonad/xmobar-weather
+++ /dev/null
@@ -1,103 +0,0 @@
-#!/usr/bin/perl
-
-use Time::Local;
-use POSIX;
-
-$content = `curl https://ipinfo.io`;
-
-die "Unable to get IP info" unless defined $content;
-
-($city, $lat, $lon) =
-  ($content =~ m/.*"city":\s+"([^"]+)".*"loc":\s+"(-?[0-9.]+),(-?[0-9.]+).*"/ims);
-
-$content = `curl "https://api.sunrise-sunset.org/json?lat=$lat&lng=$lon&formatted=0"`;
-
-die "Unable to get sunrise/sunset data" unless defined $content;
-
-if (length($content) == 0) {
-  printf("<fc=#404040></fc> ");
-  exit
-}
-
-$sunrise_str=$content;
-$sunset_str=$content;
-$sunrise_str =~ s#.*"sunrise":"([^"]*)".*#\1#;
-$sunset_str =~ s#.*"sunset":"([^"]*)".*#\1#;
-$current_str=strftime "%Y-%m-%dT%H:%M:%S+00:00", gmtime();
-
-$content = `curl "https://tgftp.nws.noaa.gov/data/observations/metar/decoded/KLMO.TXT"`;
-
-die "Unable to get weather data" unless defined $content;
-
-$sky_conditions = $content;
-$sky_conditions =~ s#.*Sky conditions:\s+([^\n]+).*#\1#ims;
-$sky_conditions =~ s#\s#_#g;
-
-$wind = $content;
-$wind =~ s#.*Wind:\s+([^\n]+).*#\1#ims;
-($wind_direction, $wind_speed) =
-    ($wind =~ m/from the ([A-Z]+).*at (\d+) MPH.*/g);
-
-
-$temp = $content;
-$temp =~ s#.*Temperature:\s+(-?[0-9.]+) F.*#\1#ims;
-
-if ($current_str gt $sunrise_str and $current_str lt $sunset_str) {
-  $is_day = 1;
-} else {
-  $is_day = 0;
-}
-
-%directions = (
-  NE => "",
-  NNE => "",
-  ENE => "",
-  SE => "",
-  SSE => "",
-  ESE => "",
-  NW => "",
-  NNW => "",
-  WNW => "",
-  SW => "",
-  SSW => "",
-  WSW => "",
-  N => "",
-  S => "",
-  W => "",
-  E => "" );
-
-$dir=%directions{$wind_direction};
-
-%conditions_day = (
-  clear => "<fc=#ddcf04></fc> ",
-  sunny => "<fc=#ddcf04></fc> ",
-  mostly_clear => "<fc=#00a3c4></fc> ",
-  mostly_sunny => "<fc=#ddcf04></fc> ",
-  partly_sunny => "<fc=#ddcf04></fc> ",
-  fair => "<fc=#a0a0a0>🌑</fc> ",
-  cloudy =>"<fc=#a0a0a0>摒</fc> ",
-  overcast =>"<fc=#808080></fc> ",
-  partly_cloudy => "<fc=#a0a0a0>杖</fc> ",
-  mostly_cloudy => "<fc=#808080></fc> ",
-  considerable_cloudiness => "<fc=#a0a0a0>ﭽ</fc> " );
-
-%conditions_night = (
-  clear => "<fc=#00a3c4></fc> ",
-  sunny => "<fc=#00a3c4></fc> ",
-  mostly_clear => "<fc=#00a3c4></fc> ",
-  mostly_sunny => "<fc=#00a3c4></fc> ",
-  partly_sunny => "<fc=#00a3c4></fc> ",
-  fair => "<fc=#808080>🌑</fc> ",
-  cloudy =>"<fc=#808080>摒</fc> ",
-  overcast =>"<fc=#404040></fc> ",
-  partly_cloudy => "<fc=#a0a0a0></fc> ",
-  mostly_cloudy => "<fc=#808080></fc> ",
-  considerable_cloudiness => "<fc=#a0a0a0>ﭽ</fc> " );
-
-if ($is_day) {
-  $conditions = %conditions_day{$sky_conditions};
-} else {
-  $conditions = %conditions_night{$sky_conditions};  
-}
-
-printf("<fc=#a0a0a0><fn=3>$city</fn> <fn=3>$dir</fn> <fn=3>${wind_speed}</fn></fc> <fn=8>$conditions</fn><fn=3><fc=#a0a0a0>%.0f°F</fc></fn>\n", $temp);
diff --git a/install.sh b/install.sh
index 59a5078..f862fe8 100755
--- a/install.sh
+++ b/install.sh
@@ -1,5 +1,7 @@
 #!/bin/bash
 
+stack build
+
 real_dir=$(dirname $(readlink -f "$0"))
 cd "$real_dir"
 
@@ -13,6 +15,9 @@ cc -o \
   xmobar/extras/battery/battery.c \
   -lm
 
+ln -sf "$(stack path --local-install-root)/bin/xmobar-weather" build/extras/HOME/.xmonad/xmobar-weather
+ln -sf "$(stack path --local-install-root)/bin/xmobar-weather" extras/HOME/.xmonad/xmobar-weather
+
 GLOBIGNORE=".:.."
 shopt -u dotglob
 
diff --git a/package.yaml b/package.yaml
index 07a09df..81ba046 100644
--- a/package.yaml
+++ b/package.yaml
@@ -6,6 +6,10 @@ executables:
     main: Main.hs
     source-dirs: src
 
+  xmobar-weather:
+    main: Main.hs
+    source-dirs: xmobar/extras/weather/src
+
 ghc-options:
   - -XBangPatterns
   - -XDataKinds
@@ -44,3 +48,6 @@ dependencies:
   - linear
   - time
   - prettyprinter
+  - aeson
+  - curl
+  - text
diff --git a/xmobar/extras/weather/src/Main.hs b/xmobar/extras/weather/src/Main.hs
new file mode 100644
index 0000000..aa5a408
--- /dev/null
+++ b/xmobar/extras/weather/src/Main.hs
@@ -0,0 +1,213 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
+
+module Main where
+
+import Control.Monad (when)
+import Control.Monad.Writer hiding (getFirst)
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+import qualified Data.ByteString.Lazy.Char8
+import qualified Data.Char
+import qualified Data.Map
+import Data.Maybe (fromMaybe)
+import qualified Data.Text
+import GHC.Generics
+import Network.Curl
+import System.Exit (exitFailure)
+import System.IO (hPutStrLn, stderr)
+import Text.Printf (printf)
+
+-- Date time that easily comparable.
+data SillyTime = SillyTime
+  { sillyTimeDate :: String,
+    sillyTimeAMPM :: String,
+    sillyTimeTime :: String
+  }
+  deriving (Ord, Eq, Show)
+
+data CurrentCondition = CurrentCondition
+  { feelsLikeF :: String,
+    cloudCover :: String,
+    humidity :: String,
+    tempF :: String,
+    weatherDesc :: String,
+    windspeedMiles :: String,
+    winddir :: String,
+    observationTime :: SillyTime
+  }
+  deriving (Generic, Show)
+
+newtype NearestArea = NearestArea
+  { areaName :: String
+  }
+  deriving (Generic, Show)
+
+data Astronomy = Astronomy
+  { sunrise :: SillyTime,
+    sunset :: SillyTime
+  }
+  deriving (Generic, Show)
+
+data Weather = Weather
+  { currentCondition :: CurrentCondition,
+    nearestArea :: NearestArea,
+    astronomy :: Astronomy
+  }
+  deriving (Generic, Show)
+
+getFirst :: Parser [a] -> Parser a
+getFirst ls = do
+  l <- ls
+  case l of
+    (a : _) -> return a
+    [] -> fail "No current conditions"
+
+instance FromJSON CurrentCondition where
+  parseJSON = withObject "CurrentCondition" $ \v ->
+    CurrentCondition <$> v .: "FeelsLikeF"
+      <*> v .: "cloudcover"
+      <*> v .: "humidity"
+      <*> v .: "temp_F"
+      <*> ( withArray
+              "WeatherDescriptions"
+              ( \vs -> do
+                  concat <$> mapM (withObject "Description" (.: "value")) vs
+              )
+              =<< (v .: "weatherDesc")
+          )
+      <*> v .: "windspeedMiles"
+      <*> v .: "winddir16Point"
+      <*> ( withText
+              "observationTime"
+              ( \txt -> case Data.Text.unpack <$> Data.Text.words txt of
+                  [a, b, c] -> return (SillyTime a c b)
+                  _ -> fail $ printf "1 Failed to parse SillyTime [%s]" (Data.Text.unpack txt)
+              )
+              =<< (v .: "localObsDateTime")
+          )
+
+instance FromJSON NearestArea where
+  parseJSON = withObject "NearestArea" $ \v ->
+    fmap NearestArea $ do
+      (areaNames :: [Object]) <- v .: "areaName"
+      concat <$> mapM (.: "value") areaNames
+
+parseAstronomy :: String -> Value -> Parser Astronomy
+parseAstronomy date = withObject "Astronomy" $ \v ->
+  Astronomy <$> (withText "sunrise" toSillyTime =<< (v .: "sunrise")) <*> (withText "sunset" toSillyTime =<< (v .: "sunset"))
+  where
+    toSillyTime str =
+      case Data.Text.unpack <$> Data.Text.words str of
+        [a, b] -> return $ SillyTime date b a
+        _ -> fail $ printf "2 Failed to parse SillyTime [%s]" (Data.Text.unpack str)
+
+instance FromJSON Weather where
+  parseJSON = withObject "Weather" $ \v ->
+    Weather
+      <$> getFirst (v .: "current_condition")
+      <*> getFirst (v .: "nearest_area")
+      <*> ( withObject
+              "Timeline"
+              ( \v -> do
+                  d <- v .: "date"
+                  parseAstronomy d =<< getFirst (v .: "astronomy")
+              )
+              =<< getFirst (v .: "weather")
+          )
+
+conditionsIconDay :: Data.Map.Map String String
+conditionsIconDay =
+  Data.Map.fromList
+    [ ("overcast", fc "#808080" "\63070"),
+      ("fair", fc "a0a0a0" "🌑"),
+      ("clear", fc "#ddcf04" "\58125"),
+      ("sunny", fc "#ddcf04" "\58125"),
+      ("mostly clear", fc "#00a3c4" "\57894"),
+      ("mostly sunny", fc "#ddcf04" "\58124"),
+      ("partly sunny", fc "#ddcf04" "\58124"),
+      ("fair", fc "#a0a0a0" "\127761"),
+      ("cloudy", fc "#a0a0a0" "\64143"),
+      ("overcast", fc "#808080" "\63070"),
+      ("partly cloudy", fc "#a0a0a0" "\64148"),
+      ("mostly cloudy", fc "#808080" "\63070"),
+      ("considerable cloudiness", fc "#a0a0a0" "\64381")
+    ]
+
+conditionsIconNight :: Data.Map.Map String String
+conditionsIconNight =
+  Data.Map.fromList
+    [ ("clear", fc "#00a3c4" "\61830"),
+      ("sunny", fc "#00a3c4" "\61830"),
+      ("mostly clear", fc "#00a3c4" "\57894"),
+      ("mostly sunny", fc "#00a3c4" "\57894"),
+      ("partly sunny", fc "#00a3c4" "\57894"),
+      ("fair", fc "#808080" "\127761"),
+      ("cloudy", fc "#808080" "\64143"),
+      ("overcast", fc "#404040" "\63070"),
+      ("partly cloudy", fc "#a0a0a0" "\57894"),
+      ("mostly cloudy", fc "#808080" "\63070"),
+      ("considerable cloudiness", fc "#a0a0a0" "\64381")
+    ]
+
+handleWeather :: Weather -> String
+handleWeather w = execWriter $ do
+  tell $ lightGrey $ fn 3 $ areaName (nearestArea w)
+  tell " "
+  tell $
+    lightGrey $
+      fn 3 $
+        case winddir (currentCondition w) of
+          "NE" -> "\62785"
+          "NNE" -> "\62785"
+          "ENE" -> "\62785"
+          "SE" -> "\62810"
+          "SSE" -> "\62810"
+          "ESE" -> "\62810"
+          "NW" -> "\62786"
+          "NNW" -> "\62786"
+          "WNW" -> "\62786"
+          "SW" -> "\62811"
+          "SSW" -> "\62811"
+          "WSW" -> "\62811"
+          "N" -> "\62788"
+          "S" -> "\62812"
+          "W" -> "\62803"
+          "E" -> "\62796"
+          _ -> "?"
+
+  tell " "
+  tell $ lightGrey $ fn 3 $ windspeedMiles (currentCondition w) ++ "mph"
+  tell " "
+
+  let conditions = if isNight then conditionsIconNight else conditionsIconDay
+  tell $
+    fn 5 $
+      fromMaybe "?" $
+        Data.Map.lookup (map Data.Char.toLower $ weatherDesc (currentCondition w)) conditions
+
+  tell " "
+  tell $ lightGrey $ fn 3 $ printf "%s°F" (tempF $ currentCondition w)
+  where
+    isNight =
+      observationTime (currentCondition w) < sunrise (astronomy w)
+        || observationTime (currentCondition w) > sunset (astronomy w)
+
+    lightGrey = fc "#a0a0a0"
+
+    fn :: Int -> String -> String
+    fn = printf "<fn=%d>%s</fn>"
+
+fc :: String -> String -> String
+fc = printf "<fc=%s>%s</fc>"
+
+main :: IO ()
+main = do
+  (code, resp) <- curlGetString "https://wttr.in?format=j2" []
+  when (code /= CurlOK) exitFailure
+
+  case eitherDecode (Data.ByteString.Lazy.Char8.pack resp) of
+    Left err -> hPutStrLn stderr $ printf "Failure to parse [%s]" err
+    Right weather -> putStrLn $ handleWeather weather