hipbot 0.1 → 0.2

raw patch · 11 files changed

+259/−41 lines, 11 filesdep +postgresql-simpledep +safePVP ok

version bump matches the API change (PVP)

Dependencies added: postgresql-simple, safe

API changes (from Hackage documentation)

Files

• .ghci +6/−0
• .gitignore +16/−0
• .travis.yml +48/−0
• HLint.hs +5/−0
• README.md +3/−0
• hipbot.cabal +14/−3
• pg.sql +9/−0
• src/HipBot.hs +73/−33
• src/HipBot/API.hs +63/−1
• src/HipBot/Internal/OAuth.hs +19/−3
• src/HipBot/Internal/Types.hs +3/−1

@@ -0,0 +1,6 @@+:set -isrc -idist/build/autogen+:set -Wall+:set -XOverloadedStrings+:l HipBot+:m + HipBot+:set prompt ">> "

@@ -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

@@ -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

@@ -0,0 +1,5 @@+import "hint" HLint.Default+import "hint" HLint.Generalise++ignore "Use import/export shortcut"+

@@ -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.

@@ -1,5 +1,5 @@ name:               hipbot-version:            0.1+version:            0.2 license:            BSD3 license-file:       LICENSE author:             Richard Wallace <rwallace@atlassian.com>@@ -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

@@ -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+);

@@ -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 

@@ -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" 

@@ -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+ 

@@ -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