module HZulip ( Event(..)
, Message(..)
, Queue(..)
, User(..)
, ZulipClient(..)
, EventCallback
, MessageCallback
, defaultBaseUrl
, eventTypes
, getEvents
, newZulip
, onNewEvent
, onNewMessage
, registerQueue
, sendMessage
, sendPrivateMessage
, sendStreamMessage
)
where
import Control.Concurrent
import Control.Exception
import Control.Lens ((.~), (&), (^.))
import qualified Data.ByteString.Char8 as BS (pack)
import qualified Data.Text as T (pack)
import Network.Wreq
import qualified Network.Wreq.Types as WT (params)
import HZulip.Types as ZT
newZulip :: String -> String -> ZulipClient
newZulip e k = ZulipClient e k defaultBaseUrl
defaultBaseUrl :: String
defaultBaseUrl = "https://api.zulip.com/v1"
eventTypes :: [String]
eventTypes = ["message", "subscriptions", "realm_user", "pointer"]
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
sendPrivateMessage :: ZulipClient -> [String] -> String -> IO Int
sendPrivateMessage z mrs = sendMessage z "private" mrs ""
sendStreamMessage :: ZulipClient -> String -> String -> String -> IO Int
sendStreamMessage z s = sendMessage z "stream" [s]
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
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
lEvId = maximum $ map eventId evs in
return (q { lastEventId = lEvId }, evs)
else fail $ responseMsg body
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 >> loop q
loop q = getEvents z q False >>=
\(q', evts) -> mapM_ f evts >>
loop q'
onNewMessage :: ZulipClient -> MessageCallback -> IO ()
onNewMessage z f = onNewEvent z ["message"] $ \evt ->
maybe (return ()) f (eventMessage evt)
wasSuccessful :: ZT.Response -> Bool
wasSuccessful = (== ResponseSuccess) . responseResult
messagesUrl :: ZulipClient -> String
messagesUrl = (++ "/messages") . clientBaseUrl
registerUrl :: ZulipClient -> String
registerUrl = (++ "/register") . clientBaseUrl
eventsUrl :: ZulipClient -> String
eventsUrl = (++ "/events") . clientBaseUrl
reqOptions :: ZulipClient -> Options
reqOptions (ZulipClient e k _) = defaults & auth .~ basicAuth (BS.pack e) (BS.pack k)