diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2015 Leon Mergen + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +network-anonymous-tor +===================== + +[![Build Status](https://travis-ci.org/solatis/haskell-network-anonymous-tor.png?branch=master)](https://travis-ci.org/solatis/haskell-network-anonymous-tor) +[![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) +[![MIT](http://b.repl.ca/v1/license-MIT-blue.png)](http://en.wikipedia.org/wiki/MIT_License) +[![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) + +network-anonymous-tor is a Haskell API for Tor anonymous networking diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/network-anonymous-tor.cabal b/network-anonymous-tor.cabal new file mode 100644 --- /dev/null +++ b/network-anonymous-tor.cabal @@ -0,0 +1,80 @@ +name: network-anonymous-tor +category: Network +version: 0.9.0 +license: MIT +license-file: LICENSE +copyright: (c) 2014 Leon Mergen +author: Leon Mergen +maintainer: leon@solatis.com +stability: experimental +synopsis: Haskell API for Tor anonymous networking +description: + This library providess an API that wraps around the Tor control port + to create ad-hoc hidden services +homepage: http://www.leonmergen.com/opensource.html +build-type: Simple +data-files: LICENSE, README.md +cabal-version: >= 1.10 +tested-with: GHC == 7.8, GHC == 7.10 + +library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -ferror-spans -auto-all -caf-all + + exposed-modules: Network.Anonymous.Tor + Network.Anonymous.Tor.Error + Network.Anonymous.Tor.Protocol + Network.Anonymous.Tor.Protocol.Types + Network.Anonymous.Tor.Protocol.Parser + Network.Anonymous.Tor.Protocol.Parser.Ast + + build-depends: base >= 4.3 && < 5 + , transformers + + , network + , network-simple + , socks + + , attoparsec + , network-attoparsec + , exceptions + , hexstring + , base32string + + , text + , bytestring + +test-suite test-suite + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -Wall -ferror-spans -threaded -auto-all -caf-all -fno-warn-type-defaults + + other-modules: Spec + Main + + build-depends: base >= 4.3 && < 5 + , exceptions + , transformers + + , network + , network-simple + , socks + + , attoparsec + , bytestring + , base32string + , text + + , hspec + , hspec-attoparsec + , hspec-expectations + + , network-anonymous-tor + +source-repository head + type: git + location: git://github.com/solatis/haskell-network-anonymous-tor.git + branch: master diff --git a/src/Network/Anonymous/Tor.hs b/src/Network/Anonymous/Tor.hs new file mode 100644 --- /dev/null +++ b/src/Network/Anonymous/Tor.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides the main interface for establishing secure and +-- anonymous connections with other hosts on the interface using the +-- Tor project. For more information about the Tor network, see: +-- +-- +module Network.Anonymous.Tor ( + -- * Introduction to Tor + -- $tor-introduction + + -- * Client side + -- $tor-client + P.connect + , P.connect' + + -- * Server side + -- $tor-server + , P.mapOnion + , accept + + -- * Probing Tor configuration information + , P.detectPort + , P.socksPort + + -- ** Setting up the context + , withSession + + ) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad.IO.Class + +import qualified Data.Base32String.Default as B32 + +import qualified Network.Simple.TCP as NST +import qualified Network.Socket as Network + +import qualified Network.Anonymous.Tor.Protocol as P + + +-------------------------------------------------------------------------------- +-- $tor-introduction +-- +-- This module is a (partial) implementation of the Tor control protocol. Tor is an +-- internet anonimization network. Whereas historically, Tor is primarily +-- intended for privately browsing the world wide web, the service also supports +-- application oriented P2P communication, to implement communication between applications. +-- +-- The general idea of the Tor control interface to Tor is that you establish a master +-- connection with the Tor control port, and create new, short-lived connections with +-- the Tor bridge for the communication with the individual peers. +-- +-------------------------------------------------------------------------------- +-- $tor-client +-- +-- == Connect through Tor with explicit port +-- Connect through Tor on using a specified SOCKS port. Note that you do not +-- need to authorize with the Tor control port for this functionality. +-- +-- @ +-- main = 'connect' 9050 constructDestination worker +-- +-- where +-- constructDestination = +-- 'SocksT.SocksAddress' (SocksT.SocksAddrDomainName (BS8.pack "www.google.com")) 80 +-- +-- worker sock = +-- -- Now you may use sock to communicate with the remote. +-- return () +-- @ +-- +-- == Connect through Tor using control port +-- Connect through Tor and derive the SOCKS port from the Tor configuration. This +-- function will query the Tor control service to find out which SOCKS port the +-- Tor daemon listens at. +-- +-- @ +-- main = 'withSession' withinSession +-- +-- where +-- constructDestination = +-- 'SocksT.SocksAddress' (SocksT.SocksAddrDomainName (BS8.pack "2a3b4c.onion")) 80 +-- +-- withinSession :: 'Network.Socket' -> IO () +-- withinSession sock = do +-- 'connect'' sock constructDestination worker +-- +-- worker sock = +-- -- Now you may use sock to communicate with the remote. +-- return () +-- @ +-- +-------------------------------------------------------------------------------- +-- $tor-server +-- +-- == Mapping +-- Create a new hidden service, and map remote port 80 to local port 8080. +-- +-- @ +-- main = 'withSession' withinSession +-- +-- where +-- withinSession :: 'Network.Socket' -> IO () +-- withinSession sock = do +-- onion <- 'mapOnion' sock 80 8080 +-- -- At this point, 'onion' contains the base32 representation of +-- -- our hidden service, without the trailing '.onion' part. +-- -- +-- -- Remember that, once we leave this function, the connection with +-- -- the Tor control service will be lost and any mappings will be +-- -- cleaned up. +-- @ +-- +-- == Server +-- Convenience function which creates a hidden service on port 80 that is mapped +-- to a server we create on the fly. Note that because we are mapping the hidden +-- service's port 1:1 with our local port, port 80 must still be available. +-- +-- @ +-- main = 'withSession' withinSession +-- +-- where +-- withinSession :: 'Network.Socket' -> IO () +-- withinSession sock = do +-- onion <- 'accept' sock 80 worker +-- -- At this point, 'onion' contains the base32 representation of +-- -- our hidden service, without the trailing '.onion' part, and any +-- -- incoming connections will be redirected to our 'worker' function. +-- -- +-- -- Once again, when we leave this function, all registered mappings +-- -- will be lost. +-- +-- worker sock = do +-- -- Now you may use sock to communicate with the remote. +-- return () +-- @ +-------------------------------------------------------------------------------- + +-- | Establishes a connection and authenticates with the Tor control socket. +-- After authorization has been succesfully completed it executes the callback +-- provided. +-- +-- Note that when the session completes, the connection with the Tor control +-- port is dropped, which means that any port mappings, connections and hidden +-- services you have registered within the session will be cleaned up. This +-- is by design, to prevent stale mappings when an application crashes. +withSession :: Integer -- | Port the Tor control server is listening at. Use + -- 'detectPort' to probe possible ports. + -> (Network.Socket -> IO a) -- | Callback function called after a session has been + -- established succesfully. + -> IO a -- | Returns the value returned by the callback. +withSession port callback = + NST.connect "127.0.0.1" (show port) (\(sock, _) -> do + _ <- P.authenticate sock + callback sock) + +-- | Convenience function that creates a new hidden service and starts accepting +-- connections for it. Note that this creates a new local server at the same +-- port as the public port, so ensure that the port is not yet in use. +accept :: MonadIO m + => Network.Socket -- | Connection with Tor control server + -> Integer -- | Port to listen at + -> (Network.Socket -> IO ()) -- | Callback function called for each incoming connection + -> m B32.Base32String -- | Returns the hidden service descriptor created + -- without the '.onion' part. +accept sock port callback = do + -- First create local service + _ <- liftIO $ forkIO $ + NST.listen "*" (show port) (\(lsock, _) -> do + putStrLn ("started server on port " ++ show port ++ ", now accepting connections") + NST.accept lsock (\(csock, _) -> do + putStrLn "accepted connection, now executing callback" + _ <- callback csock + threadDelay 1000000 + return ())) + + P.mapOnion sock port port diff --git a/src/Network/Anonymous/Tor/Error.hs b/src/Network/Anonymous/Tor/Error.hs new file mode 100644 --- /dev/null +++ b/src/Network/Anonymous/Tor/Error.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Tor error types, inspired by System.IO.Error +module Network.Anonymous.Tor.Error where + +import Data.Typeable (Typeable) + +import Control.Monad.IO.Class +import Control.Exception (throwIO) +import Control.Exception.Base (Exception) + +-- | Error type used +type TorError = TorException + +-- | Exception that we use to throw. It is the only type of exception +-- we throw, and the type of error is embedded within the exception. +data TorException = TorError { + toreType :: TorErrorType -- ^ Our error type + } deriving (Show, Eq, Typeable) + +-- | Derives our Tor exception from the standard exception, which opens it +-- up to being used with all the regular try/catch/bracket/etc functions. +instance Exception TorException + +-- | An abstract type that contains a value for each variant of 'TorError' +data TorErrorType + = Timeout + | Unreachable + | ProtocolError + | PermissionDenied + deriving (Show, Eq) + +-- | Generates new TorException +mkTorError :: TorErrorType -> TorError +mkTorError t = TorError { toreType = t } + +-- | Tor error when a timeout has occurred +timeoutErrorType :: TorErrorType +timeoutErrorType = Timeout + +-- | Tor error when a host was unreachable +unreachableErrorType :: TorErrorType +unreachableErrorType = Unreachable + +-- | Tor error when communication with the SAM bridge fails +protocolErrorType :: TorErrorType +protocolErrorType = ProtocolError + +-- | Tor error when communication with the SAM bridge fails +permissionDeniedErrorType :: TorErrorType +permissionDeniedErrorType = PermissionDenied + +-- | Raise an Tor Exception in the IO monad +torException :: (MonadIO m) + => TorException + -> m a +torException = liftIO . throwIO + +-- | Raise an Tor error in the IO monad +torError :: (MonadIO m) + => TorError + -> m a +torError = torException diff --git a/src/Network/Anonymous/Tor/Protocol.hs b/src/Network/Anonymous/Tor/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Network/Anonymous/Tor/Protocol.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Protocol description +-- +-- Defines functions that handle the advancing of the Tor control protocol. +-- +-- __Warning__: This function is used internally by 'Network.Anonymous.Tor' +-- and using these functions directly is unsupported. The +-- interface of these functions might change at any time without +-- prior notice. +-- +module Network.Anonymous.Tor.Protocol ( detectPort + , socksPort + , connect + , connect' + , protocolInfo + , authenticate + , mapOnion ) where + +import Control.Concurrent.MVar + +import Control.Monad (unless, void, when) +import Control.Monad.Catch (handleAll) +import Control.Monad.IO.Class + +import qualified Data.Attoparsec.ByteString as Atto +import qualified Data.Base32String.Default as B32 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.HexString as HS +import Data.Maybe (catMaybes, fromJust) + +import qualified Data.Text.Encoding as TE + +import qualified Network.Attoparsec as NA +import qualified Network.Simple.TCP as NST + +import qualified Network.Socket as Network hiding + (recv, + send) +import qualified Network.Socket.ByteString as Network +import qualified Network.Socks5 as Socks + +import qualified Network.Anonymous.Tor.Error as E +import qualified Network.Anonymous.Tor.Protocol.Parser as Parser +import qualified Network.Anonymous.Tor.Protocol.Parser.Ast as Ast +import qualified Network.Anonymous.Tor.Protocol.Types as T + +import Debug.Trace (trace) + +sendCommand :: MonadIO m + => Network.Socket -- ^ Our connection with the Tor control port + -> BS.ByteString -- ^ The command / instruction we wish to send + -> m [Ast.Line] +sendCommand sock = sendCommand' sock 250 E.protocolErrorType + +sendCommand' :: MonadIO m + => Network.Socket -- ^ Our connection with the Tor control port + -> Integer -- ^ The status code we expect + -> E.TorErrorType -- ^ The type of error to throw if status code doesn't match + -> BS.ByteString -- ^ The command / instruction we wish to send + -> m [Ast.Line] +sendCommand' sock status errorType msg = do + trace ("sending data: " ++ show msg) (return ()) + + _ <- liftIO $ Network.sendAll sock msg + res <- liftIO $ NA.parseOne sock (Atto.parse Parser.reply) + + trace ("got response: " ++ show res) (return ()) + + when (Ast.statusCode res /= status) + (E.torError (E.mkTorError errorType)) + + return res + +-- | Probes several default ports to see if there is a service at the remote +-- that behaves like the Tor controller daemon. Will return a list of all +-- the probed ports that have a Tor service, since in some scenarios there +-- will be multiple Tor services (specifically, when a user has both the +-- Tor browser bundle and a separate Tor relay running). +detectPort :: MonadIO m + => [Integer] -- ^ The ports we wish to probe + -> m [Integer] -- ^ The ports which respond like a Tor service +detectPort possible = do + + ports <- liftIO $ mapM hasTor possible + + return (catMaybes ports) + + where + -- Returns the port if the remote service is available and responds in + -- an expected fashion to 'protocolInfo', returns Nothing otherwise. + hasTor :: Integer -> IO (Maybe Integer) + hasTor port = liftIO $ do + result <- newEmptyMVar + + handleAll + (\_ -> putMVar result Nothing) + (NST.connect "127.0.0.1" (show port) (\(sock, _) -> do + _ <- protocolInfo sock + putMVar result (Just port))) + + takeMVar result + +-- | Returns the configured SOCKS proxy port +socksPort :: MonadIO m + => Network.Socket + -> m Integer +socksPort s = do + reply <- sendCommand s (BS8.pack "GETCONF SOCKSPORT\n") + + liftIO $ putStrLn ("got socksport reply: " ++ show reply) + + return . fst . fromJust . BS8.readInteger . fromJust . Ast.tokenValue . head . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "SocksPort") reply + +-- | Connect through a remote using the Tor SOCKS proxy. The remote might me a +-- a normal host/ip or a hidden service address. When you provide a FQDN to +-- resolve, it will be resolved by the Tor service, and as such is secure. +-- +-- This function is provided as a convenience, since it doesn't actually use +-- the Tor control protocol, and can be used to talk with any Socks5 compatible +-- proxy server. +connect :: MonadIO m + => Integer -- ^ Port our tor SOCKS server listens at. + -> Socks.SocksAddress -- ^ Address we wish to connect to + -> (Network.Socket -> IO a) -- ^ Computation to execute once connection has been establised + -> m a +connect sport remote callback = liftIO $ do + + putStrLn ("Now establishing anonymous connection with remote: " ++ show remote) + + (sock, _) <- Socks.socksConnect conf remote + + putStrLn "Established connection!" + + callback sock + + where + conf = Socks.defaultSocksConf "127.0.0.1" (fromInteger sport) + +connect' :: MonadIO m + => Network.Socket -- ^ Our connection with the Tor control port + -> Socks.SocksAddress -- ^ Address we wish to connect to + -> (Network.Socket -> IO a) -- ^ Computation to execute once connection has been establised + -> m a +connect' sock remote callback = do + sport <- socksPort sock + connect sport remote callback + +-- | Requests protocol version information from Tor. This can be used while +-- still unauthenticated and authentication methods can be derived from this +-- information. +protocolInfo :: MonadIO m + => Network.Socket + -> m T.ProtocolInfo +protocolInfo s = do + res <- sendCommand s (BS.concat ["PROTOCOLINFO", "\n"]) + + return (T.ProtocolInfo (protocolVersion res) (torVersion res) (methods res) (cookieFile res)) + + where + + protocolVersion :: [Ast.Line] -> Integer + protocolVersion reply = + fst . fromJust . BS8.readInteger . Ast.tokenKey . last . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "PROTOCOLINFO") reply + + torVersion :: [Ast.Line] -> [Integer] + torVersion reply = + map (fst . fromJust . BS8.readInteger) . BS8.split '.' . fromJust . Ast.value "Tor" . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "VERSION") reply + + methods :: [Ast.Line] -> [T.AuthMethod] + methods reply = + map (read . BS8.unpack) . BS8.split ',' . fromJust . Ast.value "METHODS" . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "AUTH") reply + + cookieFile :: [Ast.Line] -> Maybe FilePath + cookieFile reply = + fmap BS8.unpack . Ast.value "COOKIEFILE" . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "AUTH") reply + +-- | Authenticates with the Tor control server, based on the authentication +-- information returned by PROTOCOLINFO. +authenticate :: MonadIO m + => Network.Socket + -> m () +authenticate s = do + info <- protocolInfo s + + -- Ensure that we can authenticate using a cookie file + unless (T.Cookie `elem` T.authMethods info) + (E.torError (E.mkTorError E.permissionDeniedErrorType)) + + cookieData <- liftIO $ readCookie (T.cookieFile info) + + liftIO . void $ sendCommand' s 250 E.permissionDeniedErrorType (BS8.concat ["AUTHENTICATE ", TE.encodeUtf8 $ HS.toText cookieData, "\n"]) + + where + + readCookie :: Maybe FilePath -> IO HS.HexString + readCookie Nothing = E.torError (E.mkTorError E.protocolErrorType) + readCookie (Just file) = return . HS.fromBytes =<< BS.readFile file + +-- | Creates a new hidden service and maps a public port to a local port. Useful +-- for bridging a local service (e.g. a webserver or irc daemon) as a Tor +-- hidden service. +mapOnion :: MonadIO m + => Network.Socket -- ^ Connection with tor Control port + -> Integer -- ^ Remote point of hidden service to listen at + -> Integer -- ^ Local port to map onion service to + -> m B32.Base32String -- ^ The address/service id of the Onion without the .onion aprt +mapOnion s rport lport = do + reply <- sendCommand s (BS8.concat ["ADD_ONION NEW:BEST Port=", BS8.pack (show rport), ",127.0.0.1:", BS8.pack(show lport), "\n"]) + + return . B32.b32String' . fromJust . Ast.tokenValue . head . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "ServiceID") reply diff --git a/src/Network/Anonymous/Tor/Protocol/Parser.hs b/src/Network/Anonymous/Tor/Protocol/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Anonymous/Tor/Protocol/Parser.hs @@ -0,0 +1,135 @@ +-- | Parser defintions +-- +-- Defines parsers used by the Tor Control protocol +-- +-- __Warning__: This function is used internally by 'Network.Anonymous.Tor' +-- and using these functions directly is unsupported. The +-- interface of these functions might change at any time without +-- prior notice. +-- + +module Network.Anonymous.Tor.Protocol.Parser ( quotedString + , unquotedString + , reply + , key + , keyValue + , value + , token + , tokens ) where + +import Control.Applicative ((*>), (<$>), (<*), (<*>), + (<|>)) + +import qualified Data.Attoparsec.ByteString as Atto +import qualified Data.Attoparsec.ByteString.Char8 as Atto8 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Word (Word8) +import qualified Network.Anonymous.Tor.Protocol.Parser.Ast as A + +-- | Ascii offset representation of a double quote. +doubleQuote :: Word8 +doubleQuote = 34 + +-- | Ascii offset representation of a single quote. +singleQuote :: Word8 +singleQuote = 39 + +-- | Ascii offset representation of a backslash. +backslash :: Word8 +backslash = 92 + +-- | Ascii offset representation of a minus '-' symbol +minus :: Word8 +minus = 45 + +-- | Ascii offset representation of a plus '+' symbol +plus :: Word8 +plus = 43 + +-- | Ascii offset representation of a space ' ' character +space :: Word8 +space = 32 + +-- | Ascii offset representation of an equality sign. +equals :: Word8 +equals = 61 + +-- | Parses a single- or double-quoted string, and returns all bytes within the +-- value; the unescaping is beyond the scope of this function (since different +-- unescaping mechanisms might be desired). +quotedString :: Atto.Parser BS.ByteString +quotedString = + let quoted :: Word8 -- ^ The character used for quoting + -> Atto.Parser BS.ByteString -- ^ The value inside the quotes, without the surrounding quotes + quoted c = (Atto.word8 c *> escaped c <* Atto.word8 c) + + -- | Parses an escaped string, with an arbitrary surrounding quote type. + escaped :: Word8 -> Atto.Parser BS.ByteString + escaped c = BS8.concat <$> Atto8.many' + -- Make sure that we eat pairs of backslashes; this will make sure + -- that a string such as "\\\\" is interpreted correctly, and the + -- ending quoted will not be interpreted as escaped. + ( Atto8.string (BS8.pack "\\\\") + + -- This eats all escaped quotes and leaves them in tact; the unescaping + -- is beyond the scope of this function. + <|> Atto8.string (BS.pack [backslash, c]) + + -- And for the rest: eat everything that is not a quote. + <|> (BS.singleton <$> Atto.satisfy (/= c))) + + in quoted doubleQuote <|> quoted singleQuote + +-- | An unquoted string is "everything until a whitespace or newline is reached". +unquotedString :: Atto.Parser BS.ByteString +unquotedString = + Atto8.takeWhile1 (not . Atto8.isSpace) + +reply :: Atto.Parser [A.Line] +reply = do + -- A reply is a series of lines that look like 250-Foo or 250+Bar and then + -- followed by a line that uses a space like 250 Wombat. + -- + -- Let's parse all these lines into a reply. + replies <- Atto.many' (replyLine minus <|> replyLine plus) + lastReply <- replyLine space + + return (replies ++ [lastReply]) + + where + replyLine :: Word8 -> Atto.Parser A.Line + replyLine c = A.Line <$> Atto8.decimal <*> (Atto.word8 c *> tokens) <* Atto8.endOfLine + +-- | Parses either a quoted value or an unquoted value +value :: Atto.Parser BS.ByteString +value = + quotedString <|> unquotedString + +-- | Parses key and value +keyValue :: Atto.Parser A.Token +keyValue = do + A.Token k _ <- key + _ <- Atto.word8 equals + v <- value + + return (A.Token k (Just v)) + +-- | Parses a key, which is anything until either a space has been reached, or +-- an '=' is reached. +key :: Atto.Parser A.Token +key = + let isKeyEnd '=' = True + isKeyEnd c = Atto8.isSpace c + + in flip A.Token Nothing <$> Atto8.takeWhile1 (not . isKeyEnd) + +-- | A Token is either a Key or a Key/Value combination. +token :: Atto.Parser A.Token +token = + Atto.skipWhile Atto8.isHorizontalSpace *> (keyValue <|> key) + +-- | Parser that reads keys or key/values +tokens :: Atto.Parser [A.Token] +tokens = + Atto.many' token diff --git a/src/Network/Anonymous/Tor/Protocol/Parser/Ast.hs b/src/Network/Anonymous/Tor/Protocol/Parser/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Network/Anonymous/Tor/Protocol/Parser/Ast.hs @@ -0,0 +1,74 @@ +-- | Abstract syntax tree used by the 'Parser', including helper functions +-- for traversing the tree. +-- +-- __Warning__: This function is used internally by 'Network.Anonymous.Tor' +-- and using these functions directly is unsupported. The +-- interface of these functions might change at any time without +-- prior notice. +-- + +module Network.Anonymous.Tor.Protocol.Parser.Ast where +import qualified Data.Attoparsec.ByteString as Atto + +import qualified Data.ByteString as BS + +-- | A token is a key and can maybe have an associated value +data Token = Token { + tokenKey :: BS.ByteString, + tokenValue :: Maybe BS.ByteString + } deriving (Show, Eq) + +-- | A line is just a sequence of tokens -- the 'Parser' ends the chain +-- when a newline is received. +data Line = Line { + lineStatusCode :: Integer, + lineMessage :: [Token] + } deriving (Show, Eq) + +-- | Returns true if the key was found +key :: BS.ByteString -- ^ The key to look for + -> [Token] -- ^ Tokens to consider + -> Bool -- ^ Result +key _ [] = False -- Key was not found +key k1 (Token k2 _:xs) = (k1 == k2) || key k1 xs -- If keys match, return true, otherwise enter recursion + +-- | Looks up a key and returns the value if found +value :: BS.ByteString -- ^ Key to look for + -> [Token] -- ^ Tokens to consider + -> Maybe BS.ByteString -- ^ The value if the key was found +value _ [] = Nothing -- Key not found! +value k1 (Token k2 v:xs) = if k1 == k2 -- This assumes keys are unique + then v -- This returns the value of the key, if any value is associated + else value k1 xs -- Otherwise we continue our quest (in recursion) + +-- | Retrieves value, and applies it to an Attoparsec parser +valueAs :: Atto.Parser a + -> BS.ByteString + -> [Token] + -> Maybe a +valueAs p k xs = + let parseValue bs = + case Atto.parseOnly p bs of + Left _ -> Nothing + Right r -> Just r + + in case value k xs of + Nothing -> Nothing + Just v -> parseValue v + +-- | Retrieves first line that starts with a certain token +line :: BS.ByteString -- ^ Token key to look for + -> [Line] -- ^ Lines to consider + -> Maybe Line -- ^ The line that starts with this key, if found +line _ [] = Nothing +line k1 (x:xs) = + case x of + Line _ (Token k2 _:_) -> if k1 == k2 + then Just x + else line k1 xs + _ -> line k1 xs + +-- | Returns status code of a reply. +statusCode :: [Line] + -> Integer +statusCode = lineStatusCode . head diff --git a/src/Network/Anonymous/Tor/Protocol/Types.hs b/src/Network/Anonymous/Tor/Protocol/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Anonymous/Tor/Protocol/Types.hs @@ -0,0 +1,32 @@ +-- | Types used by the 'Network.Anonymous.Tor.Protocol' module + +module Network.Anonymous.Tor.Protocol.Types where + +-- | Authentication types supported by the Tor service +data AuthMethod = + Cookie | SafeCookie | HashedPassword + + deriving (Eq) + +instance Read AuthMethod where + readsPrec _ "COOKIE" = [(Cookie, "")] + readsPrec _ "SAFECOOKIE" = [(SafeCookie, "")] + readsPrec _ "HASHEDPASSWORD" = [(HashedPassword, "")] + readsPrec _ s = error ("Not a valid AuthMethod: " ++ s) + +instance Show AuthMethod where + show Cookie = "COOKIE" + show SafeCookie = "SAFECOOKIE" + show HashedPassword = "HASHEDPASSWORD" + +-- | Information about our protocol (and version) +data ProtocolInfo = ProtocolInfo { + protocolVersion :: Integer, + + torVersion :: [Integer], + + authMethods :: [AuthMethod], + + cookieFile :: Maybe FilePath + + } deriving (Show, Eq) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.Hspec.Runner +import qualified Spec + +import Network (withSocketsDo) + +main :: IO () +main = + withSocketsDo $ hspecWith defaultConfig Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}