packages feed

pusher-haskell (empty) → 0.1.0.0

raw patch · 8 files changed

+323/−0 lines, 8 filesdep +HTTPdep +MissingHdep +SHAsetup-changed

Dependencies added: HTTP, MissingH, SHA, aeson, base, bytestring, hspec, mtl, pusher-haskell, time

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Sid Raval++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pusher-haskell.cabal view
@@ -0,0 +1,42 @@+name:                pusher-haskell+version:             0.1.0.0+synopsis:            A Pusher.com client written in Haskell+description:         A server-side client for interacting with Pusher.com+homepage:            http://www.github.com/sidraval/pusher-haskell+license:             MIT+license-file:        LICENSE+author:              Sid Raval+maintainer:          sidsraval@gmail.com+category:            Web+build-type:          Simple+cabal-version:       >=1.10+source-repository head+  type: git+  location: https://github.com/sidraval/pusher-haskell.git++library+  exposed-modules:+    Network.Pusher,+    Network.Pusher.Base,+    Network.Pusher.Event,+    Network.Pusher.Channel+  build-depends:+    base >=4.7 && <4.8,+    aeson >= 0.8.0.2,+    HTTP >= 4000.2.19,+    SHA  >= 1.6.4.1,+    MissingH >= 1.3.0.1,+    mtl >= 2.2.1,+    bytestring >= 0.10.4.0,+    time >= 1.4.2+  hs-source-dirs:      src+  default-language:    Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  build-depends:+    base >=4.7 && <4.8,+    hspec >= 2.1.4,+    pusher-haskell
+ src/Network/Pusher.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Network.Pusher where++import Network.Pusher.Base+import Network.Pusher.Event+import Network.Pusher.Channel
+ src/Network/Pusher/Base.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Pusher.Base where++import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.Time.Clock.POSIX++data Pusher = Pusher { pusherAppId :: String+                     , pusherAppKey :: String+                     , pusherAppSecret :: String }++data Event = Event { eventName :: String+                   , eventData :: String }++data ChannelInfo = ChannelInfo { occupied :: Bool+                               , userCount :: Maybe Int+                               , subscriptionCount :: Maybe Int+                               } deriving Show++data Info = UserCount | SubscriptionCount++instance Show Info where+  show UserCount = "user_count"+  show SubscriptionCount = "subscription_count"++instance FromJSON ChannelInfo where+  parseJSON (Object v) = ChannelInfo <$>+                         v .: "occupied" <*>+                         v .:? "user_count" <*>+                         v .:? "subscription_count"+  parseJSON _ = mzero++type Channel = String+type Channels = [Channel]+type Timestamp = IO String+type Md5Body = String++authTimestamp :: Timestamp+authTimestamp = show <$> round <$> getPOSIXTime++baseUrl :: Pusher -> String+baseUrl (Pusher appId _ _) = "http://api.pusherapp.com/apps/" ++ appId++contentType :: String+contentType = "application/json"
+ src/Network/Pusher/Channel.hs view
@@ -0,0 +1,96 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.Pusher.Channel+-- Copyright   :  See LICENSE file+-- License     :  BSD+--+-- Maintainer  :  Sid Raval <sidsraval@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- The 'Network.Pusher.Channel' module provides an simple interface for interacting+-- with Pusher.com's @channel@ endpoints. In particular, one can fetch info+-- about every occupied channel for a given App ID, or more detailed information+-- about a channel specified by name.+-----------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module Network.Pusher.Channel (getChannelInfo) where++import Network.HTTP+import Control.Applicative+import Control.Monad+import Control.Monad.Reader+import Data.Aeson+import Data.Digest.Pure.SHA+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Hash.MD5+import Data.List+import Network.Pusher.Base++type Environment = (Pusher, Channel, [Info])++-- | @getChannelInfo (pusher, channel, info)@ requests information about a+-- particular channel for the given 'Pusher' instance. The result is either an+-- error message returned by the Pusher server, or a 'ChannelInfo' data+-- structure.++getChannelInfo :: (Pusher, Channel, [Info]) -> IO (Either String ChannelInfo)+getChannelInfo = runReaderT channelInfo++channelInfo :: ReaderT Environment IO (Either String ChannelInfo)+channelInfo = do+  (p, c, is) <- ask+  response <- liftIO . simpleHTTP . getRequest =<< generateUrl+  body <- liftIO $ getResponseBody response+  case (decode . B.pack $ body) of+    (Just c) -> return $ Right c+    Nothing -> return $ Left body++generateUrl :: ReaderT Environment IO String+generateUrl = do+  let timestamp = authTimestamp+  (p, c, is) <- ask+  withoutSignature <- urlWithoutSignature timestamp+  (++) (withoutSignature ++ "&auth_signature=")+    <$> signedAuthString timestamp++urlWithoutSignature :: Timestamp -> ReaderT Environment IO String+urlWithoutSignature t = do+  (p@(Pusher _ k _), c, is) <- ask+  liftIO $ ((++) (baseUrl p+      ++ "/channels/"+      ++ c+      ++ "?auth_version=1.0"+      ++ "&auth_key="+      ++  k+      ++ queryParamFromInfo is+      ++ "&auth_timestamp=")) <$> t++signedAuthString :: Timestamp -> ReaderT Environment IO String+signedAuthString t = do+  (p@(Pusher _ _ appSecret), c, is) <- ask+  signatureString <- unsignedAuthString t >>= return . B.pack+  return . showDigest $ hmacSha256 (B.pack appSecret) signatureString++unsignedAuthString :: Timestamp -> ReaderT Environment IO String+unsignedAuthString t = do+  (p@(Pusher appId appKey _), c, is) <- ask+  liftIO $ idKeyAndTimestamp appId appKey c+    <$> t+    >>= (\u -> return $ u ++ "&auth_version=1.0" ++ queryParamFromInfo is)++queryParamFromInfo :: [Info] -> String+queryParamFromInfo [] = mzero+queryParamFromInfo xs = "&info=" ++ (intercalate "," $ map show xs)++idKeyAndTimestamp :: String -> String -> Channel -> String -> String+idKeyAndTimestamp i k c t = "GET\n/apps/"+                            ++ i+                            ++ "/channels/"+                            ++ c+                            ++ "\nauth_key="+                            ++ k+                            ++ "&auth_timestamp="+                            ++ t
+ src/Network/Pusher/Event.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.Pusher.Event+-- Copyright   :  See LICENSE file+-- License     :  BSD+--+-- Maintainer  :  Sid Raval <sidsraval@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- The 'Network.Pusher.Event' module provides an simple interface for interacting+-- with Pusher.com's @event@ endpoints. This is used for trigger an event on one+-- or more channels with arbitrary data.+-----------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module Network.Pusher.Event (triggerEvent, triggerMultiChannelEvent) where++import Network.HTTP+import Control.Applicative+import Control.Monad+import Control.Monad.Reader+import Data.Aeson.Encode (encode)+import Data.Digest.Pure.SHA+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Hash.MD5+import Network.Pusher.Base++type Environment = (Pusher, String, Event)++-- | @triggerEvent (pusher, channel, event)@ sends an event to one+-- channel for the given 'Pusher' instance. The result is the response body+-- from the Pusher server.+triggerEvent :: (Pusher, Channel, Event) -> IO String+triggerEvent (p, c, e) = runReaderT event (p, requestBody c e, e)++-- | @triggerMultiChannelEvent (pusher, channels, event)@ sends an event to multiple+-- channels for the given 'Pusher' instance. The result is the response body+-- from the Pusher server.+triggerMultiChannelEvent :: (Pusher, String, Event) -> IO String+triggerMultiChannelEvent (p, cs, e) = runReaderT event (p, requestMultiChannelBody cs e, e)++event :: ReaderT Environment IO String+event = do+  (p, b, e) <- ask+  url <- generateUrl+  response <- liftIO . simpleHTTP $ postRequestWithBody url contentType b+  liftIO $ getResponseBody response++generateUrl :: ReaderT Environment IO String+generateUrl = do+  (p, b, e) <- ask+  let md5body = md5s . Str $ b+  let timestamp = authTimestamp+  withoutSignature <- urlWithoutSignature md5body timestamp+  (++) (withoutSignature  ++ "&auth_signature=")+    <$> signedAuthString timestamp md5body++urlWithoutSignature :: Md5Body -> Timestamp -> ReaderT Environment IO String+urlWithoutSignature b t = do+  (p@(Pusher _ k _), _, _) <- ask+  liftIO $ ((++) (baseUrl p+             ++ "/events?body_md5="+             ++ b+             ++ "&auth_version=1.0&auth_key="+             ++ k+             ++ "&auth_timestamp=")) <$> t++signedAuthString :: Timestamp -> Md5Body -> ReaderT Environment IO String+signedAuthString t b = do+  (p@(Pusher _ _ appSecret), _, _) <- ask+  signatureString <- unsignedAuthString t b >>= return . B.pack+  return . showDigest $ hmacSha256 (B.pack appSecret) signatureString++unsignedAuthString :: Timestamp -> Md5Body -> ReaderT Environment IO String+unsignedAuthString t b = do+  (p@(Pusher appId appKey _), _, _) <- ask+  liftIO $ idKeyAndTimestamp appId appKey+    <$> t+    >>= (\u -> return $ u ++ "&auth_version=1.0&body_md5=" ++ b)++requestBody c e = "{\"name\": \""+                ++ (eventName e)+                  ++ "\", \"channel\": \""+                  ++ c+                  ++ "\", \"data\":"+                  ++ (B.unpack . encode . eventData $ e)+                  ++ "}"++requestMultiChannelBody cs e = "{\"name\": \""+                             ++ (eventName e)+                             ++ "\", \"channels\": "+                             ++ show cs+                             ++ ", \"data\":"+                             ++ (B.unpack . encode . eventData $ e)+                             ++ "}"++-- Helper for unsignedAuthString+idKeyAndTimestamp :: String -> String -> String -> String+idKeyAndTimestamp i k t = "POST\n/apps/"+                          ++ i+                          ++ "/events\nauth_key="+                          ++ k+                          ++ "&auth_timestamp="+                          ++ t
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}