diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014 Christopher Reichert + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hstorchat.cabal b/hstorchat.cabal new file mode 100644 --- /dev/null +++ b/hstorchat.cabal @@ -0,0 +1,47 @@ +name: hstorchat +version: 0.1.0.0 +synopsis: Distributed instant messaging over Tor +copyright: (c) 2014 Christopher Reichert +license: GPL-3 +license-file: LICENSE +author: Christopher Reichert +maintainer: creichert07@gmail.com +build-type: Simple +cabal-version: >=1.10 +category: Network +stability: experimental +data-files: qml/*.qml, qml/img/*.png +description: + A Distributed instant messaging application built on Tor Hidden Services. + + Compatible with the original TorChat client. + +library + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >=4.6 && <4.7, network, + socks, process, hsqml>=0.3, safecopy, tagged, + attoparsec, text, socks, random, containers + exposed-modules: Network.HSTorChat.Client, + Network.HSTorChat.GUI, + Network.HSTorChat.Protocol + +executable hstorchat + main-is: src/Main.hs + ghc-options: -Wall -threaded -fno-warn-unused-do-bind + default-language: Haskell2010 + build-depends: base >=4.6 && <4.7, network, hstorchat, process, + hsqml>=0.3, text, containers + +test-suite hstorchat-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + ghc-options: -Wall + default-language: Haskell2010 + build-depends: base, hstorchat, test-framework, test-framework-hunit, + test-framework-quickcheck2, HUnit, QuickCheck + +source-repository head + type: git + location: https://github.com/creichert/hstorchat diff --git a/qml/HSTorChat.qml b/qml/HSTorChat.qml new file mode 100644 --- /dev/null +++ b/qml/HSTorChat.qml @@ -0,0 +1,160 @@ + +import QtQuick 2.0 +import QtQuick.Controls 1.1 +import QtQuick.Layouts 1.1 + +ApplicationWindow { + width: 525; height: 400 + title: "HSTorChat" + visible: true + + toolBar: ToolBar { + RowLayout { + anchors.fill: parent + ComboBox { + model: [ "Available", "Away", "Extended Away" ] + onCurrentIndexChanged: { setStatus(model[currentIndex]) } + } + TextField { + id: newbuddy + anchors.right: addBuddyButton.left + maximumLength: 16 + focus: true + validator: RegExpValidator { regExp: /[_\-2-7a-z]+\.onion/ } + placeholderText: "New buddy..." + } + ToolButton { + id: addBuddyButton + anchors.right: parent.right + text: "add" + onClicked: { newBuddy(newbuddy.text); newbuddy.text = "" } + } + } + } + + ListView { + id: buddylist + anchors.left: parent.left + anchors.top: parent.top + anchors.bottom: parent.bottom + anchors.margins: 3 + currentIndex: 0 + clip: true + width: 160 + focus: true + + Rectangle { + anchors.fill: parent + color: "lightgrey" + z: -1 + radius: 2 + } + + model: buddies + delegate: Text { + width: parent.width + text: modelData.onion + color: "white" + font.pointSize: 11 + z: 5 + MouseArea { + anchors.fill: parent + onClicked: { buddylist.currentIndex = index } + } + + Rectangle { + anchors.right: parent.right + width: 10; height: parent.height + radius: 10 + color: { if (modelData.status == "Available") + return "green" + else if (modelData.status == "Handshake") + return "steelblue" + else if (modelData.status == "Away") + return "orange" + else if (modelData.status == "Xa") + return "red" + else + return "grey" + } + } + } + + highlight: Rectangle { color: "grey"; radius: 2 } + } + + ListView { + id: msgarea + anchors.bottom: msgentrylayout.top + anchors.right: parent.right + anchors.top: parent.top + anchors.left: buddylist.right + anchors.margins: 3 + clip: true + verticalLayoutDirection: ListView.BottomToTop + model: { if (buddies[buddylist.currentIndex]) + buddies[buddylist.currentIndex].msgs } + delegate: Text { text: modelData.text + horizontalAlignment: { if (modelData.fromme) + Text.AlignRight + } + width: parent.width + wrapMode: Text.WrapAtWordBoundaryOrAnywhere + } + + Image { + anchors.horizontalCenter: parent.horizontalCenter + anchors.verticalCenter: parent.verticalCenter + width: parent.width / 1.3; height: parent.height / 2 + opacity: 0.2 + source: "img/hs.png" + } + } + + + Rectangle { + id: msgentrylayout + anchors.bottom: parent.bottom + anchors.left: buddylist.right + anchors.right: parent.right + anchors.margins: 5 + + width: parent.width; height: 80 + border.color: "darkgrey"; border.width: 1; radius: 6 + + Flickable { + id: msgentryflick + anchors.fill: parent + anchors.margins: 2 + + contentWidth: msgentry.paintedWidth + contentHeight: msgentry.paintedHeight + clip: true + + function ensureVisible(r) { + if (contentX >= r.x) + contentX = r.x; + else if (contentX+width <= r.x+r.width) + contentX = r.x+r.width-width; + if (contentY >= r.y) + contentY = r.y; + else if (contentY+height <= r.y+r.height) + contentY = r.y+r.height-height; + } + + TextEdit { + id: msgentry + width: msgentryflick.width + height: msgentryflick.height + focus: true + wrapMode: TextEdit.Wrap + onCursorRectangleChanged: msgentryflick.ensureVisible(cursorRectangle) + Keys.onReturnPressed: { if (buddylist.length <= 0) return + sendMsg(buddies[buddylist.currentIndex], msgentry.text) + msgentry.text = "" + msgarea.positionViewAtBeginning() + } + } + } + } +} diff --git a/qml/img/hs.png b/qml/img/hs.png new file mode 100644 Binary files /dev/null and b/qml/img/hs.png differ diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import qualified Data.Map as M +import Data.Text as T +import Graphics.QML +import Network.Socket +import System.IO +import System.Process + +import Network.HSTorChat.Client +import Network.HSTorChat.Protocol + +import Paths_hstorchat + + +gentorrc :: String -> IO () +gentorrc dd = writeFile (dd ++ "/torrc") $ Prelude.unlines + [ "SocksPort " ++ socksport + -- we don't use the control port currently, so leave this alone + --, "ControlPort 11119" + -- INCOMING connections for the hidden service arrive at 11009 + -- and will be forwarded to TorChat at 127.0.0.1:22009 + , "HiddenServiceDir " ++ dd ++ "/hidden_service" + , "HiddenServicePort " ++ hsport ++ " 127.0.0.1:" ++ hstcport + -- where should tor store it's cache files + , "DataDirectory " ++ dd ++ " tor_data" + -- some tuning + , "AvoidDiskWrites 1" + , "LongLivedPorts " ++ hstcport + , "FetchDirInfoEarly 1" + , "CircuitBuildTimeout 30" + , "NumEntryGuards 6" + -- You can uncomment the lines below to log Tor's activity to the + -- console or to a log file. Use this only during debugging! + -- Turning off SaveLogging will leave sensitive information on your disk, + -- the built in default is save logging turned on (set to 1). + -- so don't remove the # from that line unless you need it + -- and remember to put it in again, after you are done. + --, "Log info File tor.log" + --, "Log info stdout" + --, "SafeLogging 0" + ] + where hsport = show hstorchatHSPort + hstcport = show hstorchatLocalPort + socksport = show torSocksPort + +-- | Wait until the hidden service hostname file +-- is ready +hiddenServiceName :: IO String +hiddenServiceName = catch (do dd <- getDataDir + readFile $ dd ++ "/hidden_service/hostname") + (\e -> print (e :: IOException) + >> threadDelay 5000 + >> hiddenServiceName) + +main :: IO () +main = withSocketsDo $ do + + dd <- getDataDir + gentorrc dd + _ <- createProcess $ proc "tor" ["-f", dd ++ "/torrc"] + + onion <- hiddenServiceName + let myonion = T.take 16 $ T.pack onion + putStr $ "Hello " ++ onion + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 + + li <- inet_addr hstorchatHost + bindSocket sock $ SockAddrInet hstorchatLocalPort li + listen sock 2 + + buddies <- newMVar M.empty + p <- newMVar [] + + tc <- newObjectDC $ TorChat myonion Available buddies p + + _ <- forkIO $ forever $ do + (insock,_) <- accept sock + iHdl <- socketToHandle insock ReadWriteMode + hSetBuffering iHdl LineBuffering + forkIO $ newConnectionRequest tc iHdl + + doc <- getDataFileName "qml/HSTorChat.qml" + runEngineLoop defaultEngineConfig { + initialDocument = fileDocument doc + , contextObject = Just $ anyObjRef tc + } diff --git a/src/Network/HSTorChat/Client.hs b/src/Network/HSTorChat/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/HSTorChat/Client.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.HSTorChat.Client (newConnectionRequest + ) where + +import Control.Concurrent +import Control.Exception +import Data.Attoparsec.Text hiding (take) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Proxy +import Graphics.QML +import System.IO +import System.IO.Error +import System.Random + +import Network.HSTorChat.Protocol +import Network.HSTorChat.GUI + +-- | This loop handles a new Buddy connection request. +newConnectionRequest :: ObjRef TorChat -> Handle -> IO () +newConnectionRequest tc iHdl = do + + bs <- buds + txt <- hGetLine iHdl + case parseOnly parsePingPong (T.pack txt) of + + Left e -> putStr "Error parsing incoming connection: " >> print e + + Right (Ping onion cky) + -- Can this interrupt a legitimate connection? + | buddyonline (M.lookup onion bs) -> putStrLn $ "Already a connection to: " ++ T.unpack onion + | otherwise -> pending >>= initiateConn onion cky . filter ((== onion) . _ponion) + + -- When a Pong is received an attempt is made + -- to authenticate using the cookie we sent. + Right (Pong cke) -> pending >>= authorizePendingConnection tc iHdl . filter ((== cke) . _pcookie) + + _ -> putStrLn "Buddy is not authenticated yet. Ignoring message." + where + -- | Initiate a new connection from scratch. + initiateConn o c [] = do oHdl <- hstorchatOutConn $ o `T.append` ".onion" + gen <- getStdGen + let cky = gencookie gen + case oHdl of + (Just hdl) -> reply (PendingConnection cky o hdl) $ Ping myonion cky : stdrply c + Nothing -> putStrLn $ "Error connecting to " ++ T.unpack o + + -- | Complete an existing pending connection. + initiateConn _ c (pconn:_) = reply pconn $ stdrply c + reply p msgs = do mapM_ (hPutStrLn (_pouthandle p) . formatMsg) msgs + modifyMVar_ (_pending $ fromObjRef tc) + $ \ps -> return $ p : filter ((/= _ponion p) . _ponion) ps + newConnectionRequest tc iHdl + buddyonline Nothing = False + buddyonline (Just bud) = _status (fromObjRef bud) /= Offline + gettc = fromObjRef tc + pending = readMVar $ _pending gettc + buds = readMVar $ _buddies gettc + myonion = _myonion gettc + stdrply k = [ Pong k + , Client "HSTorChat" + , Version "0.1.0.0" + , AddMe + , Status Available ] + +authorizePendingConnection :: ObjRef TorChat -> Handle -> [PendingConnection] -> IO () +authorizePendingConnection _ _ [] = putStrLn "Security Warning: Attempted connection with unidentified cookie." +-- | A pending connection exists. Verify and start the buddy +authorizePendingConnection tc iHdl (PendingConnection cke o oHdl : _) = do + + let tc' = fromObjRef tc + bs <- readMVar $ _buddies tc' + bud <- constructBuddy $ M.lookup o bs + + -- Filter this connection. + modifyMVar_ (_pending tc') $ \ps -> return $ filter ((/= cke) . _pcookie) ps + modifyMVar_ (_buddies tc') $ \buds -> return $ M.insert o bud buds + fireSignal (Proxy :: Proxy BuddiesChanged) tc + + runBuddyConnection tc bud + where + constructBuddy :: Maybe (ObjRef Buddy) -> IO (ObjRef Buddy) + constructBuddy Nothing = do ms <- newMVar [] + newObjectDC $ Buddy o iHdl oHdl cke Handshake ms + constructBuddy (Just b) = let b' = fromObjRef b in + newObjectDC $ b' { _inConn = iHdl + , _outConn = oHdl + , _cookie = cke + , _status = Handshake + , _msgs = _msgs b' } + +runBuddyConnection :: ObjRef TorChat -> ObjRef Buddy -> IO () +runBuddyConnection tc objb = do + let b = fromObjRef objb + iHdl = _inConn b + oHdl = _outConn b + oni = _onion b + + txt <- hGetLine iHdl `catch` errorHandler + case parseOnly parseResponse (T.pack txt) of + + Left e -> print ("Error parsing incoming message: " ++ e) >> + runBuddyConnection tc objb + + Right (Message msg) -> do + cmsg <- newObjectDC $ ChatMsg msg (_onion b) False + modifyMVar_ (_msgs b) (\ms -> return (cmsg:ms)) + fireSignal (Proxy :: Proxy NewChatMsg) objb + runBuddyConnection tc objb + + Right (Status Offline) -> do + nb <- newObjectDC $ b { _status = Offline } + modifyMVar_ (_buddies $ fromObjRef tc) + $ \bs -> return $ M.insert oni nb bs + fireSignal (Proxy :: Proxy BuddiesChanged) tc + -- Cleanup handles. + hClose iHdl + hClose oHdl + + Right (Status st) -> do + nb <- newObjectDC $ b { _status = st } + modifyMVar_ (_buddies $ fromObjRef tc) + $ \bs -> return $ M.insert oni nb bs + fireSignal (Proxy :: Proxy BuddiesChanged) tc + -- Run the new buddy loop. + runBuddyConnection tc nb + + Right p -> print (T.unpack oni ++ ": " ++ show p) >> runBuddyConnection tc objb + where + errorHandler e + | isEOFError e = return "status offline" + | otherwise = ioError e diff --git a/src/Network/HSTorChat/GUI.hs b/src/Network/HSTorChat/GUI.hs new file mode 100644 --- /dev/null +++ b/src/Network/HSTorChat/GUI.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.HSTorChat.GUI where + +import Control.Concurrent +import qualified Data.Text as T +import Data.Proxy +import Data.Typeable +import Graphics.QML +import System.IO +import System.Random + +import Network.HSTorChat.Protocol + +-- Signals +data BuddiesChanged deriving Typeable +data NewChatMsg deriving Typeable +data BuddyChanged deriving Typeable + +instance DefaultClass TorChat where + classMembers = [ + defPropertySigRO "buddies" (Proxy :: Proxy BuddiesChanged) buddies + -- | Return Onion address for this instance of HSTorChat. + , defMethod "onion" (return . _myonion . fromObjRef :: ObjRef TorChat -> IO Onion) + -- | Send a message to a buddy. + , defMethod "sendMsg" sendMsg + -- | Add a new buddy. + , defMethod "newBuddy" newBuddy + , defMethod "setStatus" statusChanged + ] + where + buddies :: ObjRef TorChat -> IO [ObjRef Buddy] + buddies tc = return . buddylist =<< (readMVar . _buddies $ fromObjRef tc) + +instance DefaultClass ChatMsg where + classMembers = [ + defPropertyRO "buddy" (return . buddy . fromObjRef) + , defPropertyRO "text" (return . text . fromObjRef) + , defPropertyRO "fromme" (return . fromme . fromObjRef) + ] + +instance DefaultClass Buddy where + classMembers = [ + defPropertyRO "onion" (return . _onion . fromObjRef) + , defPropertySigRO "status" (Proxy :: Proxy BuddyChanged) status + , defPropertySigRO "msgs" (Proxy :: Proxy NewChatMsg) messages + ] + where + messages :: ObjRef Buddy -> IO [ObjRef ChatMsg] + messages = readMVar . _msgs . fromObjRef + status = return . T.pack . show . _status . fromObjRef + +instance Marshal ChatMsg where + type MarshalMode ChatMsg c d = ModeObjFrom ChatMsg c + marshaller = fromMarshaller fromObjRef + +instance Marshal Buddy where + type MarshalMode Buddy c d = ModeObjFrom Buddy c + marshaller = fromMarshaller fromObjRef + +instance SignalKeyClass BuddiesChanged where + type SignalParams BuddiesChanged = IO () + +instance SignalKeyClass NewChatMsg where + type SignalParams NewChatMsg = IO () + +instance SignalKeyClass BuddyChanged where + type SignalParams BuddyChanged = IO () + +-- | This function is called when the user enters +-- a msg in a chat window. The handle for the buddy +-- is accessed and used to send the message. +sendMsg :: ObjRef TorChat -> ObjRef Buddy -> T.Text -> IO () +sendMsg _ bud msg + | null (T.unpack msg) = putStrLn "Ignoring empty request." + -- Check if buddy is offline + | (_status . fromObjRef) bud == Offline = putStrLn "[delayed] msg not supported yet." + -- buddy should be able to receive the message + -- TODO: Implement gaurd to check _outConn status. + | otherwise = do + saveMsg $ ChatMsg msg (_onion $ fromObjRef bud) True + fireSignal (Proxy :: Proxy NewChatMsg) bud + hPutStrLn (_outConn $ fromObjRef bud) $ formatMsg $ Message msg + where + saveMsg cmsg = modifyMVar_ (_msgs $ fromObjRef bud) (\ms -> do m <- newObjectDC cmsg + return (m:ms)) + +newBuddy :: ObjRef TorChat -> T.Text -> IO () +newBuddy tc onion + | T.length onion /= 16 = putStrLn $ T.unpack onion ++ " is not 16 characters long." + | otherwise = putStrLn ("Requesting buddy connection: " ++ T.unpack onion) >> + hstorchatOutConn (onion `T.append` ".onion") >>= ping + where ping Nothing = putStrLn $ "Error attempting to connect to " ++ T.unpack onion + ping (Just oHdl) = do gen <- getStdGen + let cky = gencookie gen + tc' = fromObjRef tc + + -- Add to list of pending connection. + modifyMVar_ (_pending tc') + $ \p -> return $ PendingConnection cky onion oHdl : filter ((/= onion) . _ponion) p + hPutStrLn oHdl $ formatMsg $ Ping (_myonion tc') cky + + +statusChanged :: ObjRef TorChat -> T.Text -> IO () +statusChanged tc status + | T.unpack status == "Away" = alert Away + | T.unpack status == "Extended Away" = alert Xa + | otherwise = alert Available + where + alert st = do bs' <- readMVar . _buddies $ fromObjRef tc + bl <- return . map fromObjRef $ buddylist bs' + -- tell online buddies status. + tell (online bl) $ Status st + online = filter $ (/= Offline) . _status + tell [] _ = return () + tell (Buddy _ _ oHdl _ _ _:bs) st = hPutStrLn oHdl (formatMsg st) >> tell bs st diff --git a/src/Network/HSTorChat/Protocol.hs b/src/Network/HSTorChat/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Network/HSTorChat/Protocol.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +module Network.HSTorChat.Protocol where + +import Control.Applicative +import Control.Concurrent +import qualified Control.Exception as E +import Control.Monad +import Data.Attoparsec.Text +import qualified Data.Char as C +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Typeable +import Data.Word +import Graphics.QML +import Prelude hiding (take) +import qualified Prelude as P +import Network +import Network.Socket +import Network.Socks5 +import System.IO +import System.Random + +type Onion = T.Text +type Cookie = T.Text + +data TorChat = TorChat + { _myonion :: Onion + , _mystatus :: BuddyStatus + , _buddies :: MVar (M.Map Onion (ObjRef Buddy)) + , _pending :: MVar [PendingConnection] + } deriving Typeable + +data Buddy = Buddy + { _onion :: Onion -- ^ Buddy onion address. + , _inConn :: Handle + , _outConn :: Handle + , _cookie :: Cookie -- ^ Cookie sent to buddy. + , _status :: BuddyStatus -- ^ Buddy status + , _msgs :: MVar [ObjRef ChatMsg] + } deriving (Typeable) + +data BuddyStatus = Offline + | Handshake + | Available + | Away + | Xa -- ^ Extended Away + deriving (Eq, Read, Show) + +data PendingConnection = PendingConnection + { _pcookie :: Cookie + , _ponion :: Onion + , _pouthandle :: Handle + } deriving Show + +data ProtocolMsg = Ping Onion Cookie + | Pong T.Text + | Client T.Text + | Version T.Text + | Status BuddyStatus + | ProfileName + | ProfileText + | AvatarAlpha + | ProfileAvatar + | AddMe + | RemoveMe + | Message T.Text + | Filename + | Filedata + | FiledataOk + | FiledataError + | FileStopSending + | FileStopReceiving + deriving Show + +data ChatMsg = ChatMsg + { text :: T.Text + , buddy :: T.Text + , fromme :: Bool + } deriving (Show, Typeable) + +gencookie :: StdGen -> Cookie +gencookie g = T.pack . concatMap show $ P.take 3 (randoms g :: [Word64]) + +torSocksPort :: PortNumber +torSocksPort = 22209 + +-- Hidden service port. +hstorchatHSPort :: PortNumber +hstorchatHSPort = 11009 + +-- Port inside Socks5 tunnel. +hstorchatLocalPort :: PortNumber +hstorchatLocalPort = 22009 + +hstorchatHost :: String +hstorchatHost = "127.0.0.1" + +hstorchatOutConn :: Onion -> IO (Maybe Handle) +hstorchatOutConn onion = do + handle <- E.try $ socksConnectWith hstcConf (T.unpack onion) $ PortNumber hstorchatHSPort + case handle of + Left e -> print (e :: SocksError) >> return Nothing + Right o -> do oHdl <- socketToHandle o ReadWriteMode + hSetBuffering oHdl LineBuffering + return $ Just oHdl + where hstcConf = defaultSocksConf hstorchatHost torSocksPort + +-- | Format a message to send over a Socket. +formatMsg :: ProtocolMsg -> String +formatMsg AddMe = "add_me" +formatMsg (Message m) = "message " ++ T.unpack m +formatMsg m = map C.toLower . filter (/= '"') . show $ m + +-- | Return a BuddyList given the M.Map +buddylist :: M.Map Onion (ObjRef Buddy) -> [ObjRef Buddy] +buddylist bs = snd . unzip $ M.toList bs + +parseResponse :: Parser ProtocolMsg +parseResponse = try parsePingPong + <|> try parseVersion + <|> try parseClient + <|> try parseStatus + <|> try parseAddMe + <|> parseMsg + +parsePingPong :: Parser ProtocolMsg +parsePingPong = try parsePing + <|> try parsePong + +parsePing :: Parser ProtocolMsg +parsePing = do + string "ping" + skipSpace + -- parse onion address. + bdy <- take 16 + skipSpace + -- parse secret cookie. + cky <- takeText + return $ Ping bdy cky + +parsePong :: Parser ProtocolMsg +parsePong = do + string "pong" + skipSpace + -- parse secret key. + key <- takeText + return $ Pong key + +parseVersion :: Parser ProtocolMsg +parseVersion = do + string "version" + skipSpace + v <- takeText + return $ Version v + +parseClient :: Parser ProtocolMsg +parseClient = do + string "client" + skipSpace + c <- takeText + return $ Client c + +parseStatus :: Parser ProtocolMsg +parseStatus = do + string "status" + skipSpace + st <- takeText + return $ Status (read $ capitalized (T.unpack st) :: BuddyStatus) + where + capitalized [] = [] + capitalized (x:xs) = C.toUpper x : xs + +parseAddMe :: Parser ProtocolMsg +parseAddMe = do + string "add_me" + skipSpace + return AddMe + +parseMsg :: Parser ProtocolMsg +parseMsg = do + string "message" + skipSpace + msg <- takeText + return $ Message msg diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,20 @@ +module Main where + +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck + +main :: IO () +main = defaultMainWithOpts + [ testCase "rev" testRev + , testProperty "listRevRevId" propListRevRevId + ] mempty + +testRev :: Assertion +testRev = reverse [1, 2, 3] @?= [3, 2, 1] + +propListRevRevId :: [Int] -> Property +propListRevRevId xs = not (null xs) ==> reverse (reverse xs) == xs