module Network.Anonymous.Tor.Protocol ( Availability (..)
, isAvailable
, socksPort
, connect
, connect'
, protocolInfo
, authenticate
, mapOnion ) where
import Control.Concurrent.MVar
import Control.Monad (unless, void)
import Control.Monad.Catch ( handle
, handleIOError )
import Control.Monad.IO.Class
import qualified System.IO.Error as E
import qualified GHC.IO.Exception as E hiding (ProtocolError)
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 (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
sendCommand :: MonadIO m
=> Network.Socket
-> BS.ByteString
-> m [Ast.Line]
sendCommand sock = sendCommand' sock errorF
where
errorF :: Ast.Line -> Maybe E.TorErrorType
errorF (Ast.Line 250 _ ) = Nothing
errorF (Ast.Line c tokens) = let message = toMessage tokens
code = codeName c
err = show c ++ " " ++ code ++ ": " ++ message
in Just . E.protocolErrorType $ err
toMessage :: [Ast.Token] -> String
toMessage = unwords . map extract
extract :: Ast.Token -> String
extract (Ast.Token s Nothing ) = BS8.unpack s
extract (Ast.Token k (Just v)) = BS8.unpack k ++ "=" ++ BS8.unpack v
codeName :: Integer -> String
codeName 250 = "OK"
codeName 251 = "Operation was unnecessary"
codeName 451 = "Ressource exhausted"
codeName 500 = "Syntax error: protocol"
codeName 510 = "Unrecognized command"
codeName 511 = "Unimplemented command"
codeName 512 = "Syntax error in command argument"
codeName 513 = "Unrecognized command argument"
codeName 514 = "Authentication required"
codeName 550 = "Unspecified Tor error"
codeName 551 = "Internal error"
codeName 552 = "Unrecognized entity"
codeName 553 = "Invalid configuration value"
codeName 554 = "Invalid descriptor"
codeName 555 = "Unmanaged entity"
codeName 650 = "Asynchrounous event notification"
codeName _ = "Unrecognized status code"
sendCommand' :: MonadIO m
=> Network.Socket
-> (Ast.Line -> Maybe E.TorErrorType)
-> BS.ByteString
-> m [Ast.Line]
sendCommand' sock errorF msg = do
_ <- liftIO $ Network.sendAll sock msg
res <- liftIO $ NA.parseOne sock (Atto.parse Parser.reply)
case errorF . head $ res of
Just e -> E.torError (E.mkTorError e)
_ -> return ()
return res
data Availability =
Available |
ConnectionRefused |
IncorrectPort
deriving (Show, Eq)
isAvailable :: MonadIO m
=> Integer
-> m Availability
isAvailable port = liftIO $ do
result <- newEmptyMVar
handle (\(E.TorError (E.ProtocolError _)) -> putMVar result IncorrectPort)
$ handleIOError (\e ->
if E.ioeGetErrorType e == E.OtherError || E.ioeGetErrorType e == E.NoSuchThing
then putMVar result ConnectionRefused
else if E.ioeGetErrorType e == E.UserError
then putMVar result IncorrectPort
else E.ioError e)
(performTest port result)
takeMVar result
where
performTest port result =
NST.connect "127.0.0.1" (show port) (\(sock, _) -> do
_ <- protocolInfo sock
putMVar result Available)
socksPort :: MonadIO m
=> Network.Socket
-> m Integer
socksPort s = do
reply <- sendCommand s (BS8.pack "GETCONF SOCKSPORT\n")
return . fst . fromJust . BS8.readInteger . fromJust . Ast.tokenValue . head . Ast.lineMessage . fromJust $ Ast.line (BS8.pack "SocksPort") reply
connect :: MonadIO m
=> Integer
-> Socks.SocksAddress
-> (Network.Socket -> IO a)
-> m a
connect sport remote callback = liftIO $ do
(sock, _) <- Socks.socksConnect conf remote
callback sock
where
conf = Socks.defaultSocksConf "127.0.0.1" (fromInteger sport)
connect' :: MonadIO m
=> Network.Socket
-> Socks.SocksAddress
-> (Network.Socket -> IO a)
-> m a
connect' sock remote callback = do
sport <- socksPort sock
connect sport remote callback
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
authenticate :: MonadIO m
=> Network.Socket
-> m ()
authenticate s = do
info <- protocolInfo s
unless (T.Cookie `elem` T.authMethods info)
(E.torError (E.mkTorError . E.permissionDeniedErrorType $ "Authentication via cookie file disabled."))
cookieData <- liftIO $ readCookie (T.cookieFile info)
liftIO . void $ sendCommand' s errorF (BS8.concat ["AUTHENTICATE ", TE.encodeUtf8 $ HS.toText cookieData, "\n"])
where
readCookie :: Maybe FilePath -> IO HS.HexString
readCookie Nothing = E.torError (E.mkTorError . E.protocolErrorType $ "No cookie path specified.")
readCookie (Just file) = return . HS.fromBytes =<< BS.readFile file
errorF :: Ast.Line -> Maybe E.TorErrorType
errorF (Ast.Line 250 _) = Nothing
errorF _ = Just . E.permissionDeniedErrorType $ "Authentication failed."
mapOnion :: MonadIO m
=> Network.Socket
-> Integer
-> Integer
-> Bool
-> Maybe BS.ByteString
-> m B32.Base32String
mapOnion s rport lport detach pkey = do
reply <- sendCommand s $ BS8.concat
[ "ADD_ONION "
, maybe "NEW:BEST" (\pk -> "RSA1024:" `BS.append` pk) pkey
, if detach then " Flags=Detach " else " "
, "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