<commit_before>{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving  #-}
module SecondTransfer.Socks5.Session (
                 tlsSOCKS5Serve
               , ConnectOrForward                                  (..)
               , Socks5ServerState
               , initSocks5ServerState
     ) where

import           Control.Concurrent
import qualified Control.Exception                                  as E
import           Control.Lens                                       ( makeLenses, (^.), set)

import qualified Data.ByteString                                    as B
import           Data.ByteString.Char8                              ( unpack,  pack)
import qualified Data.Attoparsec.ByteString                         as P
import qualified Data.Binary                                        as U
import qualified Data.Binary.Put                                    as U
import           Data.Word                                          (Word16)
import           Data.Int                                           (Int64)

import qualified Network.Socket                                     as NS

import           SecondTransfer.Exception                           (SOCKS5ProtocolException (..), forkIOExc )

import           SecondTransfer.Socks5.Types
import           SecondTransfer.Socks5.Parsers
import           SecondTransfer.Socks5.Serializers

import           SecondTransfer.IOCallbacks.Types
import           SecondTransfer.IOCallbacks.SocketServer
import           SecondTransfer.IOCallbacks.Coupling                (couple)
import           SecondTransfer.IOCallbacks.WrapSocket              (HasSocketPeer(..))

-- For debugging purposes
--import           SecondTransfer.IOCallbacks.Botcher


data Socks5ServerState = Socks5ServerState {
    _nextConnection_S5S       :: !Int64
    }
makeLenses ''Socks5ServerState

initSocks5ServerState :: Socks5ServerState
initSocks5ServerState = Socks5ServerState 0

data ConnectOrForward =
    Connect_COF B.ByteString IOCallbacks
  | Forward_COF B.ByteString Word16
  | Drop_COF B.ByteString


tryRead :: IOCallbacks ->  B.ByteString  -> P.Parser a -> IO (a,B.ByteString)
tryRead iocallbacks leftovers p = do
    let
        react (P.Done i r) = return  (r, i)
        react (P.Fail i contexts msg) =
            E.throwIO $ SOCKS5ProtocolException
                 ("parseFailed: Left #" ++
                 show (B.length i) ++
                 " bytes to parse ( " ++
                 show (B.unpack i) ++
                 ") " ++ " contexts: " ++
                 (show contexts) ++
                 " message: " ++
                 msg
                )
        react (P.Partial f)  =
            go f

        go  f = do
            fragment <- (iocallbacks ^. bestEffortPullAction_IOC) True
            react (f fragment)

    react $ P.parse p leftovers


pushDatum :: IOCallbacks -> (a -> U.Put) -> a -> IO ()
pushDatum iocallbacks putthing x = do
    let
        datum = U.runPut (putthing x)
    (iocallbacks ^. pushAction_IOC) datum


-- | Forwards a set of IOCallbacks (actually, it is exactly the same passed in) after the
--   SOCKS5 negotiation, if the negotiation succeeds and the indicated "host" is approved
--   by the first parameter. Quite simple.
negotiateSocksAndForward ::  (B.ByteString -> Bool) -> IOCallbacks -> IO ConnectOrForward
negotiateSocksAndForward approver socks_here =
  do
    let
        tr = tryRead socks_here
        ps = pushDatum socks_here
    -- Start by reading the standard socks5 header
    ei <- E.try $ do
        (_auth, next1) <- tr ""  parseClientAuthMethods_Packet
        -- I will ignore the auth methods for now
        let
            server_selects = ServerSelectsMethod_Packet ProtocolVersion 0 -- No auth
        ps putServerSelectsMethod_Packet server_selects
        (req_packet, _next2) <- tr next1 parseClientRequest_Packet
        case req_packet ^. cmd_SP3 of

            Connect_S5PC  -> do
                -- Can accept a connect, to what?
                let
                    address = req_packet ^. address_SP3
                    named_host = case address of
                        DomainName_IA name -> name
                        _  -> E.throw . SOCKS5ProtocolException $ "UnsupportedAddress " ++ show address
                if  approver named_host then
                    do
                        -- First I need to answer to the client that we are happy and ready
                        let
                            server_reply = ServerReply_Packet {
                                _version_SP4    = ProtocolVersion
                              , _replyField_SP4 = Succeeded_S5RF
                              , _reservedField_SP4 = 0
                              , _address_SP4 = IPv4_IA 0x7f000001
                              , _port_SP4 = 10001
                                }
                        ps putServerReply_Packet server_reply
                        -- Now that I have the attendant, let's just activate it ...

                        -- CORRECT WAY:
                        return $ Connect_COF named_host socks_here

                    else do
                        -- Logging? We need to get that real right.
                        return $ Drop_COF named_host


            -- Other commands not handled for now
            _             -> do
                return $ Drop_COF "<socks5-unimplemented-command>"

    case ei of
        Left (SOCKS5ProtocolException msg) -> return $ Drop_COF (pack msg)
        Right result -> return result


-- | Forwards a set of IOCallbacks (actually, it is exactly the same passed in) after the
--   SOCKS5 negotiation, if the negotiation succeeds and the indicated "host" is approved
--   by the first parameter. If the approver returns false, this function will try to
--   actually connect to the host and let the software act as a true proxy.
negotiateSocksForwardOrConnect ::  (B.ByteString -> Bool) -> IOCallbacks -> IO ConnectOrForward
negotiateSocksForwardOrConnect approver socks_here =
  do
    let
        tr = tryRead socks_here
        ps = pushDatum socks_here
    -- Start by reading the standard socks5 header
    ei <- E.try $ do
        (_auth, next1) <- tr ""  parseClientAuthMethods_Packet
        -- I will ignore the auth methods for now
        let
            server_selects = ServerSelectsMethod_Packet ProtocolVersion 0 -- No auth
        ps putServerSelectsMethod_Packet server_selects
        (req_packet, _next2) <- tr next1 parseClientRequest_Packet
        case req_packet ^. cmd_SP3 of

            Connect_S5PC  -> do
                -- Can accept a connect, to what?
                let
                    address = req_packet ^. address_SP3
                    port_number = req_packet ^. port_SP3<commit_msg>A little bit of context on error messages<commit_after>{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving  #-}
module SecondTransfer.Socks5.Session (
                 tlsSOCKS5Serve
               , ConnectOrForward                                  (..)
               , Socks5ServerState
               , initSocks5ServerState
     ) where

import           Control.Concurrent
import qualified Control.Exception                                  as E
import           Control.Lens                                       ( makeLenses, (^.), set)

import qualified Data.ByteString                                    as B
import           Data.ByteString.Char8                              ( unpack,  pack)
import qualified Data.Attoparsec.ByteString                         as P
import qualified Data.Binary                                        as U
import qualified Data.Binary.Put                                    as U
import           Data.Word                                          (Word16)
import           Data.Int                                           (Int64)

import qualified Network.Socket                                     as NS

import           SecondTransfer.Exception                           (SOCKS5ProtocolException (..), forkIOExc )

import           SecondTransfer.Socks5.Types
import           SecondTransfer.Socks5.Parsers
import           SecondTransfer.Socks5.Serializers

import           SecondTransfer.IOCallbacks.Types
import           SecondTransfer.IOCallbacks.SocketServer
import           SecondTransfer.IOCallbacks.Coupling                (couple)
import           SecondTransfer.IOCallbacks.WrapSocket              (HasSocketPeer(..))

-- For debugging purposes
--import           SecondTransfer.IOCallbacks.Botcher


data Socks5ServerState = Socks5ServerState {
    _nextConnection_S5S       :: !Int64
    }
makeLenses ''Socks5ServerState

initSocks5ServerState :: Socks5ServerState
initSocks5ServerState = Socks5ServerState 0

data ConnectOrForward =
    Connect_COF B.ByteString IOCallbacks
  | Forward_COF B.ByteString Word16
  | Drop_COF B.ByteString


tryRead :: IOCallbacks ->  String  ->  B.ByteString  -> P.Parser a -> IO (a,B.ByteString)
tryRead iocallbacks what_doing leftovers p = do
    let
        react (P.Done i r) = return  (r, i)
        react (P.Fail i contexts msg) =
            E.throwIO $ SOCKS5ProtocolException
                 ("/" ++
                  what_doing ++
                  "/" ++
                  "parseFailed: Left #" ++
                 show (B.length i) ++
                 " bytes to parse ( " ++
                 show (B.unpack i) ++
                 ") " ++ " contexts: " ++
                 (show contexts) ++
                 " message: " ++
                 msg
                )
        react (P.Partial f)  =
            go f

        go  f = do
            fragment <- (iocallbacks ^. bestEffortPullAction_IOC) True
            react (f fragment)

    react $ P.parse p leftovers


pushDatum :: IOCallbacks -> (a -> U.Put) -> a -> IO ()
pushDatum iocallbacks putthing x = do
    let
        datum = U.runPut (putthing x)
    (iocallbacks ^. pushAction_IOC) datum


-- | Forwards a set of IOCallbacks (actually, it is exactly the same passed in) after the
--   SOCKS5 negotiation, if the negotiation succeeds and the indicated "host" is approved
--   by the first parameter. Quite simple.
negotiateSocksAndForward ::  (B.ByteString -> Bool) -> IOCallbacks -> IO ConnectOrForward
negotiateSocksAndForward approver socks_here =
  do
    let
        tr = tryRead socks_here
        ps = pushDatum socks_here
    -- Start by reading the standard socks5 header
    ei <- E.try $ do
        (_auth, next1) <- tr "client-auth-methods"  ""  parseClientAuthMethods_Packet
        -- I will ignore the auth methods for now
        let
            server_selects = ServerSelectsMethod_Packet ProtocolVersion 0 -- No auth
        ps putServerSelectsMethod_Packet server_selects
        (req_packet, _next2) <- tr "client-request"  next1 parseClientRequest_Packet
        case req_packet ^. cmd_SP3 of

            Connect_S5PC  -> do
                -- Can accept a connect, to what?
                let
                    address = req_packet ^. address_SP3
                    named_host = case address of
                        DomainName_IA name -> name
                        _  -> E.throw . SOCKS5ProtocolException $ "UnsupportedAddress " ++ show address
                if  approver named_host then
                    do
                        -- First I need to answer to the client that we are happy and ready
                        let
                            server_reply = ServerReply_Packet {
                                _version_SP4    = ProtocolVersion
                              , _replyField_SP4 = Succeeded_S5RF
                              , _reservedField_SP4 = 0
                              , _address_SP4 = IPv4_IA 0x7f000001
                              , _port_SP4 = 10001
                                }
                        ps putServerReply_Packet server_reply
                        -- Now that I have the attendant, let's just activate it ...

                        -- CORRECT WAY:
                        return $ Connect_COF named_host socks_here

                    else do
                        -- Logging? We need to get that real right.
                        return $ Drop_COF named_host


            -- Other commands not handled for now
            _             -> do
                return $ Drop_COF "<socks5-unimplemented-command>"

    case ei of
        Left (SOCKS5ProtocolException msg) -> return $ Drop_COF (pack msg)
        Right result -> return result


-- | Forwards a set of IOCallbacks (actually, it is exactly the same passed in) after the
--   SOCKS5 negotiation, if the negotiation succeeds and the indicated "host" is approved
--   by the first parameter. If the approver returns false, this function will try to
--   actually connect to the host and let the software act as a true proxy.
negotiateSocksForwardOrConnect ::  (B.ByteString -> Bool) -> IOCallbacks -> IO ConnectOrForward
negotiateSocksForwardOrConnect approver socks_here =
  do
    let
        tr = tryRead socks_here
        ps = pushDatum socks_here
    -- Start by reading the standard socks5 header
    ei <- E.try $ do
        (_auth, next1) <- tr "client-auth-methods" ""  parseClientAuthMethods_Packet
        -- I will ignore the auth methods for now
        let
            server_selects = ServerSelectsMethod_Packet ProtocolVersion 0 -- No auth
        ps putServerSelectsMethod_Packet server_selects
        (req_packet, _next2) <- tr "client-request" next1 parseClientRequest_Packet
        case req_packet ^. cmd_SP3 of

            Connect_S5PC  -> do
                -- Can accept a connect, to what?
                let
                    address = req_packet ^. address_SP3
                    port_number = req_packet ^. port_SP3
{'fraction_non_alphanumeric': 0.060957069427351046, 'fraction_numerical': 0.010135379714761457, 'mean_word_length': 1.4935018050541515, 'pattern_counts': {'":': 0, '<': 19, '<?xml version=': 0, '>': 46, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 24, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6874021', 'n_tokens_mistral': 3622, 'n_tokens_neox': 3404, 'n_words': 1049}