diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Chat/Main.hs b/examples/Chat/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Chat/Main.hs @@ -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 diff --git a/examples/HelloWorld/Main.hs b/examples/HelloWorld/Main.hs new file mode 100644 --- /dev/null +++ b/examples/HelloWorld/Main.hs @@ -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 diff --git a/pubnub.cabal b/pubnub.cabal new file mode 100644 --- /dev/null +++ b/pubnub.cabal @@ -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 diff --git a/src/Network/Pubnub.hs b/src/Network/Pubnub.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pubnub.hs @@ -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 diff --git a/src/Network/Pubnub/Types.hs b/src/Network/Pubnub/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pubnub/Types.hs @@ -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) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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" + [ ]