RTM.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}

module Network.Danibot.Slack.RTM (
          fromWSSURI
        , loopRTM
    ) where

import qualified Data.Monoid.Cancellative as Textual
import qualified Data.Monoid.Textual as Textual
import Data.Text (Text)
import Data.ByteString (ByteString)
import qualified Data.ByteString 
import qualified Data.ByteString.Lazy.Char8 as Bytes.Lazy.Char8
import Data.Aeson (eitherDecode',encode)
import Control.Monad
import Control.Monad.IO.Class
import Control.Exception
import Control.Concurrent.Conceit
import Control.Foldl (impurely,FoldM)
import Streaming (Stream)
import Streaming.Prelude (Of)
import qualified Streaming as Streaming
import qualified Streaming.Prelude as Streaming
import qualified Wuss
import qualified Network.WebSockets as Webs

import Network.Danibot.Slack.Types(Wire(..),Event(..),OutboundMessage(..))

data WSSEndpoint = WSSEndpoint
    {
      host :: Text
    , path :: Text 
    } deriving (Show)

fromWSSURI :: Text -> Either String WSSEndpoint
fromWSSURI uri = 
    case Textual.stripPrefix "wss://" uri of
        Nothing   -> Left "malformed wss uri"
        Just uri' -> case Textual.break_ True (=='/') uri' of
            (host,web) -> Right (WSSEndpoint host web)

{-| Connect to the Slack RTM websocket.		

-}
ws :: FoldM IO Event () -- ^ Fold for processing incoming messages.
   -> Stream (Of OutboundMessage) IO () -- ^ Stream that produces outbound messages.
   -> Webs.ClientApp ()
ws eventFold messageStream connection = 
    let conceited =
            (_Conceit (impurely Streaming.foldM_ eventFold eventStream))
            *> 
            (_Conceit (Streaming.mapM_ sendMessage messageStream))
        eventStream = forever (do
            message <- liftIO (Webs.receiveData connection)
            case eitherDecode' message of
                Left errmsg -> 
                    liftIO (throwIO (userError ("Malformed msg: " ++ errmsg)))
                Right (Wire event) -> do
                    liftIO (Bytes.Lazy.Char8.putStrLn (encode event))
                    Streaming.yield event)
        sendMessage = 
            Webs.sendTextData connection . encode . Wire
    in _runConceit conceited


loopRTM :: FoldM IO Event ()
        -> Stream (Of OutboundMessage) IO ()
        -> WSSEndpoint 
        -> IO ()
loopRTM eventHandler messageEmitter (WSSEndpoint host path) = do  
    Wuss.runSecureClient (Textual.fromText host) 
                         443
                         (Textual.fromText path) 
                         (ws eventHandler messageEmitter)