module Main where import Control.Concurrent import Network hiding (Service) import Network.IRC.Server import Network.Twitter import System.Environment import Control.Concurrent.STM import Control.Exception hiding (try) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Network.Curl import Network.IRC.Base import Network.IRC.Server.User as IU import Network.Twitter.Status import Network.Twitter.User as TU import Prelude hiding (catch) import Text.ParserCombinators.Parsec main :: IO () main = withCurlDo $ do ircd <- startIRCd "twitprox" (PortNumber 9090) setMOTD ircd motd startProxServ ircd loop where loop = threadDelay 10000000 >> loop data ProxServ = ProxServ { psSessions :: TVar (Map String Session) } data ServCommand = Login String String (Maybe String) | Logout String String data Session = Session { sUserID :: String , sUserPW :: String , sAPI :: Twitter , sThreadId :: ThreadId } parseServCmd :: Parser ServCommand parseServCmd = ( try $ do spaces string "!logout" many1 (char ' ') twitterID <- many1 $ satisfy (/= ' ') many1 (char ' ') twitterPW <- many1 $ satisfy (/= ' ') spaces eof return $ Logout twitterID twitterPW ) <|> ( try $ do spaces optional $ do string "!login" many1 (char ' ') twitterID <- many1 $ satisfy (/= ' ') many1 (char ' ') twitterPW <- many1 $ satisfy (/= ' ') channelPW <- optionMaybe $ do many1 (char ' ') many1 $ satisfy (/= ' ') spaces eof return $ Login twitterID twitterPW channelPW ) parseChName :: Parser String parseChName = do string "#Twitter:" twitterID <- many1 anyChar eof return twitterID startProxServ :: IRCd -> IO IU.User startProxServ ircd = do serv <- mkServ' let srv = Service (handler serv) myNick "http://twitter.com/" addUser ircd srv addChannel ircd errorCh addChannelUser ircd errorCh myNick return srv where myNick :: String myNick = "TwitterServ" errorCh :: String errorCh = "#TwitterErrors" mkServ' :: IO ProxServ mkServ' = do sess <- newTVarIO M.empty return ProxServ { psSessions = sess } handler :: ProxServ -> Message -> IO () handler serv (Message (Just (NickName nick _ _)) "PRIVMSG" [name, str]) | name == myNick = do Just usr <- findUser ircd myNick case parse parseServCmd "" str of Left err -> sendPrivmsg ircd usr nick (show err) Right cmd -> handleSrvCmd serv usr nick cmd `catch` \ e -> replyError usr nick e | otherwise = do usr <- findUser ircd nick case usr of Just (Registered _ _ _ _ _) -> case parse parseChName "" name of Left _ -> return () Right uid -> do sess <- atomically $ readTVar $ psSessions serv case M.lookup uid sess of Nothing -> return () Just (Session _ _ tw _) -> updateStatus tw str _ -> return () handler _ _ = return () handleSrvCmd :: ProxServ -> IU.User -> String -> ServCommand -> IO () handleSrvCmd serv usr nick (Login i p1 p2) = handleLogin serv usr nick i p1 p2 handleSrvCmd serv _ _ (Logout i p) = handleLogout serv i p handleLogin :: ProxServ -> IU.User -> String -> String -> String -> Maybe String -> IO () handleLogin serv usr nick uid twPass chPass = do sess <- atomically $ readTVar $ psSessions serv case M.lookup uid sess of Just _ -> fail ("User " ++ uid ++ " is already logged-in. Type \"/join " ++ twChannel uid ++ " \" if you know the password.") Nothing -> do sendPrivmsg ircd usr nick "Logging-in to the Twitter. Please wait..." tw <- newTwitter Nothing (Just "twitprox") login tw uid twPass let ch = twChannel uid chPass' = fromMaybe twPass chPass delChannel ircd ch "This channel is going to be recreated" addChannel ircd ch addChannelUser ircd ch myNick setChannelMode ircd (Just usr) ch ["+k", chPass'] addFriends ch =<< getFriends tw s <- mkSession usr uid twPass tw atomically $ writeTVar (psSessions serv) (M.insert uid s sess) sendPrivmsg ircd usr nick "You are successfully logged-in to the Twitter." addChannelUser ircd ch nick return () mkSession :: IU.User -> String -> String -> Twitter -> IO Session mkSession usr uid twPass tw = do tid <- forkIO $ ( (mapM_ (showStatus uid) =<< getTimeline tw) `catch` \ e -> replyError usr errorCh e ) return $ Session uid twPass tw tid killSession :: Session -> IO () killSession = killThread . sThreadId showStatus :: String -> Status -> IO () showStatus uid st = do u <- findUser ircd (userScreenName $ statUser st) usr <- case u of Just a -> return a Nothing -> do let u' = mkUser $ statUser st addUser ircd u' addChannelUser ircd (twChannel uid) (userNick u') return u' sendPrivmsg ircd usr (twChannel uid) (statText st) mkUser :: TU.User -> IU.User mkUser u = Service (const $ return ()) (userScreenName u) (TU.userName u) addFriends :: String -> [TU.User] -> IO () addFriends _ [] = return () addFriends ch (x:xs) = do addUser ircd (mkUser x) addChannelUser ircd ch (userScreenName x) addFriends ch xs handleLogout :: ProxServ -> String -> String -> IO () handleLogout serv uid twPass = do io <- atomically $ do sess <- readTVar $ psSessions serv case M.lookup uid sess of Nothing -> fail ("User " ++ uid ++ " is not logged-in.") Just s -> if sUserPW s == twPass then do writeTVar (psSessions serv) (M.delete uid sess) return $ do killSession s delChannel ircd (twChannel uid) "This channel is closed due to logging-out." else fail ("Wrong password for user " ++ uid) io twChannel :: String -> String twChannel = ("#Twitter:" ++) replyError :: IU.User -> String -> Exception -> IO () replyError usr nick e = let p = case e of ArithException _ -> True ArrayException _ -> True DynException _ -> True ErrorCall _ -> True IOException _ -> True PatternMatchFail _ -> True _ -> False in if p then sendPrivmsg ircd usr nick (show e) else throwIO e motd :: String motd = foldl (\ a b -> a ++ "\n" ++ b) "" [ "This is an IRC gateway to the Twitter. All messages are transfered in UTF-8." , "" , "To login:" , " /msg TwitterServ [!login] []" , "" , "To logout:" , " /msg TwitterServ !logout " , "" ]