This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# 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