diff --git a/hzulip.cabal b/hzulip.cabal --- a/hzulip.cabal +++ b/hzulip.cabal @@ -1,5 +1,5 @@ name: hzulip -version: 0.4.2.0 +version: 0.5.0.0 synopsis: A haskell wrapper for the Zulip API. description: This a Zulip API wrapper for Haskell. homepage: https://github.com/yamadapc/hzulip @@ -13,15 +13,15 @@ cabal-version: >=1.10 library - exposed-modules: HZulip - other-modules: HZulip.Types + exposed-modules: Web.HZulip + , Web.HZulip.Types build-depends: base >=4 && <5 , wreq >=0.2 && <1 , lens >=4.4 && <5 , aeson >=0.7 && <1 , lens-aeson >=1 && <2 , bytestring >=0.10 && <1 - , text >=1.1 &&<1.2 + , text >=1.2 &&<1.3 hs-source-dirs: src default-language: Haskell2010 @@ -38,5 +38,5 @@ , bytestring >=0.10 && <1 , hspec >=1.11 && <2 , raw-strings-qq >=1.0.2 && <2 - , text >=1.1 &&<1.2 + , text >=1.2 &&<1.3 default-language: Haskell2010 diff --git a/src/HZulip.hs b/src/HZulip.hs deleted file mode 100644 --- a/src/HZulip.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module HZulip ( Event(..) - , Message(..) - , Queue(..) - , User(..) - , ZulipClient(..) - , EventCallback - , MessageCallback - , addSubscriptions - , defaultBaseUrl - , eventTypes - , getEvents - , getSubscriptions - , newZulip - , onNewEvent - , onNewMessage - , registerQueue - , sendMessage - , sendPrivateMessage - , sendStreamMessage - ) - where - -import Control.Concurrent (threadDelay) -import Control.Exception (SomeException, handle) -import Control.Lens ((.~), (&), (^.), (^..)) -import Control.Monad (void) -import Data.Aeson.Lens (key, values, _String) -import qualified Data.ByteString.Char8 as BS (pack) -import qualified Data.Text as T (pack, unpack) -import Network.Wreq -import qualified Network.Wreq.Types as WT (params) - -import HZulip.Types as ZT - --- Public functions: -------------------------------------------------------------------------------- - --- | --- Helper for creating a `ZulipClient` with the `baseUrl` set to --- `defaultBaseUrl` -newZulip :: String -> String -> ZulipClient -newZulip e k = ZulipClient e k defaultBaseUrl - --- | --- The default zulip API URL -defaultBaseUrl :: String -defaultBaseUrl = "https://api.zulip.com/v1" - --- | --- The list of all avaiable event types -eventTypes :: [String] -eventTypes = ["message", "subscriptions", "realm_user", "pointer"] - --- | --- This wraps `POST https://api.zulip.com/v1/messages` with a nicer root --- API. Simpler helpers for each specific case of this somewhat overloaded --- endpoint will also be provided in the future. --- --- It takes the message `mtype`, `mrecipients`, `msubject` and `mcontent` --- and returns the created message's `id` in the `IO` monad. -sendMessage :: ZulipClient -> String -> [String] -> String -> String -> IO Int -sendMessage z mtype mrecipients msubject mcontent = do - let form = [ "type" := mtype - , "content" := mcontent - , "to" := show mrecipients - , "subject" := msubject - ] - - r <- postWith (reqOptions z) (messagesUrl z) form >>= asJSON - let body = r ^. responseBody - - if wasSuccessful body - then let Just mid = responseMessageId body in return mid - else fail $ responseMsg body - --- | --- Helper for sending private messages. Takes the list of recipients and --- the message's content. -sendPrivateMessage :: ZulipClient -> [String] -> String -> IO Int -sendPrivateMessage z mrs = sendMessage z "private" mrs "" - --- | --- Helper for sending stream messages. Takes the stream name, the subject --- and the message. -sendStreamMessage :: ZulipClient -> String -> String -> String -> IO Int -sendStreamMessage z s = sendMessage z "stream" [s] - --- | --- This registers a new event queue with the zulip API. It's a lower level --- function, which shouldn't be used unless you know what you're doing. It --- takes a `ZulipClient`, a list of names of the events you want to listen --- for and whether you'd like for the content to be rendered in HTML format --- (if you set the last parameter to `False` it will be kept as typed, in --- markdown format) -registerQueue :: ZulipClient -> [String] -> Bool -> IO Queue -registerQueue z evTps mdn = do - let form = [ "event_types" := show evTps - , "apply_markdown" := (if mdn then "true" else "false" :: String) - ] - - r <- postWith (reqOptions z) (registerUrl z) form >>= asJSON - let body = r ^. responseBody - - if wasSuccessful body - then let Just qid = responseQueueId body - Just lid = responseLastEventId body in - return $ Queue qid lid - else fail $ responseMsg body - --- | --- Get a list of the streams the client is currently subscribed to. -getSubscriptions :: ZulipClient -> IO [String] -getSubscriptions z = do - r <- getWith (reqOptions z) (subscriptionsUrl z) - return $ map T.unpack $ r ^.. responseBody . key "subscriptions" - . values . key "name" . _String - --- | --- Add new Stream subscriptions to the client. -addSubscriptions :: ZulipClient -> [String] -> IO () -addSubscriptions z sbs = do - let form = [ "subscriptions" := show sbs ] - void $ postWith (reqOptions z) (subscriptionsUrl z) form - --- | --- Fetches new set of events from a `Queue`. -getEvents :: ZulipClient -> Queue -> Bool -> IO (Queue, [Event]) -getEvents z q b = do - let opts = (reqOptions z) { WT.params = [ ("queue_id", T.pack $ queueId q) - , ("last_event_id", T.pack $ show $ - lastEventId q) - , ("dont_block", if b then "true" - else "false") - ] - } - - r <- getWith opts (eventsUrl z) >>= asJSON - let body = r ^. responseBody - - if wasSuccessful body - then let Just evs = responseEvents body - -- Get the last event id and pass it back with the `Queue` - lEvId = maximum $ map eventId evs in - return (q { lastEventId = lEvId }, evs) - else fail $ responseMsg body - --- | --- Registers an event callback for specified events and keeps executing it --- over events as they come in. Will loop forever -onNewEvent :: ZulipClient -> [String] -> EventCallback -> IO () -onNewEvent z etypes f = do - q <- registerQueue z etypes False - handle (tryAgain q) (loop q) - where tryAgain :: Queue -> SomeException -> IO () - tryAgain q = const $ threadDelay 1000000 >> handle (tryAgain q) (loop q) - loop q = getEvents z q False >>= - \(q', evts) -> mapM_ f evts >> - loop q' - --- | --- Registers a callback to be executed whenever a message comes in. Will --- loop forever -onNewMessage :: ZulipClient -> MessageCallback -> IO () -onNewMessage z f = onNewEvent z ["message"] $ \evt -> - -- I could just pattern match here, as I did in other places and simply - -- expect the Zulip API not to give us correct responses, but I think - -- this is more reasonable. - maybe (return ()) f (eventMessage evt) - --- Private functions: -------------------------------------------------------------------------------- - --- | --- Returns `True` if a response indicates success -wasSuccessful :: ZT.Response -> Bool -wasSuccessful = (== ResponseSuccess) . responseResult - --- | --- Gets the endpoint for creating messages for a given `ZulipClient` -messagesUrl :: ZulipClient -> String -messagesUrl = (++ "/messages") . clientBaseUrl - --- | --- Gets the endpoint for registering event queues for a given `ZulipClient` -registerUrl :: ZulipClient -> String -registerUrl = (++ "/register") . clientBaseUrl - --- | --- Gets the endpoint for fetching events for a given `ZulipClient` -eventsUrl :: ZulipClient -> String -eventsUrl = (++ "/events") . clientBaseUrl - --- | --- Gets the endpoint for fetching subscriptions for a given `ZulipClient` -subscriptionsUrl :: ZulipClient -> String -subscriptionsUrl = (++ "/users/me/subscriptions") . clientBaseUrl - --- | --- Constructs the `Wreq` HTTP request `Options` object for a `ZulipClient` -reqOptions :: ZulipClient -> Options -reqOptions (ZulipClient e k _) = defaults & auth .~ basicAuth (BS.pack e) (BS.pack k) diff --git a/src/HZulip/Types.hs b/src/HZulip/Types.hs deleted file mode 100644 --- a/src/HZulip/Types.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module HZulip.Types where - -import Control.Applicative ((<$>), (<*>), (<|>), pure) -import Control.Monad (mzero) -import Data.Aeson -import Data.Aeson.Types - --- | --- Represents a Zulip API client -data ZulipClient = ZulipClient { clientEmail :: String - , clientApiKey :: String - , clientBaseUrl :: String - } - deriving (Eq, Ord, Show) - --- | --- The internal response representation for top-down parsing of Zulip API --- JSON responses -data Response = Response { responseResult :: ResponseResult - , responseMsg :: String - - , responseMessageId :: Maybe Int - , responseQueueId :: Maybe String - , responseLastEventId :: Maybe Int - - , responseEvents :: Maybe [Event] - } - deriving (Eq, Ord, Show) - --- | --- Represnts a response result, this is just so result Strings aren't --- modeled in memory -data ResponseResult = ResponseError | ResponseSuccess - deriving(Eq, Show, Ord) - --- | --- Represents zulip events -data Event = Event { eventType :: String - , eventId :: Int - , eventMessage :: Maybe Message - } - deriving (Eq, Ord, Show) - --- | --- Represents a Zulip Message -data Message = Message { messageId :: Int - , messageType :: String - , messageContent :: String - - , messageAvatarUrl :: String - , messageTimestamp :: Int - - -- See the comment on the `FromJSON Message` instance. - , messageDisplayRecipient :: Either String [User] - - , messageSender :: User - - , messageGravatarHash :: String - - , messageRecipientId :: Int - , messageClient :: String - , messageSubjectLinks :: [String] - , messageSubject :: String - } - deriving (Eq, Ord, Show) - --- | --- Represents a zulip user account - for both `display_recipient` and --- `message_sender` representations -data User = User { userId :: Int - , userFullName :: String - , userEmail :: String - , userDomain :: String - , userShortName :: String - } - deriving (Eq, Ord, Show) - --- | --- Represents some event queue -data Queue = Queue { queueId :: String - , lastEventId :: Int - } - deriving (Eq, Ord, Show) - --- | --- The root type for Event callbacks -type EventCallback = Event -> IO () - --- | --- Type for message callbacks -type MessageCallback = Message -> IO () - -instance FromJSON Response where - parseJSON (Object o) = Response <$> - o .: "result" <*> - o .: "msg" <*> - o .:? "id" <*> - o .:? "queue_id" <*> - o .:? "last_event_id" <*> - o .:? "events" - parseJSON _ = mzero - -instance FromJSON ResponseResult where - parseJSON (String "success") = pure ResponseSuccess - parseJSON _ = pure ResponseError - -instance FromJSON Event where - parseJSON (Object o) = Event <$> - o .: "type" <*> - o .: "id" <*> - o .:? "message" - parseJSON _ = mzero - -instance FromJSON Message where - parseJSON (Object o) = Message <$> - o .: "id" <*> - o .: "type" <*> - o .: "content" <*> - - o .: "avatar_url" <*> - o .: "timestamp" <*> - - (parseDisplayRecipient =<< - o .: "display_recipient") <*> - - (User <$> - o .: "sender_id" <*> - o .: "sender_full_name" <*> - o .: "sender_email" <*> - o .: "sender_domain" <*> - o .: "sender_short_name" - ) <*> - - o .: "gravatar_hash" <*> - - o .: "recipient_id" <*> - o .: "client" <*> - o .: "subject_links" <*> - o .: "subject" - parseJSON _ = mzero - -instance FromJSON User where - parseJSON (Object o) = User <$> - o .: "id" <*> - o .: "full_name" <*> - o .: "email" <*> - o .: "domain" <*> - o .: "short_name" - parseJSON _ = mzero - -parseDisplayRecipient :: Value -> Parser (Either String [User]) -parseDisplayRecipient v = Right <$> parseJSON v <|> - Left <$> parseJSON v diff --git a/src/Web/HZulip.hs b/src/Web/HZulip.hs new file mode 100644 --- /dev/null +++ b/src/Web/HZulip.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} +module HZulip ( Event(..) + , Message(..) + , Queue(..) + , User(..) + , ZulipClient(..) + , EventCallback + , MessageCallback + , addSubscriptions + , defaultBaseUrl + , eventTypes + , getEvents + , getSubscriptions + , newZulip + , onNewEvent + , onNewMessage + , registerQueue + , sendMessage + , sendPrivateMessage + , sendStreamMessage + ) + where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, handle) +import Control.Lens ((.~), (&), (^.), (^..)) +import Control.Monad (void) +import Data.Aeson.Lens (key, values, _String) +import qualified Data.ByteString.Char8 as BS (pack) +import qualified Data.Text as T (pack, unpack) +import Network.Wreq (FormParam(..), Options(), asJSON, auth, defaults, + basicAuth, responseBody) +import Network.Wreq.Session (getWith, postWith, withSession) +import qualified Network.Wreq.Types as WT (params) + +import HZulip.Types as ZT + +-- Public functions: +------------------------------------------------------------------------------- + +-- | +-- Helper for creating a `ZulipClient` with the `baseUrl` set to +-- `defaultBaseUrl` +newZulip :: String -> String -> IO ZulipClient +newZulip e k = withSession (return . ZulipClient e k defaultBaseUrl) + +-- | +-- The default zulip API URL +defaultBaseUrl :: String +defaultBaseUrl = "https://api.zulip.com/v1" + +-- | +-- The list of all avaiable event types +eventTypes :: [String] +eventTypes = ["message", "subscriptions", "realm_user", "pointer"] + +-- | +-- This wraps `POST https://api.zulip.com/v1/messages` with a nicer root +-- API. Simpler helpers for each specific case of this somewhat overloaded +-- endpoint will also be provided in the future. +-- +-- It takes the message `mtype`, `mrecipients`, `msubject` and `mcontent` +-- and returns the created message's `id` in the `IO` monad. +sendMessage :: ZulipClient -> String -> [String] -> String -> String -> IO Int +sendMessage z mtype mrecipients msubject mcontent = do + let form = [ "type" := mtype + , "content" := mcontent + , "to" := show mrecipients + , "subject" := msubject + ] + + r <- postWith (reqOptions z) (clientSession z) (messagesUrl z) form >>= + asJSON + + let body = r ^. responseBody + + if wasSuccessful body + then let Just mid = responseMessageId body in return mid + else fail $ responseMsg body + +-- | +-- Helper for sending private messages. Takes the list of recipients and +-- the message's content. +sendPrivateMessage :: ZulipClient -> [String] -> String -> IO Int +sendPrivateMessage z mrs = sendMessage z "private" mrs "" + +-- | +-- Helper for sending stream messages. Takes the stream name, the subject +-- and the message. +sendStreamMessage :: ZulipClient -> String -> String -> String -> IO Int +sendStreamMessage z s = sendMessage z "stream" [s] + +-- | +-- This registers a new event queue with the zulip API. It's a lower level +-- function, which shouldn't be used unless you know what you're doing. It +-- takes a `ZulipClient`, a list of names of the events you want to listen +-- for and whether you'd like for the content to be rendered in HTML format +-- (if you set the last parameter to `False` it will be kept as typed, in +-- markdown format) +registerQueue :: ZulipClient -> [String] -> Bool -> IO Queue +registerQueue z evTps mdn = do + let form = [ "event_types" := show evTps + , "apply_markdown" := (if mdn then "true" else "false" :: String) + ] + + r <- postWith (reqOptions z) (clientSession z) (registerUrl z) form >>= + asJSON + let body = r ^. responseBody + + if wasSuccessful body + then let Just qid = responseQueueId body + Just lid = responseLastEventId body in + return $ Queue qid lid + else fail $ responseMsg body + +-- | +-- Get a list of the streams the client is currently subscribed to. +getSubscriptions :: ZulipClient -> IO [String] +getSubscriptions z = do + r <- getWith (reqOptions z) (clientSession z) (subscriptionsUrl z) + return $ map T.unpack $ r ^.. responseBody . key "subscriptions" + . values . key "name" . _String + +-- | +-- Add new Stream subscriptions to the client. +addSubscriptions :: ZulipClient -> [String] -> IO () +addSubscriptions z sbs = do + let form = [ "subscriptions" := show sbs ] + void $ postWith (reqOptions z) (clientSession z) (subscriptionsUrl z) form + +-- | +-- Fetches new set of events from a `Queue`. +getEvents :: ZulipClient -> Queue -> Bool -> IO (Queue, [Event]) +getEvents z q b = do + let opts = (reqOptions z) { WT.params = [ ("queue_id", T.pack $ queueId q) + , ("last_event_id", T.pack $ show $ + lastEventId q) + , ("dont_block", if b then "true" + else "false") + ] + } + + r <- getWith opts (clientSession z) (eventsUrl z) >>= asJSON + let body = r ^. responseBody + + if wasSuccessful body + then let Just evs = responseEvents body + -- Get the last event id and pass it back with the `Queue` + lEvId = maximum $ map eventId evs in + return (q { lastEventId = lEvId }, evs) + else fail $ responseMsg body + +-- | +-- Registers an event callback for specified events and keeps executing it +-- over events as they come in. Will loop forever +onNewEvent :: ZulipClient -> [String] -> EventCallback -> IO () +onNewEvent z etypes f = do + q <- registerQueue z etypes False + handle (tryAgain q) (loop q) + where tryAgain :: Queue -> SomeException -> IO () + tryAgain q = const $ threadDelay 1000000 >> handle (tryAgain q) (loop q) + loop q = getEvents z q False >>= + \(q', evts) -> mapM_ f evts >> + loop q' + +-- | +-- Registers a callback to be executed whenever a message comes in. Will +-- loop forever +onNewMessage :: ZulipClient -> MessageCallback -> IO () +onNewMessage z f = onNewEvent z ["message"] $ \evt -> + -- I could just pattern match here, as I did in other places and simply + -- expect the Zulip API not to give us correct responses, but I think + -- this is more reasonable. + maybe (return ()) f (eventMessage evt) + +-- Private functions: +------------------------------------------------------------------------------- + +-- | +-- Returns `True` if a response indicates success +wasSuccessful :: ZT.Response -> Bool +wasSuccessful = (== ResponseSuccess) . responseResult + +-- | +-- Gets the endpoint for creating messages for a given `ZulipClient` +messagesUrl :: ZulipClient -> String +messagesUrl = (++ "/messages") . clientBaseUrl + +-- | +-- Gets the endpoint for registering event queues for a given `ZulipClient` +registerUrl :: ZulipClient -> String +registerUrl = (++ "/register") . clientBaseUrl + +-- | +-- Gets the endpoint for fetching events for a given `ZulipClient` +eventsUrl :: ZulipClient -> String +eventsUrl = (++ "/events") . clientBaseUrl + +-- | +-- Gets the endpoint for fetching subscriptions for a given `ZulipClient` +subscriptionsUrl :: ZulipClient -> String +subscriptionsUrl = (++ "/users/me/subscriptions") . clientBaseUrl + +-- | +-- Constructs the `Wreq` HTTP request `Options` object for a `ZulipClient` +reqOptions :: ZulipClient -> Options +reqOptions (ZulipClient e k _ _) = defaults & auth .~ basicAuth (BS.pack e) + (BS.pack k) diff --git a/src/Web/HZulip/Types.hs b/src/Web/HZulip/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/HZulip/Types.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +module HZulip.Types where + +import Control.Applicative ((<$>), (<*>), (<|>), pure) +import Control.Monad (mzero) +import Data.Aeson +import Data.Aeson.Types +import Network.Wreq.Session + +-- | +-- Represents a Zulip API client +data ZulipClient = ZulipClient { clientEmail :: String + , clientApiKey :: String + , clientBaseUrl :: String + , clientSession :: Session + } + deriving (Show) + +-- | +-- The internal response representation for top-down parsing of Zulip API +-- JSON responses +data Response = Response { responseResult :: ResponseResult + , responseMsg :: String + + , responseMessageId :: Maybe Int + , responseQueueId :: Maybe String + , responseLastEventId :: Maybe Int + + , responseEvents :: Maybe [Event] + } + deriving (Eq, Ord, Show) + +-- | +-- Represnts a response result, this is just so result Strings aren't +-- modeled in memory +data ResponseResult = ResponseError | ResponseSuccess + deriving(Eq, Show, Ord) + +-- | +-- Represents zulip events +data Event = Event { eventType :: String + , eventId :: Int + , eventMessage :: Maybe Message + } + deriving (Eq, Ord, Show) + +-- | +-- Represents a Zulip Message +data Message = Message { messageId :: Int + , messageType :: String + , messageContent :: String + + , messageAvatarUrl :: String + , messageTimestamp :: Int + + -- See the comment on the `FromJSON Message` instance. + , messageDisplayRecipient :: Either String [User] + + , messageSender :: User + + , messageGravatarHash :: String + + , messageRecipientId :: Int + , messageClient :: String + , messageSubjectLinks :: [String] + , messageSubject :: String + } + deriving (Eq, Ord, Show) + +-- | +-- Represents a zulip user account - for both `display_recipient` and +-- `message_sender` representations +data User = User { userId :: Int + , userFullName :: String + , userEmail :: String + , userDomain :: String + , userShortName :: String + } + deriving (Eq, Ord, Show) + +-- | +-- Represents some event queue +data Queue = Queue { queueId :: String + , lastEventId :: Int + } + deriving (Eq, Ord, Show) + +-- | +-- The root type for Event callbacks +type EventCallback = Event -> IO () + +-- | +-- Type for message callbacks +type MessageCallback = Message -> IO () + +instance FromJSON Response where + parseJSON (Object o) = Response <$> + o .: "result" <*> + o .: "msg" <*> + o .:? "id" <*> + o .:? "queue_id" <*> + o .:? "last_event_id" <*> + o .:? "events" + parseJSON _ = mzero + +instance FromJSON ResponseResult where + parseJSON (String "success") = pure ResponseSuccess + parseJSON _ = pure ResponseError + +instance FromJSON Event where + parseJSON (Object o) = Event <$> + o .: "type" <*> + o .: "id" <*> + o .:? "message" + parseJSON _ = mzero + +instance FromJSON Message where + parseJSON (Object o) = Message <$> + o .: "id" <*> + o .: "type" <*> + o .: "content" <*> + + o .: "avatar_url" <*> + o .: "timestamp" <*> + + (parseDisplayRecipient =<< + o .: "display_recipient") <*> + + (User <$> + o .: "sender_id" <*> + o .: "sender_full_name" <*> + o .: "sender_email" <*> + o .: "sender_domain" <*> + o .: "sender_short_name" + ) <*> + + o .: "gravatar_hash" <*> + + o .: "recipient_id" <*> + o .: "client" <*> + o .: "subject_links" <*> + o .: "subject" + parseJSON _ = mzero + +instance FromJSON User where + parseJSON (Object o) = User <$> + o .: "id" <*> + o .: "full_name" <*> + o .: "email" <*> + o .: "domain" <*> + o .: "short_name" + parseJSON _ = mzero + +parseDisplayRecipient :: Value -> Parser (Either String [User]) +parseDisplayRecipient v = Right <$> parseJSON v <|> + Left <$> parseJSON v