Skip to content

Instantly share code, notes, and snippets.

@moleike

moleike/AQI.hs

Last active May 27, 2019 03:10
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save moleike/eb28b363ba7fb9478c9045036460fdd7 to your computer and use it in GitHub Desktop.
Save moleike/eb28b363ba7fb9478c9045036460fdd7 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
AQI.hs
{-# 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