content: {-# LANGUAGE OverloadedStrings #-}
  -- | This module defines a simple textual weather widget that polls
  -- NOAA for weather data.  To find your weather station, you can use
  -- either of the following:
  --
  -- <https://www.weather.gov/tg/siteloc>
  -- <https://cnrfc.noaa.gov/metar.php>
  --
  -- For example, Madison, WI is KMSN.
  --
  -- NOAA provides several pieces of information in each request; you can control
  -- which pieces end up in your weather widget by providing a _template_ that is
  -- filled in with the current information. The template is just a 'String' with
  -- variables between dollar signs. The variables will be substituted with real
  -- data by the widget. Example:
  --
  -- > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" }
  -- >     weatherWidget = weatherNew wcfg 10
  --
  -- This example makes a new weather widget that checks the weather at KMSN
  -- (Madison, WI) every 10 minutes, and displays the results in Celcius.
  --
  -- Available variables:
  --
  -- [@stationPlace@] The name of the weather station
  --
  -- [@stationState@] The state that the weather station is in
  --
  -- [@year@] The year the report was generated
  --
  -- [@month@] The month the report was generated
  --
  -- [@day@] The day the report was generated
  --
  -- [@hour@] The hour the report was generated
  --
  -- [@wind@] The direction and strength of the wind
  --
  -- [@visibility@] Description of current visibility conditions
  --
  -- [@skyCondition@] ?
  --
  -- [@tempC@] The temperature in Celsius
  --
  -- [@tempF@] The temperature in Farenheit
  --
  -- [@dewPoint@] The current dew point
  --
  -- [@humidity@] The current relative humidity
  --
  -- [@pressure@] The current pressure
  --
  --
  -- As an example, a template like
  --
  -- > "$tempF$ °F"
  --
  -- would yield a widget displaying the temperature in Farenheit with a small
  -- label after it.
  --
  -- Implementation Note: the weather data parsing code is taken from xmobar. This
  -- version of the code makes direct HTTP requests instead of invoking a separate
  -- cURL process.
  
  module System.Taffybar.Widget.Weather
    ( WeatherConfig(..)
    , WeatherInfo(..)
    , WeatherFormatter(WeatherFormatter)
    , weatherNew
    , weatherCustomNew
    , defaultWeatherConfig
    ) where
  
  import Control.Monad.IO.Class
  import qualified Data.ByteString.Lazy as LB
  import Data.List (stripPrefix)
  import Data.Maybe (fromMaybe)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import GI.GLib(markupEscapeText)
  import GI.Gtk
  import Network.HTTP.Client
  import Network.HTTP.Client.TLS (tlsManagerSettings)
  import Network.HTTP.Types.Status
  import System.Log.Logger
  import Text.Parsec
  import Text.Printf
  import Text.StringTemplate
  
  import System.Taffybar.Widget.Generic.PollingLabel
  
  data WeatherInfo = WI
    { stationPlace :: String
    , stationState :: String
    , year :: String
    , month :: String
    , day :: String
    , hour :: String
    , wind :: String
    , visibility :: String
    , skyCondition :: String
    , tempC :: Int
    , tempF :: Int
    , dewPoint :: String
    , humidity :: Int
    , pressure :: Int
    } deriving (Show)
  
  -- Parsers stolen from xmobar
  
  type Parser = Parsec String ()
  
  pTime :: Parser (String, String, String, String)
  pTime = do
    y <- getNumbersAsString
    _ <- char '.'
    m <- getNumbersAsString
    _ <- char '.'
    d <- getNumbersAsString
    _ <- char ' '
    (h:hh:mi:mimi) <- getNumbersAsString
    _ <- char ' '
    return (y, m, d , [h]++[hh]++":"++[mi]++mimi)
  
  pTemp :: Parser (Int, Int)
  pTemp = do
    let num = digit <|> char '-' <|> char '.'
    f <- manyTill num $ char ' '
    _ <- manyTill anyChar $ char '('
    c <- manyTill num $ char ' '
    _ <- skipRestOfLine
    return (floor (read c :: Double), floor (read f :: Double))
  
  pRh :: Parser Int
  pRh = do
    s <- manyTill digit $ char '%' <|> char '.'
    return $ read s
  
  pPressure :: Parser Int
  pPressure = do
    _ <- manyTill anyChar $ char '('
    s <- manyTill digit $ char ' '
    _ <- skipRestOfLine
    return $ read s
  
  parseData :: Parser WeatherInfo
  parseData = do
    st <- getAllBut ","
    _ <- space
    ss <- getAllBut "("
    _ <- skipRestOfLine >> getAllBut "/"
    (y,m,d,h) <- pTime
    w <- getAfterString "Wind: "
    v <- getAfterString "Visibility: "
    sk <- getAfterString "Sky conditions: "
    _ <- skipTillString "Temperature: "
    (tC,tF) <- pTemp
    dp <- getAfterString "Dew Point: "
    _ <- skipTillString "Relative Humidity: "
    rh <- pRh
    _ <- skipTillString "Pressure (altimeter): "
    p <- pPressure
    _ <- manyTill skipRestOfLine eof
    return $ WI st ss y m d h w v sk tC tF dp rh p
  
  getAllBut :: String -> Parser String
  getAllBut s =
      manyTill (noneOf s) (char $ head s)
  
  getAfterString :: String -> Parser String
  getAfterString s = pAfter <|> return ("<" ++ s ++ " not found!>")
    where
      pAfter = do
        _ <- try $ manyTill skipRestOfLine $ string s
        manyTill anyChar newline
  
  skipTillString :: String -> Parser String
  skipTillString s =
      manyTill skipRestOfLine $ string s
  
  getNumbersAsString :: Parser String
  getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n
  
  skipRestOfLine :: Parser Char
  skipRestOfLine = do
    _ <- many $ noneOf "\n\r"
    newline
  
  -- | Simple: download the document at a URL.
  downloadURL :: Manager -> Request -> IO (Either String String)
  downloadURL mgr request = do
    response <- httpLbs request mgr
    case responseStatus response of
      s | s >= status200 && s < status300 ->
        return $ Right (T.unpack . T.decodeUtf8 . LB.toStrict $ responseBody response)
      otherStatus ->
        return . Left $ "HTTP 2XX status was expected but received " ++ show otherStatus
  
  getWeather :: Manager -> String -> IO (Either String WeatherInfo)
  getWeather mgr url = do
    request <- parseRequest url
    dat <- downloadURL mgr request
    case dat of
      Right dat' -> case parse parseData url dat' of
        Right d -> return (Right d)
        Left err -> return (Left (show err))
      Left err -> return (Left (show err))
  
  defaultFormatter :: StringTemplate String -> WeatherInfo -> String
  defaultFormatter tpl wi = render tpl'
    where
      tpl' = setManyAttrib [ ("stationPlace", stationPlace wi)
                           , ("stationState", stationState wi)
                           , ("year", year wi)
                           , ("month", month wi)
                           , ("day", day wi)
                           , ("hour", hour wi)
                           , ("wind", wind wi)
                           , ("visibility", visibility wi)
                           , ("skyCondition", skyCondition wi)
                           , ("tempC", show (tempC wi))
                           , ("tempF", show (tempF wi))
                           , ("dewPoint", dewPoint wi)
                           , ("humidity", show (humidity wi))
                           , ("pressure", show (pressure wi))
                           ] tpl
  
  getCurrentWeather :: IO (Either String WeatherInfo)
      -> StringTemplate String
      -> StringTemplate String
      -> WeatherFormatter
      -> IO (T.Text, Maybe T.Text)
  getCurrentWeather getter labelTpl tooltipTpl formatter = do
    dat <- getter
    case dat of
      Right wi ->
        case formatter of
          DefaultWeatherFormatter -> do
            let rawLabel = T.pack $ defaultFormatter labelTpl wi
            let rawTooltip = T.pack $ defaultFormatter tooltipTpl wi
            lbl <- markupEscapeText rawLabel (-1)
            tooltip <- markupEscapeText rawTooltip (-1)
            return (lbl, Just tooltip)
          WeatherFormatter f -> do
            let rawLabel = T.pack $ f wi
            lbl <- markupEscapeText rawLabel (-1)
            return (lbl, Just lbl)
      Left err -> do
        logM "System.Taffybar.Widget.Weather" ERROR $ "Error in weather: " <> show err
        return ("N/A", Nothing)
  
  -- | The NOAA URL to get data from
  baseUrl :: String
  baseUrl = "https://tgftp.nws.noaa.gov/data/observations/metar/decoded"
  
  -- | A wrapper to allow users to specify a custom weather formatter.
  -- The default interpolates variables into a string as described
  -- above.  Custom formatters can do basically anything.
  data WeatherFormatter
    = WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo'
    | DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter
  
  -- | The configuration for the weather widget.  You can provide a custom
  -- format string through 'weatherTemplate' as described above, or you can
  -- provide a custom function to turn a 'WeatherInfo' into a String via the
  -- 'weatherFormatter' field.
  data WeatherConfig = WeatherConfig
    { weatherStation :: String -- ^ The weather station to poll. No default
    , weatherTemplate :: String -- ^ Template string, as described above.  Default: $tempF$ °F
    , weatherTemplateTooltip :: String -- ^ Template string, as described above.  Default: $tempF$ °F
    , weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above)
    , weatherProxy :: Maybe String -- ^ The proxy server, e.g. "http://proxy:port". Default: Nothing
    }
  
  -- | A sensible default configuration for the weather widget that just
  -- renders the temperature.
  defaultWeatherConfig :: String -> WeatherConfig
  defaultWeatherConfig station =
    WeatherConfig
    { weatherStation = station
    , weatherTemplate = "$tempF$ °F"
    , weatherTemplateTooltip =
        unlines
          [ "Station: $stationPlace$"
          , "Time: $day$.$month$.$year$ $hour$"
          , "Temperature: $tempF$ °F"
          , "Pressure: $pressure$ hPa"
          , "Wind: $wind$"
          , "Visibility: $visibility$"
          , "Sky Condition: $skyCondition$"
          , "Dew Point: $dewPoint$"
          , "Humidity: $humidity$"
          ]
    , weatherFormatter = DefaultWeatherFormatter
    , weatherProxy = Nothing
    }
  
  -- | Create a periodically-updating weather widget that polls NOAA.
  weatherNew :: MonadIO m
             => WeatherConfig -- ^ Configuration to render
             -> Double     -- ^ Polling period in _minutes_
             -> m GI.Gtk.Widget
  weatherNew cfg delayMinutes = liftIO $ do
    -- TODO: add explicit proxy host/port to WeatherConfig and
    -- get rid of this ugly stringly-typed setting
    let usedProxy = case weatherProxy cfg of
          Nothing -> noProxy
          Just str ->
            let strToBs = T.encodeUtf8 . T.pack
                noHttp = fromMaybe str $ stripPrefix "http://" str
                (phost, pport) = case span (':'/=) noHttp of
                  (h, "") -> (strToBs h, 80) -- HTTP seems to assume 80 to be the default
                  (h, ':':p) -> (strToBs h, read p)
                  _ -> error "unreachable: broken span"
            in useProxy $ Proxy phost pport
    mgr <- newManager $ managerSetProxy usedProxy tlsManagerSettings
    let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)
    let getter = getWeather mgr url
    weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg)
      (weatherFormatter cfg) delayMinutes
  
  -- | Create a periodically-updating weather widget using custom weather getter
  weatherCustomNew
    :: MonadIO m
    => IO (Either String WeatherInfo) -- ^ Weather querying action
    -> String -- ^ Weather template
    -> String -- ^ Weather template
    -> WeatherFormatter -- ^ Weather formatter
    -> Double -- ^ Polling period in _minutes_
    -> m GI.Gtk.Widget
  weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = liftIO $ do
    let labelTpl' = newSTMP labelTpl
        tooltipTpl' = newSTMP tooltipTpl
  
    l <- pollingLabelNewWithTooltip (delayMinutes * 60)
         (getCurrentWeather getter labelTpl' tooltipTpl' formatter)
  
    GI.Gtk.widgetShowAll l
    return l
  