diff --git a/hzulip.cabal b/hzulip.cabal --- a/hzulip.cabal +++ b/hzulip.cabal @@ -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 diff --git a/src/Web/HZulip.hs b/src/Web/HZulip.hs --- a/src/Web/HZulip.hs +++ b/src/Web/HZulip.hs @@ -1,37 +1,99 @@ {-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------------------------- +-- | +-- Module : Web.HZulip +-- Copyright : Pedro Tacla Yamada +-- License : MIT (see LICENSE) +-- +-- Maintainer : Pedro Tacla Yamada +-- 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" diff --git a/src/Web/HZulip/Types.hs b/src/Web/HZulip/Types.hs --- a/src/Web/HZulip/Types.hs +++ b/src/Web/HZulip/Types.hs @@ -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 <$>