module HipBot
( HipBot
, HipBotAPI(..)
, OnUninstall
, OAuthId
, RoomName
, RoomId
, RoomEvent(..)
, newHipBot
, newHipBot'
, hipBotResources
, configResource
, verifySignature
, sendNotification
, module HipBot.AbsoluteURI
, module HipBot.Descriptor
, module HipBot.Notification
) where
import Control.Applicative
import Control.Lens hiding ((.=))
import Control.Monad.Catch
import Control.Monad.Trans
import Control.Monad.Trans.Either
import qualified Data.Aeson as A
import Data.Bifunctor
import qualified Data.ByteString.UTF8 as B
import qualified Data.List as List
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Network.HTTP.Client
import Network.HTTP.Types
import qualified Network.Wreq as Wreq
import Prelude
import Safe
import HipBot.AbsoluteURI
import HipBot.API
import HipBot.Descriptor
import HipBot.Internal.HipBot
import HipBot.Internal.OAuth
import HipBot.Internal.Resources
import HipBot.Internal.Types
import HipBot.Notification
data NotificationError
= NoSuchRegistration OAuthId
| TokenError OAuthError
| RateLimitExceeded (Maybe UTCTime)
| HttpError HttpException
deriving Show
sendNotification
:: (Applicative m, MonadCatch m, MonadIO m)
=> HipBot m
-> OAuthId
-> Either RoomName RoomId
-> Notification
-> m (Maybe NotificationError)
sendNotification bot oid room n =
let
msg = A.encode n
opts tok = wreqDefaults bot
& Wreq.header hAuthorization .~
[("Bearer " <>) . T.encodeUtf8 . view accessToken $ tok]
& Wreq.header hContentType .~ ["application/json"]
nurl = show .
relativeTo ["room", either id (T.pack . show) room, "notification"] .
view capabilitiesUrl
send reg tok = Nothing <$ Wreq.postWith (opts tok) (nurl reg) msg
trySend reg tok onAuthErr = liftIO (send reg tok) `catch` handler onAuthErr
handler onAuthErr e = case e of
StatusCodeException s hdrs _
| s == unauthorized401 -> onAuthErr
| s ^. Wreq.statusCode == 429 ->
return . Just . RateLimitExceeded . rateLimitReset $ hdrs
httpExc -> return . Just . HttpError $ httpExc
reauth reg = updatedToken bot reg >>= \tok -> trySend reg tok (authFailed reg)
authFailed = return . Just . TokenError . InvalidOAuthCreds
firstTry = getToken bot oid >>= \(reg, tok) -> trySend reg tok (reauth reg)
in
either Just id <$> runEitherT firstTry
rateLimitReset :: ResponseHeaders -> Maybe UTCTime
rateLimitReset =
let
hdr = List.find ((==) "X-RateLimit-Reset" . fst)
readMayInt :: (HeaderName, B.ByteString) -> Maybe Int
readMayInt = readMay . B.toString . snd
in
fmap (posixSecondsToUTCTime . realToFrac) . (readMayInt =<<) . hdr
getToken
:: (Applicative m, MonadCatch m, MonadIO m)
=> HipBot m
-> OAuthId
-> EitherT NotificationError m (Registration, AccessToken)
getToken bot oid = lookupReg >>= fetch where
lookupReg = EitherT .
fmap (maybe (Left . NoSuchRegistration $ oid) Right) .
apiLookupRegistration (view hipBotAPI bot) $
oid
fetch (reg, tok) = do
now <- liftIO getCurrentTime
if addUTCTime 300 now < tok ^. expires
then right (reg, tok)
else updatedToken bot reg <&> (reg,)
updatedToken
:: (MonadCatch m, MonadIO m, Applicative m)
=> HipBot m
-> Registration
-> EitherT NotificationError m AccessToken
updatedToken bot reg = do
tok <- EitherT .
fmap (first TokenError) .
obtainAccessToken bot $
reg
lift . apiUpdateAccessToken (bot ^. hipBotAPI) (reg ^. oauthId) $ tok
return tok