{-# LANGUAGE OverloadedStrings #-}
-- | This is a simple weather widget that polls wttr.in to retrieve the weather,
-- instead of relying on noaa data. 
--
-- Useful if NOAA data doesn't cover your needs, or if you just like wttr.in
-- better. 
--
-- For more information on how to use wttr.in, see <https://wttr.in/:help>.

module System.Taffybar.Widget.WttrIn ( textWttrNew ) where
import System.Log.Logger
import Control.Exception as E
import Control.Monad.IO.Class
import GI.Gtk
import qualified Data.Text as T
import Data.Maybe (isJust)
import Data.Text.Encoding (decodeUtf8)
import Data.ByteString.Lazy (toStrict)
import Data.ByteString (ByteString)
import Text.Regex
import Network.HTTP.Client
import Network.HTTP.Types.Status (statusIsSuccessful)
import System.Taffybar.Widget.Generic.PollingLabel

-- | Creates a GTK Label widget that polls the requested wttr.in url for weather
-- information. 
--
-- Not compatible with image endpoints and binary data, such as the %.png%
-- endpoints. 
--
-- > -- Yields a label with the text "London: ⛅️  +72°F". Updates every 60
-- > -- seconds.
-- > textWttrNew "http://wttr.in/London?format=3" 60
textWttrNew 
 :: MonadIO m 
 => String -- ^ URL. All non-alphanumeric characters must be properly %-encoded.
 -> Double -- ^ Update Interval (in seconds)
 -> m Widget
textWttrNew :: String -> Double -> m Widget
textWttrNew String
url Double
interval = Double -> IO Text -> m Widget
forall (m :: * -> *). MonadIO m => Double -> IO Text -> m Widget
pollingLabelNew Double
interval (String -> IO Text
callWttr String
url)

-- | IO Action that calls wttr.in as per the user's request. 
callWttr :: String -> IO T.Text
callWttr :: String -> IO Text
callWttr String
url = do
  let unknownLocation :: Text -> Bool
unknownLocation Text
rsp = -- checks for a common wttr.in bug
        case Text -> Text -> Maybe Text
T.stripPrefix Text
"Unknown location; please try" Text
rsp of
          Maybe Text
Nothing          -> Bool
False
          Just Text
strippedRsp -> Text -> Int
T.length Text
strippedRsp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Text -> Int
T.length Text
rsp
      isImage :: String -> Bool
isImage = Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [String] -> Bool)
-> (String -> Maybe [String]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Regex -> String -> Maybe [String]
matchRegex (Regex -> String -> Maybe [String])
-> Regex -> String -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ String -> Regex
mkRegex String
".png")
      getResponseData :: Response ByteString -> (Bool, ByteString)
getResponseData Response ByteString
r = ( Status -> Bool
statusIsSuccessful (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
r
                          , ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
r)
      catchAndLog :: IO (Bool, ByteString) -> IO (Bool, ByteString)
catchAndLog = (IO (Bool, ByteString)
 -> (HttpException -> IO (Bool, ByteString))
 -> IO (Bool, ByteString))
-> (HttpException -> IO (Bool, ByteString))
-> IO (Bool, ByteString)
-> IO (Bool, ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Bool, ByteString)
-> (HttpException -> IO (Bool, ByteString))
-> IO (Bool, ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch ((HttpException -> IO (Bool, ByteString))
 -> IO (Bool, ByteString) -> IO (Bool, ByteString))
-> (HttpException -> IO (Bool, ByteString))
-> IO (Bool, ByteString)
-> IO (Bool, ByteString)
forall a b. (a -> b) -> a -> b
$ HttpException -> IO (Bool, ByteString)
logException
  Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
  Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
  (Bool
isOk, ByteString
response) <- IO (Bool, ByteString) -> IO (Bool, ByteString)
catchAndLog (Response ByteString -> (Bool, ByteString)
getResponseData (Response ByteString -> (Bool, ByteString))
-> IO (Response ByteString) -> IO (Bool, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager) 
  let body :: Text
body = ByteString -> Text
decodeUtf8 ByteString
response
  if Bool -> Bool
not Bool
isOk Bool -> Bool -> Bool
|| String -> Bool
isImage String
url Bool -> Bool -> Bool
|| Text -> Bool
unknownLocation Text
body
  then Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
"✨"
  else Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
body

-- Logs an Http Exception and returns wttr.in's weather unknown label.
logException :: HttpException -> IO (Bool, ByteString)
logException :: HttpException -> IO (Bool, ByteString)
logException HttpException
e = do
  let errmsg :: String
errmsg = HttpException -> String
forall a. Show a => a -> String
show HttpException
e
  String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Widget.WttrIn" Priority
ERROR (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    (String
"Warning: Couldn't call wttr.in. \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errmsg)
  (Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, ByteString) -> IO (Bool, ByteString))
-> (Bool, ByteString) -> IO (Bool, ByteString)
forall a b. (a -> b) -> a -> b
$ (Bool
False, ByteString
"✨")