hzulip 0.4.2.0 → 0.5.0.0
raw patch · 5 files changed
+369/−361 lines, 5 filesdep ~text
Dependency ranges changed: text
Files
- hzulip.cabal +5/−5
- src/HZulip.hs +0/−202
- src/HZulip/Types.hs +0/−154
- src/Web/HZulip.hs +208/−0
- src/Web/HZulip/Types.hs +156/−0
hzulip.cabal view
@@ -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
− src/HZulip.hs
@@ -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)
− src/HZulip/Types.hs
@@ -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
+ src/Web/HZulip.hs view
@@ -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)
+ src/Web/HZulip/Types.hs view
@@ -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