diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,6 @@ +:set -isrc -idist/build/autogen +:set -Wall +:set -XOverloadedStrings +:l HipBot +:m + HipBot +:set prompt ">> " diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,16 @@ +dist +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.virtualenv +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,48 @@ +# From https://github.com/hvr/multi-ghc-travis + +# NB: don't set `language: haskell` here + +# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for. +env: + - CABALVER=1.18 GHCVER=7.6.3 + - CABALVER=1.18 GHCVER=7.8.3 + - CABALVER=1.22 GHCVER=7.10.1 + - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots + +matrix: + allow_failures: + # wreq fails to build on 7.10.1 https://github.com/bos/wreq/issues/61 + - env: CABALVER=1.22 GHCVER=7.10.1 + - env: CABALVER=head GHCVER=head + +# Note: the distinction between `before_install` and `install` is not important. +before_install: + - travis_retry sudo add-apt-repository -y ppa:hvr/ghc + - travis_retry sudo apt-get update + - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + +install: + - cabal --version + - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" + - travis_retry cabal update + - cabal install --only-dependencies --enable-tests --enable-benchmarks + +# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. +script: + - if [ -f configure.ac ]; then autoreconf -i; fi + - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging + - cabal build # this builds all libraries and executables (including tests/benchmarks) + - cabal test + - cabal check + - cabal sdist # tests that a source-distribution can be generated + +# The following scriptlet checks that the resulting source distribution can be built & installed + - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; + cd dist/; + if [ -f "$SRC_TGZ" ]; then + cabal install --force-reinstalls "$SRC_TGZ"; + else + echo "expected '$SRC_TGZ' not found"; + exit 1; + fi diff --git a/HLint.hs b/HLint.hs new file mode 100644 --- /dev/null +++ b/HLint.hs @@ -0,0 +1,5 @@ +import "hint" HLint.Default +import "hint" HLint.Generalise + +ignore "Use import/export shortcut" + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# HipBot [![TravisCI](https://travis-ci.org/purefn/hipbot.svg)](https://travis-ci.org/purefn/hipbot) [![Hackage](https://img.shields.io/hackage/v/hipbot.svg?style=flat)](https://hackage.haskell.org/package/hipbot) [![Dependencies](https://img.shields.io/hackage-deps/v/hipbot.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=hipbot) + +A Haskell library for creating HipChat addons. diff --git a/hipbot.cabal b/hipbot.cabal --- a/hipbot.cabal +++ b/hipbot.cabal @@ -1,5 +1,5 @@ name: hipbot -version: 0.1 +version: 0.2 license: BSD3 license-file: LICENSE author: Richard Wallace @@ -8,11 +8,20 @@ synopsis: A library for building HipChat Bots description: A library for building HipChat Bots category: Web -homepage: https://bitbucket.org/rwallace/hipbot -bug-reports: https://bitbucket.org/rwallace/hipbot/issues +homepage: https://github.com/purefn/hipbot +bug-reports: https://github.com/purefn/hipbot/issues cabal-version: >= 1.8 build-type: Simple +extra-source-files: + .ghci + .gitignore + .travis.yml + HLint.hs + LICENSE + README.md + pg.sql + source-repository head type: git location: https://github.com/purefn/hipbot.git @@ -44,6 +53,8 @@ , lens >=4.5 && <5 , mtl >=2.0.1 && <2.3 , network-uri >=2.4 && <3 + , postgresql-simple >=0.4 && <1 + , safe >=0.2 && <1 , stm >=2.3 && <3 , text >=0.11 && <1.3 , time >=1.4 && <2 diff --git a/pg.sql b/pg.sql new file mode 100644 --- /dev/null +++ b/pg.sql @@ -0,0 +1,9 @@ +CREATE TABLE hipbot ( + oauthId char(36) PRIMARY KEY, + capabilitiesUrl varchar(255) NOT NULL, + roomId integer NOT NULL, + groupId integer NOT NULL, + oauthSecret char(40) NOT NULL, + accessToken char(40) NOT NULL, + accessTokenExpires timestamp NOT NULL +); diff --git a/src/HipBot.hs b/src/HipBot.hs --- a/src/HipBot.hs +++ b/src/HipBot.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module HipBot ( HipBot @@ -21,13 +22,18 @@ import Data.Aeson ((.=)) 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 Data.Text (Text) 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 Safe import HipBot.API import HipBot.Internal.HipBot @@ -38,6 +44,9 @@ data NotificationError = NoSuchRegistration OAuthId | TokenError OAuthError + | RateLimitExceeded (Maybe UTCTime) + | HttpError HttpException + deriving Show sendNotification :: (Applicative m, MonadCatch m, MonadIO m) @@ -46,49 +55,80 @@ -> Either RoomName RoomId -> Notification -> m (Maybe NotificationError) -sendNotification bot oid room n = getToken bot oid >>= either (return . Just) send where - -- TODO handle failures posting, right now an exception is thrown for non-2xx responses - -- we should turn those into more specific errors, e.g. RateLimitExceeded - send (reg, tok) = Nothing <$ liftIO (Wreq.postWith (opts tok) (notificationUrl room reg) msg) - opts tok = wreqDefaults bot - & Wreq.header hAuthorization .~ [("Bearer " <>) . T.encodeUtf8 . view accessToken $ tok] - & Wreq.header hContentType .~ ["application/json"] - msg = case n of - TextNotification t -> A.object - [ "message_format" .= ("text" :: Text) - , "message" .= t - ] - HtmlNotification t -> A.object - [ "message_format" .= ("html" :: Text) - , "message" .= t - ] +sendNotification bot oid room n = + let + msg = case n of + TextNotification t -> A.object + [ "message_format" .= ("text" :: Text) + , "message" .= t + ] + HtmlNotification t -> A.object + [ "message_format" .= ("html" :: Text) + , "message" .= t + ] + 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 - -> m (Either NotificationError (Registration, AccessToken)) -getToken bot oid = runEitherT (lookupReg >>= fetch) where + -> 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 - tok' <- if now > addUTCTime 300 (tok ^. expires) - then right tok - else do - tok' <- EitherT . - fmap (first TokenError) . - obtainAccessToken bot $ - reg - lift . apiUpdateAccessToken (bot ^. hipBotAPI) oid $ tok' - return tok' - return (reg, tok') + -- TODO get rid of this once confident the check is correct + liftIO $ print $ mconcat + [ "OAuthToken: expires=" + , show $ tok ^. expires + , ", now=" + , show now + ] + if addUTCTime 300 now < tok ^. expires + then right (reg, tok) + else updatedToken bot reg <&> (reg,) -notificationUrl :: Either RoomName RoomId -> Registration -> String -notificationUrl room = - show . - relativeTo ["room", either id (T.pack . show) room, "notification"] . - view capabilitiesUrl +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 diff --git a/src/HipBot/API.hs b/src/HipBot/API.hs --- a/src/HipBot/API.hs +++ b/src/HipBot/API.hs @@ -4,12 +4,25 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -module HipBot.API where +module HipBot.API + ( HipBotAPI(..) + , HasHipBotAPI(hipBotAPI) + , stmAPI + , pgAPI + ) where +import Control.Applicative import Control.Concurrent.STM import Control.Lens +import Control.Monad import Control.Monad.IO.Class +import qualified Data.ByteString.UTF8 as B import qualified Data.HashMap.Strict as HashMap +import Data.Monoid +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow +import Safe import HipBot.Internal.Types @@ -49,4 +62,53 @@ HashMap.adjust (set _2 t) $ oid } + +pgAPI :: MonadIO m => Connection -> HipBotAPI m +pgAPI conn = HipBotAPI + { apiInsertRegistration = \r t -> + let + stmt = "insert into hipbot (" <> pgFields <> ") values (?, ?, ?, ?, ?, ?, ?)" + row = + ( r ^. oauthId + , r ^. capabilitiesUrl . to show + , r ^. roomId + , r ^. groupId + , r ^. oauthSecret + , t ^. accessToken + , t ^. expires + ) + in + liftIO . void . execute conn stmt $ row + , apiDeleteRegistration = + let stmt = "delete from hipbot where oauthId = ?" + in liftIO . void . execute conn stmt . Only + , apiLookupRegistration = + let q = "select " <> pgFields <> " from hipbot where oauthId = ?" + in liftIO . fmap (fmap getRegRow . headMay) . query conn q . Only + , apiUpdateAccessToken = \oid t -> + let + stmt = "update hipbot set accessToken = ?, accessTokenExpires = ? where oauthId = ?" + ps = (t ^. accessToken, t ^. expires, oid) + in + liftIO . void . execute conn stmt $ ps + } + +pgFields :: Query +pgFields = "oauthId, capabilitiesUrl, roomId, groupId, oauthSecret, accessToken, accessTokenExpires" + +newtype RegRow = RegRow { getRegRow :: (Registration, AccessToken) } + +instance FromRow RegRow where + fromRow = (RegRow .) . (,) <$> reg <*> tok where + reg = Registration + <$> field + <*> fieldWith parseUri + <*> field + <*> field + <*> field + tok = AccessToken <$> field <*> field + parseUri f = maybe err parse where + err = returnError UnexpectedNull f "" + parse = maybe err' return . parseAbsoluteURI . B.toString where + err' = returnError ConversionFailed f "not an absolute URI" diff --git a/src/HipBot/Internal/OAuth.hs b/src/HipBot/Internal/OAuth.hs --- a/src/HipBot/Internal/OAuth.hs +++ b/src/HipBot/Internal/OAuth.hs @@ -35,6 +35,9 @@ | ParseAccessTokenError Registration AbsoluteURI Wreq.JSONError | InvalidOAuthCreds Registration +instance Show OAuthError where + show = showOAuthError + showOAuthError :: OAuthError -> String showOAuthError = \case MissingAccessTokenUrl r -> mconcat @@ -138,7 +141,20 @@ <*> o .: "expires_in" resolveExpiresIn :: HCAccessToken -> IO AccessToken -resolveExpiresIn t = resolve <$> getCurrentTime where - resolve = AccessToken (_hcAccessToken t) . addUTCTime diff - diff = realToFrac . _hcExpiresIn $ t +resolveExpiresIn t = do + now <- getCurrentTime + let + diff = realToFrac . _hcExpiresIn $ t + expiring = addUTCTime diff now + -- TODO get rid of this once confident the timing is right + print $ mconcat + [ "OAuthToken: expires_in=" + , show (_hcExpiresIn t) + , ", now=" + , show now + , ", expiring=" + , show expiring + ] + return $ AccessToken (_hcAccessToken t) expiring + diff --git a/src/HipBot/Internal/Types.hs b/src/HipBot/Internal/Types.hs --- a/src/HipBot/Internal/Types.hs +++ b/src/HipBot/Internal/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -23,12 +24,13 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock +import Data.Typeable import Network.HTTP.Types import Network.URI (URI) import qualified Network.URI as URI newtype AbsoluteURI = AbsoluteURI URI - deriving Eq + deriving (Eq, Typeable) parseAbsoluteURI :: String -> Maybe AbsoluteURI parseAbsoluteURI = fmap AbsoluteURI . URI.parseAbsoluteURI