├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── default.nix ├── examples └── Relay.lhs ├── network-anonymous-tor.cabal ├── network-anonymous-tor.nix ├── shell.nix ├── src └── Network │ └── Anonymous │ ├── Tor.hs │ └── Tor │ ├── Error.hs │ ├── Protocol.hs │ └── Protocol │ ├── Parser.hs │ ├── Parser │ └── Ast.hs │ └── Types.hs └── test ├── Main.hs ├── Network └── Anonymous │ ├── Tor │ ├── Protocol │ │ ├── Parser │ │ │ └── AstSpec.hs │ │ └── ParserSpec.hs │ └── ProtocolSpec.hs │ └── TorSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | .hpc/ 11 | cabal.sandbox.config 12 | cabal.config 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | env: 3 | - CABALVER=1.22 GHCVER=7.6.3 4 | - CABALVER=1.22 GHCVER=7.8.4 5 | - CABALVER=1.22 GHCVER=7.10.2 6 | - CABALVER=1.22 GHCVER=head 7 | 8 | matrix: 9 | allow_failures: 10 | - env: CABALVER=1.22 GHCVER=head 11 | 12 | before_install: 13 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 14 | - travis_retry sudo apt-get update 15 | 16 | - sudo apt-get install build-essential libevent-dev libssl-dev 17 | - wget https://www.torproject.org/dist/tor-0.2.7.1-alpha.tar.gz 18 | - tar -xzf tor-0.2.7.1-alpha.tar.gz 19 | - cd tor-0.2.7.1-alpha/ 20 | - ./configure --disable-unittests --disable-system-torrc 21 | - make -j4 22 | - sudo make install 23 | - cd .. 24 | 25 | # Configure & launch tor service 26 | - echo "RunAsDaemon 1" >> ~/.torrc 27 | - echo "ControlPort 9051" >> ~/.torrc 28 | - echo "CookieAuthentication 1" >> ~/.torrc 29 | - echo "ExtORPortCookieAuthFileGroupReadable 1" >> ~/.torrc 30 | - tor 31 | 32 | # Wait until Tor control port is open 33 | - nc -zvv localhost 9051; out=$?; while [[ $out -ne 0 ]]; do echo "Retry hit port 9051..."; nc -zvv localhost 9051; out=$?; sleep 1; done 34 | 35 | # Installing cabal and ghc 36 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex 37 | - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 38 | - travis_retry cabal update 39 | 40 | # Install hlint (via apt-get if available, otherwise via cabal) 41 | - travis_retry sudo apt-get -q -y install hlint || cabal install hlint 42 | 43 | # Install hpc-coveralls 44 | - cabal install hpc-coveralls -j --bindir=$HOME/.cabal/bin/ --constraint='aeson >= 0.7' 45 | - which run-cabal-test 46 | 47 | 48 | install: 49 | - cabal --version 50 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 51 | - travis_retry cabal install --only-dependencies --enable-tests --enable-benchmarks -j 52 | 53 | script: 54 | - hlint src --ignore="Parse error" 55 | - cabal configure --enable-tests --enable-benchmarks --enable-coverage -fdebug 56 | - cabal build -j 57 | - travis_retry sudo -E su $USER -c '/home/$USER/.cabal/bin/run-cabal-test --cabal-name=cabal --show-details=streaming' 58 | - cabal check 59 | - cabal sdist 60 | 61 | # The following scriptlet checks that the resulting source distribution can be built & installed 62 | - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; 63 | cd dist/; 64 | if [ -f "$SRC_TGZ" ]; then 65 | cabal install --force-reinstalls "$SRC_TGZ"; 66 | else 67 | echo "expected '$SRC_TGZ' not found"; 68 | exit 1; 69 | fi ; 70 | cd ../ 71 | 72 | after_script: 73 | - find . 74 | - hpc-coveralls test-suite --exclude-dir=test --display-report 75 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Leon Mergen 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | network-anonymous-tor 2 | ===================== 3 | 4 | [![Build Status](https://travis-ci.org/solatis/haskell-network-anonymous-tor.png?branch=master)](https://travis-ci.org/solatis/haskell-network-anonymous-tor) 5 | [![Coverage Status](https://coveralls.io/repos/solatis/haskell-network-anonymous-tor/badge.svg?branch=master)](https://coveralls.io/r/solatis/haskell-network-anonymous-tor?branch=master) 6 | [![MIT](http://b.repl.ca/v1/license-MIT-blue.png)](http://en.wikipedia.org/wiki/MIT_License) 7 | [![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) 8 | 9 | network-anonymous-tor is a Haskell API for Tor anonymous networking 10 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "ghc7101" }: 2 | nixpkgs.haskellPackages.callPackage ./network-anonymous-tor.nix { } 3 | -------------------------------------------------------------------------------- /examples/Relay.lhs: -------------------------------------------------------------------------------- 1 | > import System.Environment (getArgs) 2 | > import Control.Concurrent (threadDelay, forkIO) 3 | > import Control.Monad (void) 4 | > import System.IO (IOMode (ReadWriteMode)) 5 | 6 | > import Network (withSocketsDo) 7 | > import qualified Network.Simple.TCP as NST 8 | > import Network.Socket (socketToHandle) 9 | > import qualified Network.Socket.Splice as Splice 10 | 11 | > import qualified Network.Anonymous.Tor as Tor 12 | 13 | Our main function is fairly simple: get our configuration data and start 14 | a new Tor Session. As soon as this session completes, exit the program. 15 | 16 | > main = withSocketsDo $ do 17 | > torPort <- whichControlPort 18 | > portmap <- getPortmap 19 | 20 | Once we got the configuration data, launch a Tor session and will continue 21 | execution in the 'withinSession' function. 22 | 23 | > Tor.withSession torPort (withinSession portmap) 24 | > 25 | > where 26 | 27 | We need a simple function to detect which control port Tor listens at. By 28 | default the Tor service uses port 9051, but the Tor Browser Bundle uses 9151, 29 | to allow Tor and the TBB to run next to each other. 30 | 31 | > whichControlPort = do 32 | > let ports = [9051, 9151] 33 | > 34 | > availability <- mapM Tor.isAvailable ports 35 | 36 | At this point, the `ports` list describes the list of ports in which we think 37 | a Tor controller might be active, and `availability` has a list of the same length 38 | with the associated availability status. 39 | 40 | Since we're only interested in services that are available, we are going to 41 | combine these list, filter on the availability status, and return the first port 42 | that matches these constraints. This functionality is relatively unsafe, since 43 | it assumes at least one Tor service is running (otherwise 'head' will return an 44 | error). 45 | 46 | > return . fst . head . filter ((== Tor.Available) . snd) $ zip ports availability 47 | 48 | Some boilerplate code: we need to set up a port mapping, and rather than hard- 49 | coding it, we allow the user to provide is as command line arguments. The first 50 | argument is the public port we will listen at, the second argument the private 51 | port we relay connections to. 52 | 53 | > getPortmap :: IO (Integer, Integer) 54 | > getPortmap = do 55 | > [pub, priv] <- getArgs 56 | > return (read pub, read priv) 57 | 58 | Once a Tor session has been created and we are authenticated with the Tor 59 | control service, let's set up a new onion service which redirects incoming 60 | connections to the 'newConnection' function. 61 | 62 | > withinSession (publicPort, privatePort) controlSock = do 63 | > onion <- Tor.accept controlSock publicPort Nothing (newConnection privatePort) 64 | > putStrLn ("hidden service descriptor: " ++ show onion) 65 | 66 | If we would leave this function at this point, our connection with the Tor 67 | control service would be lost, which would cause Tor to clean up any mappings 68 | and hidden services we have registered. 69 | 70 | Since this is just an example, we will now wait for 5 minutes and then exit. 71 | 72 | > threadDelay 300000000 73 | 74 | This function is called for all incoming connections. All it needs to do is 75 | establish a connection with the local service and relay the connections to the 76 | local, private server. 77 | 78 | > newConnection privatePort sPublic = 79 | > NST.connect "127.0.0.1" (show privatePort) $ \(sPrivate, addr) -> spliceSockets sPublic sPrivate 80 | 81 | And to demonstrate that the sockets we deal with are just regular, normal 82 | network sockets, we implement a function using the `splice` package that 83 | creates a bidirectional pipe between the public and private sockets. 84 | 85 | > spliceSockets sLhs sRhs = do 86 | > hLhs <- socketToHandle sLhs ReadWriteMode 87 | > hRhs <- socketToHandle sRhs ReadWriteMode 88 | > _ <- forkIO $ Splice.splice 1024 (sLhs, Just hLhs) (sRhs, Just hRhs) 89 | > Splice.splice 1024 (sRhs, Just hRhs) (sLhs, Just hLhs) 90 | -------------------------------------------------------------------------------- /network-anonymous-tor.cabal: -------------------------------------------------------------------------------- 1 | name: network-anonymous-tor 2 | category: Network 3 | version: 0.10.0 4 | license: MIT 5 | license-file: LICENSE 6 | copyright: (c) 2014 Leon Mergen 7 | author: Leon Mergen 8 | maintainer: leon@solatis.com 9 | stability: experimental 10 | synopsis: Haskell API for Tor anonymous networking 11 | description: 12 | This library providess an API that wraps around the Tor control port 13 | to create ad-hoc hidden services 14 | homepage: http://www.leonmergen.com/opensource.html 15 | build-type: Simple 16 | data-files: LICENSE, README.md 17 | cabal-version: >= 1.10 18 | tested-with: GHC == 7.6, GHC == 7.8, GHC == 7.10 19 | 20 | library 21 | hs-source-dirs: src 22 | default-language: Haskell2010 23 | ghc-options: -Wall -ferror-spans -auto-all -caf-all 24 | 25 | exposed-modules: Network.Anonymous.Tor 26 | Network.Anonymous.Tor.Error 27 | Network.Anonymous.Tor.Protocol 28 | Network.Anonymous.Tor.Protocol.Types 29 | Network.Anonymous.Tor.Protocol.Parser 30 | Network.Anonymous.Tor.Protocol.Parser.Ast 31 | 32 | build-depends: base >= 4.3 && < 5 33 | , transformers 34 | 35 | , network 36 | , network-simple 37 | , socks 38 | 39 | , attoparsec 40 | , network-attoparsec 41 | , exceptions 42 | , hexstring 43 | , base32string 44 | 45 | , text 46 | , bytestring 47 | 48 | test-suite test-suite 49 | type: exitcode-stdio-1.0 50 | default-language: Haskell2010 51 | hs-source-dirs: test 52 | main-is: Main.hs 53 | ghc-options: -Wall -ferror-spans -threaded -auto-all -caf-all -fno-warn-type-defaults 54 | 55 | other-modules: Spec 56 | Main 57 | 58 | build-depends: base >= 4.3 && < 5 59 | , exceptions 60 | , transformers 61 | 62 | , network 63 | , network-simple 64 | , socks 65 | 66 | , attoparsec 67 | , bytestring 68 | , base32string 69 | , text 70 | 71 | , hspec 72 | , hspec-attoparsec 73 | , hspec-expectations 74 | 75 | , network-anonymous-tor 76 | 77 | executable tor-relay 78 | default-language: Haskell2010 79 | hs-source-dirs: examples 80 | main-is: Relay.lhs 81 | 82 | build-depends: base >= 4.3 && < 5 83 | , exceptions 84 | 85 | , network 86 | , network-simple 87 | , splice 88 | 89 | , network-anonymous-tor 90 | 91 | 92 | source-repository head 93 | type: git 94 | location: git://github.com/solatis/haskell-network-anonymous-tor.git 95 | branch: master 96 | -------------------------------------------------------------------------------- /network-anonymous-tor.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, attoparsec, base, base32string, bytestring 2 | , exceptions, hexstring, hspec, hspec-attoparsec 3 | , hspec-expectations, network, network-attoparsec, network-simple 4 | , socks, splice, stdenv, text, transformers 5 | }: 6 | mkDerivation { 7 | pname = "network-anonymous-tor"; 8 | version = "0.9.2"; 9 | src = ./.; 10 | isLibrary = true; 11 | isExecutable = true; 12 | doCheck = false; 13 | 14 | buildDepends = [ 15 | attoparsec base base32string bytestring exceptions hexstring 16 | network network-attoparsec network-simple socks splice text 17 | transformers 18 | ]; 19 | testDepends = [ 20 | attoparsec base base32string bytestring exceptions hspec 21 | hspec-attoparsec hspec-expectations network network-simple socks 22 | text transformers 23 | ]; 24 | homepage = "http://www.leonmergen.com/opensource.html"; 25 | description = "Haskell API for Tor anonymous networking"; 26 | license = stdenv.lib.licenses.mit; 27 | } 28 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "ghc7101" }: 2 | (import ./default.nix { inherit nixpkgs compiler; }).env 3 | -------------------------------------------------------------------------------- /src/Network/Anonymous/Tor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | -- | This module provides the main interface for establishing secure and 5 | -- anonymous connections with other hosts on the interface using the 6 | -- Tor project. For more information about the Tor network, see: 7 | -- 8 | -- 9 | module Network.Anonymous.Tor ( 10 | -- * Introduction to Tor 11 | -- $tor-introduction 12 | 13 | -- * Client side 14 | -- $tor-client 15 | P.connect 16 | , P.connect' 17 | 18 | -- * Server side 19 | -- $tor-server 20 | , P.mapOnion 21 | , accept 22 | 23 | -- * Probing Tor configuration information 24 | , P.Availability (..) 25 | , P.isAvailable 26 | , P.socksPort 27 | 28 | -- ** Setting up the context 29 | , withSession 30 | 31 | ) where 32 | 33 | import Control.Concurrent (forkIO, threadDelay) 34 | import Control.Monad.IO.Class 35 | 36 | import qualified Data.Base32String.Default as B32 37 | import qualified Data.ByteString as BS 38 | 39 | import qualified Network.Simple.TCP as NST 40 | import qualified Network.Socket as Network 41 | 42 | import qualified Network.Anonymous.Tor.Protocol as P 43 | 44 | 45 | -------------------------------------------------------------------------------- 46 | -- $tor-introduction 47 | -- 48 | -- This module is a (partial) implementation of the Tor control protocol. Tor is an 49 | -- internet anonimization network. Whereas historically, Tor is primarily 50 | -- intended for privately browsing the world wide web, the service also supports 51 | -- application oriented P2P communication, to implement communication between applications. 52 | -- 53 | -- The general idea of the Tor control interface to Tor is that you establish a master 54 | -- connection with the Tor control port, and create new, short-lived connections with 55 | -- the Tor bridge for the communication with the individual peers. 56 | -- 57 | -------------------------------------------------------------------------------- 58 | -- $tor-client 59 | -- 60 | -- == Connect through Tor with explicit port 61 | -- Connect through Tor on using a specified SOCKS port. Note that you do not 62 | -- need to authorize with the Tor control port for this functionality. 63 | -- 64 | -- @ 65 | -- main = 'connect' 9050 constructDestination worker 66 | -- 67 | -- where 68 | -- constructDestination = 69 | -- 'SocksT.SocksAddress' (SocksT.SocksAddrDomainName (BS8.pack "www.google.com")) 80 70 | -- 71 | -- worker sock = 72 | -- -- Now you may use sock to communicate with the remote. 73 | -- return () 74 | -- @ 75 | -- 76 | -- == Connect through Tor using control port 77 | -- Connect through Tor and derive the SOCKS port from the Tor configuration. This 78 | -- function will query the Tor control service to find out which SOCKS port the 79 | -- Tor daemon listens at. 80 | -- 81 | -- @ 82 | -- main = 'withSession' withinSession 83 | -- 84 | -- where 85 | -- constructDestination = 86 | -- 'SocksT.SocksAddress' (SocksT.SocksAddrDomainName (BS8.pack "2a3b4c.onion")) 80 87 | -- 88 | -- withinSession :: 'Network.Socket' -> IO () 89 | -- withinSession sock = do 90 | -- 'connect'' sock constructDestination worker 91 | -- 92 | -- worker sock = 93 | -- -- Now you may use sock to communicate with the remote. 94 | -- return () 95 | -- @ 96 | -- 97 | -------------------------------------------------------------------------------- 98 | -- $tor-server 99 | -- 100 | -- == Mapping 101 | -- Create a new hidden service, and map remote port 80 to local port 8080. 102 | -- 103 | -- @ 104 | -- main = 'withSession' withinSession 105 | -- 106 | -- where 107 | -- withinSession :: 'Network.Socket' -> IO () 108 | -- withinSession sock = do 109 | -- onion <- 'mapOnion' sock 80 8080 110 | -- -- At this point, 'onion' contains the base32 representation of 111 | -- -- our hidden service, without the trailing '.onion' part. 112 | -- -- 113 | -- -- Remember that, once we leave this function, the connection with 114 | -- -- the Tor control service will be lost and any mappings will be 115 | -- -- cleaned up. 116 | -- @ 117 | -- 118 | -- == Server 119 | -- Convenience function which creates a hidden service on port 80 that is mapped 120 | -- to a server we create on the fly. Note that because we are mapping the hidden 121 | -- service's port 1:1 with our local port, port 80 must still be available. 122 | -- 123 | -- @ 124 | -- main = 'withSession' withinSession 125 | -- 126 | -- where 127 | -- withinSession :: 'Network.Socket' -> IO () 128 | -- withinSession sock = do 129 | -- onion <- 'accept' sock 80 worker 130 | -- -- At this point, 'onion' contains the base32 representation of 131 | -- -- our hidden service, without the trailing '.onion' part, and any 132 | -- -- incoming connections will be redirected to our 'worker' function. 133 | -- -- 134 | -- -- Once again, when we leave this function, all registered mappings 135 | -- -- will be lost. 136 | -- 137 | -- worker sock = do 138 | -- -- Now you may use sock to communicate with the remote. 139 | -- return () 140 | -- @ 141 | -------------------------------------------------------------------------------- 142 | 143 | -- | Establishes a connection and authenticates with the Tor control socket. 144 | -- After authorization has been succesfully completed it executes the callback 145 | -- provided. 146 | -- 147 | -- Note that when the session completes, the connection with the Tor control 148 | -- port is dropped, which means that any port mappings, connections and hidden 149 | -- services you have registered within the session will be cleaned up. This 150 | -- is by design, to prevent stale mappings when an application crashes. 151 | 152 | withSession :: Integer -- ^ Port the Tor control server is listening at. Use 153 | -- 'detectPort' to probe possible ports. 154 | -> (Network.Socket -> IO a) -- ^ Callback function called after a session has been 155 | -- established succesfully. 156 | -> IO a -- ^ Returns the value returned by the callback. 157 | withSession port callback = 158 | NST.connect "127.0.0.1" (show port) (\(sock, _) -> do 159 | _ <- P.authenticate sock 160 | callback sock) 161 | 162 | -- | Convenience function that creates a new hidden service and starts accepting 163 | -- connections for it. Note that this creates a new local server at the same 164 | -- port as the public port, so ensure that the port is not yet in use. 165 | accept :: MonadIO m 166 | => Network.Socket -- ^ Connection with Tor control server 167 | -> Integer -- ^ Port to listen at 168 | -> Maybe BS.ByteString -- ^ Optional private key to use to set up the hidden service 169 | -> (Network.Socket -> IO ()) -- ^ Callback function called for each incoming connection 170 | -> m B32.Base32String -- ^ Returns the hidden service descriptor created without 171 | -- the '.onion' part 172 | accept sock port pkey callback = do 173 | -- First create local service 174 | _ <- liftIO $ forkIO $ 175 | NST.listen "*" (show port) (\(lsock, _) -> 176 | NST.accept lsock (\(csock, _) -> do 177 | _ <- callback csock 178 | threadDelay 1000000 179 | return ())) 180 | 181 | -- Do the onion mapping after that 182 | P.mapOnion sock port port False pkey 183 | -------------------------------------------------------------------------------- /src/Network/Anonymous/Tor/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | -- | Tor error types, inspired by System.IO.Error 4 | module Network.Anonymous.Tor.Error where 5 | 6 | import Data.Typeable (Typeable) 7 | 8 | import Control.Monad.IO.Class 9 | import Control.Exception (throwIO) 10 | import Control.Exception.Base (Exception) 11 | 12 | -- | Error type used 13 | type TorError = TorException 14 | 15 | -- | Exception that we use to throw. It is the only type of exception 16 | -- we throw, and the type of error is embedded within the exception. 17 | data TorException = TorError { 18 | toreType :: TorErrorType -- ^ Our error type 19 | } deriving (Show, Eq, Typeable) 20 | 21 | -- | Derives our Tor exception from the standard exception, which opens it 22 | -- up to being used with all the regular try/catch/bracket/etc functions. 23 | instance Exception TorException 24 | 25 | -- | An abstract type that contains a value for each variant of 'TorError' 26 | data TorErrorType 27 | = Timeout 28 | | Unreachable 29 | | ProtocolError String 30 | | PermissionDenied String 31 | deriving (Show, Eq) 32 | 33 | -- | Generates new TorException 34 | mkTorError :: TorErrorType -> TorError 35 | mkTorError t = TorError { toreType = t } 36 | 37 | -- | Tor error when a timeout has occurred 38 | timeoutErrorType :: TorErrorType 39 | timeoutErrorType = Timeout 40 | 41 | -- | Tor error when a host was unreachable 42 | unreachableErrorType :: TorErrorType 43 | unreachableErrorType = Unreachable 44 | 45 | -- | Tor error when communication with the SAM bridge fails 46 | protocolErrorType :: String -> TorErrorType 47 | protocolErrorType = ProtocolError 48 | 49 | -- | Tor error when communication with the SAM bridge fails 50 | permissionDeniedErrorType :: String -> TorErrorType 51 | permissionDeniedErrorType = PermissionDenied 52 | 53 | -- | Raise an Tor Exception in the IO monad 54 | torException :: (MonadIO m) 55 | => TorException 56 | -> m a 57 | torException = liftIO . throwIO 58 | 59 | -- | Raise an Tor error in the IO monad 60 | torError :: (MonadIO m) 61 | => TorError 62 | -> m a 63 | torError = torException 64 | -------------------------------------------------------------------------------- /src/Network/Anonymous/Tor/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Protocol description 4 | -- 5 | -- Defines functions that handle the advancing of the Tor control protocol. 6 | -- 7 | -- __Warning__: This function is used internally by 'Network.Anonymous.Tor' 8 | -- and using these functions directly is unsupported. The 9 | -- interface of these functions might change at any time without 10 | -- prior notice. 11 | -- 12 | module Network.Anonymous.Tor.Protocol ( Availability (..) 13 | , isAvailable 14 | , socksPort 15 | , connect 16 | , connect' 17 | , protocolInfo 18 | , authenticate 19 | , mapOnion ) where 20 | 21 | import Control.Concurrent.MVar 22 | 23 | import Control.Monad (void) 24 | import Control.Monad.Catch ( handle 25 | , handleIOError ) 26 | import Control.Monad.IO.Class 27 | 28 | import qualified System.IO.Error as E 29 | import qualified GHC.IO.Exception as E hiding (ProtocolError) 30 | 31 | import qualified Data.Attoparsec.ByteString as Atto 32 | import qualified Data.Base32String.Default as B32 33 | import qualified Data.ByteString as BS 34 | import qualified Data.ByteString.Char8 as BS8 35 | import qualified Data.HexString as HS 36 | import Data.Maybe (fromJust) 37 | 38 | import qualified Data.Text.Encoding as TE 39 | 40 | import qualified Network.Attoparsec as NA 41 | import qualified Network.Simple.TCP as NST 42 | 43 | import qualified Network.Socket as Network hiding 44 | (recv, 45 | send) 46 | import qualified Network.Socket.ByteString as Network 47 | import qualified Network.Socks5 as Socks 48 | 49 | import qualified Network.Anonymous.Tor.Error as E 50 | import qualified Network.Anonymous.Tor.Protocol.Parser as Parser 51 | import qualified Network.Anonymous.Tor.Protocol.Parser.Ast as Ast 52 | import qualified Network.Anonymous.Tor.Protocol.Types as T 53 | 54 | sendCommand :: MonadIO m 55 | => Network.Socket -- ^ Our connection with the Tor control port 56 | -> BS.ByteString -- ^ The command / instruction we wish to send 57 | -> m [Ast.Line] 58 | sendCommand sock = sendCommand' sock errorF 59 | where 60 | 61 | errorF :: Ast.Line -> Maybe E.TorErrorType 62 | errorF (Ast.Line 250 _ ) = Nothing 63 | errorF (Ast.Line c tokens) = let message = toMessage tokens 64 | code = codeName c 65 | err = show c ++ " " ++ code ++ ": " ++ message 66 | in Just . E.protocolErrorType $ err 67 | 68 | toMessage :: [Ast.Token] -> String 69 | toMessage = unwords . map extract 70 | 71 | extract :: Ast.Token -> String 72 | extract (Ast.Token s Nothing ) = BS8.unpack s 73 | extract (Ast.Token k (Just v)) = BS8.unpack k ++ "=" ++ BS8.unpack v 74 | 75 | codeName :: Integer -> String 76 | codeName 250 = "OK" 77 | codeName 251 = "Operation was unnecessary" 78 | codeName 451 = "Ressource exhausted" 79 | codeName 500 = "Syntax error: protocol" 80 | codeName 510 = "Unrecognized command" 81 | codeName 511 = "Unimplemented command" 82 | codeName 512 = "Syntax error in command argument" 83 | codeName 513 = "Unrecognized command argument" 84 | codeName 514 = "Authentication required" 85 | codeName 550 = "Unspecified Tor error" 86 | codeName 551 = "Internal error" 87 | codeName 552 = "Unrecognized entity" 88 | codeName 553 = "Invalid configuration value" 89 | codeName 554 = "Invalid descriptor" 90 | codeName 555 = "Unmanaged entity" 91 | codeName 650 = "Asynchrounous event notification" 92 | codeName _ = "Unrecognized status code" 93 | 94 | sendCommand' :: MonadIO m 95 | => Network.Socket -- ^ Our connection with the Tor control port 96 | -> (Ast.Line -> Maybe E.TorErrorType) -- ^ A function using the first line of the response to determine wether to throw an error 97 | -> BS.ByteString -- ^ The command / instruction we wish to send 98 | -> m [Ast.Line] 99 | sendCommand' sock errorF msg = do 100 | _ <- liftIO $ Network.sendAll sock msg 101 | res <- liftIO $ NA.parseOne sock (Atto.parse Parser.reply) 102 | 103 | case errorF . head $ res of 104 | Just e -> E.torError (E.mkTorError e) 105 | _ -> return () 106 | 107 | return res 108 | 109 | -- | Represents the availability status of Tor for a specific port. 110 | data Availability = 111 | Available | -- ^ There is a Tor control service listening at the port 112 | ConnectionRefused | -- ^ There is no service listening at the port 113 | IncorrectPort -- ^ There is a non-Tor control service listening at the port 114 | deriving (Show, Eq) 115 | 116 | -- | Probes a port to see if there is a service at the remote that behaves 117 | -- like the Tor controller daemon. Will return the status of the probed 118 | -- port. 119 | isAvailable :: MonadIO m 120 | => Integer -- ^ The ports we wish to probe 121 | -> m Availability -- ^ The status of all the ports 122 | isAvailable port = liftIO $ do 123 | 124 | result <- newEmptyMVar 125 | 126 | handle (\(E.TorError (E.ProtocolError _)) -> putMVar result IncorrectPort) 127 | $ handleIOError (\e -> 128 | -- The error raised for a Connection Refused is a very descriptive OtherError 129 | if E.ioeGetErrorType e == E.OtherError || E.ioeGetErrorType e == E.NoSuchThing 130 | then putMVar result ConnectionRefused 131 | else if E.ioeGetErrorType e == E.UserError -- This gets thrown by network-attoparsec 132 | -- when there is a parse error. 133 | then putMVar result IncorrectPort 134 | else E.ioError e) 135 | (performTest port result) 136 | 137 | takeMVar result 138 | 139 | where 140 | performTest port result = 141 | NST.connect "127.0.0.1" (show port) (\(sock, _) -> do 142 | _ <- protocolInfo sock 143 | putMVar result Available) 144 | -- | Returns the configured SOCKS proxy port 145 | socksPort :: MonadIO m 146 | => Network.Socket 147 | -> m Integer 148 | socksPort s = do 149 | reply <- sendCommand s (BS8.pack "GETCONF SOCKSPORT\n") 150 | let line = fromJust $ Ast.line (BS8.pack "SocksPort") reply 151 | let token = fromJust . Ast.tokenValue . head $ Ast.lineMessage line 152 | return . fst . fromJust . BS8.readInteger $ removeAddress token 153 | -- Removes the optional address: part from [address:]port strings 154 | where removeAddress str = if ':' `BS8.elem` str 155 | then BS8.tail $ BS8.dropWhile (/= ':') str 156 | else str 157 | 158 | -- | Connect through a remote using the Tor SOCKS proxy. The remote might me a 159 | -- a normal host/ip or a hidden service address. When you provide a FQDN to 160 | -- resolve, it will be resolved by the Tor service, and as such is secure. 161 | -- 162 | -- This function is provided as a convenience, since it doesn't actually use 163 | -- the Tor control protocol, and can be used to talk with any Socks5 compatible 164 | -- proxy server. 165 | connect :: MonadIO m 166 | => Integer -- ^ Port our tor SOCKS server listens at. 167 | -> Socks.SocksAddress -- ^ Address we wish to connect to 168 | -> (Network.Socket -> IO a) -- ^ Computation to execute once connection has been establised 169 | -> m a 170 | connect sport remote callback = liftIO $ do 171 | (sock, _) <- Socks.socksConnect conf remote 172 | callback sock 173 | 174 | where 175 | conf = Socks.defaultSocksConf "127.0.0.1" (fromInteger sport) 176 | 177 | connect' :: MonadIO m 178 | => Network.Socket -- ^ Our connection with the Tor control port 179 | -> Socks.SocksAddress -- ^ Address we wish to connect to 180 | -> (Network.Socket -> IO a) -- ^ Computation to execute once connection has been establised 181 | -> m a 182 | connect' sock remote callback = do 183 | sport <- socksPort sock 184 | connect sport remote callback 185 | 186 | -- | Requests protocol version information from Tor. This can be used while 187 | -- still unauthenticated and authentication methods can be derived from this 188 | -- information. 189 | protocolInfo :: MonadIO m 190 | => Network.Socket 191 | -> m T.ProtocolInfo 192 | protocolInfo s = do 193 | res <- sendCommand s (BS.concat ["PROTOCOLINFO", "\n"]) 194 | 195 | return (T.ProtocolInfo (protocolVersion res) (torVersion res) (methods res) (cookieFile res)) 196 | 197 | where 198 | 199 | protocolVersion :: [Ast.Line] -> Integer 200 | protocolVersion reply = 201 | fst . fromJust . BS8.readInteger . Ast.tokenKey . last . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "PROTOCOLINFO") reply 202 | 203 | torVersion :: [Ast.Line] -> [Integer] 204 | torVersion reply = 205 | map (fst . fromJust . BS8.readInteger) . BS8.split '.' . fromJust . Ast.value "Tor" . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "VERSION") reply 206 | 207 | methods :: [Ast.Line] -> [T.AuthMethod] 208 | methods reply = 209 | map (read . BS8.unpack) . BS8.split ',' . fromJust . Ast.value "METHODS" . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "AUTH") reply 210 | 211 | cookieFile :: [Ast.Line] -> Maybe FilePath 212 | cookieFile reply = 213 | fmap BS8.unpack . Ast.value "COOKIEFILE" . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "AUTH") reply 214 | 215 | -- | Authenticates with the Tor control server, based on the authentication 216 | -- information returned by PROTOCOLINFO. 217 | authenticate :: MonadIO m 218 | => Network.Socket 219 | -> m () 220 | authenticate s = do 221 | info <- protocolInfo s 222 | 223 | let send = liftIO . void . sendCommand' s errorF . BS8.concat . (++["\n"]) 224 | if T.Cookie `elem` T.authMethods info 225 | then do 226 | cookieData <- liftIO $ readCookie (T.cookieFile info) 227 | send ["AUTHENTICATE ", TE.encodeUtf8 $ HS.toText cookieData] 228 | else if T.Null `elem` T.authMethods info 229 | then send ["AUTHENTICATE"] 230 | else E.torError . E.mkTorError . E.permissionDeniedErrorType $ "The only authentication methods supported are COOKIE and NULL." 231 | 232 | where 233 | 234 | readCookie :: Maybe FilePath -> IO HS.HexString 235 | readCookie Nothing = E.torError (E.mkTorError . E.protocolErrorType $ "No cookie path specified.") 236 | readCookie (Just file) = return . HS.fromBytes =<< BS.readFile file 237 | 238 | errorF :: Ast.Line -> Maybe E.TorErrorType 239 | errorF (Ast.Line 250 _) = Nothing 240 | errorF _ = Just . E.permissionDeniedErrorType $ "Authentication failed." 241 | 242 | -- | Creates a new hidden service and maps a public port to a local port. Useful 243 | -- for bridging a local service (e.g. a webserver or irc daemon) as a Tor 244 | -- hidden service. If a private key is supplied, it is used to instantiate the 245 | -- service. 246 | mapOnion :: MonadIO m 247 | => Network.Socket -- ^ Connection with tor Control port 248 | -> Integer -- ^ Remote point of hidden service to listen at 249 | -> Integer -- ^ Local port to map onion service to 250 | -> Bool -- ^ Wether to detach the hidden service from the current session 251 | -> Maybe BS.ByteString -- ^ Optional private key to use to set up the hidden service 252 | -> m B32.Base32String -- ^ The address/service id of the Onion without the .onion part 253 | mapOnion s rport lport detach pkey = do 254 | reply <- sendCommand s $ BS8.concat 255 | [ "ADD_ONION " 256 | , maybe "NEW:BEST" (\pk -> "RSA1024:" `BS.append` pk) pkey 257 | , if detach then " Flags=Detach " else " " 258 | , "Port=" 259 | , BS8.pack (show rport) 260 | , ",127.0.0.1:" 261 | , BS8.pack(show lport) 262 | , "\n"] 263 | 264 | return . B32.b32String' . fromJust . Ast.tokenValue . head . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "ServiceID") reply 265 | -------------------------------------------------------------------------------- /src/Network/Anonymous/Tor/Protocol/Parser.hs: -------------------------------------------------------------------------------- 1 | -- | Parser defintions 2 | -- 3 | -- Defines parsers used by the Tor Control protocol 4 | -- 5 | -- __Warning__: This function is used internally by 'Network.Anonymous.Tor' 6 | -- and using these functions directly is unsupported. The 7 | -- interface of these functions might change at any time without 8 | -- prior notice. 9 | -- 10 | 11 | module Network.Anonymous.Tor.Protocol.Parser ( quotedString 12 | , unquotedString 13 | , reply 14 | , key 15 | , keyValue 16 | , value 17 | , token 18 | , tokens ) where 19 | 20 | import Control.Applicative ((*>), (<$>), (<*), (<*>), 21 | (<|>)) 22 | 23 | import qualified Data.Attoparsec.ByteString as Atto 24 | import qualified Data.Attoparsec.ByteString.Char8 as Atto8 25 | import qualified Data.ByteString as BS 26 | import qualified Data.ByteString.Char8 as BS8 27 | import Data.Word (Word8) 28 | import qualified Network.Anonymous.Tor.Protocol.Parser.Ast as A 29 | 30 | -- | Ascii offset representation of a double quote. 31 | doubleQuote :: Word8 32 | doubleQuote = 34 33 | 34 | -- | Ascii offset representation of a single quote. 35 | singleQuote :: Word8 36 | singleQuote = 39 37 | 38 | -- | Ascii offset representation of a backslash. 39 | backslash :: Word8 40 | backslash = 92 41 | 42 | -- | Ascii offset representation of a minus '-' symbol 43 | minus :: Word8 44 | minus = 45 45 | 46 | -- | Ascii offset representation of a plus '+' symbol 47 | plus :: Word8 48 | plus = 43 49 | 50 | -- | Ascii offset representation of a space ' ' character 51 | space :: Word8 52 | space = 32 53 | 54 | -- | Ascii offset representation of an equality sign. 55 | equals :: Word8 56 | equals = 61 57 | 58 | -- | Parses a single- or double-quoted string, and returns all bytes within the 59 | -- value; the unescaping is beyond the scope of this function (since different 60 | -- unescaping mechanisms might be desired). 61 | quotedString :: Atto.Parser BS.ByteString 62 | quotedString = 63 | let quoted :: Word8 -- ^ The character used for quoting 64 | -> Atto.Parser BS.ByteString -- ^ The value inside the quotes, without the surrounding quotes 65 | quoted c = (Atto.word8 c *> escaped c <* Atto.word8 c) 66 | 67 | -- | Parses an escaped string, with an arbitrary surrounding quote type. 68 | escaped :: Word8 -> Atto.Parser BS.ByteString 69 | escaped c = BS8.concat <$> Atto8.many' 70 | -- Make sure that we eat pairs of backslashes; this will make sure 71 | -- that a string such as "\\\\" is interpreted correctly, and the 72 | -- ending quoted will not be interpreted as escaped. 73 | ( Atto8.string (BS8.pack "\\\\") 74 | 75 | -- This eats all escaped quotes and leaves them in tact; the unescaping 76 | -- is beyond the scope of this function. 77 | <|> Atto8.string (BS.pack [backslash, c]) 78 | 79 | -- And for the rest: eat everything that is not a quote. 80 | <|> (BS.singleton <$> Atto.satisfy (/= c))) 81 | 82 | in quoted doubleQuote <|> quoted singleQuote 83 | 84 | -- | An unquoted string is "everything until a whitespace or newline is reached". 85 | unquotedString :: Atto.Parser BS.ByteString 86 | unquotedString = 87 | Atto8.takeWhile1 (not . Atto8.isSpace) 88 | 89 | reply :: Atto.Parser [A.Line] 90 | reply = do 91 | -- A reply is a series of lines that look like 250-Foo or 250+Bar and then 92 | -- followed by a line that uses a space like 250 Wombat. 93 | -- 94 | -- Let's parse all these lines into a reply. 95 | replies <- Atto.many' (replyLine minus <|> replyLine plus) 96 | lastReply <- replyLine space 97 | 98 | return (replies ++ [lastReply]) 99 | 100 | where 101 | replyLine :: Word8 -> Atto.Parser A.Line 102 | replyLine c = A.Line <$> Atto8.decimal <*> (Atto.word8 c *> tokens) <* Atto8.endOfLine 103 | 104 | -- | Parses either a quoted value or an unquoted value 105 | value :: Atto.Parser BS.ByteString 106 | value = 107 | quotedString <|> unquotedString 108 | 109 | -- | Parses key and value 110 | keyValue :: Atto.Parser A.Token 111 | keyValue = do 112 | A.Token k _ <- key 113 | _ <- Atto.word8 equals 114 | v <- value 115 | 116 | return (A.Token k (Just v)) 117 | 118 | -- | Parses a key, which is anything until either a space has been reached, or 119 | -- an '=' is reached. 120 | key :: Atto.Parser A.Token 121 | key = 122 | let isKeyEnd '=' = True 123 | isKeyEnd c = Atto8.isSpace c 124 | 125 | in flip A.Token Nothing <$> Atto8.takeWhile1 (not . isKeyEnd) 126 | 127 | -- | A Token is either a Key or a Key/Value combination. 128 | token :: Atto.Parser A.Token 129 | token = 130 | Atto.skipWhile Atto8.isHorizontalSpace *> (keyValue <|> key) 131 | 132 | -- | Parser that reads keys or key/values 133 | tokens :: Atto.Parser [A.Token] 134 | tokens = 135 | Atto.many' token 136 | -------------------------------------------------------------------------------- /src/Network/Anonymous/Tor/Protocol/Parser/Ast.hs: -------------------------------------------------------------------------------- 1 | -- | Abstract syntax tree used by the 'Parser', including helper functions 2 | -- for traversing the tree. 3 | -- 4 | -- __Warning__: This function is used internally by 'Network.Anonymous.Tor' 5 | -- and using these functions directly is unsupported. The 6 | -- interface of these functions might change at any time without 7 | -- prior notice. 8 | -- 9 | 10 | module Network.Anonymous.Tor.Protocol.Parser.Ast where 11 | import qualified Data.Attoparsec.ByteString as Atto 12 | 13 | import qualified Data.ByteString as BS 14 | 15 | -- | A token is a key and can maybe have an associated value 16 | data Token = Token { 17 | tokenKey :: BS.ByteString, 18 | tokenValue :: Maybe BS.ByteString 19 | } deriving (Show, Eq) 20 | 21 | -- | A line is just a sequence of tokens -- the 'Parser' ends the chain 22 | -- when a newline is received. 23 | data Line = Line { 24 | lineStatusCode :: Integer, 25 | lineMessage :: [Token] 26 | } deriving (Show, Eq) 27 | 28 | -- | Returns true if the key was found 29 | key :: BS.ByteString -- ^ The key to look for 30 | -> [Token] -- ^ Tokens to consider 31 | -> Bool -- ^ Result 32 | key _ [] = False -- Key was not found 33 | key k1 (Token k2 _:xs) = (k1 == k2) || key k1 xs -- If keys match, return true, otherwise enter recursion 34 | 35 | -- | Looks up a key and returns the value if found 36 | value :: BS.ByteString -- ^ Key to look for 37 | -> [Token] -- ^ Tokens to consider 38 | -> Maybe BS.ByteString -- ^ The value if the key was found 39 | value _ [] = Nothing -- Key not found! 40 | value k1 (Token k2 v:xs) = if k1 == k2 -- This assumes keys are unique 41 | then v -- This returns the value of the key, if any value is associated 42 | else value k1 xs -- Otherwise we continue our quest (in recursion) 43 | 44 | -- | Retrieves value, and applies it to an Attoparsec parser 45 | valueAs :: Atto.Parser a 46 | -> BS.ByteString 47 | -> [Token] 48 | -> Maybe a 49 | valueAs p k xs = 50 | let parseValue bs = 51 | case Atto.parseOnly p bs of 52 | Left _ -> Nothing 53 | Right r -> Just r 54 | 55 | in case value k xs of 56 | Nothing -> Nothing 57 | Just v -> parseValue v 58 | 59 | -- | Retrieves first line that starts with a certain token 60 | line :: BS.ByteString -- ^ Token key to look for 61 | -> [Line] -- ^ Lines to consider 62 | -> Maybe Line -- ^ The line that starts with this key, if found 63 | line _ [] = Nothing 64 | line k1 (x:xs) = 65 | case x of 66 | Line _ (Token k2 _:_) -> if k1 == k2 67 | then Just x 68 | else line k1 xs 69 | _ -> line k1 xs 70 | 71 | -- | Returns status code of a reply. 72 | statusCode :: [Line] 73 | -> Integer 74 | statusCode = lineStatusCode . head 75 | -------------------------------------------------------------------------------- /src/Network/Anonymous/Tor/Protocol/Types.hs: -------------------------------------------------------------------------------- 1 | -- | Types used by the 'Network.Anonymous.Tor.Protocol' module 2 | 3 | module Network.Anonymous.Tor.Protocol.Types where 4 | 5 | -- | Authentication types supported by the Tor service 6 | data AuthMethod = 7 | Cookie | SafeCookie | HashedPassword | Null 8 | 9 | deriving (Eq) 10 | 11 | instance Read AuthMethod where 12 | readsPrec _ "COOKIE" = [(Cookie, "")] 13 | readsPrec _ "SAFECOOKIE" = [(SafeCookie, "")] 14 | readsPrec _ "HASHEDPASSWORD" = [(HashedPassword, "")] 15 | readsPrec _ "NULL" = [(Null, "")] 16 | readsPrec _ s = error ("Not a valid AuthMethod: " ++ s) 17 | 18 | instance Show AuthMethod where 19 | show Cookie = "COOKIE" 20 | show SafeCookie = "SAFECOOKIE" 21 | show HashedPassword = "HASHEDPASSWORD" 22 | show Null = "NULL" 23 | 24 | -- | Information about our protocol (and version) 25 | data ProtocolInfo = ProtocolInfo { 26 | protocolVersion :: Integer, 27 | 28 | torVersion :: [Integer], 29 | 30 | authMethods :: [AuthMethod], 31 | 32 | cookieFile :: Maybe FilePath 33 | 34 | } deriving (Show, Eq) 35 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec.Runner 4 | import qualified Spec 5 | 6 | import Network (withSocketsDo) 7 | 8 | main :: IO () 9 | main = 10 | withSocketsDo $ hspecWith defaultConfig Spec.spec 11 | -------------------------------------------------------------------------------- /test/Network/Anonymous/Tor/Protocol/Parser/AstSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Anonymous.Tor.Protocol.Parser.AstSpec where 4 | 5 | import qualified Data.Attoparsec.ByteString as Atto 6 | import Network.Anonymous.Tor.Protocol.Parser.Ast 7 | 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "looking up keys" $ do 13 | it "should return true when a key exists" $ 14 | let tokens = [Token "foo" Nothing] 15 | in key "foo" tokens `shouldBe` True 16 | 17 | it "should return false when a key does not exist" $ 18 | let tokens = [Token "foo" Nothing] 19 | in key "bar" tokens `shouldBe` False 20 | 21 | it "should return true when a key has a value associated with it" $ 22 | let tokens = [Token "foo" (Just "bar")] 23 | in key "foo" tokens `shouldBe` True 24 | 25 | it "should return true when a key exists multiple times" $ 26 | let tokens = [Token "foo" Nothing, Token "foo" Nothing] 27 | in key "foo" tokens `shouldBe` True 28 | 29 | describe "looking up values" $ do 30 | it "should return value when a key has a value" $ 31 | let tokens = [Token "foo" (Just "bar")] 32 | in value "foo" tokens `shouldBe` Just ("bar") 33 | 34 | it "should return Nothing when a key has no value" $ 35 | let tokens = [Token "foo" Nothing] 36 | in value "foo" tokens `shouldBe` Nothing 37 | 38 | it "should return Nothing when a key does not exist" $ 39 | let tokens = [Token "foo" Nothing] 40 | in value "bar" tokens `shouldBe` Nothing 41 | 42 | it "should return first occurence if a key exists more than one time" $ 43 | let tokens = [Token "foo" (Just "bar"), Token "foo" (Just "wombat")] 44 | in value "foo" tokens `shouldBe` (Just "bar") 45 | 46 | describe "looking up values and parsing them" $ do 47 | let wombatParser = Atto.string "wombat" 48 | 49 | it "should succeed when parsing digits" $ 50 | let tokens = [Token "foo" (Just "wombat")] 51 | 52 | in valueAs wombatParser "foo" tokens `shouldBe` Just ("wombat") 53 | 54 | it "should return nothing when value is not found" $ 55 | let tokens = [Token "foo" (Just "wombat")] 56 | 57 | in valueAs wombatParser "bar" tokens `shouldBe` Nothing 58 | 59 | it "should return nothing when value cannot be parsed" $ 60 | let tokens = [Token "foo" (Just "abcd")] 61 | 62 | in valueAs wombatParser "foo" tokens `shouldBe` Nothing 63 | 64 | describe "looking up lines from replies" $ do 65 | it "should look up a simple line" $ 66 | let reply = [Line 250 [Token "foo" Nothing]] 67 | in line "foo" reply `shouldBe` Just (Line 250 [Token "foo" Nothing]) 68 | 69 | it "should fail when no line exists" $ 70 | let reply = [Line 250 [Token "foo" Nothing]] 71 | in line "bar" reply `shouldBe` Nothing 72 | 73 | it "should fail on case sensitivity" $ 74 | let reply = [Line 250 [Token "Foo" Nothing]] 75 | in line "foo" reply `shouldBe` Nothing 76 | 77 | describe "looking up status codes from replies" $ do 78 | it "should return the correct status code" $ 79 | let reply = [Line 250 [Token "foo" Nothing]] 80 | in statusCode reply `shouldBe` 250 81 | 82 | it "should return the status code of the first line" $ 83 | let reply = [Line 205 [Token "foo" Nothing], Line 250 [Token "foo" Nothing]] 84 | in statusCode reply `shouldBe` 205 85 | -------------------------------------------------------------------------------- /test/Network/Anonymous/Tor/Protocol/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Anonymous.Tor.Protocol.ParserSpec where 4 | 5 | import qualified Data.ByteString as BS 6 | import qualified Data.ByteString.Char8 as BS8 7 | 8 | import Network.Anonymous.Tor.Protocol.Parser 9 | import Network.Anonymous.Tor.Protocol.Parser.Ast 10 | 11 | import Test.Hspec 12 | import Test.Hspec.Attoparsec 13 | 14 | testDestination :: BS.ByteString 15 | testDestination = "TedPIHKiYHLLavX~2XgghB-jYBFkwkeztWM5rwyJCO2yR2gT92FcuEahEcTrykTxafzv~4jSQOL5w0EqElqlM~PEFy5~L1pOyGB56-yVd4I-g2fsM9MGKlXNOeQinghKOcfbQx1LVY35-0X5lQSNX-8I~U7Lefukj7gSC5hieWkDS6WiUW6nYw~t061Ra0GXf2qzqFTB4nkQvnCFKaZGtNwOUUpmIbF0OtLyr6TxC7BQKgcg4jyZPS1LaBO6Wev0ZFYiQHLk4S-1LQFBfT13BxN34g-eCInwHlYeMD6NEdiy0BYHhnbBTq02HbgD3FjxW~GBBB-6a~eFABaIiJJ08XR8Mm6KKpNh~gQXut2OLxs55UhEkqk8YmTODrf6yzWzldCdaaAEVMfryO9oniWWCVl1FgLmzUHPGQ3yzvb8OlXiED2hunEfaEg0fg77FRDnYJnDHMF7i5zcUzRGb67rUa1To~H65hR9cFNWTAwX4svC-gRbbvxfi-bthyj-QqeBBQAEAAcAAOEyRS5bFHDrXnWpsjcRvpQj436gS4iCjCzdOohWgeBKC~gfLVY658op9GF6oRJ78ezPN9FBE0JqNrAM75-uL9CIeJd8JUwdldm83RNSVI1ZPZBK-5F3DgIjTsqHDMzQ9xPETiBO2UZZogXSThx9I9uYuAtg296ZhziKjYnl7wi2i3IgQlNbuPW16ajOcNeKnL1OqFipAL9e3k~LEhgBNM3J2hK1M4jO~BQ19TxIXXUfBsHFU4YjwkAOKqOxR1iP8YD~xUSfdtF9mBe6fT8-WW3-n2WgHXiTLW3PJjJuPYM4hNKNmsxsEz5vi~DE6H1pUsPVs2oXFYKZF3EcsKUVaAVWJBarBPuVNYdJgIbgl1~TJeNor8hGQw6rUTJFaZ~jjQ==" 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "parsing quoted string" $ do 20 | it "it should succeed when providing a doublequoted string" $ 21 | let msg :: BS.ByteString 22 | msg = "\"foo\"" 23 | 24 | in msg ~> quotedString `shouldParse` "foo" 25 | 26 | it "it should succeed when providing a doublequoted value with spaces" $ 27 | let msg :: BS.ByteString 28 | msg = "\"foo bar\"" 29 | 30 | in msg ~> quotedString `shouldParse` "foo bar" 31 | 32 | it "it should succeed when providing a doublequoted value with an escaped quote" $ 33 | let msg :: BS.ByteString 34 | msg = "\"foo \\\" bar\"" 35 | 36 | in msg ~> quotedString `shouldParse` "foo \\\" bar" 37 | 38 | it "it should stop after a doublequoted value has been reached" $ 39 | let msg :: BS.ByteString 40 | msg = "\"foo bar\" \"baz\"" 41 | 42 | in msg ~> quotedString `shouldParse` "foo bar" 43 | 44 | describe "parsing unquoted strings" $ do 45 | it "it should succeed when providing a simple value" $ 46 | let msg :: BS.ByteString 47 | msg = "foo" 48 | 49 | in msg ~> unquotedString `shouldParse` "foo" 50 | 51 | it "it should stop after whitespace" $ 52 | let msg :: BS.ByteString 53 | msg = "foo bar" 54 | 55 | in msg ~> unquotedString `shouldParse` "foo" 56 | 57 | it "it should stop after a newline" $ 58 | let msg :: BS.ByteString 59 | msg = "foo\r\nbar" 60 | 61 | in msg ~> unquotedString `shouldParse` "foo" 62 | 63 | describe "parsing replies" $ do 64 | it "should succeed on a single line reply" $ 65 | let msg :: BS.ByteString 66 | msg = "250 OK\n" 67 | 68 | in msg ~> reply `shouldParse` ([Line 250 [Token "OK" Nothing]]) 69 | 70 | it "should succeed on a multi line reply" $ 71 | let msg :: BS.ByteString 72 | msg = "250-Foo Bar\n250 OK\n" 73 | 74 | in msg ~> reply `shouldParse` ([Line 250 [Token "Foo" Nothing, Token "Bar" Nothing], 75 | Line 250 [Token "OK" Nothing]]) 76 | 77 | it "should parse protocolinfo reply" $ 78 | let msg :: BS.ByteString 79 | msg = BS8.unlines [ "250-PROTOCOLINFO 1" 80 | , "250-AUTH METHODS=COOKIE,SAFECOOKIE,HASHEDPASSWORD COOKIEFILE=\"C:\\\\Users\\\\leon\\\\Desktop\\\\Tor Browser\\\\Browser\\\\TorBrowser\\\\Data\\\\Tor\\\\control_auth_cookie\"" 81 | , "250-VERSION Tor=\"0.2.6.7\"" 82 | , "250 OK"] 83 | 84 | in msg ~> reply `shouldParse` ([ Line 250 [Token "PROTOCOLINFO" Nothing, Token "1" Nothing] 85 | , Line 250 [Token "AUTH" Nothing, Token "METHODS" (Just "COOKIE,SAFECOOKIE,HASHEDPASSWORD"), Token "COOKIEFILE" (Just "C:\\\\Users\\\\leon\\\\Desktop\\\\Tor Browser\\\\Browser\\\\TorBrowser\\\\Data\\\\Tor\\\\control_auth_cookie")] 86 | , Line 250 [Token "VERSION" Nothing, Token "Tor" (Just "0.2.6.7")] 87 | , Line 250 [Token "OK" Nothing]]) 88 | -------------------------------------------------------------------------------- /test/Network/Anonymous/Tor/ProtocolSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Anonymous.Tor.ProtocolSpec where 4 | 5 | import Control.Concurrent (ThreadId, forkIO, 6 | killThread, threadDelay) 7 | import Control.Concurrent.MVar 8 | import Control.Monad.Catch 9 | import Control.Monad.IO.Class 10 | 11 | import Data.List (intersect) 12 | 13 | import qualified Network.Simple.TCP as NS (accept, connect, 14 | listen, send) 15 | import qualified Network.Socket as NS (Socket) 16 | 17 | import qualified Network.Anonymous.Tor.Protocol as P 18 | import qualified Network.Anonymous.Tor.Protocol.Types as PT 19 | import qualified Network.Socks5.Types as SocksT 20 | 21 | import qualified Data.Base32String.Default as B32 22 | import qualified Data.ByteString.Char8 as BS8 23 | import qualified Data.Text as T 24 | import qualified Data.Text.Encoding as TE 25 | 26 | import Test.Hspec 27 | 28 | mockServer :: ( MonadIO m 29 | , MonadMask m) 30 | => String 31 | -> (NS.Socket -> IO a) 32 | -> m ThreadId 33 | mockServer port callback = do 34 | tid <- liftIO $ forkIO $ 35 | NS.listen "*" port (\(lsock, _) -> NS.accept lsock (\(sock, _) -> do 36 | _ <- callback sock 37 | threadDelay 1000000 38 | return ())) 39 | 40 | liftIO $ threadDelay 500000 41 | return tid 42 | 43 | whichPort :: IO Integer 44 | whichPort = do 45 | let ports = [9051, 9151] 46 | availability <- mapM P.isAvailable ports 47 | return . fst . head . filter ((== P.Available) . snd) $ zip ports availability 48 | 49 | connect :: (NS.Socket -> IO a) -> IO a 50 | connect callback = do 51 | port <- whichPort 52 | NS.connect "127.0.0.1" (show port) (\(sock, _) -> callback sock) 53 | 54 | spec :: Spec 55 | spec = do 56 | describe "when detecting a Tor control port" $ do 57 | it "should detect a port" $ do 58 | port <- whichPort 59 | port `shouldSatisfy` (> 1024) 60 | 61 | describe "when detecting protocol info" $ do 62 | it "should allow cookie or null authentication" $ do 63 | info <- connect P.protocolInfo 64 | (PT.authMethods info) `shouldSatisfy` 65 | (not . null . intersect [PT.Cookie, PT.Null]) 66 | 67 | describe "when authenticating with Tor" $ do 68 | it "should succeed" $ do 69 | _ <- connect P.authenticate 70 | True `shouldBe` True 71 | 72 | describe "when detecting SOCKS port" $ do 73 | it "should return a valid port" $ do 74 | port <- connect $ \sock -> do 75 | P.authenticate sock 76 | P.socksPort sock 77 | 78 | port `shouldSatisfy` (> 1024) 79 | 80 | describe "when connecting through a SOCKS port" $ do 81 | it "should be able to connect to google" $ 82 | let clientSock done _ = 83 | putMVar done True 84 | 85 | constructSocksDestination = 86 | SocksT.SocksAddress (SocksT.SocksAddrDomainName (BS8.pack "www.google.com")) 80 87 | 88 | in do 89 | done <- newEmptyMVar 90 | 91 | _ <- connect $ \controlSock -> do 92 | P.authenticate controlSock 93 | P.connect' controlSock constructSocksDestination (clientSock done) 94 | 95 | takeMVar done `shouldReturn` True 96 | 97 | describe "when mapping an onion address" $ do 98 | it "should succeed in creating a mapping" $ 99 | let serverSock sock = do 100 | putStrLn "got client connecting to hidden service!" 101 | NS.send sock "HELLO\n" 102 | clientSock _ = 103 | putStrLn "Got a connection with hidden service!" 104 | 105 | destinationAddress onion = 106 | TE.encodeUtf8 $ T.concat [B32.toText onion, T.pack ".ONION"] 107 | 108 | constructSocksDestination onion = 109 | SocksT.SocksAddress (SocksT.SocksAddrDomainName (destinationAddress onion)) 80 110 | 111 | in do 112 | thread <- liftIO $ mockServer "8080" serverSock 113 | 114 | _ <- connect $ \controlSock -> do 115 | P.authenticate controlSock 116 | addr <- P.mapOnion controlSock 80 8080 False Nothing 117 | 118 | putStrLn ("got onion address: " ++ show addr) 119 | putStrLn ("waiting 1 minute..") 120 | 121 | threadDelay 60000000 122 | 123 | putStrLn ("waited 1 minute, connecting..") 124 | 125 | P.connect' controlSock (constructSocksDestination addr) clientSock 126 | 127 | killThread thread 128 | -------------------------------------------------------------------------------- /test/Network/Anonymous/TorSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Anonymous.TorSpec where 4 | 5 | import Control.Concurrent (threadDelay) 6 | import Control.Concurrent.MVar 7 | 8 | import qualified Network.Anonymous.Tor as Tor 9 | import qualified Network.Socks5.Types as SocksT 10 | 11 | import qualified Data.Base32String.Default as B32 12 | import qualified Data.Text as T 13 | import qualified Data.Text.Encoding as TE 14 | 15 | import Test.Hspec 16 | 17 | whichPort :: IO Integer 18 | whichPort = do 19 | let ports = [9051, 9151] 20 | availability <- mapM Tor.isAvailable ports 21 | return . fst . head . filter ((== Tor.Available) . snd) $ zip ports availability 22 | 23 | spec :: Spec 24 | spec = do 25 | describe "when starting a new server" $ do 26 | it "should accept connections through a hidden server" $ do 27 | clientDone <- newEmptyMVar 28 | serverDone <- newEmptyMVar 29 | 30 | port <- whichPort 31 | Tor.withSession port (withinSession clientDone serverDone) 32 | 33 | takeMVar clientDone `shouldReturn` True 34 | takeMVar serverDone `shouldReturn` True 35 | 36 | where 37 | withinSession clientDone serverDone sock = do 38 | onion <- Tor.accept sock 4321 Nothing (serverWorker serverDone) 39 | 40 | putStrLn ("Got Tor hidden server: " ++ show onion) 41 | putStrLn ("waiting 30 seconds..") 42 | threadDelay 30000000 43 | putStrLn ("waited 30 seconds, connecting..") 44 | 45 | Tor.connect' sock (constructDestination onion 4321) (clientWorker clientDone) 46 | 47 | destinationAddress onion = 48 | TE.encodeUtf8 $ T.concat [B32.toText onion, T.pack ".ONION"] 49 | 50 | constructDestination onion port = 51 | SocksT.SocksAddress (SocksT.SocksAddrDomainName (destinationAddress onion)) port 52 | 53 | serverWorker serverDone _ = do 54 | putStrLn "Accepted connection" 55 | putMVar serverDone True 56 | 57 | clientWorker clientDone _ = do 58 | putStrLn "Connected to hidden service!" 59 | putMVar clientDone True 60 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} 2 | --------------------------------------------------------------------------------