diff --git a/examples/Chat/Main.hs b/examples/Chat/Main.hs --- a/examples/Chat/Main.hs +++ b/examples/Chat/Main.hs @@ -9,6 +9,7 @@ import GHC.Generics import Data.Aeson +import Data.Maybe import Control.Concurrent.Async import Control.Monad @@ -24,53 +25,45 @@ 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 :: T.Text -> Bool -> PN newClient name encrypt - | encrypt = either (error . show) (\x -> Client { clientName = name - , pn = x}) encKey - | otherwise = Client { clientName = name - , pn = newPN} + | encrypt = either (error . show) (\x -> x{ uuid_key = (Just name) }) encKey + | otherwise = newPN where encKey = setEncryptionKey newPN "enigma" - newPN = defaultPN { channels = ["testchathaskell2"] + newPN = defaultPN { uuid_key = (Just name) + , channels = ["testchathaskell2"] , sub_key = "demo" , pub_key = "demo" , ssl = False } -runClient :: Client -> IO () -runClient Client{..} = do +runClient :: PN -> IO () +runClient pn = do a <- receiver withAsync (cli a) $ \b -> do _ <- waitAnyCancel [a, b] return () - where + where cli a = forever $ do msg <- I.getLine case msg of "/leave" -> do - leave pn (head $ channels pn) clientName + leave pn (head $ channels pn) (fromJust $ uuid_key pn) unsubscribe a mzero _ -> - publish pn (head $ channels pn) Msg { username=clientName + publish pn (head $ channels pn) Msg { username=(fromJust $ uuid_key pn) , msg=msg } receiver = - subscribe pn defaultSubscribeOptions{ uid = Just clientName - - , onPresence = Just outputPresence + subscribe pn defaultSubscribeOptions{ onPresence = Just outputPresence , onMsg = output , onConnect = putStrLn "Connected..." } diff --git a/pubnub.cabal b/pubnub.cabal --- a/pubnub.cabal +++ b/pubnub.cabal @@ -2,9 +2,9 @@ -- see http://haskell.org/cabal/users-guide/ name: pubnub -version: 0.1.0.0 +version: 1.0.0 synopsis: PubNub Haskell SDK --- description: +description: The PubNub Network makes Real-time easy with a Simple Communications API. Two Functions: Send/Receive (Publish/Subscribe). We provide a web-service API for businesses to build scalable Data Push communication apps on Mobile, Tablet and Web. Bidirectional JSON. homepage: http://github.com/pubnub/haskell license: MIT license-file: LICENSE @@ -34,12 +34,13 @@ , http-types >= 0.8.3 , uuid >= 1.3.3 , async >= 2.0.1.4 - , data-default + , data-default >= 0.5.3 , 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 + , time >= 1.4.0.1 ghc-options: -Wall hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Network/Pubnub.hs b/src/Network/Pubnub.hs --- a/src/Network/Pubnub.hs +++ b/src/Network/Pubnub.hs @@ -17,6 +17,11 @@ , leave , getUuid , unsubscribe + + -- PAM API functions + , audit + , auth + , grant ) where import Network.Pubnub.Types @@ -32,6 +37,7 @@ import Control.Exception.Lifted (try) import Data.Text.Encoding import Data.Maybe +import Data.Time.Clock.POSIX import Data.Digest.Pure.SHA import Crypto.Cipher.AES @@ -45,7 +51,7 @@ time :: IO (Maybe Timestamp) time = do - let req = buildRequest defaultPN ["time", "0"] [] Nothing + let req = buildRequest defaultPN ["time", "0"] [] Nothing res <- withManager $ httpLbs req return (decode $ responseBody res :: Maybe Timestamp) @@ -54,14 +60,14 @@ case onPresence subOpts of Nothing -> subscribeInternal pn subOpts Just onPresenceCallback -> - case uid subOpts of - Nothing -> getUuid >>= \u -> subscribe' subOpts{uid = Just u} - _ -> subscribe' subOpts + case uuid_key pn of + Nothing -> getUuid >>= \u -> subscribe' pn{uuid_key = Just u} + _ -> subscribe' pn where - subscribe' subOpts' = + subscribe' pn' = do - a <- presence pn (uid subOpts') onPresenceCallback - b <- subscribeInternal pn subOpts' + a <- presence pn' (uuid_key pn') onPresenceCallback + b <- subscribeInternal pn' subOpts link2 a b return a @@ -96,17 +102,17 @@ 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 -> + Right res -> case (ctx pn', iv pn') of (Just c, Just i) -> - case decode $ responseBody r of + case decode $ responseBody res 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 + case decode $ responseBody res of Just (SubscribeResponse (resp, t)) -> do _ <- liftIO $ mapM (onMsg subOpts) resp subscribe' manager (pn' { time_token=t }) @@ -129,7 +135,7 @@ , encodeUtf8 $ T.intercalate "," (channels pn') , bsFromInteger $ jsonp_callback pn' , tt ] - (maybe [] (\u -> [("uuid", encodeUtf8 u)]) (uid subOpts)) + (userIdOptions pn') (subTimeout subOpts) decodeEncrypted c i m = decodeUnencrypted $ decrypt c i m @@ -154,7 +160,9 @@ , sig , encodeUtf8 channel , bsFromInteger $ jsonp_callback pn - , encrypt (ctx pn) (iv pn) encoded_msg] [] Nothing + , encrypt (ctx pn) (iv pn) encoded_msg] + (userIdOptions pn) + Nothing res <- withManager $ httpLbs req return (decode $ responseBody res) where @@ -180,9 +188,8 @@ 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 } + let subOpts = defaultSubscribeOptions{ onMsg = fn } + pn' = pn { uuid_key=u, ctx=Nothing, channels=presence_channels } in subscribeInternal pn' subOpts where @@ -196,7 +203,10 @@ , "sub-key" , encodeUtf8 $ sub_key pn , "channel" - , encodeUtf8 channel] (convertHistoryOptions options) Nothing + , encodeUtf8 channel] + ((convertHistoryOptions options) ++ + (userIdOptions pn)) + Nothing res <- withManager $ httpLbs req return (decode $ responseBody res) @@ -219,6 +229,60 @@ unsubscribe :: Async () -> IO () unsubscribe = cancel + +-- PAM functions + +audit :: PN -> Auth -> IO (Maybe Value) +audit = pamDo "audit" + +grant :: PN -> Auth -> IO (Maybe Value) +grant = pamDo "grant" + +auth :: PN -> T.Text -> PN +auth pn k = pn{auth_key = (Just k)} + +pamDo :: B.ByteString -> PN -> Auth -> IO (Maybe Value) +pamDo pamMethod pn authR = do + ts <- (bsFromInteger . round) <$> getPOSIXTime + let req = buildRequest pn pamURI ((pamQS ts) ++ [("signature", signature ts)]) Nothing + res <- withManager $ httpLbs req + return (decode $ responseBody res) + where + authK = T.intercalate "," $ authKeys authR + channel = fromJust $ chan authR + authRead = r authR + authWrite = w authR + + pubKey = encodeUtf8 $ pub_key pn + subKey = encodeUtf8 $ sub_key pn + secKey = L.fromStrict . encodeUtf8 $ sec_key pn + + signature ts = B64.encode . L.toStrict . bytestringDigest $ hmacSha256 secKey (msg ts) + + msg ts = L.fromStrict $ B.intercalate B.empty [ subKey, "\n" + , pubKey, "\n" + , pamMethod, "\n" + , B.tail $ renderSimpleQuery True $ pamQS ts] + + pamURI = [ "v1" + , "auth" + , pamMethod + , "sub-key" + , subKey] + + pamQS ts = [ ("auth", encodeUtf8 authK) + , ("channel", encodeUtf8 channel) + , ("r", if authRead then "1" else "0") + , ("timestamp", ts) + , ("w", if authWrite then "1" else "0")] + + +-- internal functions +userIdOptions :: PN -> [(B.ByteString, B.ByteString)] +userIdOptions pn = + (maybe [] (\u -> [("uuid", encodeUtf8 u)]) (uuid_key pn)) ++ + (maybe [] (\a -> [("auth", encodeUtf8 a)]) (auth_key pn)) + buildRequest :: PN -> [B.ByteString] -> SimpleQuery -> Maybe Int -> Request buildRequest pn elems qs timeout = def { host = encodeUtf8 $ origin pn @@ -228,7 +292,7 @@ , requestHeaders = [ ("V", "3.1") , ("User-Agent", "Haskell") , ("Accept", "*/*")] - , queryString = renderSimpleQuery True qs + , queryString = renderSimpleQuery True qs , secure = ssl pn , responseTimeout = Just (maybe 5000000 (* 1000000) timeout) } diff --git a/src/Network/Pubnub/Types.hs b/src/Network/Pubnub/Types.hs --- a/src/Network/Pubnub/Types.hs +++ b/src/Network/Pubnub/Types.hs @@ -12,6 +12,8 @@ , defaultPN , SubscribeOptions(..) , defaultSubscribeOptions + , Auth(..) + , defaultAuth , ConnectResponse(..) , SubscribeResponse(..) , EncryptedSubscribeResponse(..) @@ -47,6 +49,8 @@ , pub_key :: T.Text , sub_key :: T.Text , sec_key :: T.Text + , uuid_key :: Maybe UUID + , auth_key :: Maybe T.Text , channels :: [T.Text] , jsonp_callback :: Integer , time_token :: Timestamp @@ -60,6 +64,8 @@ , pub_key = T.empty , sub_key = T.empty , sec_key = "0" + , uuid_key = Nothing + , auth_key = Nothing , channels = [] , jsonp_callback = 0 , time_token = Timestamp 0 @@ -68,9 +74,7 @@ , iv = makeIV (B.pack "0123456789012345") , ssl = False } -data SubscribeOptions a = SubscribeOptions { uid :: Maybe UUID - - , onMsg :: a -> IO () +data SubscribeOptions a = SubscribeOptions { onMsg :: a -> IO () , onConnect :: IO () , onDisconnect :: IO () , onError :: Maybe Int -> Maybe B.ByteString -> IO () @@ -82,9 +86,7 @@ , windowing :: Maybe Integer } defaultSubscribeOptions :: SubscribeOptions a -defaultSubscribeOptions = SubscribeOptions { uid = Nothing - - , onMsg = \_ -> return () +defaultSubscribeOptions = SubscribeOptions { onMsg = \_ -> return () , onConnect = return () , onDisconnect = return () , onError = \_ _ -> return () @@ -94,6 +96,20 @@ , subTimeout = Just 310 , resumeOnReconnect = True , windowing = Nothing } + +data Auth = Auth { chan :: Maybe T.Text + , authKeys :: [T.Text] + , r :: Bool + , w :: Bool + , ttl :: Int } + deriving (Show) + +defaultAuth :: Auth +defaultAuth = Auth { chan = Nothing + , authKeys = [] + , r = False + , w = False + , ttl = 0 } setEncryptionKey :: PN -> B.ByteString -> Either KeyError PN setEncryptionKey pn key =