Ranka-0.1: Omegle.hs

module Omegle (
    OmegleState,
    newOmegleState,
    getOmegleState,
    startOmegle,
    stopOmegle,
    sendToOmegle,
    startAndSendToOmegle
) where

import Network.XMPP
import Network.XMPP.MUC

import Network
import Data.IORef
import Control.Concurrent
import Network.HTTP
import Network.URI
import Text.JSON
import Text.JSON.String
import Codec.Binary.UTF8.String

import Data.List

-- | Omegle connection state.
type OmegleState = IORef Omegle
data Omegle = NoConnect | Connect OmegleID
type OmegleID = String

-- | Create IORef.
newOmegleState :: IO OmegleState
newOmegleState = newIORef NoConnect

-- | Get state.
getOmegleState :: OmegleState -> IO String
getOmegleState omegleState = do
    omegle <- readIORef omegleState
    return $ case omegle of
      NoConnect -> "not connected"
      Connect oID -> "connected, id:"++oID

-- | Start new omegle chat.
startOmegle :: OmegleState -> TCPConnection -> String -> IO String
startOmegle omegleState c room = do
    omegle <- readIORef omegleState
    case omegle of
      Connect oID -> return $ "FAIL, already connected, id:"++oID
      NoConnect -> do oID <- getNewOmegleID
                      writeIORef omegleState (Connect oID)
                      forkIO $ runOmegleEvents omegleState c room
                      return ""

-- | Stop omegle chat.
stopOmegle :: OmegleState -> IO String
stopOmegle omegleState = do
    omegle <- readIORef omegleState
    case omegle of
      NoConnect -> return "FAIL, not connected"
      Connect oID -> do writeIORef omegleState NoConnect
                        sendOmegleDisconnect oID
                        return ""

-- | Send message to omegle chat.
sendToOmegle :: OmegleState -> String -> IO String
sendToOmegle omegleState msg = do
    omegle <- readIORef omegleState
    case omegle of
      NoConnect -> return "FAIL, not connected"
      Connect oID -> do responce <- sendToOmegleID oID msg
                        return $ if responce == "fail"
                                   then "FAIL"
                                   else ""

-- | Start and send.
startAndSendToOmegle :: OmegleState
                     -> TCPConnection
                     -> String
                     -> String
                     -> IO String
startAndSendToOmegle omegleState c room msg = do
    omegle <- readIORef omegleState
    case omegle of
      Connect oID -> sendToOmegle omegleState msg
      NoConnect -> do startOmegle omegleState c room
                      threadDelay 300000 -- waiting before sending
                                         -- message after connect
                      startAndSendToOmegle omegleState c room msg

-----------------------------------------------

-- | Check omegle event, sleep and run again.
runOmegleEvents :: OmegleState -> TCPConnection -> String -> IO ()
runOmegleEvents omegleState c room = do
    omegle <- readIORef omegleState
    case omegle of
      NoConnect -> return ()
      Connect oID -> do
        responce <- getOmegleResponce oID
        print responce
        case runGetJSON readJSArray responce of
          Right (JSArray a) -> do
            msgs' <- mapM parseArr a
            let msgs = filt msgs'
            if null msgs
              then return ()
              else runXMPP c $ sendGroupchatMessage room msgs
            threadDelay 3000000 -- waiting before new loop
            runOmegleEvents omegleState c room
          _ -> do stopOmegle omegleState
                  runXMPP c $ sendGroupchatMessage room "[disconnect]"

        where
          parseArr (JSArray [JSString jscmd, JSString jsmsg])
            | pJSStr jscmd "gotMessage" = return $ fromJSString jsmsg
          parseArr (JSArray [JSString jscmd, JSString jsmsg])
            | pJSStr jscmd "strangerDisconnected" = stopOmegle omegleState >>
                                                    return "[disconnect]"
          parseArr _ = return ""

          pJSStr jsStr = (==) (fromJSString jsStr)

          filt = intercalate "\n" . filter (not . null)

-- | Get omegle id.
getNewOmegleID :: IO OmegleID
getNewOmegleID = do
    id' <- post "http://omegle.com/start" ""
    return $ init $ tail $ id'

-- | Get responce from omegle.
getOmegleResponce :: OmegleID -> IO String
getOmegleResponce oID = post "http://omegle.com/events" ("id="++oID)

-- | Disconnect from omegle.
sendOmegleDisconnect :: OmegleID -> IO String
sendOmegleDisconnect oID = post "http://omegle.com/disconnect" ("id="++oID)

-- | Send msg to omegle.
sendToOmegleID :: OmegleID -> String -> IO String
sendToOmegleID oID msg = let msg' = urlEncode $ encodeString msg
                         in post "http://omegle.com/send"
                            ("msg="++msg'++"&id="++oID)

-----------------------------------------------

-- | Do post request and return responce body
post :: String -> String -> IO String
post uriStr body =
    let uri = maybe nullURI id $ parseURI uriStr
    in simpleHTTP (request uri body) >>= getResponseBody

-- | Request construcion.
request :: URI -> String -> Request String
request uri body =
    Request { rqURI     = uri
            , rqMethod  = POST
            , rqHeaders = [ Header HdrContentLength (show $ length body)
                          , Header HdrContentType
                            "application/x-www-form-urlencoded; charset=utf-8"
                          ]
            , rqBody    = body
            }