| {-# LANGUAGE DataKinds #-} | |
| {-# LANGUAGE DeriveGeneric #-} | |
| {-# LANGUAGE FlexibleContexts #-} | |
| {-# LANGUAGE LambdaCase #-} | |
| {-# LANGUAGE NamedFieldPuns #-} | |
| {-# LANGUAGE OverloadedStrings #-} | |
| {-# LANGUAGE QuasiQuotes #-} | |
| {-# LANGUAGE RecordWildCards #-} | |
| {-# LANGUAGE TypeOperators #-} | |
| import Control.Concurrent.Lifted (fork, threadDelay) | |
| import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVar, | |
| readTVar) | |
| import Control.Exception (try) | |
| import Control.Monad (forM, forM_, forever) | |
| import Control.Monad.IO.Class (MonadIO, liftIO) | |
| import Control.Monad.Reader | |
| import Control.Monad.STM (atomically, retry) | |
| import Control.Monad.Trans.Class (lift) | |
| import Control.Monad.Trans.Control (MonadBaseControl, restoreT) | |
| import Control.Monad.Trans.Maybe (runMaybeT) | |
| import Data.Aeson | |
| import Data.Aeson.QQ (aesonQQ) | |
| import Data.Aeson.Types | |
| import Data.Bifunctor | |
| import Data.List.Extra (minimumOn) | |
| import Data.Maybe (catMaybes) | |
| import Data.String (fromString) | |
| import Data.Text (Text) | |
| import qualified Data.Text as T | |
| import qualified Data.Vector as V | |
| import GHC.Generics | |
| import Line.Bot.Client | |
| import Line.Bot.Types as B | |
| import Line.Bot.Webhook as W | |
| import Network.Connection | |
| import Network.HTTP.Conduit hiding (Proxy) | |
| import Network.HTTP.Simple hiding (Proxy) | |
| import Network.Wai.Handler.Warp (runEnv) | |
| import Servant | |
| import Servant.Server (Context ((:.), EmptyContext)) | |
| import System.Environment (getEnv) | |
| import Text.Read (readMaybe) | |
| data AQData = AQData | |
| { aqi :: Int | |
| , county :: Text | |
| , lat :: Double | |
| , lng :: Double | |
| , status :: Text | |
| , pm25 :: Int | |
| , pm10 :: Int | |
| , o3 :: Int | |
| , co :: Double | |
| , so2 :: Double | |
| } | |
| deriving (Eq, Show, Generic) | |
| data Env = Env | |
| { token :: ChannelToken | |
| , secret :: ChannelSecret | |
| , users :: TVar [(Source, Coord)] | |
| } | |
| parseAQData :: Value -> Parser (Maybe AQData) | |
| parseAQData = withObject "AQData" $ \o -> runMaybeT $ do | |
| aqi <- restoreT $ readMaybe <$> o .: "AQI" | |
| county <- lift $ o .: "County" | |
| lat <- restoreT $ readMaybe <$> o .: "Latitude" | |
| lng <- restoreT $ readMaybe <$> o .: "Longitude" | |
| status <- lift $ o .: "Status" | |
| pm25 <- restoreT $ readMaybe <$> o .: "PM2.5" | |
| pm10 <- restoreT $ readMaybe <$> o .: "PM10" | |
| o3 <- restoreT $ readMaybe <$> o .: "O3" | |
| co <- restoreT $ readMaybe <$> o .: "CO" | |
| so2 <- restoreT $ readMaybe <$> o .: "SO2" | |
| return AQData {..} | |
| instance FromJSON AQData where | |
| parseJSONList = withArray "[AQData]" $ \arr -> | |
| catMaybes <$> forM (V.toList arr) parseAQData | |
| noSSLVerifyManager :: IO Manager | |
| noSSLVerifyManager = let tlsSettings = TLSSettingsSimple { | |
| -- This is where we disable certificate verification | |
| settingDisableCertificateValidation = True, | |
| settingDisableSession=False, | |
| settingUseServerName=True} | |
| in newManager $ mkManagerSettings tlsSettings Nothing | |
| getAQData :: IO [AQData] | |
| getAQData = do | |
| manager <- noSSLVerifyManager | |
| eresponse <- try $ httpJSON $ setRequestManager manager opendata | |
| case eresponse of | |
| Left e -> do | |
| print (e :: HttpException) | |
| getAQData -- retry | |
| Right response -> do | |
| let body = getResponseBody response | |
| return body | |
| where | |
| opendata = "https://opendata.epa.gov.tw/ws/Data/AQI?$format=json" | |
| type Coord = (Double, Double) | |
| distRad :: Double -> Coord -> Coord -> Double | |
| distRad radius (lat1, lng1) (lat2, lng2) = 2 * radius * asin (min 1.0 root) | |
| where | |
| hlat = hsin (lat2 - lat1) | |
| hlng = hsin (lng2 - lng1) | |
| root = sqrt (hlat + cos lat1 * cos lat2 * hlng) | |
| hsin = (^ 2) . sin . (/ 2) -- harvesine of an angle | |
| distDeg :: Double -> Coord -> Coord -> Double | |
| distDeg radius p1 p2 = distRad radius (deg2rad p1) (deg2rad p2) | |
| where | |
| d2r = (/ 180) . (* pi) | |
| deg2rad = bimap d2r d2r | |
| distance :: Coord -> Coord -> Double | |
| distance = distDeg 6371 --earth radius | |
| getCoord :: AQData -> Coord | |
| getCoord AQData{..} = (lat, lng) | |
| closestTo :: [AQData] -> Coord -> AQData | |
| closestTo xs coord = (distance coord . getCoord) `minimumOn` xs | |
| askLoc :: (MonadReader Env m, MonadIO m) => ReplyToken -> m () | |
| askLoc rt = do | |
| Env {token} <- ask | |
| _ <- liftIO $ runLine comp token | |
| return () | |
| where | |
| welcome = "Where are you?" | |
| qr = QuickReply [QuickReplyButton Nothing (ActionLocation "location")] | |
| comp = replyMessage rt [B.MessageText welcome (Just qr)] | |
| addUser :: (MonadReader Env m, MonadIO m) => Source -> Coord -> m () | |
| addUser source coord = do | |
| Env {users} <- ask | |
| liftIO $ atomically $ modifyTVar users ((source, coord) :) | |
| return () | |
| unhealthy :: AQData -> Bool | |
| unhealthy AQData{..} = aqi > 100 | |
| notifyChat :: (Source, AQData) -> Line NoContent | |
| notifyChat (Source a, x) | |
| | unhealthy x = pushMessage a [mkMessage x] | |
| | otherwise = return NoContent | |
| processAQData :: (MonadReader Env m, MonadIO m) => m () | |
| processAQData = do | |
| Env {users, token} <- ask | |
| users' <- liftIO $ atomically $ do | |
| xs <- readTVar users | |
| case xs of | |
| [] -> retry | |
| _ -> return xs | |
| liftIO $ getAQData >>= \aqData -> | |
| let users'' = [(user, aqData `closestTo` coord) | (user, coord) <- users'] | |
| in forM_ users'' $ flip runLine token . notifyChat | |
| return () | |
| loop :: (MonadReader Env m, MonadIO m, MonadBaseControl IO m) => m () | |
| loop = do | |
| fork $ forever $ do | |
| threadDelay (120 * 10^6) | |
| processAQData | |
| return () | |
| webhook :: (MonadReader Env m, MonadIO m) => [Event] -> m NoContent | |
| webhook events = do | |
| forM_ events $ \case | |
| EventFollow {..} -> askLoc replyToken | |
| EventJoin {..} -> askLoc replyToken | |
| EventMessage { message = W.MessageLocation {..} | |
| , source | |
| } -> addUser source (latitude, longitude) | |
| _ -> return () | |
| return NoContent | |
| aqServer :: ServerT Webhook (ReaderT Env Handler) | |
| aqServer = webhook . events | |
| api = Proxy :: Proxy Webhook | |
| pc = Proxy :: Proxy '[ChannelSecret] | |
| app :: MonadReader Env m => m Application | |
| app = ask >>= \env -> | |
| let server = hoistServerWithContext api pc (`runReaderT` env) aqServer | |
| in return $ serveWithContext api (secret env :. EmptyContext) server | |
| main :: IO () | |
| main = do | |
| token <- fromString <$> getEnv "CHANNEL_TOKEN" | |
| secret <- fromString <$> getEnv "CHANNEL_SECRET" | |
| env <- atomically $ Env token secret <$> newTVar [] | |
| liftIO $ runReaderT loop env | |
| runEnv 3000 $ runReader app env | |
| mkMessage :: AQData -> B.Message | |
| mkMessage x = B.MessageFlex "alternate text" (flexContent x) Nothing | |
| flexContent :: AQData -> Value | |
| flexContent AQData{..} = [aesonQQ| | |
| { | |
| "type": "bubble", | |
| "styles": { | |
| "footer": { | |
| "separator": true | |
| } | |
| }, | |
| "header": { | |
| "type": "box", | |
| "layout": "vertical", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "AIR QUALITY ALERT", | |
| "weight": "bold", | |
| "size": "xl", | |
| "color": "#ff0000", | |
| "margin": "md" | |
| }, | |
| { | |
| "type": "text", | |
| "text": "Unhealthy air reported in your area", | |
| "size": "xs", | |
| "color": "#aaaaaa", | |
| "wrap": true | |
| } | |
| ] | |
| }, | |
| "body": { | |
| "type": "box", | |
| "layout": "vertical", | |
| "contents": [ | |
| { | |
| "type": "box", | |
| "layout": "vertical", | |
| "margin": "xxl", | |
| "spacing": "sm", | |
| "contents": [ | |
| { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "County", | |
| "size": "sm", | |
| "color": "#555555", | |
| "flex": 0 | |
| }, | |
| { | |
| "type": "text", | |
| "text": #{county}, | |
| "size": "sm", | |
| "color": "#111111", | |
| "align": "end" | |
| } | |
| ] | |
| }, | |
| { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "Status", | |
| "size": "sm", | |
| "color": "#555555", | |
| "flex": 0 | |
| }, | |
| { | |
| "type": "text", | |
| "text": #{status}, | |
| "size": "sm", | |
| "color": "#111111", | |
| "align": "end" | |
| } | |
| ] | |
| }, | |
| { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "AQI", | |
| "weight": "bold", | |
| "size": "sm", | |
| "color": "#ff0000", | |
| "flex": 0 | |
| }, | |
| { | |
| "type": "text", | |
| "text": #{show aqi}, | |
| "weight": "bold", | |
| "size": "sm", | |
| "color": "#ff0000", | |
| "align": "end" | |
| } | |
| ] | |
| }, | |
| { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "PM2.5", | |
| "size": "sm", | |
| "color": "#555555", | |
| "flex": 0 | |
| }, | |
| { | |
| "type": "text", | |
| "text": #{show pm25}, | |
| "size": "sm", | |
| "color": "#111111", | |
| "align": "end" | |
| } | |
| ] | |
| }, | |
| { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "PM10", | |
| "size": "sm", | |
| "color": "#555555", | |
| "flex": 0 | |
| }, | |
| { | |
| "type": "text", | |
| "text": #{show pm10}, | |
| "size": "sm", | |
| "color": "#111111", | |
| "align": "end" | |
| } | |
| ] | |
| }, | |
| { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "O3", | |
| "size": "sm", | |
| "color": "#555555", | |
| "flex": 0 | |
| }, | |
| { | |
| "type": "text", | |
| "text": #{show o3}, | |
| "size": "sm", | |
| "color": "#111111", | |
| "align": "end" | |
| } | |
| ] | |
| }, | |
| { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "CO", | |
| "size": "sm", | |
| "color": "#555555", | |
| "flex": 0 | |
| }, | |
| { | |
| "type": "text", | |
| "text": #{show co}, | |
| "size": "sm", | |
| "color": "#111111", | |
| "align": "end" | |
| } | |
| ] | |
| }, | |
| { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "text", | |
| "text": "SO2", | |
| "size": "sm", | |
| "color": "#555555", | |
| "flex": 0 | |
| }, | |
| { | |
| "type": "text", | |
| "text": #{show so2}, | |
| "size": "sm", | |
| "color": "#111111", | |
| "align": "end" | |
| } | |
| ] | |
| } | |
| ] | |
| } | |
| ] | |
| }, | |
| "footer": { | |
| "type": "box", | |
| "layout": "horizontal", | |
| "contents": [ | |
| { | |
| "type": "button", | |
| "action": { | |
| "type": "uri", | |
| "label": "More info", | |
| "uri": "https://www.epa.gov.tw/" | |
| } | |
| } | |
| ] | |
| } | |
| } | |
| |] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment