# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
#   https://docs.haskellstack.org/en/stable/topics/lock_files
packages: []
snapshots:
- completed:
    sha256: 4cb7085bcc4e7d0b58a523df16a25201800a076f643445ec4f8bb78a94be652f
    size: 726109
    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/18.yaml
  original:
    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/18.yaml

# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/configure/yaml/
# A 'specific' Stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# snapshot: lts-23.24
# snapshot: nightly-2025-06-15
# snapshot: ghc-9.8.4
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# snapshot: ./custom-snapshot.yaml
# snapshot: https://example.com/snapshots/2024-01-01.yaml
snapshot:
  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/18.yaml
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
#   subdirs:
#   - auto-update
#   - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the snapshot.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
# Override default flag values for project packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of Stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=3.7"
#
# Override the architecture used by Stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by Stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

{-# LANGUAGE OverloadedStrings #-}
module Tproxy where
import Ip
import System.Process (callProcess, readProcess)
import Data.List (isPrefixOf)
import Control.Exception (try, SomeException)
import System.IO (hPutStrLn, stderr)
import Control.Monad (forM_, void, when)
import System.Directory (findExecutable)
-- Run a system command with arguments
runCmd :: IO FilePath -> [String] -> IO ()
runCmd cmd args = do
  command <- cmd
  res <- try (callProcess command args) :: IO (Either SomeException ())
  case res of
    Left e  -> hPutStrLn stderr $ "[ERROR] " ++ command ++ " " ++ unwords args ++ ": " ++ show e
    Right _ -> putStrLn $ "[OK] " ++ command ++ " " ++ unwords args
iptablesBin :: IO FilePath
iptablesBin = findExecutable "iptables" >>= maybe (fail "iptables not found") pure
ipBin :: IO FilePath
ipBin = findExecutable "ip" >>= maybe (fail "ip not found") pure
-- | Run iptables with arguments.
--   Automatically prefixes "iptables" when using xtables-nft-multi.
iptables :: [String] -> IO ()
iptables args = runCmd iptablesBin args
-- | Run ip (iproute2) with arguments.
ip :: [String] -> IO String
ip args = do
  path <- ipBin
  readProcess path args ""
-- Detect the first global IPv4 address (like awk '{print $4}' in the script)
detectLocalCIDR :: IO (Maybe String)
detectLocalCIDR = do
  output <- ip ["-o", "-4", "addr", "show", "scope", "global"]
  let parts = [ w | line <- lines output, w <- words line, '/' `elem` w ]
  pure $ case parts of
    []    -> Nothing
    (x:_) -> Just x
-- Create all the XRAY and XRAY_MASK chains and rules
applyRules :: IO ()
applyRules = do
  mCIDR <- detectLocalCIDR
  let localCIDR = maybe "192.168.2.184/24" id mCIDR
  putStrLn $ "Using local CIDR: " ++ localCIDR
  iptables ["-t", "mangle", "-N", "XRAY"]
  iptables ["-t", "mangle", "-A", "XRAY", "-d", localCIDR, "-j", "RETURN"]
  let returns =
        [ "224.0.0.0/3", "0.0.0.0/8", "10.0.0.0/8", "100.64.0.0/10", "127.0.0.0/8"
        , "169.254.0.0/16", "172.16.0.0/12", "192.168.0.0/16", "198.18.0.0/15"
        , "224.0.0.0/4", "240.0.0.0/4" ]
  forM_ returns $ \r -> iptables ["-t", "mangle", "-A", "XRAY", "-d", r, "-j", "RETURN"]
  iptables ["-t", "mangle", "-A", "XRAY", "!", "-s", localCIDR, "-j", "RETURN"]
  iptables ["-t", "mangle", "-A", "XRAY", "-p", "tcp", "-j", "TPROXY", "--on-port", "12345", "--tproxy-mark", "1"]
  iptables ["-t", "mangle", "-A", "XRAY", "-p", "udp", "-j", "TPROXY", "--on-port", "12345", "--tproxy-mark", "1"]
  iptables ["-t", "mangle", "-A", "PREROUTING", "-j", "XRAY"]
  iptables ["-t", "mangle", "-N", "XRAY_MASK"]
  iptables ["-t", "mangle", "-A", "XRAY_MASK", "-m", "owner", "--gid-owner", "988", "-j", "RETURN"]
  let maskReturns =
        [ "0.0.0.0/8", "10.0.0.0/8", "127.0.0.0/8", "169.254.0.0/16", "172.16.0.0/12"
        , localCIDR, "224.0.0.0/4", "240.0.0.0/4" ]
  forM_ maskReturns $ \r -> iptables ["-t", "mangle", "-A", "XRAY_MASK", "-d", r, "-j", "RETURN"]
  iptables ["-t", "mangle", "-A", "XRAY_MASK", "-j", "MARK", "--set-mark", "1"]
  iptables ["-t", "mangle", "-A", "OUTPUT", "-p", "tcp", "-j", "XRAY_MASK"]
  iptables ["-t", "mangle", "-A", "OUTPUT", "-p", "udp", "-j", "XRAY_MASK"]
  runCmd ipBin ["route", "add", "local", "0.0.0.0/0", "dev", "lo", "table", "100"]
  runCmd ipBin ["rule", "add", "fwmark", "1", "table", "100"]
-- Remove all XRAY rules and chains
-- Think of using ip set to clear the udp2raw rules
clearRules :: IO ()
clearRules = do
  putStrLn "Clearing XRAY and XRAY_MASK chains..."
  iptables ["-t", "mangle", "-D", "PREROUTING", "-j", "XRAY"]
  iptables ["-t", "mangle", "-F", "XRAY"]
  iptables ["-t", "mangle", "-X", "XRAY"]
  iptables ["-t", "mangle", "-F", "XRAY_MASK"]
  iptables ["-t", "mangle", "-X", "XRAY_MASK"]
  void $ ip ["route", "del", "local", "default", "dev", "lo", "table", "100"]
  void $ ip ["rule", "del", "table", "100"]
applyFakeTCP :: String -> Int -> IO ()
applyFakeTCP server port = do
  iptables  ["-I", "INPUT", "-s", server, "-p", "tcp", "-m", "tcp", "--sport", show port, "-j", "DROP"]
applyICMP :: String -> IO ()
applyICMP server = do
  iptables  ["-I", "INPUT", "-s", server, "-p", "icmp", "--icmp-type", "0", "-j", "DROP"]

{-# LANGUAGE OverloadedStrings #-}
module Ip (waitForIP) where
import Control.Concurrent (threadDelay)
import System.IO (hPutStrLn, stderr)
import qualified Data.ByteString.Char8 as B
import Network.DNS
import Network.Socket
import Data.List (isPrefixOf)
import Data.Maybe (listToMaybe)
waitForIP :: String -> String -> IO String
waitForIP ns domain = do
  result <- resolveWithHostname ns domain
  case result of
    [] -> do
      hPutStrLn stderr $ "Waiting for 2 seconds for " ++ domain
      threadDelay (2 * 1000000)
      waitForIP ns domain
    (ip:_) -> pure ip
resolveWithHostname :: String -> String -> IO [String]
resolveWithHostname nsHost domain = do
  nsIP <- resolveNameServer nsHost
  case nsIP of
    Nothing -> do
      hPutStrLn stderr $ "Could not resolve nameserver " ++ nsHost
      pure []
    Just ipStr -> do
      hPutStrLn stderr $ "Querying " ++ domain ++ " using nameserver " ++ ipStr
      -- old network-dns only supports RCFilePath or RCHostName
      let conf = defaultResolvConf { resolvInfo = RCHostName ipStr }
      rs <- makeResolvSeed conf
      withResolver rs $ \resolver -> do
        r <- lookupA resolver (B.pack domain)
        case r of
          Left err -> do
            hPutStrLn stderr $ "DNS query failed: " ++ show err
            pure []
          Right ips -> do
            hPutStrLn stderr $ "DNS reply: " ++ show ips
            pure (map show ips)
resolveNameServer :: String -> IO (Maybe String)
resolveNameServer host
  | all (`elem` (".0123456789" :: String)) host = pure (Just host)  -- already numeric
  | otherwise = do
      infos <- getAddrInfo (Just defaultHints) (Just host) (Just "53")
      pure $ fmap (stripPort . show . addrAddress) (listToMaybe infos)
stripPort :: String -> String
stripPort s
  | ":" `isPrefixOf` dropWhile (/=':') s = takeWhile (/=':') s
  | otherwise = s

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module ConfigParser (
    ConfigEntry(..), -- Export the data constructor and all field accessors
    Config,          -- Export the type alias
    parseConfigFile  -- Export the main function
) where
import Data.Yaml
import Data.Text (Text)
import GHC.Generics (Generic)
import System.IO (hPutStrLn, stderr)
import System.Exit (exitFailure)
-- 1. DATA DEFINITIONS (These must be exported)
data ConfigEntry = ConfigEntry
  { name             :: Text
  , nameserver       :: Text
  , domain           :: Text
  , raw_mode         :: Text
  , port             :: Maybe Int
  , speeder_password :: Text
  , udp2raw_password :: Text
  } deriving (Show, Generic)
type Config = [ConfigEntry]
instance FromJSON ConfigEntry where
  parseJSON = withObject "ConfigEntry" $ \v -> ConfigEntry
    <$> v .: "name"
    <*> v .: "nameserver"
    <*> v .: "domain"
    <*> v .: "raw_mode"
    <*> v .:? "port"
    <*> v .: "speeder_password"
    <*> v .: "udp2raw_password"
-- 2. EXPORTED FUNCTION
-- This function reads the file and returns the parsed configuration or an error message.
parseConfigFile :: FilePath -> IO (Either String Config)
parseConfigFile configFile = do
  result <- decodeFileEither configFile
  case result of
    Left err -> pure $ Left $ "Error parsing YAML from " ++ configFile ++ ": " ++ show err
    Right cfg -> pure $ Right cfg

cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.38.1.
--
-- see: https://github.com/sol/hpack
name:           proxy
version:        0.1.0.0
category:       System
author:         Igor Polyakov
maintainer:     iop_jr@yahoo.com
copyright:      2025 Igor Polyakov
license:        MIT
build-type:     Simple
library
  exposed-modules:
      ConfigParser
      Tproxy
      Ip
  other-modules:
      Paths_proxy
  hs-source-dirs:
      src
  build-depends:
      aeson
    , base >=4.7 && <5
    , bytestring
    , containers
    , directory
    , dns
    , network
    , process
    , split
    , text
    , unix
    , yaml
  default-language: Haskell2010
executable tproxy-controller
  main-is: Controller.hs
  other-modules:
      Paths_proxy
  hs-source-dirs:
      app
  default-extensions:
      ScopedTypeVariables
  ghc-options: -threaded -rtsopts -with-rtsopts=-N
  build-depends:
      aeson
    , base >=4.7 && <5
    , bytestring
    , containers
    , directory
    , dns
    , network
    , process
    , proxy
    , split
    , text
    , unix
    , yaml
  default-language: Haskell2010

# package.yaml
name:                proxy
version:             0.1.0.0
license:             MIT
author:              "Igor Polyakov"
maintainer:          "iop_jr@yahoo.com"
copyright:           "2025 Igor Polyakov"
category:            System
# Define the package dependencies (like Data.Yaml, Data.Text, etc.)
dependencies:
- base >= 4.7 && < 5
- yaml          # For parsing
- aeson         # For JSON/YAML data types
- text          # For Data.Text type
- containers    # If you use HashMap, Map, etc. (optional, include if needed)
- process
- network
- directory
- dns
- bytestring
- split
- unix
# --- LIBRARY DEFINITION ---
# This section defines the modules (ConfigParser.hs, Tproxy.hs) that the executable uses.
library:
  source-dirs: src
  exposed-modules:
  - ConfigParser
  - Tproxy
  - Ip
# --- EXECUTABLE DEFINITION ---
# This defines the main program (Controller.hs)
executables:
  tproxy-controller: # Name of the executable binary that will be created
    main: Controller.hs
    source-dirs: app
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    # The executable depends on the library we just defined,
    # as well as the system dependencies.
    dependencies:
    - proxy # This links to the 'library' section defined above
    default-extensions:
    - ScopedTypeVariables

module Main (main) where
import ConfigParser      -- Import the module we just created
import Tproxy
import Ip
import Network.Socket
import Control.Concurrent (forkIO)
import Control.Exception (catch, try, SomeException)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr, IOMode( ReadWriteMode ), hSetBuffering, BufferMode( LineBuffering ), hGetLine, hClose, stdout, BufferMode( NoBuffering ))
import Control.Monad (forM_, unless, forever)
import System.Posix.Files (setFileMode)
import qualified Data.Text as T
import System.Exit (exitSuccess)
import System.Directory (removeFile)
socketPath :: FilePath
socketPath = "/run/tproxy/socket"
main :: IO ()
main = do
  safeMain `catch` \(e :: SomeException) -> hPutStrLn stderr $ "[ERROR] " ++ show e
safeMain :: IO ()
safeMain = do
  hSetBuffering stdout NoBuffering
  -- 1. Get the configuration file path
  args <- getArgs
  let configFile = case args of
                     (f:_) -> f
                     [] -> "servers.yaml"
  -- 2. Call the exported function from the ConfigParser module
  parseResult <- ConfigParser.parseConfigFile configFile
  case parseResult of
    -- Handle failure (The Left String contains the formatted error)
    Left errorMessage -> do
      hPutStrLn stderr errorMessage
      exitFailure
    -- Handle success
    Right cfg -> do
      putStrLn $ "Successfully loaded configuration from " ++ configFile ++ ":"
      -- Accessing the first entry's nameserver
      case cfg of
        (entry:_) -> do
          putStrLn $ "First server " ++ show (name entry)
          ip <- waitForIP (T.unpack $ nameserver entry) (T.unpack $ domain entry)
          putStrLn $ "the IP is " ++ show ip
          applyRules
          applyICMP ip
        [] -> putStrLn "Configuration file was empty."
    -- Clean up old socket if exists
  catch (removeFile socketPath) (\(_::SomeException) -> pure ())
  sock <- socket AF_UNIX Stream 0
  bind sock (SockAddrUnix socketPath)
  setFileMode socketPath 0o775
  listen sock 1
  forever $ do
    (conn, _) <- accept sock
    _ <- forkIO $ handleClient conn
    pure ()
handleClient :: Socket -> IO ()
handleClient conn = do
  h <- socketToHandle conn ReadWriteMode
  hSetBuffering h LineBuffering
  cmd <- hGetLine h
  case cmd of
    "start" -> do
      putStrLn "Received start command"
      applyRules
      hPutStrLn h "started"
    "stop" -> do
      putStrLn "Received stop command"
      clearRules
      hPutStrLn h "stopped"
    "exit" -> do
      putStrLn "Exiting tproxy service"
      hPutStrLn h "bye"
      clearRules
      hClose h
      exitSuccess
    _ -> hPutStrLn h "unknown command"
  hClose h

.stack-work