Make stdio server one shot. Exit when stdin close or cnx break
Former-commit-id: 88761398962764745bc495314aca962e728ca8bc [formerly ec5245e4e8582cac1acea8fce93960b10e1355ab] [formerly a646606c4757a7d95717e61a530268b53a55194e [formerly 90a8177d55b2e9cda3b8b9f2786a5acefa42967d]] Former-commit-id: a4f3b053093aa350adbff3a77cfb5d5b2e3aed1c [formerly 0e601f35539a884b3de44b080e45113e4ca0c2ce] Former-commit-id: dca46be4453bdd312262edb9ba34cc58eda7bfe7 Former-commit-id: 9da4d6d8f74375d25a98d967a7a78ec1e4287780 Former-commit-id: 69fcfe79afd0f2373753dfc854511ca8072cc77d Former-commit-id: d6c7c44c03f3d633e14d7f6256db44d33201e95b [formerly dfd19ae45fce99c663acf1de25b4a4cf448d4e3a] Former-commit-id: 7c0201b20d79c4819644d844910d6a60da772bba
This commit is contained in:
Σrebe - Romain GERARD
parent
bcb2617b9d
commit
8c611e9149
23 changed files with 1971 additions and 2040 deletions
5
.gitignore
vendored
5
.gitignore
vendored
|
|
@ -14,3 +14,8 @@ tags
|
|||
bin/
|
||||
*~
|
||||
.stack-work
|
||||
|
||||
|
||||
# Added by cargo
|
||||
|
||||
/target
|
||||
|
|
|
|||
1787
Cargo.lock
generated
Normal file
1787
Cargo.lock
generated
Normal file
File diff suppressed because it is too large
Load diff
19
Cargo.toml
Normal file
19
Cargo.toml
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
[package]
|
||||
name = "wstunnel"
|
||||
version = "0.1.0"
|
||||
edition = "2021"
|
||||
|
||||
# See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html
|
||||
|
||||
[dependencies]
|
||||
clap = { version = "4.4.5", features = ["derive"]}
|
||||
url = "2.4.1"
|
||||
|
||||
reqwest = { version = "0.11.20", features = ["stream", "trust-dns"] }
|
||||
hyper = { version = "1.0.0-rc.4", features = ["client", "http2"] }
|
||||
hyper-openssl = {version = "0.9.2", features = []}
|
||||
|
||||
tokio = { version = "1.32.0", features = ["full"] }
|
||||
|
||||
tracing = { version = "0.1.37", features = ["log"] }
|
||||
tracing-subscriber = { version = "0.3.17", features = ["env-filter", "fmt", "local-time"] }
|
||||
37
Dockerfile
37
Dockerfile
|
|
@ -1,37 +0,0 @@
|
|||
# Build Cache image
|
||||
FROM fpco/stack-build-small:lts-19.2 as builder-cache
|
||||
|
||||
COPY stack.yaml /mnt
|
||||
COPY *.cabal /mnt
|
||||
WORKDIR /mnt
|
||||
RUN rm -rf ~/.stack && \
|
||||
stack config set system-ghc --global true && \
|
||||
stack setup && \
|
||||
stack install --ghc-options="-fPIC" --only-dependencies
|
||||
|
||||
|
||||
|
||||
# Build phase
|
||||
FROM builder-cache as builder
|
||||
# FROM ghcr.io/erebe/wstunnel:build-cache as builder
|
||||
COPY . /mnt
|
||||
|
||||
RUN echo ' ld-options: -static' >> wstunnel.cabal ; \
|
||||
stack install --ghc-options="-fPIC"
|
||||
#RUN upx /root/.local/bin/wstunnel
|
||||
|
||||
|
||||
|
||||
# Final Image
|
||||
FROM alpine:latest as runner
|
||||
|
||||
LABEL org.opencontainers.image.source https://github.com/erebe/server
|
||||
|
||||
COPY --from=builder /root/.local/bin/wstunnel /
|
||||
RUN adduser -D abc && chmod +x /wstunnel
|
||||
|
||||
USER abc
|
||||
WORKDIR /
|
||||
|
||||
CMD ["/wstunnel"]
|
||||
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
FROM nixos/nix as builder
|
||||
MAINTAINER github@erebe.eu
|
||||
|
||||
RUN nix-channel --add https://nixos.org/channels/nixpkgs-unstable nixpkgs
|
||||
RUN nix-channel --update
|
||||
RUN nix-env -i bash upx
|
||||
|
||||
WORKDIR /mnt
|
||||
COPY stack.yaml /mnt
|
||||
COPY *.cabal /mnt
|
||||
COPY default.nix /mnt
|
||||
|
||||
RUN nix-build --no-link -A fullBuildScript
|
||||
COPY . /mnt
|
||||
RUN $(nix-build --no-link -A fullBuildScript)
|
||||
30
LICENSE
30
LICENSE
|
|
@ -1,30 +0,0 @@
|
|||
Copyright Romain Gerard (c) 2016-2023
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Author name here nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
176
README.md
176
README.md
|
|
@ -1,176 +0,0 @@
|
|||
|
||||
<p align="center">
|
||||
<img src="https://github.com/erebe/wstunnel/raw/master/logo_wstunnel.png" alt="wstunnel logo"/>
|
||||
</p>
|
||||
|
||||
## Description
|
||||
|
||||
Most of the time when you are using a public network, you are behind some kind of firewall or proxy. One of their purpose is to constrain you to only use certain kind of protocols. Nowadays, the most widespread protocol is http and is de facto allowed by third party equipment.
|
||||
|
||||
This tool understands this fact and uses the websocket protocol which is compatible with http in order to bypass firewalls and proxies. Wstunnel allows you to tunnel what ever traffic you want.
|
||||
|
||||
My inspiration came from [this project](https://www.npmjs.com/package/wstunnel) but as I don't want to install npm and nodejs to use this tool, I remade it in Haskell and improved it.
|
||||
|
||||
**What to expect:**
|
||||
|
||||
* Good error messages and debug informations
|
||||
* Static tunneling (TCP and UDP)
|
||||
* Dynamic tunneling (socks5 proxy)
|
||||
* Support for http proxy (when behind one)
|
||||
* Support for tls/https server (with embedded self signed certificate, see comment in the example section)
|
||||
* Support IPv6
|
||||
* **Standalone binary for linux x86_64** (so just cp it where you want)
|
||||
* Standalone archive for windows
|
||||
|
||||
P.S: Please do not pay attention to Main.hs because as I hate to write command line code this file is crappy
|
||||
|
||||
## Command line
|
||||
|
||||
```
|
||||
Use the websockets protocol to tunnel {TCP,UDP} traffic
|
||||
wsTunnelClient <---> wsTunnelServer <---> RemoteHost
|
||||
Use secure connection (wss://) to bypass proxies
|
||||
|
||||
wstunnel [OPTIONS] ws[s]://wstunnelServer[:port]
|
||||
|
||||
Client options:
|
||||
-L --localToRemote=[BIND:]PORT:HOST:PORT Listen on local and forwards
|
||||
traffic from remote. Can be
|
||||
used multiple time
|
||||
-D --dynamicToRemote=[BIND:]PORT Listen on local and
|
||||
dynamically (with socks5 proxy)
|
||||
forwards traffic from remote
|
||||
-u --udp forward UDP traffic instead
|
||||
of TCP
|
||||
--udpTimeoutSec=INT When using udp forwarding,
|
||||
timeout in seconds after when
|
||||
the tunnel connection is
|
||||
closed. Default 30sec, -1 means
|
||||
no timeout
|
||||
-p --httpProxy=USER:PASS@HOST:PORT If set, will use this proxy
|
||||
to connect to the server
|
||||
--soMark=int (linux only) Mark network
|
||||
packet with SO_MARK sockoption
|
||||
with the specified value. You
|
||||
need to use {root, sudo,
|
||||
capabilities} to run wstunnel
|
||||
when using this option
|
||||
--upgradePathPrefix=String Use a specific prefix that
|
||||
will show up in the http path
|
||||
in the upgrade request. Useful
|
||||
if you need to route requests
|
||||
server side but don't have
|
||||
vhosts
|
||||
--hostHeader=String If set, add the custom string
|
||||
as host http header
|
||||
--tlsSNI=String If set, use custom string in
|
||||
the SNI during TLS handshake
|
||||
--websocketPingFrequencySec=int do a hearthbeat ping every x
|
||||
seconds to maintain websocket
|
||||
connection
|
||||
--upgradeCredentials=USER[:PASS] Credentials for the Basic
|
||||
HTTP authorization type sent
|
||||
with the upgrade request.
|
||||
-H --customHeaders="HeaderName: HeaderValue" Send custom headers in the
|
||||
upgrade request. Can be used
|
||||
multiple time
|
||||
-h --help Display help message
|
||||
-V --version Print version information
|
||||
Server options:
|
||||
--server Start a server that will
|
||||
forward traffic for you
|
||||
-r --restrictTo=HOST:PORT Accept traffic to be
|
||||
forwarded only to this service
|
||||
--tlsCertificate=FILE [optional] provide a custom
|
||||
tls certificate (.crt) that the
|
||||
server will use instead of the
|
||||
embeded one
|
||||
--tlsKey=FILE [optional] provide a custom
|
||||
tls key (.key) that the server
|
||||
will use instead of the embeded
|
||||
one
|
||||
Common options:
|
||||
-v --verbose Print debug information
|
||||
-q --quiet Print only errors
|
||||
```
|
||||
|
||||
## Examples
|
||||
### Simplest one
|
||||
On your remote host, start the wstunnel's server by typing this command in your terminal
|
||||
```bash
|
||||
wstunnel --server ws://0.0.0.0:8080
|
||||
```
|
||||
This will create a websocket server listening on any interface on port 8080.
|
||||
On the client side use this command to forward traffic through the websocket tunnel
|
||||
```bash
|
||||
wstunnel -D 8888 ws://myRemoteHost:8080
|
||||
```
|
||||
This command will create a sock5 server listening on port 8888 of a loopback interface and will forward traffic.
|
||||
|
||||
With firefox you can setup a proxy using this tunnel, by setting in networking preferences 127.0.0.1:8888 and selecting socks5 proxy
|
||||
|
||||
or with curl
|
||||
|
||||
```bash
|
||||
curl -x socks5h://127.0.0.1:8888 http://google.com/
|
||||
#Please note h after the 5, it is to avoid curl resolving DNS name locally
|
||||
```
|
||||
|
||||
### As proxy command for SSH
|
||||
You can specify `stdio` as source port on the client side if you wish to use wstunnel as part of a proxy command for ssh
|
||||
```
|
||||
ssh -o ProxyCommand="wstunnel -L stdio:%h:%p ws://localhost:8080" my-server
|
||||
```
|
||||
|
||||
### When behind a corporate proxy
|
||||
An other useful example is when you want to bypass an http proxy (a corporate proxy for example)
|
||||
The most reliable way to do it is to use wstunnel as described below
|
||||
|
||||
Start your wstunnel server with tls activated
|
||||
```
|
||||
wstunnel --server wss://0.0.0.0:443 -r 127.0.0.1:22
|
||||
```
|
||||
The server will listen on any interface using port 443 (https) and restrict traffic to be forwarded only to the ssh daemon.
|
||||
|
||||
**Be aware that the server will use self signed certificate with weak cryptographic algorithm.
|
||||
It was made in order to add the least possible overhead while still being compliant with tls.**
|
||||
|
||||
**Do not rely on wstunnel to protect your privacy, as it only forwards traffic that is already secure by design (ex: https)**
|
||||
|
||||
Now on the client side start the client with
|
||||
```
|
||||
wstunnel -L 9999:127.0.0.1:22 -p mycorporateproxy:8080 wss://myRemoteHost:443
|
||||
```
|
||||
It will start a tcp server on port 9999 that will contact the corporate proxy, negotiate a tls connection with the remote host and forward traffic to the ssh daemon on the remote host.
|
||||
|
||||
You may now access your server from your local machine on ssh by using
|
||||
```
|
||||
ssh -p 9999 login@127.0.0.1
|
||||
```
|
||||
|
||||
### Wireguard and wstunnel
|
||||
https://kirill888.github.io/notes/wireguard-via-websocket/
|
||||
|
||||
- If you see some throughput issue, be sure to lower the MTU of your wireguard interface (you can do it via config file) to something like 1300 or you will endup fragmenting udp packet (due to overhead of other layer) which is always causing issues
|
||||
- If wstunnel cannot connect to server while wireguard is on, be sure you have added a static route via your main gateway for the ip of wstunnel server.
|
||||
Else if you forward all the traffic without putting a static route, you will endup looping your traffic wireguard interface -> wstunnel client -> wireguard interface
|
||||
|
||||
|
||||
## How to Build
|
||||
Install the stack tool https://docs.haskellstack.org/en/stable/README/ or if you are a believer
|
||||
```
|
||||
curl -sSL https://get.haskellstack.org/ | sh
|
||||
```
|
||||
and run those commands at the root of the project
|
||||
```
|
||||
stack init
|
||||
stack install
|
||||
```
|
||||
|
||||
## TODO
|
||||
- [x] Add sock5 proxy
|
||||
- [x] Add better logging
|
||||
- [x] Add better error handling
|
||||
- [x] Add httpProxy authentification
|
||||
- [ ] Add Reverse tunnel
|
||||
- [x] Add more tests for socks5 proxy
|
||||
333
app/Main.hs
333
app/Main.hs
|
|
@ -1,333 +0,0 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-cse #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import ClassyPrelude hiding (getArgs, head)
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.List (head, (!!))
|
||||
import System.Console.CmdArgs
|
||||
import System.Environment (getArgs, withArgs)
|
||||
|
||||
import qualified Logger
|
||||
import Tunnel
|
||||
import Types
|
||||
import Credentials
|
||||
import Control.Concurrent.Async as Async
|
||||
|
||||
data WsTunnel = WsTunnel
|
||||
{ localToRemote :: [String]
|
||||
-- , remoteToLocal :: String
|
||||
, dynamicToRemote :: String
|
||||
, wsTunnelServer :: String
|
||||
, udpMode :: Bool
|
||||
, udpTimeout :: Int
|
||||
, proxy :: String
|
||||
, soMark :: Int
|
||||
, verbose :: Bool
|
||||
, quiet :: Bool
|
||||
, pathPrefix :: String
|
||||
, hostHeader :: String
|
||||
, tlsSNI :: String
|
||||
, tlsVerifyCertificate :: Bool
|
||||
, websocketPingFrequencySec :: Int
|
||||
, wsTunnelCredentials :: String
|
||||
, customHeaders :: [String]
|
||||
, serverMode :: Bool
|
||||
, restrictTo :: String
|
||||
, tlsCertificate :: FilePath
|
||||
, tlsKey :: FilePath
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
data WsServerInfo = WsServerInfo
|
||||
{ useTls :: !Bool
|
||||
, host :: !String
|
||||
, port :: !Int
|
||||
} deriving (Show)
|
||||
|
||||
data TunnelInfo = TunnelInfo
|
||||
{ localHost :: !String
|
||||
, localPort :: !Int
|
||||
, remoteHost :: !String
|
||||
, remotePort :: !Int
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
cmdLine :: WsTunnel
|
||||
cmdLine = WsTunnel
|
||||
{ localToRemote = def &= explicit &= name "L" &= name "localToRemote" &= typ "[BIND:]PORT:HOST:PORT"
|
||||
&= help "Listen on local and forwards traffic from remote. Can be used multiple time" &= groupname "Client options"
|
||||
-- , remoteToLocal = def &= explicit &= name "R" &= name "RemoteToLocal" &= typ "[BIND:]PORT:HOST:PORT"
|
||||
-- &= help "Listen on remote and forward traffic from local"
|
||||
, dynamicToRemote= def &= explicit &= name "D" &= name "dynamicToRemote" &= typ "[BIND:]PORT"
|
||||
&= help "Listen on local and dynamically (with socks5 proxy) forwards traffic from remote" &= groupname "Client options"
|
||||
, udpMode = def &= explicit &= name "u" &= name "udp" &= help "forward UDP traffic instead of TCP" &= groupname "Client options"
|
||||
, udpTimeout = def &= explicit &= name "udpTimeoutSec" &= help "When using udp forwarding, timeout in seconds after when the tunnel connection is closed. Default 30sec, -1 means no timeout"
|
||||
&= groupname "Client options"
|
||||
, customHeaders = def &= explicit &= name "H" &= name "customHeaders" &= help "Send custom headers in the upgrade request. Can be used multiple time"
|
||||
&= typ "\"HeaderName: HeaderValue\"" &= groupname "Client options"
|
||||
, pathPrefix = def &= explicit &= name "upgradePathPrefix"
|
||||
&= help "Use a specific prefix that will show up in the http path in the upgrade request. Useful if you need to route requests server side but don't have vhosts"
|
||||
&= typ "String" &= groupname "Client options"
|
||||
, wsTunnelCredentials
|
||||
= def &= explicit &= name "upgradeCredentials"
|
||||
&= help "Credentials for the Basic HTTP authorization type sent with the upgrade request."
|
||||
&= typ "USER[:PASS]"
|
||||
, proxy = def &= explicit &= name "p" &= name "httpProxy"
|
||||
&= help "If set, will use this proxy to connect to the server" &= typ "USER:PASS@HOST:PORT"
|
||||
, hostHeader = def &= explicit &= name "hostHeader" &= groupname "Client options"
|
||||
&= help "If set, add the custom string as host http header" &= typ "String" &= groupname "Client options"
|
||||
, tlsSNI = def &= explicit &= name "tlsSNI" &= groupname "Client options"
|
||||
&= help "If set, use custom string in the SNI during TLS handshake" &= typ "String" &= groupname "Client options"
|
||||
, tlsVerifyCertificate = def &= explicit &= name "tlsVerifyCertificate" &= groupname "Client options"
|
||||
&= help "Verify tls server certificate. Default to false"
|
||||
, soMark = def &= explicit &= name "soMark"
|
||||
&= help "(linux only) Mark network packet with SO_MARK sockoption with the specified value. You need to use {root, sudo, capabilities} to run wstunnel when using this option" &= typ "int"
|
||||
, websocketPingFrequencySec = def &= explicit &= name "websocketPingFrequencySec"
|
||||
&= help "do a hearthbeat ping every x seconds to maintain websocket connection" &= typ "int"
|
||||
, wsTunnelServer = def &= argPos 0 &= typ "ws[s]://wstunnelServer[:port]"
|
||||
|
||||
, serverMode = def &= explicit &= name "server"
|
||||
&= help "Start a server that will forward traffic for you" &= groupname "Server options"
|
||||
, restrictTo = def &= explicit &= name "r" &= name "restrictTo" &= groupname "Server options"
|
||||
&= help "Accept traffic to be forwarded only to this service" &= typ "HOST:PORT"
|
||||
, tlsCertificate = def &= explicit &= name "tlsCertificate" &= groupname "Server options"
|
||||
&= help "[optional] provide a custom tls certificate (.crt) that the server will use instead of the embeded one" &= typFile
|
||||
, tlsKey = def &= explicit &= name "tlsKey" &= groupname "Server options"
|
||||
&= help "[optional] provide a custom tls key (.key) that the server will use instead of the embeded one" &= typFile
|
||||
, verbose = def &= groupname "Common options" &= help "Print debug information"
|
||||
, quiet = def &= help "Print only errors" &= groupname "Common options"
|
||||
} &= summary ( "Use the websockets protocol to tunnel {TCP,UDP} traffic\n"
|
||||
++ "wsTunnelClient <---> wsTunnelServer <---> RemoteHost\n"
|
||||
++ "Use secure connection (wss://) to bypass proxies"
|
||||
)
|
||||
&= helpArg [explicit, name "help", name "h", groupname "Common options"]
|
||||
|
||||
|
||||
toPort :: String -> Int
|
||||
toPort "stdio" = 0
|
||||
toPort str = case readMay str of
|
||||
Just por -> por
|
||||
Nothing -> error $ "Invalid port number `" ++ str ++ "`"
|
||||
|
||||
parseServerInfo :: WsServerInfo -> String -> WsServerInfo
|
||||
parseServerInfo server [] = server
|
||||
parseServerInfo server ('w':'s':':':'/':'/':xs) = parseServerInfo (server {Main.useTls = False, Main.port = 80}) xs
|
||||
parseServerInfo server ('w':'s':'s':':':'/':'/':xs) = parseServerInfo (server {Main.useTls = True, Main.port = 443}) xs
|
||||
parseServerInfo server (':':prt) = server {Main.port = toPort prt}
|
||||
parseServerInfo server ('[':xs) = parseServerInfo (server {Main.host = BC.unpack . BC.init . fst $ BC.spanEnd (/= ']') (BC.pack xs)}) (BC.unpack . snd $ BC.spanEnd (/= ']') (BC.pack xs))
|
||||
parseServerInfo server hostPath = parseServerInfo (server {Main.host = takeWhile (/= ':') hostPath}) (dropWhile (/= ':') hostPath)
|
||||
|
||||
|
||||
parseTunnelInfo :: String -> TunnelInfo
|
||||
parseTunnelInfo strr = do
|
||||
let str = BC.pack strr
|
||||
if BC.count ']' str <= 0 then
|
||||
mkIPv4 $ BC.unpack <$> BC.split ':' str
|
||||
else
|
||||
mkIPv6 $ str
|
||||
|
||||
where
|
||||
mkIPv4 [lPort, host, rPort] = TunnelInfo {localHost = "127.0.0.1", Main.localPort = toPort lPort, remoteHost = host, remotePort = toPort rPort}
|
||||
mkIPv4 [bind,lPort, host,rPort] = TunnelInfo {localHost = bind, Main.localPort = toPort lPort, remoteHost = host, remotePort = toPort rPort}
|
||||
mkIPv4 _ = error $ "Invalid tunneling information `" ++ strr ++ "`, please use format [BIND:]PORT:HOST:PORT"
|
||||
|
||||
mkIPv6 str = do
|
||||
let !(localHost, remain) = if BC.head str == '[' then
|
||||
BC.drop 2 <$> BC.span (/= ']') (BC.drop 1 str)
|
||||
else if BC.head str < '0' || BC.head str > '9' then
|
||||
BC.drop 1 <$> BC.span (/= ':') str
|
||||
else
|
||||
("", str)
|
||||
|
||||
let (remain, rPort) = first BC.init . BC.spanEnd (/= ':') $ str
|
||||
let (remain2, remoteHost) = if BC.last remain == ']' then
|
||||
first (BC.init . BC.init) $ BC.spanEnd (/= '[') (BC.init remain)
|
||||
else
|
||||
first BC.init $ BC.spanEnd (/= ':') remain
|
||||
|
||||
let (remain3, lPort) = BC.spanEnd (/= ':') $ remain2
|
||||
if remain3 == mempty then
|
||||
TunnelInfo {localHost = "::1", Main.localPort = toPort (BC.unpack lPort), remoteHost = (BC.unpack remoteHost), remotePort = toPort (BC.unpack rPort)}
|
||||
else
|
||||
let localHost = BC.filter (\c -> c /= '[' && c /= ']') (BC.init remain3) in
|
||||
TunnelInfo {localHost = BC.unpack localHost, Main.localPort = toPort (BC.unpack lPort), remoteHost = (BC.unpack remoteHost), remotePort = toPort (BC.unpack rPort)}
|
||||
|
||||
|
||||
|
||||
parseRestrictTo :: String -> ((ByteString, Int) -> Bool)
|
||||
parseRestrictTo "" = const True
|
||||
parseRestrictTo str = let !(!h, !p) = fromMaybe (error "Invalid Parameter restart") parse
|
||||
in (\(!hst, !port) -> hst == h && port == p)
|
||||
where
|
||||
parse = do
|
||||
let (host, port) = BC.spanEnd (/= ':') (BC.pack str)
|
||||
guard (host /= mempty)
|
||||
portNumber <- readMay . BC.unpack $ port :: Maybe Int
|
||||
return (BC.filter (\c -> c /= '[' && c /= ']') (BC.init host), portNumber)
|
||||
|
||||
parseProxyInfo :: String -> Maybe ProxySettings
|
||||
parseProxyInfo str = do
|
||||
let ret = BC.split ':' (BC.pack str)
|
||||
|
||||
guard (length ret >= 2)
|
||||
if length ret == 3
|
||||
then do
|
||||
portNumber <- readMay $ BC.unpack $ ret !! 2 :: Maybe Int
|
||||
let cred = (head ret, head (BC.split '@' (ret !! 1)))
|
||||
let h = BC.split '@' (ret !! 1) !! 1
|
||||
return $ ProxySettings (BC.unpack h) (fromIntegral portNumber) (Just cred)
|
||||
else if length ret == 2
|
||||
then do
|
||||
portNumber <- readMay . BC.unpack $ ret !! 1 :: Maybe Int
|
||||
return $ ProxySettings (BC.unpack $ head ret) (fromIntegral portNumber) Nothing
|
||||
else Nothing
|
||||
|
||||
parseCustomHeader :: String -> (CI ByteString, ByteString)
|
||||
parseCustomHeader header = (CI.mk . BC.pack $ takeWhile (/= ':') header, BC.pack . dropWhile (\c -> c == ' ' || c == ':') $ (dropWhile (/= ':') header))
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
cfg' <- if null args then withArgs ["--help"] (cmdArgs cmdLine) else cmdArgs cmdLine
|
||||
let cfg = cfg' { pathPrefix = if pathPrefix cfg' == mempty then "wstunnel" else pathPrefix cfg'
|
||||
, Main.udpTimeout = if Main.udpTimeout cfg' == 0 then 30 * 10^(6 :: Int)
|
||||
else if Main.udpTimeout cfg' == -1 then -1
|
||||
else Main.udpTimeout cfg' * 10^(6:: Int)
|
||||
, Main.websocketPingFrequencySec = if Main.websocketPingFrequencySec cfg' == 0
|
||||
then 30
|
||||
else Main.websocketPingFrequencySec cfg'
|
||||
}
|
||||
|
||||
let serverInfo = parseServerInfo (WsServerInfo False "" 0) (wsTunnelServer cfg)
|
||||
Logger.init (if quiet cfg then Logger.QUIET
|
||||
else if verbose cfg
|
||||
then Logger.VERBOSE
|
||||
else Logger.NORMAL)
|
||||
|
||||
_ <- writeIORef sO_MARK_Value (soMark cfg)
|
||||
runApp cfg serverInfo
|
||||
putStrLn "Goodbye !"
|
||||
return ()
|
||||
|
||||
|
||||
runApp :: WsTunnel -> WsServerInfo -> IO ()
|
||||
runApp cfg serverInfo
|
||||
-- server mode
|
||||
| serverMode cfg = do
|
||||
putStrLn $ "Starting server with opts " <> tshow serverInfo
|
||||
key <- if Main.tlsKey cfg /= mempty then readFile (Main.tlsKey cfg) else return Credentials.key
|
||||
certificate <- if Main.tlsCertificate cfg /= mempty then readFile (Main.tlsCertificate cfg) else return Credentials.certificate
|
||||
let tls = if Main.useTls serverInfo then Just (certificate, key) else Nothing
|
||||
runServer tls (Main.host serverInfo, fromIntegral $ Main.port serverInfo) (parseRestrictTo $ restrictTo cfg)
|
||||
|
||||
-- -L localToRemote tunnels
|
||||
| not . null $ localToRemote cfg = do
|
||||
let tunnelInfos = parseTunnelInfo <$> localToRemote cfg
|
||||
let tunnelSettings = tunnelInfos >>= \tunnelInfo ->
|
||||
if Main.localPort tunnelInfo == 0 then [toStdioLocalToRemoteTunnelSetting cfg serverInfo tunnelInfo]
|
||||
else if udpMode cfg then [toUdpLocalToRemoteTunnelSetting cfg serverInfo tunnelInfo]
|
||||
else [toTcpLocalToRemoteTunnelSetting cfg serverInfo tunnelInfo]
|
||||
Async.mapConcurrently_ runClient tunnelSettings
|
||||
|
||||
-- -D dynamicToRemote tunnels
|
||||
| not . null $ dynamicToRemote cfg = do
|
||||
let tunnelSetting = toDynamicTunnelSetting cfg serverInfo . parseTunnelInfo $ dynamicToRemote cfg ++ ":127.0.0.1:1212"
|
||||
runClient tunnelSetting
|
||||
|
||||
| otherwise = do
|
||||
putStrLn "Cannot parse correctly the command line. Please fill an issue"
|
||||
|
||||
where
|
||||
toStdioLocalToRemoteTunnelSetting cfg serverInfo (TunnelInfo lHost lPort rHost rPort) =
|
||||
TunnelSettings {
|
||||
localBind = lHost
|
||||
, Types.localPort = fromIntegral lPort
|
||||
, serverHost = Main.host serverInfo
|
||||
, serverPort = fromIntegral $ Main.port serverInfo
|
||||
, destHost = rHost
|
||||
, destPort = fromIntegral rPort
|
||||
, Types.useTls = Main.useTls serverInfo
|
||||
, protocol = STDIO
|
||||
, proxySetting = parseProxyInfo (proxy cfg)
|
||||
, useSocks = False
|
||||
, upgradePrefix = pathPrefix cfg
|
||||
, upgradeCredentials = BC.pack $ wsTunnelCredentials cfg
|
||||
, udpTimeout = Main.udpTimeout cfg
|
||||
, tlsSNI = BC.pack $ Main.tlsSNI cfg
|
||||
, tlsVerifyCertificate = Main.tlsVerifyCertificate cfg
|
||||
, hostHeader = BC.pack $ Main.hostHeader cfg
|
||||
, websocketPingFrequencySec = Main.websocketPingFrequencySec cfg
|
||||
, customHeaders = parseCustomHeader <$> Main.customHeaders cfg
|
||||
}
|
||||
|
||||
toTcpLocalToRemoteTunnelSetting cfg serverInfo (TunnelInfo lHost lPort rHost rPort) =
|
||||
TunnelSettings {
|
||||
localBind = lHost
|
||||
, Types.localPort = fromIntegral lPort
|
||||
, serverHost = Main.host serverInfo
|
||||
, serverPort = fromIntegral $ Main.port serverInfo
|
||||
, destHost = rHost
|
||||
, destPort = fromIntegral rPort
|
||||
, Types.useTls = Main.useTls serverInfo
|
||||
, protocol = TCP
|
||||
, proxySetting = parseProxyInfo (proxy cfg)
|
||||
, useSocks = False
|
||||
, upgradePrefix = pathPrefix cfg
|
||||
, upgradeCredentials = BC.pack $ wsTunnelCredentials cfg
|
||||
, udpTimeout = Main.udpTimeout cfg
|
||||
, tlsSNI = BC.pack $ Main.tlsSNI cfg
|
||||
, tlsVerifyCertificate = Main.tlsVerifyCertificate cfg
|
||||
, hostHeader = BC.pack $ Main.hostHeader cfg
|
||||
, websocketPingFrequencySec = Main.websocketPingFrequencySec cfg
|
||||
, customHeaders = parseCustomHeader <$> Main.customHeaders cfg
|
||||
}
|
||||
|
||||
toUdpLocalToRemoteTunnelSetting cfg serverInfo (TunnelInfo lHost lPort rHost rPort) =
|
||||
TunnelSettings {
|
||||
localBind = lHost
|
||||
, Types.localPort = fromIntegral lPort
|
||||
, serverHost = Main.host serverInfo
|
||||
, serverPort = fromIntegral $ Main.port serverInfo
|
||||
, destHost = rHost
|
||||
, destPort = fromIntegral rPort
|
||||
, Types.useTls = Main.useTls serverInfo
|
||||
, protocol = UDP
|
||||
, proxySetting = parseProxyInfo (proxy cfg)
|
||||
, useSocks = False
|
||||
, upgradePrefix = pathPrefix cfg
|
||||
, upgradeCredentials = BC.pack $ wsTunnelCredentials cfg
|
||||
, udpTimeout = Main.udpTimeout cfg
|
||||
, tlsSNI = BC.pack $ Main.tlsSNI cfg
|
||||
, tlsVerifyCertificate = Main.tlsVerifyCertificate cfg
|
||||
, hostHeader = BC.pack $ Main.hostHeader cfg
|
||||
, websocketPingFrequencySec = Main.websocketPingFrequencySec cfg
|
||||
, customHeaders = parseCustomHeader <$> Main.customHeaders cfg
|
||||
}
|
||||
|
||||
toDynamicTunnelSetting cfg serverInfo (TunnelInfo lHost lPort _ _) =
|
||||
TunnelSettings {
|
||||
localBind = lHost
|
||||
, Types.localPort = fromIntegral lPort
|
||||
, serverHost = Main.host serverInfo
|
||||
, serverPort = fromIntegral $ Main.port serverInfo
|
||||
, destHost = ""
|
||||
, destPort = 0
|
||||
, Types.useTls = Main.useTls serverInfo
|
||||
, protocol = SOCKS5
|
||||
, proxySetting = parseProxyInfo (proxy cfg)
|
||||
, useSocks = True
|
||||
, upgradePrefix = pathPrefix cfg
|
||||
, upgradeCredentials = BC.pack $ wsTunnelCredentials cfg
|
||||
, udpTimeout = Main.udpTimeout cfg
|
||||
, tlsSNI = BC.pack $ Main.tlsSNI cfg
|
||||
, tlsVerifyCertificate = Main.tlsVerifyCertificate cfg
|
||||
, hostHeader = BC.pack $ Main.hostHeader cfg
|
||||
, websocketPingFrequencySec = Main.websocketPingFrequencySec cfg
|
||||
, customHeaders = parseCustomHeader <$> Main.customHeaders cfg
|
||||
}
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#!/bin/sh
|
||||
|
||||
# Ubuntu 18
|
||||
|
||||
sudo apt-get install git llvm-6.0-tools zlib1g-dev
|
||||
export PATH="/usr/lib/llvm-6.0/bin/:$PATH"
|
||||
|
||||
wget https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-aarch64.tar.gz
|
||||
tar xzvf stack-2.1.3-linux-aarch64.tar.gz
|
||||
sudo cp stack-2.1.3-linux-aarch64/stack /usr/local/bin/
|
||||
git clone https://github.com/erebe/wstunnel
|
||||
cd wstunnel
|
||||
stack setup
|
||||
stack build
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
#!/bin/sh
|
||||
|
||||
# Raspbian
|
||||
|
||||
sudo apt-get install git llvm-6.0-tools zlib1g-dev ghc
|
||||
export PATH="/usr/lib/llvm-6.0/bin/:$PATH"
|
||||
|
||||
wget https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-arm.tar.gz
|
||||
tar xzvf stack-*.tar.gz
|
||||
sudo cp stack-*/stack /usr/local/bin/
|
||||
git clone https://github.com/erebe/wstunnel
|
||||
cd wstunnel
|
||||
|
||||
stack config set system-ghc --global true
|
||||
sed -i "s/resolver:.*/resolver: lts-12.26/g" stack.yaml
|
||||
sed -i 's/-rtsopts ".*//g' wstunnel.cabal
|
||||
|
||||
stack setup
|
||||
stack build
|
||||
52
default.nix
52
default.nix
|
|
@ -1,52 +0,0 @@
|
|||
# Run using:
|
||||
#
|
||||
# $(nix-build --no-link -A fullBuildScript)
|
||||
{
|
||||
stack2nix-output-path ? "custom-stack2nix-output.nix",
|
||||
}:
|
||||
let
|
||||
cabalPackageName = "wstunnel";
|
||||
compiler = "ghc865"; # matching stack.yaml
|
||||
|
||||
# Pin static-haskell-nix version.
|
||||
static-haskell-nix =
|
||||
if builtins.pathExists ../.in-static-haskell-nix
|
||||
then toString ../. # for the case that we're in static-haskell-nix itself, so that CI always builds the latest version.
|
||||
# Update this hash to use a different `static-haskell-nix` version:
|
||||
else fetchTarball https://github.com/nh2/static-haskell-nix/archive/b402b38c3af2300e71caeebe51b5e4e1ae2e924c.tar.gz;
|
||||
|
||||
# Pin nixpkgs version
|
||||
# By default to the one `static-haskell-nix` provides, but you may also give
|
||||
# your own as long as it has the necessary patches, using e.g.
|
||||
# pkgs = import (fetchTarball https://github.com/nh2/nixpkgs/archive/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa123.tar.gz) {};
|
||||
pkgs = import "${static-haskell-nix}/nixpkgs.nix";
|
||||
|
||||
stack2nix-script = import "${static-haskell-nix}/static-stack2nix-builder/stack2nix-script.nix" {
|
||||
inherit pkgs;
|
||||
stack-project-dir = toString ./.; # where stack.yaml is
|
||||
hackageSnapshot = "2019-10-21T00:00:00Z"; # pins e.g. extra-deps without hashes or revisions
|
||||
};
|
||||
|
||||
static-stack2nix-builder = import "${static-haskell-nix}/static-stack2nix-builder/default.nix" {
|
||||
normalPkgs = pkgs;
|
||||
inherit cabalPackageName compiler stack2nix-output-path;
|
||||
# disableOptimization = true; # for compile speed
|
||||
};
|
||||
|
||||
# Full invocation, including pinning `nix` version itself.
|
||||
fullBuildScript = pkgs.writeScript "stack2nix-and-build-script.sh" ''
|
||||
#!/usr/bin/env bash
|
||||
set -eu -o pipefail
|
||||
STACK2NIX_OUTPUT_PATH=$(${stack2nix-script})
|
||||
export NIX_PATH=nixpkgs=${pkgs.path}
|
||||
${pkgs.nix}/bin/nix-build --no-link -A static_package --argstr stack2nix-output-path "$STACK2NIX_OUTPUT_PATH" "$@"
|
||||
'';
|
||||
|
||||
in
|
||||
{
|
||||
static_package = static-stack2nix-builder.static_package;
|
||||
inherit fullBuildScript;
|
||||
# For debugging:
|
||||
inherit stack2nix-script;
|
||||
inherit static-stack2nix-builder;
|
||||
}
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 32 KiB |
|
|
@ -1,44 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Credentials where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
-- openssl genrsa 1024 > host.key
|
||||
-- openssl req -new -x509 -nodes -sha1 -days 9999 -key host.key > host.cert
|
||||
key :: ByteString
|
||||
key = "-----BEGIN RSA PRIVATE KEY-----\n" <>
|
||||
"MIICXAIBAAKBgQCzP4dg89HDyWfe2k5KD8RdFNh7G9Rla8cjMtE6ccBx84B1WbG5\n" <>
|
||||
"ziRpaCvsTdYSVRwcbR07+4oqR302vyCBZ+r/djpYuTyUTNRYC9+h4wdPGXKhKpeR\n" <>
|
||||
"z1BNVKCsQ6qcBFLDb7l6ra+g36DMQuLcJvLx7LX7elW5w9M/I4FFfV+aeQIDAQAB\n" <>
|
||||
"AoGAD744qa9AcS2zTcNmtOKFoJdAHC/pi67XoqPH9JYhDOESGzxxe5w7XnajxPFh\n" <>
|
||||
"J+MJwQVkV+xTyjrVKIXI2RTDct6tdG2jDcH6P0Xf3I6BPBhvw9pLlisUHTqVxFpV\n" <>
|
||||
"nAoUiyWYZcEiF37IT/uwdRAlhqgitjK7rhZfkM2XNpMb3gECQQDp1qpVk4y5smFE\n" <>
|
||||
"IfZPr94paBZLRD9EwHnxZVM27oR0C95YIgcc12mNchYxIOW4szKwyaUCZLafiojA\n" <>
|
||||
"+anojR/RAkEAxDxnn/3qWmHGYrs/1wrT9FEoC6XZGBHboQIcYYGihK/64P8E19WF\n" <>
|
||||
"BmexzLZdlilieT0ATM5I9zOULSiZ4H/iKQJAC46PdpFHSDo3sm1XRhL0EOnTCD9E\n" <>
|
||||
"PTqiDDssxK8/HpkjkQmFfnhrABGeZSkyEVHR9IjSve6KVBI9tgPg0NyAsQJAEZB+\n" <>
|
||||
"jfmCQnjB8xBjlHHpqtKgzPoZRmhCylSQCcI6s7m0sPLikhcQgxRA+9vO4KPvpn5p\n" <>
|
||||
"SnakXUwGlUwvCcMokQJBAKw9U5H88GyB4qWhnwhustnVnVg/bzkYGpryjDx6mLYh\n" <>
|
||||
"eMPlv6aH546XMJbQ6fRe3tgMBBgOD1QN9WvKuFQo2K4=\n" <>
|
||||
"-----END RSA PRIVATE KEY-----"
|
||||
|
||||
certificate :: ByteString
|
||||
certificate = "-----BEGIN CERTIFICATE-----\n" <>
|
||||
"MIIC5DCCAk2gAwIBAgIUBjMRJwxK4qoz64RFZcHQorbfrucwDQYJKoZIhvcNAQEF\n" <>
|
||||
"BQAwgYMxCzAJBgNVBAYTAkZSMRIwEAYDVQQIDAlBcXVpdGFpbmUxETAPBgNVBAcM\n" <>
|
||||
"CEd1ZXRoYXJ5MRMwEQYDVQQKDApFcmViZSBDb3JwMRIwEAYDVQQLDAlIYWNrIEhh\n" <>
|
||||
"Y2sxDjAMBgNVBAMMBWVyZWJlMRQwEgYJKoZIhvcNAQkBFgVlcmViZTAeFw0xOTEw\n" <>
|
||||
"MjQxMTM5NDVaFw00NzAzMTAxMTM5NDVaMIGDMQswCQYDVQQGEwJGUjESMBAGA1UE\n" <>
|
||||
"CAwJQXF1aXRhaW5lMREwDwYDVQQHDAhHdWV0aGFyeTETMBEGA1UECgwKRXJlYmUg\n" <>
|
||||
"Q29ycDESMBAGA1UECwwJSGFjayBIYWNrMQ4wDAYDVQQDDAVlcmViZTEUMBIGCSqG\n" <>
|
||||
"SIb3DQEJARYFZXJlYmUwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALM/h2Dz\n" <>
|
||||
"0cPJZ97aTkoPxF0U2Hsb1GVrxyMy0TpxwHHzgHVZsbnOJGloK+xN1hJVHBxtHTv7\n" <>
|
||||
"iipHfTa/IIFn6v92Oli5PJRM1FgL36HjB08ZcqEql5HPUE1UoKxDqpwEUsNvuXqt\n" <>
|
||||
"r6DfoMxC4twm8vHstft6VbnD0z8jgUV9X5p5AgMBAAGjUzBRMB0GA1UdDgQWBBRC\n" <>
|
||||
"8mpWQdiOTYy+GBxUQ9vssIloMTAfBgNVHSMEGDAWgBRC8mpWQdiOTYy+GBxUQ9vs\n" <>
|
||||
"sIloMTAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAGkUgoDLmb5e\n" <>
|
||||
"SWPR61QEByPkIji4DytJfzUeJBZKyRQSMGC08yUAPAmFbIt1jqBO6nTum3TjlV6S\n" <>
|
||||
"7bv3kEhkgTdoKHyWtBitnR2wg90Ybm4K6OKLnoKZgvl1IZ6x8LCqI1RVIQMHaUkL\n" <>
|
||||
"L3+otPXxpH1LXGnikOlwLkF2LPhRmX9X\n" <>
|
||||
"-----END CERTIFICATE-----"
|
||||
|
|
@ -1,76 +0,0 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module HttpProxy () where
|
||||
|
||||
|
||||
|
||||
import ClassyPrelude
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
|
||||
import Control.Monad.Except
|
||||
import qualified Data.Streaming.Network as N
|
||||
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Network.Socket (HostName, PortNumber)
|
||||
|
||||
import Logger
|
||||
import Types
|
||||
|
||||
|
||||
data HttpProxySettings = HttpProxySettings
|
||||
{ proxyHost :: HostName
|
||||
, proxyPort :: PortNumber
|
||||
, credentials :: Maybe (ByteString, ByteString)
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
httpProxyConnection :: MonadError Error m => HttpProxySettings -> (HostName, PortNumber) -> (Connection -> IO (m a)) -> IO (m a)
|
||||
httpProxyConnection HttpProxySettings{..} (host, port) app = onError $ do
|
||||
debug $ "Opening tcp connection to proxy " <> show proxyHost <> ":" <> show proxyPort
|
||||
|
||||
ret <- N.runTCPClient (N.clientSettingsTCP (fromIntegral proxyPort) (fromString proxyHost)) $ \conn' -> do
|
||||
let conn = toConnection conn'
|
||||
_ <- sendConnectRequest conn
|
||||
|
||||
-- wait 10sec for a reply before giving up
|
||||
let _10sec = 1000000 * 10
|
||||
responseM <- timeout _10sec $ readConnectResponse mempty conn
|
||||
|
||||
case responseM of
|
||||
Just (isAuthorized -> True) -> app conn
|
||||
Just response -> return . throwError $ ProxyForwardError (BC.unpack response)
|
||||
Nothing -> return . throwError $ ProxyForwardError ("No response from the proxy after "
|
||||
<> show (_10sec `div` 1000000) <> "sec" )
|
||||
|
||||
debug $ "Closing tcp connection to proxy " <> show proxyHost <> ":" <> show proxyPort
|
||||
return ret
|
||||
|
||||
where
|
||||
credentialsToHeader :: (ByteString, ByteString) -> ByteString
|
||||
credentialsToHeader (user, password) = "Proxy-Authorization: Basic " <> B64.encode (user <> ":" <> password) <> "\r\n"
|
||||
|
||||
sendConnectRequest :: Connection -> IO ()
|
||||
sendConnectRequest h = write h $ "CONNECT " <> fromString host <> ":" <> fromString (show port) <> " HTTP/1.0\r\n"
|
||||
<> "Host: " <> fromString host <> ":" <> fromString (show port) <> "\r\n"
|
||||
<> maybe mempty credentialsToHeader credentials
|
||||
<> "\r\n"
|
||||
|
||||
readConnectResponse :: ByteString -> Connection -> IO ByteString
|
||||
readConnectResponse buff conn = do
|
||||
responseM <- read conn
|
||||
case responseM of
|
||||
Nothing -> return buff
|
||||
Just response -> if "\r\n\r\n" `isInfixOf` response
|
||||
then return $ buff <> response
|
||||
else readConnectResponse (buff <> response) conn
|
||||
|
||||
isAuthorized :: ByteString -> Bool
|
||||
isAuthorized response = " 200 " `isInfixOf` response
|
||||
|
||||
onError f = catch f $ \(e :: SomeException) -> return $
|
||||
if take 10 (show e) == "user error"
|
||||
then throwError $ ProxyConnectionError (show e)
|
||||
else throwError $ ProxyConnectionError ("Unknown Error :: " <> show e)
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
module Logger where
|
||||
|
||||
import ClassyPrelude
|
||||
import Network.Socket (HostName, PortNumber)
|
||||
import qualified System.Log.Logger as LOG
|
||||
|
||||
|
||||
data Verbosity = QUIET | VERBOSE | NORMAL
|
||||
|
||||
init :: Verbosity -> IO ()
|
||||
init lvl = LOG.updateGlobalLogger "wstunnel" $ case lvl of
|
||||
QUIET -> LOG.setLevel LOG.ERROR
|
||||
VERBOSE -> LOG.setLevel LOG.DEBUG
|
||||
NORMAL -> LOG.setLevel LOG.INFO
|
||||
|
||||
toStr :: (HostName, PortNumber) -> String
|
||||
toStr (host, port) = fromString host <> ":" <> show port
|
||||
|
||||
err :: String -> IO()
|
||||
err msg = LOG.errorM "wstunnel" $ "ERROR :: " <> msg
|
||||
|
||||
info :: String -> IO()
|
||||
info = LOG.infoM "wstunnel"
|
||||
|
||||
debug :: String -> IO()
|
||||
debug msg = LOG.debugM "wstunnel" $ "DEBUG :: " <> msg
|
||||
140
src/Protocols.hs
140
src/Protocols.hs
|
|
@ -1,140 +0,0 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Protocols where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent (forkFinally, threadDelay)
|
||||
import qualified Data.HashMap.Strict as H
|
||||
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
|
||||
import qualified Data.Streaming.Network as N
|
||||
|
||||
import Network.Socket (HostName, PortNumber)
|
||||
import qualified Network.Socket as N
|
||||
import qualified Network.Socket.ByteString as N
|
||||
|
||||
import Data.Binary (decode, encode)
|
||||
|
||||
import Logger
|
||||
import qualified Socks5
|
||||
import Types
|
||||
|
||||
|
||||
runSTDIOServer :: (StdioAppData -> IO ()) -> IO ()
|
||||
runSTDIOServer app = do
|
||||
stdin_old_buffering <- hGetBuffering stdin
|
||||
stdout_old_buffering <- hGetBuffering stdout
|
||||
|
||||
hSetBuffering stdin (BlockBuffering (Just 512))
|
||||
hSetBuffering stdout NoBuffering
|
||||
|
||||
void $ forever $ app StdioAppData
|
||||
|
||||
hSetBuffering stdin stdin_old_buffering
|
||||
hSetBuffering stdout stdout_old_buffering
|
||||
info $ "CLOSE stdio server"
|
||||
|
||||
runTCPServer :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()
|
||||
runTCPServer endPoint@(host, port) app = do
|
||||
info $ "WAIT for tcp connection on " <> toStr endPoint
|
||||
let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host)
|
||||
void $ N.runTCPServer srvSet app
|
||||
info $ "CLOSE tcp server on " <> toStr endPoint
|
||||
|
||||
runTCPClient :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()
|
||||
runTCPClient endPoint@(host, port) app = do
|
||||
info $ "CONNECTING to " <> toStr endPoint
|
||||
let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.clientSettingsTCP (fromIntegral port) (BC.pack host)
|
||||
void $ N.runTCPClient srvSet app
|
||||
info $ "CLOSE connection to " <> toStr endPoint
|
||||
|
||||
|
||||
runUDPClient :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO ()
|
||||
runUDPClient endPoint@(host, port) app = do
|
||||
info $ "SENDING datagrammes to " <> toStr endPoint
|
||||
bracket (N.getSocketUDP host (fromIntegral port)) (N.close . fst) $ \(socket, addrInfo) -> do
|
||||
sem <- newEmptyMVar
|
||||
app UdpAppData { appAddr = N.addrAddress addrInfo
|
||||
, appSem = sem
|
||||
, appRead = fst <$> N.recvFrom socket 4096
|
||||
, appWrite = \payload -> void $ N.sendAllTo socket payload (N.addrAddress addrInfo)
|
||||
}
|
||||
|
||||
info $ "CLOSE udp connection to " <> toStr endPoint
|
||||
|
||||
|
||||
runUDPServer :: (HostName, PortNumber) -> Int -> (UdpAppData -> IO ()) -> IO ()
|
||||
runUDPServer endPoint@(host, port) cnxTimeout app = do
|
||||
info $ "WAIT for datagrames on " <> toStr endPoint
|
||||
clientsCtx <- newIORef mempty
|
||||
void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (forever . run clientsCtx)
|
||||
info $ "CLOSE udp server" <> toStr endPoint
|
||||
|
||||
where
|
||||
addNewClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> N.SockAddr -> ByteString -> IO UdpAppData
|
||||
addNewClient clientsCtx socket addr payload = do
|
||||
sem <- newMVar payload
|
||||
let appData = UdpAppData { appAddr = addr
|
||||
, appSem = sem
|
||||
, appRead = takeMVar sem
|
||||
, appWrite = \payload' -> void $ N.sendAllTo socket payload' addr
|
||||
}
|
||||
void $ atomicModifyIORef' clientsCtx (\clients -> (H.insert addr appData clients, ()))
|
||||
return appData
|
||||
|
||||
removeClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> UdpAppData -> IO ()
|
||||
removeClient clientsCtx clientCtx = do
|
||||
void $ atomicModifyIORef' clientsCtx (\clients -> (H.delete (appAddr clientCtx) clients, ()))
|
||||
debug "TIMEOUT connection"
|
||||
|
||||
pushDataToClient :: UdpAppData -> ByteString -> IO ()
|
||||
pushDataToClient clientCtx payload = putMVar (appSem clientCtx) payload
|
||||
`catch` (\(_ :: SomeException) -> debug $ "DROP udp packet, client thread dead")
|
||||
-- If we are unlucky the client's thread died before we had the time to push the data on a already full mutex
|
||||
-- and will leave us waiting forever for the mutex to empty. So catch the exeception and drop the message.
|
||||
-- Udp is not a reliable protocol so transmission failure should be handled by the application layer
|
||||
|
||||
-- We run the server inside another thread in order to avoid Haskell runtime sending to the main thread
|
||||
-- the exception BlockedIndefinitelyOnMVar
|
||||
-- We dont use also MVar to wait for the end of the thread to avoid also receiving this exception
|
||||
run :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO ()
|
||||
run clientsCtx socket = do
|
||||
_ <- forkFinally (runEventLoop clientsCtx socket) (\_ -> debug "UdpServer died")
|
||||
threadDelay (maxBound :: Int)
|
||||
|
||||
runEventLoop :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO ()
|
||||
runEventLoop clientsCtx socket = forever $ do
|
||||
(payload, addr) <- N.recvFrom socket 4096
|
||||
clientCtx <- H.lookup addr <$> readIORef clientsCtx
|
||||
|
||||
case clientCtx of
|
||||
Just clientCtx' -> pushDataToClient clientCtx' payload
|
||||
_ -> do
|
||||
clientCtx <- addNewClient clientsCtx socket addr payload
|
||||
_ <- forkFinally (void . timeout cnxTimeout $ app clientCtx) (\_ -> removeClient clientsCtx clientCtx)
|
||||
return ()
|
||||
|
||||
|
||||
runSocks5Server :: Socks5.ServerSettings -> TunnelSettings -> (TunnelSettings -> N.AppData -> IO()) -> IO ()
|
||||
runSocks5Server socksSettings@Socks5.ServerSettings{..} cfg inner = do
|
||||
info $ "Starting socks5 proxy " <> show socksSettings
|
||||
|
||||
_ <- N.runTCPServer (N.serverSettingsTCP (fromIntegral listenOn) (fromString bindOn)) $ \cnx -> do
|
||||
-- Get the auth request and response with a no Auth
|
||||
authRequest <- decode . fromStrict <$> N.appRead cnx :: IO Socks5.RequestAuth
|
||||
debug $ "Socks5 authentification request " <> show authRequest
|
||||
let responseAuth = encode $ Socks5.ResponseAuth (fromIntegral Socks5.socksVersion) Socks5.NoAuth
|
||||
N.appWrite cnx (toStrict responseAuth)
|
||||
|
||||
-- Get the request and update dynamically the tunnel config
|
||||
request <- decode . fromStrict <$> N.appRead cnx :: IO Socks5.Request
|
||||
debug $ "Socks5 forward request " <> show request
|
||||
let responseRequest = encode $ Socks5.Response (fromIntegral Socks5.socksVersion) Socks5.SUCCEEDED (Socks5.addr request) (Socks5.port request) (Socks5.addrType request)
|
||||
let cfg' = cfg { destHost = Socks5.addr request, destPort = Socks5.port request }
|
||||
N.appWrite cnx (toStrict responseRequest)
|
||||
|
||||
inner cfg' cnx
|
||||
|
||||
info $ "Closing socks5 proxy " <> show socksSettings
|
||||
243
src/Socks5.hs
243
src/Socks5.hs
|
|
@ -1,243 +0,0 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Socks5 where
|
||||
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Binary
|
||||
import Data.Binary.Get
|
||||
import Data.Binary.Put
|
||||
import qualified Data.ByteString.Char8 as BC8
|
||||
import Data.Either
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Read as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Network.Socket (HostName, PortNumber)
|
||||
import Numeric (showHex)
|
||||
|
||||
socksVersion :: Word8
|
||||
socksVersion = 0x05
|
||||
|
||||
data AuthMethod = NoAuth
|
||||
| GSSAPI
|
||||
| Login
|
||||
| Reserved
|
||||
| NotAllowed
|
||||
deriving (Show, Read)
|
||||
|
||||
data AddressType = DOMAIN_NAME
|
||||
| IPv4
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
data RequestAuth = RequestAuth
|
||||
{ version :: Int
|
||||
, methods :: Vector AuthMethod
|
||||
} deriving (Show, Read)
|
||||
|
||||
data ResponseAuth = ResponseAuth
|
||||
{ version :: Int
|
||||
, method :: AuthMethod
|
||||
} deriving (Show, Read)
|
||||
|
||||
instance Binary ResponseAuth where
|
||||
put ResponseAuth{..} = putWord8 (fromIntegral version) >> put method
|
||||
get = ResponseAuth <$> (fromIntegral <$> getWord8)
|
||||
<*> get
|
||||
|
||||
|
||||
instance Binary AuthMethod where
|
||||
put val = case val of
|
||||
NoAuth -> putWord8 0x00
|
||||
GSSAPI -> putWord8 0x01
|
||||
Login -> putWord8 0x02
|
||||
NotAllowed -> putWord8 0xFF
|
||||
_ {- Reserverd -} -> putWord8 0x03
|
||||
|
||||
get = do
|
||||
method <- getWord8
|
||||
return $ case method of
|
||||
0x00 -> NoAuth
|
||||
0x01 -> GSSAPI
|
||||
0x02 -> Login
|
||||
0xFF -> NotAllowed
|
||||
_ -> Reserved
|
||||
|
||||
|
||||
instance Binary RequestAuth where
|
||||
put RequestAuth{..} = do
|
||||
putWord8 (fromIntegral version)
|
||||
putWord8 (fromIntegral $ length methods)
|
||||
mapM_ put methods
|
||||
-- Check length <= 255
|
||||
|
||||
get = do
|
||||
version <- fromIntegral <$> getWord8
|
||||
guard (version == 0x05)
|
||||
nbMethods <- fromIntegral <$> getWord8
|
||||
guard (nbMethods > 0 && nbMethods <= 0xFF)
|
||||
methods <- replicateM nbMethods get
|
||||
return $ RequestAuth version methods
|
||||
|
||||
|
||||
|
||||
data Request = Request
|
||||
{ version :: Int
|
||||
, command :: Command
|
||||
, addr :: HostName
|
||||
, port :: PortNumber
|
||||
, addrType :: AddressType
|
||||
} deriving (Show)
|
||||
|
||||
data Command = Connect
|
||||
| Bind
|
||||
| UdpAssociate
|
||||
deriving (Show, Eq, Enum, Bounded)
|
||||
|
||||
|
||||
instance Binary Command where
|
||||
put = putWord8 . (+1) . fromIntegral . fromEnum
|
||||
|
||||
get = do
|
||||
cmd <- (\val -> fromIntegral val - 1) <$> getWord8
|
||||
guard $ cmd >= fromEnum (minBound :: Command) && cmd <= fromEnum (maxBound :: Command)
|
||||
|
||||
return .toEnum $ cmd
|
||||
|
||||
|
||||
instance Binary Request where
|
||||
put Request{..} = do
|
||||
putWord8 (fromIntegral version)
|
||||
put command
|
||||
putWord8 0x00 -- RESERVED
|
||||
_ <- if addrType == DOMAIN_NAME
|
||||
then do
|
||||
putWord8 0x03
|
||||
let host = BC8.pack addr
|
||||
putWord8 (fromIntegral . length $ host)
|
||||
traverse_ put host
|
||||
else do
|
||||
putWord8 0x01
|
||||
let ipv4 = fst . Data.Either.fromRight (0, mempty) . T.decimal . T.pack <$> splitElem '.' addr
|
||||
traverse_ putWord8 ipv4
|
||||
|
||||
putWord16be (fromIntegral port)
|
||||
|
||||
|
||||
|
||||
get = do
|
||||
version <- fromIntegral <$> getWord8
|
||||
guard (version == 5)
|
||||
cmd <- get :: Get Command
|
||||
_ <- getWord8 -- RESERVED
|
||||
|
||||
opCode <- fromIntegral <$> getWord8 -- Addr type, we support only ipv4 and domainame
|
||||
guard (opCode == 0x03 || opCode == 0x01) -- DOMAINNAME OR IPV4
|
||||
|
||||
host <- if opCode == 0x03
|
||||
then do
|
||||
nbWords <- fromIntegral <$> getWord8
|
||||
fromRight T.empty . E.decodeUtf8' <$> replicateM nbWords getWord8
|
||||
else do
|
||||
ipv4 <- replicateM 4 getWord8 :: Get [Word8]
|
||||
let ipv4Str = T.intercalate "." $ fmap (tshow . fromEnum) ipv4
|
||||
return ipv4Str
|
||||
|
||||
guard (not $ null host)
|
||||
port <- fromIntegral <$> getWord16be
|
||||
|
||||
return Request
|
||||
{ version = version
|
||||
, command = cmd
|
||||
, addr = unpack host
|
||||
, port = port
|
||||
, addrType = if opCode == 0x03 then DOMAIN_NAME else IPv4
|
||||
}
|
||||
|
||||
|
||||
|
||||
toHex :: LByteString -> String
|
||||
toHex = foldr showHex "" . unpack
|
||||
|
||||
data Response = Response
|
||||
{ version :: Int
|
||||
, returnCode :: RetCode
|
||||
, serverAddr :: HostName
|
||||
, serverPort :: PortNumber
|
||||
, serverAddrType :: AddressType
|
||||
} deriving (Show)
|
||||
|
||||
data RetCode = SUCCEEDED
|
||||
| GENERAL_FAILURE
|
||||
| NOT_ALLOWED
|
||||
| NO_NETWORK
|
||||
| HOST_UNREACHABLE
|
||||
| CONNECTION_REFUSED
|
||||
| TTL_EXPIRED
|
||||
| UNSUPPORTED_COMMAND
|
||||
| UNSUPPORTED_ADDRESS_TYPE
|
||||
| UNASSIGNED
|
||||
deriving (Show, Eq, Enum, Bounded)
|
||||
|
||||
instance Binary RetCode where
|
||||
put = putWord8 . fromIntegral . fromEnum
|
||||
get = toEnum . min maxBound . fromIntegral <$> getWord8
|
||||
|
||||
|
||||
instance Binary Response where
|
||||
put Response{..} = do
|
||||
putWord8 socksVersion
|
||||
put returnCode
|
||||
putWord8 0x00 -- Reserved
|
||||
_ <- if serverAddrType == DOMAIN_NAME
|
||||
then do
|
||||
putWord8 0x03
|
||||
let host = BC8.pack serverAddr
|
||||
putWord8 (fromIntegral . length $ host)
|
||||
traverse_ put host
|
||||
else do
|
||||
putWord8 0x01
|
||||
let ipv4 = fst . Data.Either.fromRight (0, mempty) . T.decimal . T.pack <$> splitElem '.' serverAddr
|
||||
traverse_ putWord8 ipv4
|
||||
|
||||
putWord16be (fromIntegral serverPort)
|
||||
|
||||
|
||||
get = do
|
||||
version <- fromIntegral <$> getWord8
|
||||
guard(version == fromIntegral socksVersion)
|
||||
ret <- toEnum . min maxBound . fromIntegral <$> getWord8
|
||||
_ <- getWord8 -- RESERVED
|
||||
opCode <- fromIntegral <$> getWord8 -- Type
|
||||
guard(opCode == 0x03 || opCode == 0x01)
|
||||
host <- if opCode == 0x03
|
||||
then do
|
||||
nbWords <- fromIntegral <$> getWord8
|
||||
fromRight T.empty . E.decodeUtf8' <$> replicateM nbWords getWord8
|
||||
else do
|
||||
ipv4 <- replicateM 4 getWord8 :: Get [Word8]
|
||||
let ipv4Str = T.intercalate "." $ fmap (tshow . fromEnum) ipv4
|
||||
return ipv4Str
|
||||
guard (not $ null host)
|
||||
port <- getWord16be
|
||||
|
||||
return Response
|
||||
{ version = version
|
||||
, returnCode = ret
|
||||
, serverAddr = unpack host
|
||||
, serverPort = fromIntegral port
|
||||
, serverAddrType = if opCode == 0x03 then DOMAIN_NAME else IPv4
|
||||
}
|
||||
|
||||
|
||||
|
||||
data ServerSettings = ServerSettings
|
||||
{ listenOn :: PortNumber
|
||||
, bindOn :: HostName
|
||||
-- , onAuthentification :: (MonadIO m, MonadError IOException m) => RequestAuth -> m ResponseAuth
|
||||
-- , onRequest :: (MonadIO m, MonadError IOException m) => Request -> m Response
|
||||
} deriving (Show)
|
||||
303
src/Tunnel.hs
303
src/Tunnel.hs
|
|
@ -1,303 +0,0 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
module Tunnel
|
||||
( runClient
|
||||
, runServer
|
||||
, rrunTCPClient
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
|
||||
import qualified Data.Conduit.Network.TLS as N
|
||||
import qualified Data.Streaming.Network as N
|
||||
|
||||
import Network.Socket (HostName, PortNumber)
|
||||
import qualified Network.Socket as N
|
||||
import qualified Network.Socket.ByteString as N
|
||||
import qualified Network.Socket.ByteString.Lazy as NL
|
||||
|
||||
import qualified Network.WebSockets as WS
|
||||
import qualified Network.WebSockets.Connection as WS
|
||||
import qualified Network.WebSockets.Stream as WS
|
||||
|
||||
import Control.Monad.Except
|
||||
import qualified Network.Connection as NC
|
||||
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
|
||||
import Types
|
||||
import Protocols
|
||||
import qualified Socks5
|
||||
import Logger
|
||||
|
||||
|
||||
|
||||
rrunTCPClient :: MonadError Error m => N.ClientSettings -> (Connection -> IO (m a)) -> IO (m a)
|
||||
rrunTCPClient cfg app = onError $ bracket
|
||||
(do
|
||||
let _10sec = 1000000 * 10
|
||||
ret <- timeout _10sec $ N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg)
|
||||
(s, addr) <- pure $ case ret of
|
||||
Just (s, addr) -> (s, addr)
|
||||
Nothing -> error $ "Cannot open tcp socket within 10 sec to " <> show (N.getHost cfg) <> ":" <> show (N.getPort cfg)
|
||||
|
||||
so_mark_val <- readIORef sO_MARK_Value
|
||||
when (so_mark_val /= 0 && N.isSupportedSocketOption sO_MARK) (N.setSocketOption s sO_MARK so_mark_val)
|
||||
return (s,addr)
|
||||
)
|
||||
(\r -> catch (N.close $ fst r) (\(_ :: SomeException) -> return ()))
|
||||
(\(s, _) -> app Connection
|
||||
{ read = Just <$> N.safeRecv s defaultRecvBufferSize
|
||||
, write = N.sendAll s
|
||||
, close = N.close s
|
||||
, rawConnection = Just s
|
||||
})
|
||||
where
|
||||
onError = flip catch (\(e :: SomeException) -> return . throwError . TunnelError $ show e)
|
||||
|
||||
--
|
||||
-- Pipes
|
||||
--
|
||||
tunnelingClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))
|
||||
tunnelingClientP cfg@TunnelSettings{..} app conn = onError $ do
|
||||
debug "Opening Websocket stream"
|
||||
|
||||
stream <- connectionToStream conn
|
||||
let authorization = ([("Authorization", "Basic " <> B64.encode upgradeCredentials) | not (null upgradeCredentials)])
|
||||
let headers = authorization <> customHeaders
|
||||
let hostname = if not (null hostHeader) then BC.unpack hostHeader else serverHost
|
||||
|
||||
ret <- WS.runClientWithStream stream hostname (toPath cfg) WS.defaultConnectionOptions headers run
|
||||
|
||||
debug "Closing Websocket stream"
|
||||
return ret
|
||||
|
||||
where
|
||||
connectionToStream Connection{..} = WS.makeStream read (write . toStrict . fromJust)
|
||||
onError = flip catch (\(e :: SomeException) -> return . throwError . WebsocketError $ show e)
|
||||
run cnx = WS.withPingThread cnx websocketPingFrequencySec mempty (app (toConnection cnx))
|
||||
|
||||
|
||||
tlsClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))
|
||||
tlsClientP TunnelSettings{..} app conn = onError $ do
|
||||
debug "Doing tls Handshake"
|
||||
|
||||
context <- NC.initConnectionContext
|
||||
let socket = fromJust $ rawConnection conn
|
||||
h <- N.socketToHandle socket ReadWriteMode
|
||||
|
||||
connection <- NC.connectFromHandle context h connectionParams
|
||||
ret <- app (toConnection connection) `finally` hClose h
|
||||
|
||||
debug "Closing TLS"
|
||||
return ret
|
||||
|
||||
where
|
||||
onError = flip catch (\(e :: SomeException) -> return . throwError . TlsError $ show e)
|
||||
tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = not tlsVerifyCertificate
|
||||
, NC.settingDisableSession = False
|
||||
, NC.settingUseServerName = False
|
||||
}
|
||||
connectionParams = NC.ConnectionParams { NC.connectionHostname = if tlsSNI == mempty then serverHost else BC.unpack tlsSNI
|
||||
, NC.connectionPort = serverPort
|
||||
, NC.connectionUseSecure = Just tlsSettings
|
||||
, NC.connectionUseSocks = Nothing
|
||||
}
|
||||
|
||||
|
||||
--
|
||||
-- Connectors
|
||||
--
|
||||
tcpConnection :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())
|
||||
tcpConnection TunnelSettings{..} app = onError $ do
|
||||
debug $ "Opening tcp connection to " <> fromString serverHost <> ":" <> show (fromIntegral serverPort :: Int)
|
||||
|
||||
ret <- rrunTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) app
|
||||
|
||||
debug $ "Closing tcp connection to " <> fromString serverHost <> ":" <> show (fromIntegral serverPort :: Int)
|
||||
return ret
|
||||
|
||||
where
|
||||
onError = flip catch (\(e :: SomeException) -> return $ (throwError $ TunnelError $ show e))
|
||||
|
||||
|
||||
|
||||
httpProxyConnection :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())
|
||||
httpProxyConnection TunnelSettings{..} app = onError $ do
|
||||
let settings = fromJust proxySetting
|
||||
debug $ "Opening tcp connection to proxy " <> show settings
|
||||
|
||||
ret <- rrunTCPClient (N.clientSettingsTCP (fromIntegral (port settings)) (BC.pack $ host settings)) $ \conn -> do
|
||||
_ <- sendConnectRequest settings conn
|
||||
responseM <- timeout (1000000 * 10) $ readConnectResponse mempty conn
|
||||
let response = fromMaybe "No response of the proxy after 10s" responseM
|
||||
|
||||
if isAuthorized response
|
||||
then app conn
|
||||
else return . throwError . ProxyForwardError $ BC.unpack response
|
||||
|
||||
debug $ "Closing tcp connection to proxy " <> show settings
|
||||
return ret
|
||||
|
||||
where
|
||||
credentialsToHeader (user, password) = "Proxy-Authorization: Basic " <> B64.encode (user <> ":" <> password) <> "\r\n"
|
||||
sendConnectRequest settings h = write h $ "CONNECT " <> fromString serverHost <> ":" <> fromString (show serverPort) <> " HTTP/1.0\r\n"
|
||||
<> "Host: " <> fromString serverHost <> ":" <> fromString (show serverPort) <> "\r\n"
|
||||
<> maybe mempty credentialsToHeader (credentials settings)
|
||||
<> "\r\n"
|
||||
|
||||
readConnectResponse buff conn = do
|
||||
response <- fromJust <$> read conn
|
||||
if "\r\n\r\n" `BC.isInfixOf` response
|
||||
then return $ buff <> response
|
||||
else readConnectResponse (buff <> response) conn
|
||||
|
||||
isAuthorized response = " 200 " `BC.isInfixOf` response
|
||||
|
||||
onError = flip catch (\(e :: SomeException) -> return $ when (take 10 (show e) == "user error") (throwError $ ProxyConnectionError $ show e))
|
||||
|
||||
--
|
||||
-- Client
|
||||
--
|
||||
runClient :: TunnelSettings -> IO ()
|
||||
runClient cfg@TunnelSettings{..} = do
|
||||
let withEndPoint = if isJust proxySetting then httpProxyConnection cfg else tcpConnection cfg
|
||||
let doTlsIf tlsNeeded app = if tlsNeeded then tlsClientP cfg app else app
|
||||
let withTunnel cfg' app = withEndPoint (doTlsIf useTls . tunnelingClientP cfg' $ app)
|
||||
|
||||
let app cfg' localH = do
|
||||
ret <- withTunnel cfg' $ \remoteH -> do
|
||||
ret <- remoteH <==> toConnection localH
|
||||
info $ "CLOSE tunnel :: " <> show cfg'
|
||||
return ret
|
||||
|
||||
handleError ret
|
||||
|
||||
case protocol of
|
||||
UDP -> runUDPServer (localBind, localPort) udpTimeout (app cfg)
|
||||
TCP -> runTCPServer (localBind, localPort) (app cfg)
|
||||
STDIO -> runSTDIOServer (app cfg)
|
||||
SOCKS5 -> runSocks5Server (Socks5.ServerSettings localPort localBind) cfg app
|
||||
|
||||
|
||||
|
||||
|
||||
--
|
||||
-- Server
|
||||
--
|
||||
runTlsTunnelingServer :: (ByteString, ByteString) -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
||||
runTlsTunnelingServer (tlsCert, tlsKey) endPoint@(bindTo, portNumber) isAllowed = do
|
||||
info $ "WAIT for TLS connection on " <> toStr endPoint
|
||||
|
||||
N.runTCPServerTLS (N.tlsConfigBS (fromString bindTo) (fromIntegral portNumber) tlsCert tlsKey) $ \sClient ->
|
||||
runApp sClient WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed)
|
||||
|
||||
info "SHUTDOWN server"
|
||||
|
||||
where
|
||||
runApp :: N.AppData -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
|
||||
runApp appData opts app = do
|
||||
stream <- WS.makeStream (N.appRead appData <&> \payload -> if payload == mempty then Nothing else Just payload) (N.appWrite appData . toStrict . fromJust)
|
||||
--let socket = fromJust $ N.appRawSocket appData
|
||||
--stream <- WS.makeStream (N.recv socket defaultRecvBufferSize <&> \payload -> if payload == mempty then Nothing else Just payload) (NL.sendAll socket . fromJust)
|
||||
bracket (WS.makePendingConnectionFromStream stream opts)
|
||||
(\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))
|
||||
app
|
||||
|
||||
runTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
||||
runTunnelingServer endPoint@(host, port) isAllowed = do
|
||||
info $ "WAIT for connection on " <> toStr endPoint
|
||||
|
||||
let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host)
|
||||
void $ N.runTCPServer srvSet $ \sClient -> do
|
||||
let socket = fromJust $ N.appRawSocket sClient
|
||||
stream <- WS.makeStream (N.recv socket defaultRecvBufferSize <&> \payload -> if payload == mempty then Nothing else Just payload) (NL.sendAll socket . fromJust)
|
||||
runApp stream WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed)
|
||||
|
||||
info "CLOSE server"
|
||||
|
||||
where
|
||||
runApp :: WS.Stream -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
|
||||
runApp socket opts = bracket (WS.makePendingConnectionFromStream socket opts)
|
||||
(\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))
|
||||
|
||||
serverEventLoop :: N.SockAddr -> ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
|
||||
serverEventLoop sClient isAllowed pendingConn = do
|
||||
let path = fromPath . WS.requestPath $ WS.pendingRequest pendingConn
|
||||
let forwardedFor = filter (\(header, _) -> header == "x-forwarded-for") $ WS.requestHeaders $ WS.pendingRequest pendingConn
|
||||
info $ "NEW incoming connection from " <> show sClient <> " " <> show forwardedFor
|
||||
case path of
|
||||
Nothing -> info "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"
|
||||
Just (!proto, !rhost, !rport) ->
|
||||
if not $ isAllowed (rhost, rport)
|
||||
then do
|
||||
info "Rejecting tunneling"
|
||||
WS.rejectRequest pendingConn "Restriction is on, You cannot request this tunneling"
|
||||
else do
|
||||
conn <- WS.acceptRequest pendingConn
|
||||
case proto of
|
||||
UDP -> runUDPClient (BC.unpack rhost, fromIntegral rport) (\cnx -> void $ toConnection conn <==> toConnection cnx)
|
||||
TCP -> runTCPClient (BC.unpack rhost, fromIntegral rport) (\cnx -> void $ toConnection conn <==> toConnection cnx)
|
||||
STDIO -> mempty
|
||||
SOCKS5 -> mempty
|
||||
|
||||
|
||||
runServer :: Maybe (ByteString, ByteString) -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
||||
runServer Nothing = runTunnelingServer
|
||||
runServer (Just (tlsCert, tlsKey)) = runTlsTunnelingServer (tlsCert, tlsKey)
|
||||
|
||||
|
||||
|
||||
|
||||
--
|
||||
-- Commons
|
||||
--
|
||||
toPath :: TunnelSettings -> String
|
||||
toPath TunnelSettings{..} = "/" <> upgradePrefix <> "/"
|
||||
<> toLower (show $ if protocol == UDP then UDP else TCP)
|
||||
<> "/" <> destHost <> "/" <> show destPort
|
||||
|
||||
fromPath :: ByteString -> Maybe (Protocol, ByteString, Int)
|
||||
fromPath path = let rets = BC.split '/' . BC.drop 1 $ path
|
||||
in do
|
||||
guard (length rets == 4)
|
||||
let [_, protocol, h, prt] = rets
|
||||
prt' <- readMay . BC.unpack $ prt :: Maybe Int
|
||||
proto <- readMay . toUpper . BC.unpack $ protocol :: Maybe Protocol
|
||||
return (proto, h, prt')
|
||||
|
||||
handleError :: Either Error () -> IO ()
|
||||
handleError (Right ()) = return ()
|
||||
handleError (Left errMsg) =
|
||||
case errMsg of
|
||||
ProxyConnectionError msg -> err "Cannot connect to the proxy" >> debugPP msg
|
||||
ProxyForwardError msg -> err "Connection not allowed by the proxy" >> debugPP msg
|
||||
TunnelError msg -> err "Cannot establish the connection to the server" >> debugPP msg
|
||||
LocalServerError msg -> err "Cannot create the localServer, port already binded ?" >> debugPP msg
|
||||
WebsocketError msg -> err "Cannot establish websocket connection with the server" >> debugPP msg
|
||||
TlsError msg -> err "Cannot do tls handshake with the server" >> debugPP msg
|
||||
Other msg -> debugPP msg
|
||||
|
||||
where
|
||||
debugPP msg = debug $ "====\n" <> msg <> "\n===="
|
||||
|
||||
myTry :: MonadError Error m => IO a -> IO (m ())
|
||||
myTry f = either (\(e :: SomeException) -> throwError . Other $ show e) (const $ return ()) <$> try f
|
||||
|
||||
(<==>) :: Connection -> Connection -> IO (Either Error ())
|
||||
(<==>) hTunnel hOther =
|
||||
myTry $ race_ (propagateReads hTunnel hOther) (propagateWrites hTunnel hOther)
|
||||
|
||||
propagateReads :: Connection -> Connection -> IO ()
|
||||
propagateReads hTunnel hOther = forever $ read hTunnel >>= write hOther . fromJust
|
||||
|
||||
|
||||
propagateWrites :: Connection -> Connection -> IO ()
|
||||
propagateWrites hTunnel hOther = do
|
||||
payload <- fromJust <$> read hOther
|
||||
unless (null payload) (write hTunnel payload >> propagateWrites hTunnel hOther)
|
||||
148
src/Types.hs
148
src/Types.hs
|
|
@ -1,148 +0,0 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Types where
|
||||
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Maybe
|
||||
import System.IO (stdin, stdout)
|
||||
import Data.ByteString (hGetSome, hPutStr)
|
||||
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import qualified Data.Streaming.Network as N
|
||||
import qualified Network.Connection as NC
|
||||
import Network.Socket (HostName, PortNumber)
|
||||
import qualified Network.Socket as N hiding (recv, recvFrom, send, sendTo)
|
||||
import qualified Network.WebSockets.Connection as WS
|
||||
import System.IO.Unsafe (unsafeDupablePerformIO)
|
||||
|
||||
|
||||
instance Hashable PortNumber where
|
||||
hashWithSalt s p = hashWithSalt s (fromEnum p)
|
||||
|
||||
deriving instance Generic N.SockAddr
|
||||
deriving instance Hashable N.SockAddr
|
||||
|
||||
|
||||
{-# NOINLINE defaultRecvBufferSize #-}
|
||||
defaultRecvBufferSize :: Int
|
||||
defaultRecvBufferSize = unsafeDupablePerformIO $
|
||||
bracket (N.socket N.AF_INET N.Stream 0) N.close (\sock -> N.getSocketOption sock N.RecvBuffer)
|
||||
|
||||
sO_MARK :: N.SocketOption
|
||||
sO_MARK = N.SockOpt 1 36 -- https://elixir.bootlin.com/linux/latest/source/arch/alpha/include/uapi/asm/socket.h#L64
|
||||
|
||||
{-# NOINLINE sO_MARK_Value #-}
|
||||
sO_MARK_Value :: IORef Int
|
||||
sO_MARK_Value = unsafeDupablePerformIO $ (newIORef 0)
|
||||
|
||||
data Protocol = UDP | TCP | STDIO | SOCKS5 deriving (Show, Read, Eq)
|
||||
|
||||
data StdioAppData = StdioAppData
|
||||
|
||||
data UdpAppData = UdpAppData
|
||||
{ appAddr :: N.SockAddr
|
||||
, appSem :: MVar ByteString
|
||||
, appRead :: IO ByteString
|
||||
, appWrite :: ByteString -> IO ()
|
||||
}
|
||||
|
||||
instance N.HasReadWrite UdpAppData where
|
||||
readLens f appData = fmap (\getData -> appData { appRead = getData}) (f $ appRead appData)
|
||||
writeLens f appData = fmap (\writeData -> appData { appWrite = writeData}) (f $ appWrite appData)
|
||||
|
||||
data ProxySettings = ProxySettings
|
||||
{ host :: HostName
|
||||
, port :: PortNumber
|
||||
, credentials :: Maybe (ByteString, ByteString)
|
||||
} deriving (Show)
|
||||
|
||||
data TunnelSettings = TunnelSettings
|
||||
{ proxySetting :: Maybe ProxySettings
|
||||
, localBind :: HostName
|
||||
, localPort :: PortNumber
|
||||
, serverHost :: HostName
|
||||
, serverPort :: PortNumber
|
||||
, destHost :: HostName
|
||||
, destPort :: PortNumber
|
||||
, protocol :: Protocol
|
||||
, useTls :: Bool
|
||||
, useSocks :: Bool
|
||||
, upgradePrefix :: String
|
||||
, upgradeCredentials
|
||||
:: ByteString
|
||||
, tlsSNI :: ByteString
|
||||
, tlsVerifyCertificate :: Bool
|
||||
, hostHeader :: ByteString
|
||||
, udpTimeout :: Int
|
||||
, websocketPingFrequencySec :: Int
|
||||
, customHeaders :: [(CI ByteString, ByteString)]
|
||||
}
|
||||
|
||||
instance Show TunnelSettings where
|
||||
show TunnelSettings{..} = localBind <> ":" <> show localPort
|
||||
<> (if isNothing proxySetting
|
||||
then mempty
|
||||
else " <==PROXY==> " <> host (fromJust proxySetting) <> ":" <> (show . port $ fromJust proxySetting)
|
||||
)
|
||||
<> " <==" <> (if useTls then "WSS" else "WS") <> "==> "
|
||||
<> serverHost <> ":" <> show serverPort
|
||||
<> " <==" <> show (if protocol == SOCKS5 then TCP else protocol) <> "==> " <> destHost <> ":" <> show destPort
|
||||
|
||||
|
||||
data Connection = Connection
|
||||
{ read :: IO (Maybe ByteString)
|
||||
, write :: ByteString -> IO ()
|
||||
, close :: IO ()
|
||||
, rawConnection :: Maybe N.Socket
|
||||
}
|
||||
|
||||
class ToConnection a where
|
||||
toConnection :: a -> Connection
|
||||
|
||||
instance ToConnection StdioAppData where
|
||||
toConnection conn = Connection { read = Just <$> hGetSome stdin 512
|
||||
, write = hPutStr stdout
|
||||
, close = return ()
|
||||
, rawConnection = Nothing
|
||||
}
|
||||
|
||||
instance ToConnection WS.Connection where
|
||||
toConnection conn = Connection { read = Just <$> WS.receiveData conn
|
||||
, write = WS.sendBinaryData conn
|
||||
, close = WS.sendClose conn (mempty :: LByteString)
|
||||
, rawConnection = Nothing
|
||||
}
|
||||
|
||||
instance ToConnection N.AppData where
|
||||
toConnection conn = Connection { read = Just <$> N.appRead conn
|
||||
, write = N.appWrite conn
|
||||
, close = N.appCloseConnection conn
|
||||
, rawConnection = Nothing
|
||||
}
|
||||
|
||||
instance ToConnection UdpAppData where
|
||||
toConnection conn = Connection { read = Just <$> appRead conn
|
||||
, write = appWrite conn
|
||||
, close = return ()
|
||||
, rawConnection = Nothing
|
||||
}
|
||||
|
||||
instance ToConnection NC.Connection where
|
||||
toConnection conn = Connection { read = Just <$> NC.connectionGetChunk conn
|
||||
, write = NC.connectionPut conn
|
||||
, close = NC.connectionClose conn
|
||||
, rawConnection = Nothing
|
||||
}
|
||||
|
||||
data Error = ProxyConnectionError String
|
||||
| ProxyForwardError String
|
||||
| LocalServerError String
|
||||
| TunnelError String
|
||||
| WebsocketError String
|
||||
| TlsError String
|
||||
| Other String
|
||||
deriving (Show)
|
||||
160
src/main.rs
Normal file
160
src/main.rs
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
use std::borrow::Cow;
|
||||
use std::collections::BTreeMap;
|
||||
use std::io::ErrorKind;
|
||||
use std::net::{IpAddr, Ipv4Addr, Ipv6Addr, SocketAddr};
|
||||
use std::str::FromStr;
|
||||
use std::time::Duration;
|
||||
use clap::Parser;
|
||||
use hyper::body::Body;
|
||||
use hyper::Request;
|
||||
use hyper_openssl::HttpsConnector;
|
||||
use url::{Host, Url, UrlQuery};
|
||||
|
||||
/// Simple program to greet a person
|
||||
#[derive(clap::Parser, Debug)]
|
||||
#[command(author, version, about, long_about = None)]
|
||||
struct Wstunnel {
|
||||
|
||||
#[command(subcommand)]
|
||||
commands: Commands,
|
||||
}
|
||||
|
||||
#[derive(clap::Subcommand, Debug)]
|
||||
enum Commands {
|
||||
Client(Client),
|
||||
Server(Server)
|
||||
}
|
||||
#[derive(clap::Args, Debug)]
|
||||
struct Client {
|
||||
/// Name of the person to greet
|
||||
#[arg(short='L', long, value_name = "[BIND:]PORT:HOST:PORT", value_parser = parse_env_var)]
|
||||
local_to_remote: Vec<LocalToRemote>,
|
||||
}
|
||||
|
||||
#[derive(clap::Args, Debug)]
|
||||
struct Server {
|
||||
/// Name of the person to greet
|
||||
#[arg(short='L', long, value_name = "[BIND:]PORT:HOST:PORT", value_parser = parse_env_var)]
|
||||
local_to_remote: String,
|
||||
}
|
||||
|
||||
#[derive(Copy, Clone, Debug)]
|
||||
enum L4Protocol {
|
||||
TCP, UDP { timeout: Duration }
|
||||
}
|
||||
|
||||
impl L4Protocol {
|
||||
fn new_udp() -> L4Protocol {
|
||||
L4Protocol::UDP { timeout: Duration::from_secs(30) }
|
||||
}
|
||||
}
|
||||
|
||||
#[derive(Clone, Debug)]
|
||||
struct LocalToRemote {
|
||||
protocol: L4Protocol,
|
||||
local: SocketAddr,
|
||||
remote: (Host<String>, u16),
|
||||
}
|
||||
|
||||
fn parse_env_var(arg: &str) -> Result<LocalToRemote, std::io::Error> {
|
||||
use std::io::Error;
|
||||
|
||||
let (mut protocol, arg) = match &arg[..6] {
|
||||
"tcp://" => (L4Protocol::TCP, &arg[6..]),
|
||||
"udp://" => (L4Protocol::new_udp(), &arg[6..]),
|
||||
_ => (L4Protocol::TCP, arg)
|
||||
};
|
||||
|
||||
let (bind, remaining) = if arg.starts_with('[') {
|
||||
// ipv6 bind
|
||||
let Some((ipv6_str, remaining)) = arg.split_once(']') else {
|
||||
return Err(Error::new(ErrorKind::InvalidInput, format!("cannot parse IPv6 bind from {}", arg)));
|
||||
};
|
||||
let Ok(ipv6_addr) = Ipv6Addr::from_str(&ipv6_str[1..]) else {
|
||||
return Err(Error::new(ErrorKind::InvalidInput, format!("cannot parse IPv6 bind from {}", ipv6_str)));
|
||||
};
|
||||
|
||||
(IpAddr::V6(ipv6_addr), remaining)
|
||||
} else {
|
||||
// Maybe ipv4 addr
|
||||
let Some((ipv4_str, remaining)) = arg.split_once(':') else {
|
||||
return Err(Error::new(ErrorKind::InvalidInput, format!("cannot parse IPv4 bind from {}", arg)));
|
||||
};
|
||||
|
||||
match Ipv4Addr::from_str(ipv4_str) {
|
||||
Ok(ip4_addr) => (IpAddr::V4(ip4_addr), remaining),
|
||||
// Must be the port, so we default to ipv6 bind
|
||||
Err(_) => (IpAddr::V6(Ipv6Addr::from_str("::1").unwrap()), arg)
|
||||
}
|
||||
};
|
||||
|
||||
let Some((port_str, remaining)) = remaining.trim_start_matches(':').split_once(':') else {
|
||||
return Err(Error::new(ErrorKind::InvalidInput, format!("cannot parse bind port from {}", remaining)));
|
||||
};
|
||||
|
||||
let Ok(bind_port): Result<u16, _> = port_str.parse() else {
|
||||
return Err(Error::new(ErrorKind::InvalidInput, format!("cannot parse bind port from {}", port_str)));
|
||||
};
|
||||
|
||||
|
||||
let Ok(remote) = Url::parse(&format!("fake://{}", remaining)) else {
|
||||
return Err(Error::new(ErrorKind::InvalidInput, format!("cannot parse remote from {}", remaining)));
|
||||
};
|
||||
|
||||
let Some(remote_host) = remote.host() else {
|
||||
return Err(Error::new(ErrorKind::InvalidInput, format!("cannot parse remote host from {}", remaining)));
|
||||
};
|
||||
|
||||
let Some(remote_port) = remote.port() else {
|
||||
return Err(Error::new(ErrorKind::InvalidInput, format!("cannot parse remote port from {}", remaining)));
|
||||
};
|
||||
|
||||
match &mut protocol {
|
||||
L4Protocol::TCP => {}
|
||||
L4Protocol::UDP { ref mut timeout, .. } => {
|
||||
let options: BTreeMap<Cow<'_, str>, Cow<'_, str>> = remote.query_pairs().collect();
|
||||
if let Some(duration) = options.get("timeout_sec")
|
||||
.and_then(|x| x.parse::<u64>().ok())
|
||||
.map(|x| Duration::from_secs(x)) {
|
||||
*timeout = duration;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
Ok(LocalToRemote {
|
||||
protocol,
|
||||
local: SocketAddr::new(bind, bind_port),
|
||||
remote: (remote_host.to_owned(), remote_port)
|
||||
})
|
||||
}
|
||||
|
||||
fn main() {
|
||||
println!("Hello, world!");
|
||||
let args = Wstunnel::parse();
|
||||
|
||||
println!("Hello {:?}!", args)
|
||||
|
||||
let client = reqwest::Client::builder()
|
||||
.timeout(Duration::from_secs(10))
|
||||
.connect_timeout(Duration::from_secs(10))
|
||||
.danger_accept_invalid_certs(true)
|
||||
.build().unwrap();
|
||||
|
||||
|
||||
let mut conn = HttpsConnector::new()?;
|
||||
conn.set_callback(move |c, _| {
|
||||
// Prevent native TLS lib from inferring and verifying a default SNI.
|
||||
c.set_use_server_name_indication(false);
|
||||
c.set_verify_hostname(false);
|
||||
|
||||
// And set a custom SNI instead.
|
||||
c.set_hostname("somewhere.com")
|
||||
});
|
||||
Client::builder()
|
||||
.build::<_, Body>(conn)
|
||||
.request(Request::get("somewhere-else.com").body(())?)
|
||||
.await?;
|
||||
|
||||
reqwest::Proxy::all("https://google.com").unwrap().basic_auth("", "")
|
||||
|
||||
}
|
||||
62
stack.yaml
62
stack.yaml
|
|
@ -1,62 +0,0 @@
|
|||
# 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/yaml_configuration/
|
||||
|
||||
# Resolver to choose 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:
|
||||
#
|
||||
# resolver: lts-3.5
|
||||
# resolver: nightly-2015-09-21
|
||||
# resolver: ghc-7.10.2
|
||||
# resolver: ghcjs-0.1.0_ghc-7.10.2
|
||||
# resolver:
|
||||
# name: custom-snapshot
|
||||
# location: "./custom-snapshot.yaml"
|
||||
resolver: lts-19.2
|
||||
|
||||
# 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
|
||||
# - location:
|
||||
# git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
# subdirs:
|
||||
# - auto-update
|
||||
# - wai
|
||||
packages:
|
||||
- .
|
||||
# Dependency packages to be pulled from upstream that are not in the resolver
|
||||
# using the same syntax as the packages field.
|
||||
# (e.g., acme-missiles-0.3)
|
||||
extra-deps: [ ]
|
||||
|
||||
# Override default flag values for local 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: ">=1.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
|
||||
241
test/Spec.hs
241
test/Spec.hs
|
|
@ -1,241 +0,0 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import ClassyPrelude hiding (getArgs, head)
|
||||
import qualified Logger
|
||||
import qualified Network.Socket as N hiding (recv, recvFrom,
|
||||
send, sendTo)
|
||||
import qualified Network.Socket.ByteString as N
|
||||
import qualified Data.Conduit.Network.TLS as N
|
||||
import qualified Data.Streaming.Network as N
|
||||
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Control.Concurrent.Async as Async
|
||||
import Data.ByteString (hPutStr)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Test.Hspec
|
||||
import Data.Binary (decode, encode)
|
||||
|
||||
|
||||
import Tunnel
|
||||
import Types
|
||||
import Protocols
|
||||
import Credentials
|
||||
import qualified Socks5 as Socks5
|
||||
|
||||
testTCPLocalToRemote :: Bool -> IO ()
|
||||
testTCPLocalToRemote useTLS = do
|
||||
|
||||
Logger.init Logger.VERBOSE
|
||||
|
||||
success <- newIORef False
|
||||
let needle = "toto"
|
||||
|
||||
-- SERVER
|
||||
let serverPort = 8080
|
||||
let tls = if useTLS then Just (Credentials.certificate, Credentials.key) else Nothing
|
||||
let serverWithoutTLS = runServer tls ("0.0.0.0", serverPort) (const True)
|
||||
|
||||
-- CLIENT
|
||||
let tunnelSetting = TunnelSettings {
|
||||
localBind = "localhost"
|
||||
, Types.localPort = fromIntegral 8081
|
||||
, serverHost = "localhost"
|
||||
, serverPort = fromIntegral serverPort
|
||||
, destHost = "localhost"
|
||||
, destPort = fromIntegral 8082
|
||||
, Types.useTls = useTLS
|
||||
, protocol = TCP
|
||||
, proxySetting = Nothing
|
||||
, useSocks = False
|
||||
, upgradePrefix = "wstunnel"
|
||||
, udpTimeout = 0
|
||||
, upgradeCredentials = ""
|
||||
, hostHeader = "toto.com"
|
||||
, tlsSNI = "toto.com"
|
||||
, websocketPingFrequencySec = 30
|
||||
, customHeaders = [(CI.mk "toto", "tata"), (CI.mk "titi", "tutu")]
|
||||
, tlsVerifyCertificate = False
|
||||
}
|
||||
let client = runClient tunnelSetting
|
||||
|
||||
-- Remote STUB ENDPOINT
|
||||
let remoteSetting = N.serverSettingsTCP (fromIntegral 8082) "localhost"
|
||||
let remoteServerEndpoint = N.runTCPServer remoteSetting $ (\sClient -> do N.appRead sClient >>= \payload -> if payload == needle then writeIORef success True else writeIORef success False)
|
||||
|
||||
-- local STUB ENDPOINT
|
||||
let localClient = rrunTCPClient (N.clientSettingsTCP (fromIntegral 8081) "localhost") (\cnx -> write cnx needle)
|
||||
|
||||
putStrLn "Starting remote endpoint"
|
||||
Async.async $ timeout (10 * 10^6) remoteServerEndpoint
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Starting wstunnel server"
|
||||
Async.async $ timeout (10 * 10^6) serverWithoutTLS
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Starting wstunnel client"
|
||||
Async.async $ timeout (10 * 10^6) client
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Writing data to the pipeline"
|
||||
_ <- localClient
|
||||
threadDelay (7 * 10^6)
|
||||
|
||||
isSuccess <- readIORef success
|
||||
if not isSuccess
|
||||
then throwString "Tunnel is not working"
|
||||
else putStrLn "Success"
|
||||
|
||||
testUDPLocalToRemote :: Bool -> IO ()
|
||||
testUDPLocalToRemote useTLS = do
|
||||
|
||||
Logger.init Logger.VERBOSE
|
||||
|
||||
success <- newIORef False
|
||||
let needle = "toto"
|
||||
|
||||
-- SERVER
|
||||
let serverPort = 8080
|
||||
let tls = if useTLS then Just (Credentials.certificate, Credentials.key) else Nothing
|
||||
let serverWithoutTLS = runServer tls ("0.0.0.0", serverPort) (const True)
|
||||
|
||||
-- CLIENT
|
||||
let tunnelSetting = TunnelSettings {
|
||||
localBind = "localhost"
|
||||
, Types.localPort = fromIntegral 8081
|
||||
, serverHost = "localhost"
|
||||
, serverPort = fromIntegral serverPort
|
||||
, destHost = "localhost"
|
||||
, destPort = fromIntegral 8082
|
||||
, Types.useTls = useTLS
|
||||
, protocol = UDP
|
||||
, proxySetting = Nothing
|
||||
, useSocks = False
|
||||
, upgradePrefix = "wstunnel"
|
||||
, udpTimeout = -1
|
||||
, upgradeCredentials = ""
|
||||
, hostHeader = "toto.com"
|
||||
, tlsSNI = "toto.com"
|
||||
, websocketPingFrequencySec = 30
|
||||
, customHeaders = [(CI.mk "toto", "tata"), (CI.mk "titi", "tutu")]
|
||||
, tlsVerifyCertificate = False
|
||||
}
|
||||
let client = runClient tunnelSetting
|
||||
|
||||
-- Remote STUB ENDPOINT
|
||||
let remoteServerEndpoint = runUDPServer ("localhost", fromIntegral 8082) (-1) $ (\sClient -> do read (toConnection sClient) >>= \(Just payload) -> if payload == needle then writeIORef success True else writeIORef success False)
|
||||
|
||||
-- local STUB ENDPOINT
|
||||
let localClient = runUDPClient ("localhost", fromIntegral 8081) (\cnx -> write (toConnection cnx) needle)
|
||||
|
||||
putStrLn "Starting remote endpoint"
|
||||
Async.async $ timeout (10 * 10^6) remoteServerEndpoint
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Starting wstunnel server"
|
||||
Async.async $ timeout (10 * 10^6) serverWithoutTLS
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Starting wstunnel client"
|
||||
Async.async $ timeout (10 * 10^6) client
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Writing data to the pipeline"
|
||||
_ <- localClient
|
||||
threadDelay (7 * 10^6)
|
||||
|
||||
isSuccess <- readIORef success
|
||||
if not isSuccess
|
||||
then throwString "Tunnel is not working"
|
||||
else putStrLn "Success"
|
||||
|
||||
testSocks5Tunneling :: Bool -> IO ()
|
||||
testSocks5Tunneling useTLS = do
|
||||
|
||||
Logger.init Logger.VERBOSE
|
||||
|
||||
success <- newIORef False
|
||||
let needle = "toto"
|
||||
|
||||
-- SERVER
|
||||
let serverPort = 8080
|
||||
let tls = if useTLS then Just (Credentials.certificate, Credentials.key) else Nothing
|
||||
let serverWithoutTLS = runServer tls ("0.0.0.0", serverPort) (const True)
|
||||
|
||||
-- CLIENT
|
||||
let tunnelSetting = TunnelSettings {
|
||||
localBind = "localhost"
|
||||
, Types.localPort = fromIntegral 8081
|
||||
, serverHost = "localhost"
|
||||
, serverPort = fromIntegral serverPort
|
||||
, destHost = ""
|
||||
, destPort = 0
|
||||
, Types.useTls = useTLS
|
||||
, protocol = SOCKS5
|
||||
, proxySetting = Nothing
|
||||
, useSocks = False
|
||||
, upgradePrefix = "wstunnel"
|
||||
, udpTimeout = -1
|
||||
, upgradeCredentials = ""
|
||||
, hostHeader = "toto.com"
|
||||
, tlsSNI = "toto.com"
|
||||
, websocketPingFrequencySec = 30
|
||||
, customHeaders = [(CI.mk "toto", "tata"), (CI.mk "titi", "tutu")]
|
||||
, tlsVerifyCertificate = False
|
||||
}
|
||||
let client = runClient tunnelSetting
|
||||
|
||||
-- Remote STUB ENDPOINT
|
||||
let remoteSetting = N.serverSettingsTCP (fromIntegral 8082) "localhost"
|
||||
let remoteServerEndpoint = N.runTCPServer remoteSetting $ (\sClient -> do N.appRead sClient >>= \payload -> if payload == needle then writeIORef success True else writeIORef success False)
|
||||
|
||||
|
||||
putStrLn "Starting remote endpoint"
|
||||
Async.async $ timeout (10 * 10^6) remoteServerEndpoint
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Starting wstunnel server"
|
||||
Async.async $ timeout (10 * 10^6) serverWithoutTLS
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Starting wstunnel client"
|
||||
Async.async $ timeout (10 * 10^6) client
|
||||
threadDelay (1 * 10^6)
|
||||
|
||||
putStrLn "Writing data to the pipeline"
|
||||
rrunTCPClient (N.clientSettingsTCP (fromIntegral 8081) "localhost") $ \cnx -> do
|
||||
write cnx (toStrict . encode $ Socks5.RequestAuth (fromIntegral Socks5.socksVersion) (fromList [Socks5.NoAuth]))
|
||||
_ <- read cnx
|
||||
write cnx (toStrict . encode $ Socks5.Request (fromIntegral Socks5.socksVersion) Socks5.Connect "localhost" 8082 Socks5.DOMAIN_NAME)
|
||||
_ <- read cnx
|
||||
write cnx needle
|
||||
|
||||
threadDelay (7 * 10^6)
|
||||
|
||||
isSuccess <- readIORef success
|
||||
if not isSuccess
|
||||
then throwString "Tunnel is not working"
|
||||
else putStrLn "Success"
|
||||
|
||||
main :: IO ()
|
||||
main = hspec $ do
|
||||
describe "Socks5 tunneling" $ do
|
||||
it "Testing socks5 -D without TLS" $ do
|
||||
testSocks5Tunneling False
|
||||
it "Testing socks5 -D with TLS" $ do
|
||||
testSocks5Tunneling True
|
||||
|
||||
describe "TCP tunneling" $ do
|
||||
it "Testing TCP -L without TLS" $ do
|
||||
testTCPLocalToRemote False
|
||||
it "Testing TCP -L with TLS" $ do
|
||||
testTCPLocalToRemote True
|
||||
|
||||
describe "UDP tunneling" $ do
|
||||
it "Testing UDP -L without TLS" $ do
|
||||
testUDPLocalToRemote False
|
||||
it "Testing UDP -L with TLS" $ do
|
||||
testUDPLocalToRemote True
|
||||
|
||||
|
|
@ -1,81 +0,0 @@
|
|||
name: wstunnel
|
||||
version: 0.5.1.0
|
||||
synopsis: Tunneling program over websocket protocol
|
||||
description: For more information regarding wstunnel, please refer to README.md
|
||||
homepage: https://github.com/githubuser/wstunnel#readme
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Erèbe
|
||||
maintainer: github@erebe.eu
|
||||
copyright: 2021 Erèbe
|
||||
category: Web
|
||||
build-type: Simple
|
||||
-- extra-source-files:
|
||||
cabal-version: >=1.10
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: Tunnel, Protocols, Types, Logger, Socks5, Credentials, HttpProxy
|
||||
default-extensions: NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RecordWildCards
|
||||
build-depends: async
|
||||
, base >= 4.5 && < 5
|
||||
, base64-bytestring >= 1.0
|
||||
, binary >= 0.7
|
||||
, bytestring
|
||||
, classy-prelude
|
||||
, connection
|
||||
, hslogger
|
||||
, mtl
|
||||
, network >= 3.1.2
|
||||
, network-conduit-tls
|
||||
, streaming-commons
|
||||
, text >= 1.2.2.1
|
||||
, unordered-containers
|
||||
, websockets >= 0.12.4.0
|
||||
, iproute
|
||||
, case-insensitive
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite wstunnel-test
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
default-extensions: NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RecordWildCards
|
||||
build-depends: base >= 4.5 && < 5
|
||||
, async
|
||||
, text >= 1.2.2.1
|
||||
, classy-prelude
|
||||
, bytestring
|
||||
, network
|
||||
, network-conduit-tls
|
||||
, streaming-commons
|
||||
, wstunnel
|
||||
, hspec
|
||||
, binary
|
||||
, case-insensitive
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
default-language: Haskell2010
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/githubuser/wstunnel
|
||||
|
||||
executable wstunnel
|
||||
hs-source-dirs: app
|
||||
main-is: Main.hs
|
||||
default-extensions: NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RecordWildCards
|
||||
ghc-options: -threaded
|
||||
-O3
|
||||
-rtsopts "-with-rtsopts=-N -qb -qg"
|
||||
build-depends: base >= 4.5 && < 5
|
||||
, bytestring
|
||||
, classy-prelude
|
||||
, cmdargs
|
||||
, hslogger
|
||||
, text >= 1.2.2.1
|
||||
, async
|
||||
, wstunnel
|
||||
, case-insensitive
|
||||
|
||||
default-language: Haskell2010
|
||||
Loading…
Reference in a new issue