module Web.HZulip ( Event(..)
, Message(..)
, Queue(..)
, User(..)
, ZulipOptions(..)
, ZulipM
, EventCallback
, MessageCallback
, addSubscriptions
, addAllSubscriptions
, defaultBaseUrl
, eventTypes
, getEvents
, getStreams
, getStreamSubscribers
, getSubscriptions
, onNewEvent
, onNewMessage
, registerQueue
, removeSubscriptions
, runZulip
, sendMessage
, sendPrivateMessage
, sendStreamMessage
, sinkZulipMessages
, sourceZulipEvents
, sourceZulipMessages
, withZulip
, withZulipCreds
, zulipOptions
, lift
, ask
)
where
import Control.Arrow (second)
import Control.Concurrent.STM (TBQueue, atomically, writeTBQueue)
import Control.Lens ((^..))
import Control.Monad (void)
import Control.Monad.Catch (catch, throwM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Reader (ask, runReaderT)
import Data.Aeson (decode)
import Data.Aeson.Lens (key, values, _String)
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.Conduit (Sink, Source, await)
import Data.Conduit.Async (gatherFrom)
import Data.List (intercalate)
import Data.Text as T (Text, unpack)
import Data.Text.Encoding as T (encodeUtf8)
import Network.HTTP.Client (Request, HttpException(..), 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
zulipOptions :: String -> String -> IO ZulipOptions
zulipOptions e k = do
manager <- newManager tlsManagerSettings
return $ ZulipOptions e k defaultBaseUrl manager
runZulip :: ZulipM a -> ZulipOptions -> IO a
runZulip = runReaderT
withZulip :: ZulipOptions -> ZulipM a -> IO a
withZulip = flip runZulip
withZulipCreds :: String -> String -> ZulipM a -> IO a
withZulipCreds e k action = do
opts <- zulipOptions e k
runZulip action opts
defaultBaseUrl :: String
defaultBaseUrl = "https://api.zulip.com/v1"
eventTypes :: [String]
eventTypes = ["message", "subscriptions", "realm_user", "pointer"]
sendMessage :: String -> [String] -> String -> String -> ZulipM Int
sendMessage mtype mrecipients msubject mcontent = do
let form = [ ("type" , mtype)
, ("content", mcontent)
, ("to" , show mrecipients)
, ("subject", msubject)
]
body <- zulipMakeRequest Messages methodPost form >>= decodeResponse
let Just mid = responseMessageId body in return mid
sendPrivateMessage :: [String] -> String -> ZulipM Int
sendPrivateMessage mrs = sendMessage "private" mrs ""
sendStreamMessage :: String -> String -> String -> ZulipM Int
sendStreamMessage s = sendMessage "stream" [s]
registerQueue :: [String] -> Bool -> ZulipM Queue
registerQueue evTps mdn = do
let form = [ ("event_types" , show evTps)
, ("apply_markdown", if mdn then "true" else "false")
]
body <- zulipMakeRequest Register methodPost form >>= decodeResponse
let Just qid = responseQueueId body
Just lid = responseLastEventId body
in return $ Queue qid lid
getStreams :: ZulipM [String]
getStreams = do
r <- zulipMakeRequest Streams methodGet []
return $ map T.unpack $ r ^.. key "streams" . values
. key "name" . _String
getStreamSubscribers :: String -> ZulipM [String]
getStreamSubscribers s = do
r <- zulipMakeRequest' ("/streams/" ++ s ++ "/members") methodGet []
return $ map T.unpack $ r ^.. key "subscribers" . values . _String
getSubscriptions :: ZulipM [String]
getSubscriptions = do
r <- zulipMakeRequest Subscriptions methodGet []
return $ map T.unpack $ r ^.. key "subscriptions" . values
. key "name" . _String
addAllSubscriptions :: ZulipM [String]
addAllSubscriptions = do
ss <- getStreams
addSubscriptions ss
return ss
addSubscriptions :: [String] -> ZulipM ()
addSubscriptions sbs = do
let sbs' = intercalate "," $ map (\s -> "{\"name\":" ++ show s ++ "}") sbs
form = [ ("add", "[" ++ sbs' ++ "]") ]
void $ zulipMakeRequest Subscriptions methodPatch form
removeSubscriptions :: [String] -> ZulipM ()
removeSubscriptions sbs = do
let form = [ ("delete", show sbs ) ]
void $ zulipMakeRequest Subscriptions methodPatch form
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")
]
body <- zulipMakeRequest Events methodGet qs >>= decodeResponse
let Just evs = responseEvents body
lEvId = maximum $ map eventId evs
in return (q { lastEventId = lEvId }, evs)
onNewEvent :: [String] -> EventCallback -> ZulipM ()
onNewEvent etypes f = do
q <- registerQueue etypes False
loop q
where getEvents' q = catch (getEvents q False) (onTimeout q)
loop q = do
(q', evts) <- getEvents' q
mapM_ f evts
loop q'
onTimeout q ResponseTimeout = getEvents' q
onTimeout _ ex = throwM ex
onNewMessage :: MessageCallback -> ZulipM ()
onNewMessage f = onNewEvent ["message"] $ \evt ->
maybe (return ()) f (eventMessage evt)
sinkZulipMessages :: Sink (String, [String], String, String) ZulipM ()
sinkZulipMessages = loop
where loop = await >>= maybe (return ())
(\(w, x, y, z) -> do
void $ lift $ sendMessage w x y z
loop)
sourceZulipEvents :: Int
-> [String]
-> Source ZulipM Event
sourceZulipEvents bufSize evts = gatherFrom bufSize $
onNewEvent evts . zulipWriteTBQueueIO
sourceZulipMessages :: Int
-> Source ZulipM Message
sourceZulipMessages bufSize = gatherFrom bufSize $
onNewMessage . zulipWriteTBQueueIO
data Endpoint = Messages | Register | Events | Subscriptions | Streams
type RequestData = [(T.Text, String)]
zulipMakeRequest :: Endpoint -> Method -> RequestData -> ZulipM BL.ByteString
zulipMakeRequest e = zulipMakeRequest' (endpointSuffix e)
zulipMakeRequest' :: String -> Method -> RequestData -> ZulipM BL.ByteString
zulipMakeRequest' u m d = do
z <- ask
req <- liftIO $ parseUrl (clientBaseUrl z ++ u)
req' <- prepareRequest d req m
res <- liftIO $ httpLbs req' { method = m } $ clientManager z
return $ responseBody res
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
prepareRequest :: RequestData -> Request -> Method -> ZulipM Request
prepareRequest [] r _ = applyAuth r
prepareRequest d r m | m == 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
applyAuth :: Request -> ZulipM Request
applyAuth req = do
ZulipOptions e k _ _ <- ask
return $ applyBasicAuth (C.pack e) (C.pack k) req
wasSuccessful :: ZT.Response -> Bool
wasSuccessful = (== ResponseSuccess) . responseResult
endpointSuffix :: Endpoint -> String
endpointSuffix Messages = "/messages"
endpointSuffix Events = "/events"
endpointSuffix Register = "/register"
endpointSuffix Subscriptions = "/users/me/subscriptions"
endpointSuffix Streams = "/streams"
zulipWriteTBQueueIO :: TBQueue a -> a -> ZulipM ()
zulipWriteTBQueueIO q x = lift $ atomically $ writeTBQueue q x