hzulip 0.5.0.1 → 1.0.0.0
raw patch · 3 files changed
+260/−115 lines, 3 filesdep +asyncdep +exceptionsdep +http-clientdep −wreq
Dependencies added: async, exceptions, http-client, http-client-tls, http-types, mtl, scotty, transformers
Dependencies removed: wreq
Files
- hzulip.cabal +15/−3
- src/Web/HZulip.hs +223/−101
- src/Web/HZulip/Types.hs +22/−11
hzulip.cabal view
@@ -1,5 +1,5 @@ name: hzulip-version: 0.5.0.1+version: 1.0.0.0 synopsis: A haskell wrapper for the Zulip API. description: This a Zulip API wrapper for Haskell. homepage: https://github.com/yamadapc/hzulip@@ -16,7 +16,12 @@ exposed-modules: Web.HZulip , Web.HZulip.Types build-depends: base >=4 && <5- , wreq >=0.2 && <1+ , http-client >=0.2 && <1+ , http-client-tls+ , http-types+ , exceptions >=0.6 && <0.7+ , mtl >=2.1 && <2.2+ , transformers , lens >=4.4 && <5 , aeson >=0.7 && <1 , lens-aeson >=1 && <2@@ -31,9 +36,16 @@ hs-source-dirs: src , test build-depends: base >=4 && <5- , wreq >=0.2 && <1+ , async+ , http-client >=0.2 && <1+ , http-client-tls+ , http-types+ , exceptions >=0.6 && <0.7+ , mtl >=2.1 && <2.2+ , transformers , lens >=4.4 && <5 , aeson >=0.7 && <1+ , scotty >=0.9 && <0.10 , lens-aeson >=1 && <2 , bytestring >=0.10 && <1 , hspec >=1.11 && <2
src/Web/HZulip.hs view
@@ -1,37 +1,99 @@ {-# LANGUAGE OverloadedStrings #-}+-------------------------------------------------------------------------------+-- |+-- Module : Web.HZulip+-- Copyright : Pedro Tacla Yamada+-- License : MIT (see LICENSE)+--+-- Maintainer : Pedro Tacla Yamada <tacla.yamada@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- A Wrapper library for the Zulip API. Works on top of a 'ReaderT' monad+-- transformer, holding a 'ZulipOptions' object, which should hold the+-- state and configuration for the API client.+--+-- Using the library is made easier through a set of helper functions. This+-- design is more concise and than passing around configuration variables;+-- one could easily bypass it with the use of 'runZulip', though that isn't+-- recommended.+--+-- Example usage:+-- > import Web.HZulip+-- >+-- > main :: IO ()+-- > main = withZulipCreds "zulip-api-user" "zulip-api-key" $ do+-- > -- Since we are inside the ZulipM ReaderT monad transformer, we+-- > -- don't need to pass options around. The above function already+-- > -- created an HTTP manager, for connection pooling and wrapped the+-- > -- default configuration options with the Monad:+-- > print =<< getSubscriptions+-- > -- >> ["haskell"]+-- >+-- > -- Sending messages is as easy as:+-- > void $ sendStreamMessage "haskell" -- message stream+-- > "hzulip" -- message topic+-- > "Message from Haskell" -- message content+-- >+-- > -- Listening for events works with a callback based API. More+-- > -- complex patterns for concurrent message handling can be created+-- > -- from it. As long as your zulip user is already subscribed to+-- > -- streams, this is all you have to do:+-- > onNewEvent ["message"] $ \msg -> do+-- > liftIO $ putStrLn "Got a new message!"+-- > let usr = messageSender msg+-- > fn = userFullName usr+-- > e = userEmail usr+-- >+-- > sendPrivateMessage [e] $ "Thanks for the message " ++ fn ++ "!!"+-- module Web.HZulip ( Event(..) , Message(..) , Queue(..) , User(..)- , ZulipClient(..)+ , ZulipOptions(..) , EventCallback , MessageCallback , addSubscriptions , defaultBaseUrl , eventTypes , getEvents+ , getStreams+ , getStreamSubscribers , getSubscriptions- , newZulip , onNewEvent , onNewMessage , registerQueue+ , removeSubscriptions+ , runZulip , sendMessage , sendPrivateMessage , sendStreamMessage+ , withZulip+ , withZulipCreds+ , zulipOptions ) where +import Control.Arrow (second) import Control.Concurrent (threadDelay)-import Control.Exception (SomeException, handle)-import Control.Lens ((.~), (&), (^.), (^..))+import Control.Lens ((^..)) import Control.Monad (void)+import Control.Monad.Catch (SomeException, handleAll)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, runReaderT)+import Data.Aeson (decode) 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 qualified Data.ByteString.Lazy as BL (ByteString)+import qualified Data.ByteString.Char8 as C (pack)+import qualified Data.ByteString.Lazy.Char8 as CL (unpack)+import Data.Text as T (Text, unpack)+import Data.Text.Encoding as T (encodeUtf8)+import Network.HTTP.Client (Request, applyBasicAuth, httpLbs, method,+ newManager, parseUrl, responseBody, setQueryString)+import Network.HTTP.Client.MultipartFormData (formDataBody, partBS)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (Method, methodGet, methodPatch, methodPost) import Web.HZulip.Types as ZT @@ -39,12 +101,32 @@ ------------------------------------------------------------------------------- -- |--- Helper for creating a `ZulipClient` with the `baseUrl` set to+-- Helper for creating a `ZulipOptions` object with the `baseUrl` set to -- `defaultBaseUrl`-newZulip :: String -> String -> IO ZulipClient-newZulip e k = withSession (return . ZulipClient e k defaultBaseUrl)+zulipOptions :: String -> String -> IO ZulipOptions+zulipOptions e k = do+ manager <- newManager tlsManagerSettings+ return $ ZulipOptions e k defaultBaseUrl manager -- |+-- Helper to run Actions in the Zulip Monad+runZulip :: ZulipM a -> ZulipOptions -> IO a+runZulip = runReaderT++-- |+-- Flipped version of 'runZulip'+withZulip :: ZulipOptions -> ZulipM a -> IO a+withZulip = flip runZulip++-- |+-- Helper for creating a minimal 'ZulipOptions' object and running an action+-- in the 'ZulipM' monad+withZulipCreds :: String -> String -> ZulipM a -> IO a+withZulipCreds e k action = do+ opts <- zulipOptions e k+ runZulip action opts++-- | -- The default zulip API URL defaultBaseUrl :: String defaultBaseUrl = "https://api.zulip.com/v1"@@ -60,114 +142,121 @@ -- 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+-- and returns the created message's `id` in the `ZulipM` monad.+sendMessage :: String -> [String] -> String -> String -> ZulipM Int+sendMessage 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+ body <- zulipMakeRequest Messages methodPost form >>= decodeResponse+ let Just mid = responseMessageId body in return mid -- | -- 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 ""+sendPrivateMessage :: [String] -> String -> ZulipM Int+sendPrivateMessage mrs = sendMessage "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]+sendStreamMessage :: String -> String -> String -> ZulipM Int+sendStreamMessage s = sendMessage "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+-- takes 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)+registerQueue :: [String] -> Bool -> ZulipM Queue+registerQueue evTps mdn = do+ let form = [ ("event_types" , show evTps)+ , ("apply_markdown", if mdn then "true" else "false") ] - r <- postWith (reqOptions z) (clientSession z) (registerUrl z) form >>=- asJSON- let body = r ^. responseBody+ body <- zulipMakeRequest Register methodPost form >>= decodeResponse - if wasSuccessful body- then let Just qid = responseQueueId body- Just lid = responseLastEventId body in- return $ Queue qid lid- else fail $ responseMsg body+ let Just qid = responseQueueId body+ Just lid = responseLastEventId body+ in return $ Queue qid lid -- |+-- Get a list of all the public streams+getStreams :: ZulipM [String]+getStreams = do+ r <- zulipMakeRequest Streams methodGet []+ return $ map T.unpack $ r ^.. key "streams" . values+ . key "name" . _String++-- |+-- Get all the user emails subscribed to a stream+getStreamSubscribers :: String -> ZulipM [String]+getStreamSubscribers s = do+ r <- zulipMakeRequest' ("/streams/" ++ s ++ "/members") methodGet []+ return $ map T.unpack $ r ^.. key "subscribers" . values . _String++-- | -- 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+getSubscriptions :: ZulipM [String]+getSubscriptions = do+ r <- zulipMakeRequest Subscriptions methodGet []+ return $ map T.unpack $ r ^.. 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+addSubscriptions :: [String] -> ZulipM ()+addSubscriptions sbs = do+ let form = [ ("subscriptions", show sbs) ]+ void $ zulipMakeRequest Subscriptions methodPost 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")- ]- }+-- Remove one or more Stream subscriptions from the client+removeSubscriptions :: [String] -> ZulipM ()+removeSubscriptions sbs = do+ let form = [ ("delete", show sbs ) ]+ void $ zulipMakeRequest Subscriptions methodPatch form - r <- getWith opts (clientSession z) (eventsUrl z) >>= asJSON- let body = r ^. responseBody+-- |+-- Fetches new set of events from a `Queue`.+getEvents :: Queue -> Bool -> ZulipM (Queue, [Event])+getEvents q b = do+ let qs = [ ("queue_id" , queueId q)+ , ("last_event_id", show $ lastEventId q)+ , ("dont_block" , if b then "true" else "false")+ ] - 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+ body <- zulipMakeRequest Events methodGet qs >>= decodeResponse+ 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) -- | -- 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 >>=+onNewEvent :: [String] -> EventCallback -> ZulipM ()+onNewEvent etypes f = do+ q <- registerQueue etypes False+ handleAll (tryAgain q) (loop q)+ where tryAgain :: Queue -> SomeException -> ZulipM ()+ tryAgain q _ = do+ liftIO (threadDelay 1000000)+ handleAll (tryAgain q) (loop q)+ loop q = getEvents 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 ->+onNewMessage :: MessageCallback -> ZulipM ()+onNewMessage f = onNewEvent ["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.@@ -176,33 +265,66 @@ -- Private functions: ------------------------------------------------------------------------------- +data Endpoint = Messages | Register | Events | Subscriptions | Streams+ -- |--- Returns `True` if a response indicates success-wasSuccessful :: ZT.Response -> Bool-wasSuccessful = (== ResponseSuccess) . responseResult+-- Key-value pair abstraction for working with querystrings or form-data+type RequestData = [(T.Text, String)] -- |--- Gets the endpoint for creating messages for a given `ZulipClient`-messagesUrl :: ZulipClient -> String-messagesUrl = (++ "/messages") . clientBaseUrl+-- Makes a request to some @Endpoint@ in the zulip API+zulipMakeRequest :: Endpoint -> Method -> RequestData -> ZulipM BL.ByteString+zulipMakeRequest e = zulipMakeRequest' (endpointSuffix e) -- |--- Gets the endpoint for registering event queues for a given `ZulipClient`-registerUrl :: ZulipClient -> String-registerUrl = (++ "/register") . clientBaseUrl+-- Makes a request to some untyped URL in the zulip API. Serializes the+-- data as a QueryString on GET requests and as form-data otherwise+zulipMakeRequest' :: String -> Method -> RequestData -> ZulipM BL.ByteString+zulipMakeRequest' u m d = do+ z <- ask+ req <- liftIO $ parseUrl (clientBaseUrl z ++ u)+ req' <- prepareRequest d req+ res <- liftIO $ httpLbs req' { method = m } $ clientManager z+ return $ responseBody res -- |--- Gets the endpoint for fetching events for a given `ZulipClient`-eventsUrl :: ZulipClient -> String-eventsUrl = (++ "/events") . clientBaseUrl+-- A helper for decoding a response in the Zulip monad+decodeResponse :: BL.ByteString -> ZulipM ZT.Response+decodeResponse b = case decode b of+ Just r -> if wasSuccessful r then return r+ else fail $ responseMsg r+ _ -> fail $ "Unexpected response from the Zulip API: " ++ CL.unpack b -- |--- Gets the endpoint for fetching subscriptions for a given `ZulipClient`-subscriptionsUrl :: ZulipClient -> String-subscriptionsUrl = (++ "/users/me/subscriptions") . clientBaseUrl+-- Adds a QueryString or FormData body, represented by a list of tuples,+-- and authenticates the request, with the current zulip state's+-- credentials.+prepareRequest :: RequestData -> Request -> ZulipM Request+prepareRequest [] r = applyAuth r+prepareRequest d r | method r == methodGet =+ applyAuth $ setQueryString (map helper d) r+ where helper (k, v) = (encodeUtf8 k, Just $ C.pack v)+prepareRequest d r =+ applyAuth =<< formDataBody (map (uncurry partBS . second C.pack) d) r -- |--- 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)+-- Adds authentication to a 'Request' with the configuration in the 'ZulipM'+-- monad+applyAuth :: Request -> ZulipM Request+applyAuth req = do+ ZulipOptions e k _ _ <- ask+ return $ applyBasicAuth (C.pack e) (C.pack k) req++-- |+-- Returns `True` if a response indicates success+wasSuccessful :: ZT.Response -> Bool+wasSuccessful = (== ResponseSuccess) . responseResult++-- |+-- Gets the suffix for some endpoint+endpointSuffix :: Endpoint -> String+endpointSuffix Messages = "/messages"+endpointSuffix Events = "/events"+endpointSuffix Register = "/register"+endpointSuffix Subscriptions = "/users/me/subscriptions"+endpointSuffix Streams = "/streams"
src/Web/HZulip/Types.hs view
@@ -1,21 +1,32 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Web.HZulip.Types where import Control.Applicative ((<$>), (<*>), (<|>), pure) import Control.Monad (mzero)-import Data.Aeson-import Data.Aeson.Types-import Network.Wreq.Session+import Control.Monad.Trans.Reader (ReaderT)+import Data.Aeson.Types (FromJSON(..), Parser, Value(..), (.:?), (.:))+import Network.HTTP.Client (Manager) -- |+-- The Monad in which Zulip API actions happen in. This is a 'ReaderT'+-- alias, so it's also a instance of 'MonadTrans', 'MonadIO' etc.+type ZulipM a = ReaderT ZulipOptions IO a++-- | -- Represents a Zulip API client-data ZulipClient = ZulipClient { clientEmail :: String- , clientApiKey :: String- , clientBaseUrl :: String- , clientSession :: Session- }- deriving (Show)+data ZulipOptions = ZulipOptions { clientEmail :: String+ , clientApiKey :: String+ , clientBaseUrl :: String+ , clientManager :: Manager+ } +instance Show ZulipOptions where+ show ZulipOptions{..} = "ZulipOptions { " ++ show clientEmail +++ "\n , " ++ show clientApiKey +++ "\n , " ++ show clientBaseUrl +++ "\n , Manager {...}\n}"+ -- | -- The internal response representation for top-down parsing of Zulip API -- JSON responses@@ -87,11 +98,11 @@ -- | -- The root type for Event callbacks-type EventCallback = Event -> IO ()+type EventCallback = Event -> ZulipM () -- | -- Type for message callbacks-type MessageCallback = Message -> IO ()+type MessageCallback = Message -> ZulipM () instance FromJSON Response where parseJSON (Object o) = Response <$>