{-# 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