Blame Network/Socks5/Wire.hs

Packit fc2124
{-# LANGUAGE DeriveDataTypeable #-}
Packit fc2124
-- |
Packit fc2124
-- Module      : Network.Socks5.Wire
Packit fc2124
-- License     : BSD-style
Packit fc2124
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
Packit fc2124
-- Stability   : experimental
Packit fc2124
-- Portability : unknown
Packit fc2124
module Network.Socks5.Wire
Packit fc2124
    ( SocksHello(..)
Packit fc2124
    , SocksHelloResponse(..)
Packit fc2124
    , SocksRequest(..)
Packit fc2124
    , SocksResponse(..)
Packit fc2124
    ) where
Packit fc2124
Packit fc2124
import Control.Applicative
Packit fc2124
import Control.Monad
Packit fc2124
import qualified Data.ByteString as B
Packit fc2124
import Data.Serialize
Packit fc2124
Packit fc2124
import Network.Socket (PortNumber)
Packit fc2124
Packit fc2124
import Network.Socks5.Types
Packit fc2124
import Network.Socks5.Parse as P (anyByte, take)
Packit fc2124
Packit fc2124
-- | Initial message sent by client with the list of authentification methods supported
Packit fc2124
data SocksHello = SocksHello { getSocksHelloMethods :: [SocksMethod] }
Packit fc2124
    deriving (Show,Eq)
Packit fc2124
Packit fc2124
-- | Initial message send by server in return from Hello, with the
Packit fc2124
-- server chosen method of authentication
Packit fc2124
data SocksHelloResponse = SocksHelloResponse { getSocksHelloResponseMethod :: SocksMethod }
Packit fc2124
    deriving (Show,Eq)
Packit fc2124
Packit fc2124
-- | Define a SOCKS requests
Packit fc2124
data SocksRequest = SocksRequest
Packit fc2124
    { requestCommand  :: SocksCommand
Packit fc2124
    , requestDstAddr  :: SocksHostAddress
Packit fc2124
    , requestDstPort  :: PortNumber
Packit fc2124
    } deriving (Show,Eq)
Packit fc2124
Packit fc2124
-- | Define a SOCKS response
Packit fc2124
data SocksResponse = SocksResponse
Packit fc2124
    { responseReply    :: SocksReply
Packit fc2124
    , responseBindAddr :: SocksHostAddress
Packit fc2124
    , responseBindPort :: PortNumber
Packit fc2124
    } deriving (Show,Eq)
Packit fc2124
Packit fc2124
getAddr 1 = SocksAddrIPV4 <$> getWord32host
Packit fc2124
getAddr 3 = SocksAddrDomainName <$> (getWord8 >>= getByteString . fromIntegral)
Packit fc2124
getAddr 4 = SocksAddrIPV6 <$> (liftM4 (,,,) getWord32host getWord32host getWord32host getWord32host)
Packit fc2124
getAddr n = error ("cannot get unknown socket address type: " ++ show n)
Packit fc2124
Packit fc2124
putAddr (SocksAddrIPV4 h)         = putWord8 1 >> putWord32host h
Packit fc2124
putAddr (SocksAddrDomainName b)   = putWord8 3 >> putWord8 (fromIntegral $ B.length b) >> putByteString b
Packit fc2124
putAddr (SocksAddrIPV6 (a,b,c,d)) = putWord8 4 >> mapM_ putWord32host [a,b,c,d]
Packit fc2124
Packit fc2124
getSocksRequest 5 = do
Packit fc2124
    cmd <- toEnum . fromIntegral <$> getWord8
Packit fc2124
    _   <- getWord8
Packit fc2124
    addr <- getWord8 >>= getAddr
Packit fc2124
    port <- fromIntegral <$> getWord16be
Packit fc2124
    return $ SocksRequest cmd addr port
Packit fc2124
getSocksRequest v =
Packit fc2124
    error ("unsupported version of the protocol " ++ show v)
Packit fc2124
Packit fc2124
getSocksResponse 5 = do
Packit fc2124
    reply <- toEnum . fromIntegral <$> getWord8
Packit fc2124
    _     <- getWord8
Packit fc2124
    addr <- getWord8 >>= getAddr
Packit fc2124
    port <- fromIntegral <$> getWord16be
Packit fc2124
    return $ SocksResponse reply addr port
Packit fc2124
getSocksResponse v =
Packit fc2124
    error ("unsupported version of the protocol " ++ show v)
Packit fc2124
Packit fc2124
instance Serialize SocksHello where
Packit fc2124
    put (SocksHello ms) = do
Packit fc2124
        putWord8 5
Packit fc2124
        putWord8 $ fromIntegral $ length ms
Packit fc2124
        mapM_ (putWord8 . fromIntegral . fromEnum) ms
Packit fc2124
    get = do
Packit fc2124
        v <- getWord8
Packit fc2124
        case v of
Packit fc2124
            5 -> getWord8 >>= flip replicateM (toEnum . fromIntegral <$> getWord8) . fromIntegral >>= return . SocksHello
Packit fc2124
            _ -> error "unsupported sock hello version"
Packit fc2124
Packit fc2124
instance Serialize SocksHelloResponse where
Packit fc2124
    put (SocksHelloResponse m) = putWord8 5 >> putWord8 (fromIntegral $ fromEnum $ m)
Packit fc2124
    get = do
Packit fc2124
        v <- getWord8
Packit fc2124
        case v of
Packit fc2124
            5 -> SocksHelloResponse . toEnum . fromIntegral <$> getWord8
Packit fc2124
            _ -> error "unsupported sock hello response version"
Packit fc2124
Packit fc2124
instance Serialize SocksRequest where
Packit fc2124
    put req = do
Packit fc2124
        putWord8 5
Packit fc2124
        putWord8 $ fromIntegral $ fromEnum $ requestCommand req
Packit fc2124
        putWord8 0
Packit fc2124
        putAddr $ requestDstAddr req
Packit fc2124
        putWord16be $ fromIntegral $ requestDstPort req
Packit fc2124
        
Packit fc2124
    get = getWord8 >>= getSocksRequest
Packit fc2124
Packit fc2124
instance Serialize SocksResponse where
Packit fc2124
    put req = do
Packit fc2124
        putWord8 5
Packit fc2124
        putWord8 $ fromIntegral $ fromEnum $ responseReply req
Packit fc2124
        putWord8 0
Packit fc2124
        putAddr $ responseBindAddr req
Packit fc2124
        putWord16be $ fromIntegral $ responseBindPort req
Packit fc2124
    get = getWord8 >>= getSocksResponse