hstorchat (empty) → 0.1.0.0
raw patch · 10 files changed
+784/−0 lines, 10 filesdep +HUnitdep +QuickCheckdep +attoparsecsetup-changedbinary-added
Dependencies added: HUnit, QuickCheck, attoparsec, base, containers, hsqml, hstorchat, network, process, random, safecopy, socks, tagged, test-framework, test-framework-hunit, test-framework-quickcheck2, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hstorchat.cabal +47/−0
- qml/HSTorChat.qml +160/−0
- qml/img/hs.png binary
- src/Main.hs +92/−0
- src/Network/HSTorChat/Client.hs +132/−0
- src/Network/HSTorChat/GUI.hs +116/−0
- src/Network/HSTorChat/Protocol.hs +185/−0
- tests/Main.hs +20/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hstorchat.cabal view
@@ -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
+ qml/HSTorChat.qml view
@@ -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()+ }+ }+ }+ }+}
+ qml/img/hs.png view
binary file changed (absent → 50366 bytes)
+ src/Main.hs view
@@ -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+ }
+ src/Network/HSTorChat/Client.hs view
@@ -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
+ src/Network/HSTorChat/GUI.hs view
@@ -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
+ src/Network/HSTorChat/Protocol.hs view
@@ -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
+ tests/Main.hs view
@@ -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