pubnub (empty) → 0.1.0.0
raw patch · 8 files changed
+698/−0 lines, 8 filesdep +Cabaldep +HUnitdep +QuickChecksetup-changed
Dependencies added: Cabal, HUnit, QuickCheck, SHA, aeson, async, base, base64-bytestring, bytestring, cipher-aes, conduit, crypto-api, crypto-cipher-types, data-default, http-client, http-conduit, http-types, lifted-base, mtl, pubnub, smallcheck, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, text, transformers, uuid, vector
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- examples/Chat/Main.hs +98/−0
- examples/HelloWorld/Main.hs +25/−0
- pubnub.cabal +97/−0
- src/Network/Pubnub.hs +236/−0
- src/Network/Pubnub/Types.hs +200/−0
- test/Test.hs +13/−0
+ LICENSE view
@@ -0,0 +1,27 @@+PubNub Real-time Cloud-Hosted Push API and Push Notification Client Frameworks+Copyright (c) 2013 PubNub Inc.+http://www.pubnub.com/+http://www.pubnub.com/terms++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.++PubNub Real-time Cloud-Hosted Push API and Push Notification Client Frameworks+Copyright (c) 2013 PubNub Inc.+http://www.pubnub.com/+http://www.pubnub.com/terms
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Chat/Main.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Network.Pubnub+import Network.Pubnub.Types++import GHC.Generics+import Data.Aeson++import Control.Concurrent.Async+import Control.Monad+import qualified Data.Text.IO as I+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as L++data Msg = Msg { username :: T.Text+ , msg :: T.Text }+ deriving (Show, Generic)++instance ToJSON Msg++instance FromJSON Msg++type ClientName = T.Text++data Client = Client { clientName :: ClientName+ , pn :: PN }++main :: IO ()+main = do+ putStrLn "Enter Username: "+ username <- I.getLine+ runClient $ newClient username True++newClient :: ClientName -> Bool -> Client+newClient name encrypt+ | encrypt = either (error . show) (\x -> Client { clientName = name+ , pn = x}) encKey+ | otherwise = Client { clientName = name+ , pn = newPN}+ where+ encKey = setEncryptionKey newPN "enigma"++ newPN = defaultPN { channels = ["testchathaskell2"]+ , sub_key = "demo"+ , pub_key = "demo"+ , ssl = False }++runClient :: Client -> IO ()+runClient Client{..} = do+ a <- receiver+ withAsync (cli a) $ \b -> do+ _ <- waitAnyCancel [a, b]+ return ()+ where+ cli a = forever $ do+ msg <- I.getLine+ case msg of+ "/leave" -> do+ leave pn (head $ channels pn) clientName+ unsubscribe a+ mzero+ _ ->+ publish pn (head $ channels pn) Msg { username=clientName+ , msg=msg }++ receiver =+ subscribe pn defaultSubscribeOptions{ uid = Just clientName++ , onPresence = Just outputPresence+ , onMsg = output+ , onConnect = putStrLn "Connected..." }++outputPresence :: Presence -> IO ()+outputPresence Presence{..} = do+ I.putStr "** "+ I.putStr uuid+ case action of+ Join ->+ putStrLn " has joined channel"+ Leave ->+ putStrLn " has left channel"+ Timeout ->+ putStrLn " has dropped from channel"++output :: Maybe Msg -> IO ()+output (Just m) =+ I.putStrLn $ T.concat ["<", username m, "> : ", msg m]+output Nothing = return ()++encodeMsg :: Msg -> L.ByteString+encodeMsg = encode++decodeMsg :: L.ByteString -> Maybe [Msg]+decodeMsg = decode
+ examples/HelloWorld/Main.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Network.Pubnub+import Network.Pubnub.Types+import Data.Aeson+import Control.Concurrent+import qualified Data.Text as T++main :: IO ()+main = do+ let pn = defaultPN{channels=["hello_world"], sub_key="demo", pub_key="demo"}+ _ <- subscribe pn defaultSubscribeOptions{ onMsg = output+ , onConnect = putStrLn "Connected..." }+ _ <- threadDelay 1000000+ hello <- publish pn "hello_world" ("hello" :: T.Text)+ print hello+ hello2 <- history pn "hello_world" [ Reverse True+ , Count 2] :: IO (Maybe (History Value))+ print hello2+ return ()++output :: Maybe Value -> IO ()+output = print
+ pubnub.cabal view
@@ -0,0 +1,97 @@+-- Initial pubnub.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/++name: pubnub+version: 0.1.0.0+synopsis: PubNub Haskell SDK+-- description:+homepage: http://github.com/pubnub/haskell+license: MIT+license-file: LICENSE+author: Tristan Sloughter+maintainer: t@crashfast.com+-- copyright:+category: Cloud, API+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Network.Pubnub, Network.Pubnub.Types+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.6 && <4.7+ , aeson >= 0.7.0.0+ , http-conduit >= 2.0.0.3+ , http-client >= 0.2.0.3+ , conduit >= 1.0.9.3+ , bytestring >= 0.10.0.2+ , transformers >= 0.3.0.0+ , vector >= 0.10.9.1+ , text >= 0.11.1+ , lifted-base >= 0.2.1.1+ , mtl >= 2.1.2+ , http-types >= 0.8.3+ , uuid >= 1.3.3+ , async >= 2.0.1.4+ , data-default+ , SHA >= 1.6.1+ , cipher-aes >= 0.2.6+ , crypto-api >= 0.12.2.2+ , crypto-cipher-types >= 0.0.9+ , base64-bytestring >= 1.0.0.1+ ghc-options: -Wall+ hs-source-dirs: src+ default-language: Haskell2010++executable hello_world+ hs-source-dirs: examples/HelloWorld+ ghc-options: -Wall+ main-is: Main.hs+ default-language: Haskell2010+ build-depends: base ==4.6.*, Cabal >= 1.16.0+ , pubnub+ , aeson >= 0.6.2.1+ , text >= 0.11.1++executable chat+ hs-source-dirs: examples/Chat+ ghc-options: -Wall+ main-is: Main.hs+ default-language: Haskell2010+ build-depends: base ==4.6.*, Cabal >= 1.16.0+ , aeson >= 0.6.2.1+ , bytestring >= 0.10.0.2+ , async >= 2.0.1.4+ , pubnub >= 0.1.0.0+ , text >= 0.11.1++executable test-pubnub-haskell+ hs-source-dirs: test+ ghc-options: -Wall+ main-is: Test.hs+ default-language: Haskell2010+ build-depends: base ==4.6.*, Cabal >= 1.16.0+ , pubnub+ , HUnit+ , QuickCheck+ , smallcheck+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , tasty-smallcheck+test-suite Tests+ hs-source-dirs: test+ ghc-options: -Wall+ main-is: Test.hs+ Type: exitcode-stdio-1.0+ default-language: Haskell2010+ build-depends: base ==4.6.*, Cabal >= 1.16.0+ , pubnub+ , HUnit+ , QuickCheck+ , smallcheck+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , tasty-smallcheck
+ src/Network/Pubnub.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Pubnub+ (+ PN(..)+ , defaultPN+ , Timestamp(..)++ -- API function+ , time+ , publish+ , subscribe+ , hereNow+ , presence+ , history+ , leave+ , getUuid+ , unsubscribe+ ) where++import Network.Pubnub.Types++import Data.Default (def)+import Data.Aeson+import Data.UUID.V4+import Network.HTTP.Conduit+import Network.HTTP.Types+import Control.Monad.Trans+import Control.Concurrent.Async+import Control.Applicative ((<$>))+import Control.Exception.Lifted (try)+import Data.Text.Encoding+import Data.Maybe++import Data.Digest.Pure.SHA+import Crypto.Cipher.AES+import Crypto.Padding++import qualified Data.Text as T+import qualified Data.UUID as U+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Base64 as B64++time :: IO (Maybe Timestamp)+time = do+ let req = buildRequest defaultPN ["time", "0"] [] Nothing+ res <- withManager $ httpLbs req+ return (decode $ responseBody res :: Maybe Timestamp)++subscribe :: (FromJSON b) => PN -> SubscribeOptions b -> IO (Async ())+subscribe pn subOpts =+ case onPresence subOpts of+ Nothing -> subscribeInternal pn subOpts+ Just onPresenceCallback ->+ case uid subOpts of+ Nothing -> getUuid >>= \u -> subscribe' subOpts{uid = Just u}+ _ -> subscribe' subOpts+ where+ subscribe' subOpts' =+ do+ a <- presence pn (uid subOpts') onPresenceCallback+ b <- subscribeInternal pn subOpts'+ link2 a b+ return a++subscribeInternal :: (FromJSON b) => PN -> SubscribeOptions b -> IO (Async ())+subscribeInternal pn subOpts =+ async (withManager $ \manager -> lift $ connect pn{time_token = Timestamp 0} manager False)+ where+ connect pn' manager isReconnect = do+ let req = buildSubscribeRequest pn' "0"+ eres <- try $ httpLbs req manager :: IO (Either HttpException (Response L.ByteString))+ case eres of+ Right res ->+ case decode $ responseBody res of+ Just (ConnectResponse ([], t)) -> do+ liftIO (if isReconnect+ then onReconnect subOpts+ else onConnect subOpts)+ subscribe' manager (if resumeOnReconnect subOpts && isReconnect+ then pn+ else pn{time_token=t})+ _ -> do+ liftIO (onDisconnect subOpts)+ subscribe' manager pn+ Left (StatusCodeException (Status code msg) _ _) -> do+ liftIO $ onError subOpts (Just code) (Just msg)+ connect pn' manager isReconnect+ Left _ -> do+ liftIO $ onError subOpts Nothing Nothing+ connect pn' manager isReconnect++ subscribe' manager pn' = do+ let req = buildSubscribeRequest pn' $ head . L.toChunks $ encode (time_token pn')+ eres <- try $ httpLbs req manager :: IO (Either HttpException (Response L.ByteString))+ case eres of+ Right r ->+ case (ctx pn', iv pn') of+ (Just c, Just i) ->+ case decode $ responseBody r of+ Just (EncryptedSubscribeResponse (resp, t)) -> do+ _ <- liftIO $ mapM (onMsg subOpts . decodeEncrypted c i) resp+ subscribe' manager (pn' { time_token=t })+ Nothing ->+ subscribe' manager pn'+ (_, _) ->+ case decode $ responseBody r of+ Just (SubscribeResponse (resp, t)) -> do+ _ <- liftIO $ mapM (onMsg subOpts) resp+ subscribe' manager (pn' { time_token=t })+ Nothing ->+ subscribe' manager pn'+ Left (ResponseTimeout :: HttpException) ->+ subscribe' manager pn'+ Left (StatusCodeException (Status code msg) _ _) -> do+ liftIO $ onError subOpts (Just code) (Just msg)+ reconnect pn' manager+ Left _ -> do+ liftIO $ onError subOpts Nothing Nothing+ reconnect pn' manager++ reconnect pn' manager = connect pn' manager True++ buildSubscribeRequest pn' tt =+ buildRequest pn' [ "subscribe"+ , encodeUtf8 $ sub_key pn'+ , encodeUtf8 $ T.intercalate "," (channels pn')+ , bsFromInteger $ jsonp_callback pn'+ , tt ]+ (maybe [] (\u -> [("uuid", encodeUtf8 u)]) (uid subOpts))+ (subTimeout subOpts)++ decodeEncrypted c i m = decodeUnencrypted $ decrypt c i m++ decodeUnencrypted :: (FromJSON b) => B.ByteString -> b+ decodeUnencrypted m = fromJust $ decode $ L.fromStrict m++ decrypt c i m = unpadPKCS5 $ decryptCBC c i $ B64.decodeLenient $ decodeJson m++ decodeJson :: T.Text -> B.ByteString+ decodeJson s = case decode (L.fromStrict (encodeUtf8 s)) of+ Nothing -> encodeUtf8 s+ Just l -> encodeUtf8 l++publish :: ToJSON a => PN -> T.Text -> a -> IO (Maybe PublishResponse)+publish pn channel msg = do+ let encoded_msg = head . L.toChunks $ encode msg+ let sig = signature (sec_key pn) encoded_msg+ let req = buildRequest pn [ "publish"+ , encodeUtf8 $ pub_key pn+ , encodeUtf8 $ sub_key pn+ , sig+ , encodeUtf8 channel+ , bsFromInteger $ jsonp_callback pn+ , encrypt (ctx pn) (iv pn) encoded_msg] [] Nothing+ res <- withManager $ httpLbs req+ return (decode $ responseBody res)+ where+ signature "0" _ = "0"+ signature secret m = B.pack $ showDigest $ hmacSha256 (L.fromStrict $ encodeUtf8 secret) (L.fromStrict m)++ encrypt (Just c) (Just i) m = encodeJson $ B64.encode $ encryptCBC c i (padPKCS5 16 m)+ encrypt Nothing _ m = m+ encrypt _ Nothing m = m++ encodeJson s = L.toStrict $ encode (decodeUtf8 s)++hereNow :: PN -> T.Text -> IO (Maybe HereNow)+hereNow pn channel = do+ let req = buildRequest pn [ "v2"+ , "presence"+ , "sub-key"+ , encodeUtf8 $ sub_key pn+ , "channel"+ , encodeUtf8 channel] [] Nothing+ res <- withManager $ httpLbs req+ return (decode $ responseBody res)++presence :: (FromJSON b) => PN -> Maybe UUID -> (b -> IO ()) -> IO (Async ())+presence pn u fn =+ let subOpts = defaultSubscribeOptions{ onMsg = fn+ , uid = u }+ pn' = pn { ctx=Nothing, channels=presence_channels }+ in+ subscribeInternal pn' subOpts+ where+ presence_channels = map (prepend "-pnpres") (channels pn)+ prepend = flip T.append++history :: FromJSON b => PN -> T.Text -> HistoryOptions -> IO (Maybe (History b))+history pn channel options = do+ let req = buildRequest pn [ "v2"+ , "history"+ , "sub-key"+ , encodeUtf8 $ sub_key pn+ , "channel"+ , encodeUtf8 channel] (convertHistoryOptions options) Nothing+ res <- withManager $ httpLbs req+ return (decode $ responseBody res)++leave :: PN -> T.Text -> UUID -> IO ()+leave pn channel u = do+ let req = buildRequest pn [ "v2"+ , "presence"+ , "sub-key"+ , encodeUtf8 $ sub_key pn+ , "channel"+ , encodeUtf8 channel+ , "leave"] [("uuid", encodeUtf8 u)] Nothing+ _ <- withManager $ httpLbs req+ return ()++getUuid :: IO UUID+getUuid =+ T.pack . U.toString <$> nextRandom++unsubscribe :: Async () -> IO ()+unsubscribe = cancel++buildRequest :: PN -> [B.ByteString] -> SimpleQuery -> Maybe Int -> Request+buildRequest pn elems qs timeout =+ def { host = encodeUtf8 $ origin pn+ , path = B.intercalate "/" elems+ , method = "GET"+ , port = if ssl pn then 443 else 80+ , requestHeaders = [ ("V", "3.1")+ , ("User-Agent", "Haskell")+ , ("Accept", "*/*")]+ , queryString = renderSimpleQuery True qs+ , secure = ssl pn+ , responseTimeout = Just (maybe 5000000 (* 1000000) timeout) }++bsFromInteger :: Integer -> B.ByteString+bsFromInteger = B.pack . show
+ src/Network/Pubnub/Types.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Network.Pubnub.Types+ (+ convertHistoryOptions++ -- Record construction+ , Timestamp(..)+ , PN(..)+ , defaultPN+ , SubscribeOptions(..)+ , defaultSubscribeOptions+ , ConnectResponse(..)+ , SubscribeResponse(..)+ , EncryptedSubscribeResponse(..)+ , PublishResponse(..)+ , UUID+ , Presence(..)+ , Action(..)+ , HereNow(..)+ , History(..)+ , HistoryOption(..)+ , HistoryOptions+ , setEncryptionKey+ ) where++import GHC.Generics++import Control.Applicative ((<$>), pure, empty)+import Data.Text.Read+import Data.Aeson+import Data.Aeson.TH+import Data.Aeson.Types++import Crypto.Cipher.AES+import Crypto.Cipher.Types+import Data.Digest.Pure.SHA++import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as L++data PN = PN { origin :: T.Text+ , pub_key :: T.Text+ , sub_key :: T.Text+ , sec_key :: T.Text+ , channels :: [T.Text]+ , jsonp_callback :: Integer+ , time_token :: Timestamp+ , cipher_key :: B.ByteString+ , ctx :: Maybe AES+ , iv :: Maybe (IV AES)+ , ssl :: Bool}++defaultPN :: PN+defaultPN = PN { origin = "haskell.pubnub.com"+ , pub_key = T.empty+ , sub_key = T.empty+ , sec_key = "0"+ , channels = []+ , jsonp_callback = 0+ , time_token = Timestamp 0+ , cipher_key = B.empty+ , ctx = Nothing+ , iv = makeIV (B.pack "0123456789012345")+ , ssl = False }++data SubscribeOptions a = SubscribeOptions { uid :: Maybe UUID++ , onMsg :: a -> IO ()+ , onConnect :: IO ()+ , onDisconnect :: IO ()+ , onError :: Maybe Int -> Maybe B.ByteString -> IO ()+ , onPresence :: Maybe (Presence -> IO ())+ , onReconnect :: IO ()++ , subTimeout :: Maybe Int+ , resumeOnReconnect :: Bool+ , windowing :: Maybe Integer }++defaultSubscribeOptions :: SubscribeOptions a+defaultSubscribeOptions = SubscribeOptions { uid = Nothing++ , onMsg = \_ -> return ()+ , onConnect = return ()+ , onDisconnect = return ()+ , onError = \_ _ -> return ()+ , onPresence = Nothing+ , onReconnect = return ()++ , subTimeout = Just 310+ , resumeOnReconnect = True+ , windowing = Nothing }++setEncryptionKey :: PN -> B.ByteString -> Either KeyError PN+setEncryptionKey pn key =+ either Left (\a -> Right pn{ctx = Just (initAES256 a)}) (convertKey key)+ where+ initAES256 :: Key AES -> AES+ initAES256 = cipherInit++ convertKey k = makeKey (B.pack . take 32 . showDigest . sha256 $ L.fromStrict k)++newtype Timestamp = Timestamp Integer+ deriving (Show)++instance ToJSON Timestamp where+ toJSON (Timestamp t) = (Number . fromIntegral) t++instance FromJSON Timestamp where+ parseJSON (String s) = Timestamp <$> (pure . decimalRight) s+ parseJSON (Array a) =+ Timestamp <$> (withScientific "Integral" $ pure . floor) (V.head a)+ parseJSON _ = empty++data ConnectResponse = ConnectResponse ([Value], Timestamp)+ deriving (Show, Generic)++instance FromJSON ConnectResponse++data PublishResponse = PublishResponse Integer String Timestamp+ deriving (Show, Generic)++instance FromJSON PublishResponse++data SubscribeResponse a = SubscribeResponse (a, Timestamp)+ deriving (Show, Generic)++instance (FromJSON a) => FromJSON (SubscribeResponse a)++data EncryptedSubscribeResponse = EncryptedSubscribeResponse ([T.Text], Timestamp)+ deriving (Show, Generic)++instance FromJSON EncryptedSubscribeResponse++type UUID = T.Text+type Occupancy = Integer++data Action = Join | Leave | Timeout+ deriving (Show)++instance FromJSON Action where+ parseJSON (String "join") = pure Join+ parseJSON (String "leave") = pure Leave+ parseJSON (String "timeout") = pure Timeout+ parseJSON _ = empty++instance ToJSON Action where+ toJSON Join = String "join"+ toJSON Leave = String "leave"+ toJSON Timeout = String "timeout"++data Presence = Presence { action :: Action+ , timestamp :: Integer+ , uuid :: UUID+ , presenceOccupancy :: Occupancy }+ deriving (Show)++data HereNow = HereNow { uuids :: [UUID]+ , herenowOccupancy :: Occupancy }+ deriving (Show)++data History a = History [a] Integer Integer+ deriving (Show, Generic)++instance (FromJSON a) => FromJSON (History a)++data HistoryOption = Start Integer+ | End Integer+ | Reverse Bool+ | Count Integer++type HistoryOptions = [HistoryOption]++convertHistoryOptions :: HistoryOptions -> [(B.ByteString, B.ByteString)]+convertHistoryOptions =+ map convertHistoryOption++convertHistoryOption :: HistoryOption -> (B.ByteString, B.ByteString)+convertHistoryOption (Start i) = ("start", B.pack $ show i)+convertHistoryOption (End i) = ("end", B.pack $ show i)+convertHistoryOption (Reverse True) = ("reverse", "true")+convertHistoryOption (Reverse False) = ("reverse", "false")+convertHistoryOption (Count i) = ("count", B.pack $ show i)++decimalRight :: T.Text -> Integer+decimalRight = either (const 0) fst . decimal++$(deriveJSON defaultOptions{ fieldLabelModifier =+ \ x -> case x of+ "presenceOccupancy" -> "occupancy"+ _ -> x } ''Presence)++$(deriveJSON defaultOptions{ fieldLabelModifier = \ x ->+ case x of+ "herenowOccupancy" -> "occupancy"+ _ -> x } ''HereNow)
+ test/Test.hs view
@@ -0,0 +1,13 @@+module Main where++import Test.Tasty (defaultMain,testGroup,TestTree)+--import Test.Tasty.HUnit++--import Network.Pubnub++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "All Tests"+ [ ]