pax_global_header00006660000000000000000000000064152731763240014524gustar00rootroot0000000000000052 comment=5c7176ef9eda20f0f2f2daebecdc2ab991121737 mhatta-tordnsel-1d9141b/000077500000000000000000000000001527317632400151615ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/.github/000077500000000000000000000000001527317632400165215ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/.github/workflows/000077500000000000000000000000001527317632400205565ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/.github/workflows/ci.yml000066400000000000000000000122111527317632400216710ustar00rootroot00000000000000name: CI on: push: pull_request: schedule: # Catch breakage from new library releases. - cron: '17 4 * * 1' jobs: build: name: GHC ${{ matrix.ghc }} # Pinned rather than ubuntu-latest, so that a change of the runner image # doesn't break the build behind our backs. runs-on: ubuntu-24.04 strategy: fail-fast: false matrix: ghc: ['9.4', '9.6', '9.8', '9.10', '9.12', '9.14'] steps: - uses: actions/checkout@v6 - uses: haskell-actions/setup@v2 id: setup with: ghc-version: ${{ matrix.ghc }} cabal-version: latest - name: Configure run: | cabal update cabal configure --enable-tests cabal build all --dry-run - uses: actions/cache@v5 with: path: ${{ steps.setup.outputs.cabal-store }} key: cabal-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dist-newstyle/cache/plan.json') }} restore-keys: cabal-${{ runner.os }}-${{ matrix.ghc }}- - name: Build run: cabal build all - name: Test run: cabal test all --test-show-details=direct - name: Check the package run: cabal check distro: # Build with nothing but Ubuntu's Haskell packages, the way a # distribution package would be built. name: Ubuntu packages (Setup.hs) runs-on: ubuntu-24.04 steps: - uses: actions/checkout@v6 - name: Install dependencies run: | sudo apt-get update sudo apt-get install -y ghc libghc-network-dev libghc-conduit-dev \ libghc-conduit-extra-dev libghc-cryptohash-sha256-dev \ libghc-hunit-dev libghc-quickcheck2-dev - name: Build and test # The runner image puts a GHC installed with ghcup (without our # dependencies) first on the PATH; use Ubuntu's instead. run: | export PATH=/usr/bin:$PATH ghc --version runghc Setup.hs configure --enable-tests --user \ --with-compiler=/usr/bin/ghc --with-hc-pkg=/usr/bin/ghc-pkg runghc Setup.hs build runghc Setup.hs test integration: # End-to-end test against a private Tor network (see tests/integration). name: Integration (chutney ${{ matrix.chutney }}) runs-on: ubuntu-24.04 strategy: fail-fast: false matrix: include: # The last chutney with the old command line (the GitHub mirror, # frozen since chutney moved to Tor's GitLab). - chutney: legacy experimental: false # Current chutney. Not required to pass until it has been seen to # work; then pin it to a commit and drop "experimental". - chutney: current experimental: true continue-on-error: ${{ matrix.experimental }} steps: - uses: actions/checkout@v6 - name: Get chutney (legacy) if: matrix.chutney == 'legacy' uses: actions/checkout@v6 with: repository: torproject/chutney ref: 62b54a55215c94eb14adc22c5acd17b2ada04b76 path: chutney - name: Get chutney (current) if: matrix.chutney == 'current' run: | git clone --depth 1 https://gitlab.torproject.org/tpo/core/chutney.git chutney git -C chutney log -1 --format='chutney %H %cd' - name: Install dependencies run: | sudo apt-get update sudo apt-get install -y tor bind9-dnsutils curl python3-venv ghc \ libghc-network-dev libghc-conduit-dev libghc-conduit-extra-dev \ libghc-cryptohash-sha256-dev libghc-hunit-dev sudo systemctl stop tor || true tor --version # Python 3.12 removed asyncore and asynchat, which chutney still # imports. pip can't install into Ubuntu's Python (PEP 668), so use # a virtual environment; chutney runs the first python3 on the PATH. python3 -m venv "$RUNNER_TEMP/venv" "$RUNNER_TEMP/venv/bin/pip" install pyasyncore pyasynchat if [ "${{ matrix.chutney }}" = current ]; then "$RUNNER_TEMP/venv/bin/pip" install tomli_w typeguard paramiko rpyc fi "$RUNNER_TEMP/venv/bin/python3" -c 'import asyncore, asynchat' - name: Build # As in the distro job: use Ubuntu's GHC, not the runner's ghcup one. run: | export PATH=/usr/bin:$PATH runghc Setup.hs configure --user \ --with-compiler=/usr/bin/ghc --with-hc-pkg=/usr/bin/ghc-pkg runghc Setup.hs build - name: Run run: | export PATH=$RUNNER_TEMP/venv/bin:$PATH SUDO=sudo KEEP=1 TMPDIR=$RUNNER_TEMP \ tests/integration/run.sh chutney dist/build/tordnsel/tordnsel - name: Keep the logs if: failure() uses: actions/upload-artifact@v6 with: name: integration-logs-${{ matrix.chutney }} path: | ${{ runner.temp }}/tordnsel-it.*/*.log ${{ runner.temp }}/tordnsel-it.*/*.out ${{ runner.temp }}/tordnsel-it.*/chutney/net/nodes/*/*.log ${{ runner.temp }}/tordnsel-it.*/chutney/net/nodes/*/torrc if-no-files-found: ignore mhatta-tordnsel-1d9141b/.gitignore000066400000000000000000000001621527317632400171500ustar00rootroot00000000000000 *~ .cabal-sandbox/ cabal.config cabal.project.local cabal.sandbox.config dist-ghc94/ dist-newstyle/ dist/ local/ mhatta-tordnsel-1d9141b/ChangeLog000066400000000000000000000406521527317632400167420ustar00rootroot000000000000000.4.0 - 2026-11-05 o Security (from an audit of 0.3.0): - Dropping privileges: without Group, use the user's primary group instead of keeping group 0; set the supplementary groups to the user's (as initgroups(3) does) instead of keeping root's. - Exit test listener: at most 16 connections from one address, and 15 seconds (not 30) to send the request. One host could take all the handlers and stop the exit tests. Bad requests are logged at debug level. - DNS: DNSRateLimit is now 100 by default (it was off), loopback is never limited, and ANY gets a single RRset (RFC 8482): the A record for a listed name, the SOA at the apex. A public server could be used to amplify spoofed floods. - Exit test results loaded from the state directory are cut down to the 16 most recent addresses per relay, like new ones. - The statistics socket is mode 0660 (it was 0666), owned by the user and group we drop privileges to. o Tor: - TorControlAddress and TorSocksAddress accept Unix sockets, unix:/path, and IPv6 addresses, which failed to connect before. Debian's tor package works without changes to the torrc: TorControlAddress unix:/run/tor/control TorSocksAddress unix:/run/tor/socks with TorDNSEL in the debian-tor group. - Retry the control connection at least once a minute (it was every 5 minutes at worst), so that a restarted Tor is noticed quickly. o Other: - The exit-addresses file is synced to disk before it replaces the old one, and is read correctly even if it isn't sorted. o Upgrading: - With DNSRateLimit unset, UDP is now limited to 100 queries a second per client network; set it to 0 for the old behaviour. - The statistics socket is no longer world-accessible; run whatever reads it (contrib/cacti-input.pl) as TorDNSEL's user or group. 0.3.1 - 2026-11-05 o Web interface: terminating the web server (at shutdown, say) could hang forever if a request had just been served: the handler's exit signal was thrown away. 0.3.0 - 2026-10-28 o Security (from an audit of 0.2.2): - Control port: never use plain COOKIE authentication, which would send the contents of whatever file the other end names; read the cookie file only if it is a regular file of exactly 32 bytes; give up on the handshake after 30 seconds and on QUIT after 5. Something other than Tor on the control port could read files, exhaust our memory with /dev/zero, or keep us from ever reconnecting. - Exit tests: each cookie is accepted once, and a relay gets at most 16 tested exit addresses. A malicious exit could replay its test's cookie from other addresses (open proxies, shared NAT) and have them listed. - DNS over TCP: at most 8 connections per client network, 100 queries per connection, a 2 second idle timeout when busy, and a timeout on sending. One client could take all the connections. - The UDP rate limiter tracks at most 100,000 networks. - Web interface: at most 8 connections per client, and 3 seconds to send the request. - Exit test listener: a header line without a colon no longer escapes the request handler as an exception. - Startup: umask 077; refuse state and runtime directories writable by other users; create the PID file with O_EXCL, never through a symbolic link. - The systemd unit has more sandboxing, including a system call filter. o New features: - "exit" queries, {IP}.{zone}, the form of the Tor Project's exit list service: listed iff IP is a Tor exit, with the relays' fingerprints in TXT records. Also /api/v1/exit on the web interface. - DNSClientSubnet (on by default): "me" queries are about the client subnet a resolver gives with the EDNS client subnet option (RFC 7871). - HTTPTrustedProxy: believe X-Forwarded-For from these reverse proxies. - HTTPMetricsAllowFrom: Prometheus metrics at /metrics for these clients, including the number of running exits and rate-limited queries. o Other: - Root without CAP_SYS_RESOURCE (e.g. in a container) no longer fails to start when it can't raise the hard limit on open files. - The statistics socket also reports RateLimited. 0.2.2 - 2026-10-24 o Security: - Authenticate to Tor's control port with SAFECOOKIE when Tor offers it (whenever cookie authentication is on), so that the cookie itself is never sent, and refuse to authenticate if Tor can't prove it knows the cookie. Needs cryptohash-sha256. - New option DNSRateLimit: answer at most that many UDP queries per second from each client network (IPv4 /24, IPv6 /56); of the queries over the limit, every second one gets a truncated response and the rest are dropped. Off by default. o DNS: - Answer over TCP too (RFC 7766), on the same address as UDP: queries may be pipelined; at most 128 connections, each closed after 10 idle seconds. Firewalls must let TCP to DNSListenAddress through. - UDP responses may be as large as the client's EDNS(0) payload size (at most 1232 bytes); larger ones are truncated (TC bit) instead of being replaced by SERVFAIL, so that clients retry over TCP. - Answer QCLASS * queries like class IN ones instead of with NXDOMAIN. o Internals: - DNS and SOCKS decoding are pure and total, instead of catching exceptions in IO. - The main thread and the network state manager use the strict StateT. - Asynchronous exceptions are recognised by SomeAsyncException. - ADDRMAP events: take the expiry from EXPIRES (UTC), not local time. o Testing: - QuickCheck properties for the DNS decoder (arbitrary and damaged input, round trips), the SOCKS and AUTHCHALLENGE parsers and the rate limiter. Needs QuickCheck. - Unit tests for DNS over TCP on real loopback connections, truncation, rate limiting, SAFECOOKIE and ADDRMAP; the integration test asks over TCP too. 0.2.1 - 2026-10-23 o Building: - Don't derive Typeable, which GHC 9.12 and newer warn about. o Testing: - CI: build the "Ubuntu packages" and integration jobs with Ubuntu's GHC rather than the ghcup GHC the runner image puts first on the PATH; install chutney's Python dependencies in a virtual environment; test against both the last chutney with the old command line and current chutney; keep the logs of failed integration runs. - The integration test reports why chutney failed instead of exiting silently, and refuses working directories too deep for Tor's control sockets. 0.2.0 - 2026-10-20 o Building: - Port to GHC 9.4 and newer (tested with 9.4.7 and 9.10.3) and current libraries (mtl 2.3, network 3, conduit 1.3, unix 2.8, binary 0.8). The code base targeted GHC 7.6. - Modern cabal file (library, executable, test suite); GitHub Actions CI over GHC 9.4 - 9.14, Ubuntu's own Haskell packages, and an end-to-end test against a private Tor network built with chutney. - Drop the libcrypto dependency: random bytes come from the kernel's CSPRNG device, opened before chroot. - Link with the threaded RTS, which uses epoll/kqueue; the select(2) FD_SETSIZE cap on file descriptors no longer applies. o Tor compatibility (tested with Tor 0.4.9.6): - Active exit tests work again. Tor refuses .exit hostnames on its SOCKS port since 0.3.x, so every test failed; tests now install a MAPADDRESS mapping to ADDRESS.FINGERPRINT.exit through the controller. - Follow NEWCONSENSUS events instead of NS events. Since Tor 0.4.8 NS events may never mention stable relays again, so they were dropped from our view after 24 hours. - Parse both forms of router status entries and the current descriptor and exit policy syntax ("private", IPv6 rules, *4/*6). o New features (doc/torel-design.md): - Query type 2, "{IP}.{listname}.list.{zone}", with lists defined by the new ExitList option. - Query type 3, "{IP}.{port}.me.{zone}", answered with a TTL of 0. - A web interface (HTTPListenAddress, HTTPPublicAddress) with JSON endpoints for every query type, /api/ip, /torbulkexitlist and /exit-addresses. o DNS: - Support EDNS(0) (OPT echo, BADVERS) and answer TXT queries with an explanation of the listing (RFC 5782). - Answer prefixes of valid query names with NOERROR/NODATA, which keeps resolvers using QNAME minimisation working. - IPv6 listen addresses ("[::]:53"); queries from IPv6 hosts. - Don't crash the decoder on unknown opcodes or response codes. o Bug fixes: - --reconfigure works again with network 3 and current bytestring. - Malformed values of optional config options are reported instead of being silently ignored. 0.1.1 - 2011-06-28 - Correctly label the release version and Changelog. - Add updated website and maintainers in tordnsel.cabal. - Document the tordnsel init script for Debian. 0.1.0 - 2011-06-28 o Deployment: - Add support for logging messages to stdout, stderr, syslog, or to a file. Syslog logging should be useful for running in a chroot. - Display better error messages for config file parsing, directory parsing, Tor controller errors, I/O errors, and almost every error condition. - Add a man page fully documenting config options, signals, files, sockets, and exit codes. - Add support for reloading the configuration by reloading the config file when we receive SIGHUP, or by listening for the contents of the config file on a Unix domain socket. The latter is useful for running in a chroot, where the process can't access its own config file. - Implement the reload command in the sample init.d script using the new --reconfigure command-line option, which reloads the config file through a Unix domain socket for chroot-friendliness. - Exit gracefully when we receive SIGINT or SIGTERM. - Add a --verify-config command-line option for checking whether the config file is well-formed without starting TorDNSEL. Apply it in the sample init.d script. - Add --help and --version command-line options. o Reliability: - Implement Erlang-style thread links and monitors for error handling. - Refactor every thread to support a start/reconfigure/terminate API. - Each thread now runs in a fault-tolerant supervision hierarchy in which the thread is responsible for handling errors in its children, and its supervisor handles errors in it. If a thread dies unexpectedly, the reason it died is logged and its supervisor attempts to restart it when possible. o New required options: - Create a new required RuntimeDirectory option for the statistics and reconfigure sockets. - Rename the AuthoritativeZone option to ZoneOfAuthority, since name servers are authoritative, not zones. o Performance: - Share copies of exit policy rules and exit policies with a hash table of weak pointers. According to nickm, only 5% of them are distinct. - Squash some space leaks in network state updates. o Standards conformance: - Stop requiring that reserved bits in the DNS header be 0. o Active tests: - Replace the ConcurrentExitTests option with EnableActiveTesting, since we now automatically detect limits imposed on open file descriptors by FD_SETSIZE and resource limits. - Refactor the exit test initiator to keep a history of scheduled exit tests and dynamically adjust the rate at which tests are initiated. This should smooth out the pubkey crypto demands on Tor that were maxing out CPU utilization. - Make a better effort to avoid redundant testing by storing pending tests in a distinct queue. - Stop testing every node periodically between descriptor publications. Instead, every hour attempt to test through any exit nodes that haven't been successfully tested since they last published a descriptor. This should have a similar effect of catching nodes that slipped through an earlier attempted test. - Regenerate the exit-addresses store every time a new network status consensus is received instead of every 15 minutes. - Reduce the maximum relay age from 48 hours to 24 hours. This should cut down the length of time a relay is listed in the exitlist after it has been disabled or changed to a non-exit relay. o Controller: - Close controller connections cleanly with the QUIT command. - Add support for authenticating with PROTOCOLINFO. - Set the new FetchDirInfoEarly option to enable fetching dir info on the mirror schedule, preferably from authorities. - Ensure that config options we set are rolled back to their previous state when a controller connection is closed cleanly. 0.0.6 - 2007-07-28 - Support an optional A record for our authoritative zone. - Return our own NS record in the appropriate places. - Don't modify the group ownership of our state directory. - Rebuild the exit-addresses file every 15 minutes so LastStatus items stay up to date. - Ensure exit tests are scheduled when we receive new descriptors. - Generate cookies using OpenSSL's strong pseudo-random number generator. - Add a "Connection: close" header to test requests and responses. - Test once through each port exit policies allow, recording varying exit addresses for individual nodes. - Periodically (currently, every 150 minutes) test through every node marked running. - Make cumulative DNS load statistics available via a Unix stream socket located in our state directory. Add a sample data input script for Cacti. - Increase the test result retention period to 48 hours. - Ensure the controller socket is closed immediately when connect fails. - Rate limit exit test initiation to one node every three seconds. This should reduce the load we put on Tor, particularly during periodic tests. 0.0.5 - 2007-06-12 - Set QR in responses as we did in 0.0.3 and earlier. Fixes a bug introduced in 0.0.4. - Return a SOA record when queries ask for one. - Ensure that the state directory has correct ownership and permissions. - Include a Debian-style init script and instructions for setting up TorDNSEL with it. (patch from Jacob Appelbaum) 0.0.4 - 2007-06-02 - Return REFUSED instead of SERVFAIL for queries outside the authoritative zone. - Return NODATA for queries matching the authoritative zone. - Return NODATA for positive results when queries ask for non-A records. - Support queries with a type of *. - Return a SOA record with NXDOMAIN and NODATA responses to support negative caching. - Don't send responses that exceed 512 bytes. - Drop incoming messages with QR set. - Implement compression for domain names in responses. - Add a required SOARName option to specify the RNAME field in SOA records. 0.0.3 - 2007-04-27 - Implement active testing through exit nodes to determine the IP address connections actually originate from. Store this information in state files so external scripts have access to it. - Always return an A record with the value 127.0.0.2 when queried about 127.0.0.2. This conforms to the convention for testing DNSBLs. - Fix a bug that could kill the Tor controller thread when Tor is restarted. Tor closing the control connection created a race condition allowing an asynchronous exception to escape an exception handler and kill the Tor controller thread. 0.0.2 - 2007-04-14 - Fix another bug caused by the incorrect Ord instance for PortNumber. We don't want to accept DNS queries from privileged ports so we can avoid a potential denial of service caused by an attacker spoofing our own IP address in the query. 0.0.1 - 2007-04-13 - Ignore incoming descriptors with published times older than ones we already have. - Consider any router that has published a descriptor within the last 48 hours to be running. This means we don't use network status info anymore, but we'll still keep track of it in case it becomes useful. - Set FetchUselessDescriptors so we receive descriptors for non-running routers. - Fix a bug caused by an erroneous Ord instance for PortNumber in Network.Socket. PortNumbers were being compared in host order even though they're stored in network order. This caused some queries to incorrectly match exit policy rules and others to miss matches. 0.0.0 - 2007-04-11 - Initial release. mhatta-tordnsel-1d9141b/LICENSE000066400000000000000000000030701527317632400161660ustar00rootroot00000000000000The person or persons who have associated work with this document (the "Dedicator" or "Certifier") hereby either (a) certifies that, to the best of his knowledge, the work of authorship identified is in the public domain of the country from which the work is published, or (b) hereby dedicates whatever copyright the dedicators holds in the work of authorship identified below (the "Work") to the public domain. A certifier, moreover, dedicates any copyright interest he may have in the associated work, and for these purposes, is described as a "dedicator" below. A certifier has taken reasonable steps to verify the copyright status of this work. Certifier recognizes that his good faith efforts may not shield him from liability if in fact the work certified is not in the public domain. Dedicator makes this dedication for the benefit of the public at large and to the detriment of the Dedicator's heirs and successors. Dedicator intends this dedication to be an overt act of relinquishment in perpetuity of all present and future rights under copyright law, whether vested or contingent, in the Work. Dedicator understands that such relinquishment of all rights includes the relinquishment of all rights to enforce (by lawsuit or otherwise) those copyrights in the Work. Dedicator recognizes that, once placed in the public domain, the Work may be freely reproduced, distributed, transmitted, used, modified, built upon, or otherwise exploited by anyone for any purpose, commercial or non-commercial, and in any way, including by methods that have not yet been invented or conceived. mhatta-tordnsel-1d9141b/README.md000066400000000000000000000160761527317632400164520ustar00rootroot00000000000000# TorDNSEL: A Tor DNS-based Exit List TorDNSEL answers, over DNS and HTTP, the question "which Tor exit nodes will connect to me?" Rather than listing every Tor relay, it only lists the exits whose exit policy actually permits connections to the service asking. The design and its rationale are in [doc/torel-design.md](doc/torel-design.md); the man page ([doc/tordnsel.8](doc/tordnsel.8)) documents every option. ## Queries Assume our `ZoneOfAuthority` is `exitlist.example.com`. Addresses in names are reversed, as in other DNSBLs. A listed name has an A record of `127.0.0.2` (and a TXT record explaining why); an unlisted name is NXDOMAIN. Queries outside our zone are REFUSED. ### Type 1, "ip-port" ``` {IP1}.{port}.{IP2}.ip-port.exitlist.example.com ``` Listed iff there is a Tor exit at IP1 that permits connections to port on IP2. E.g. `1.0.0.10.80.4.3.2.1.ip-port.exitlist.example.com` asks whether 10.0.0.1 is a Tor exit that allows connections to 1.2.3.4:80. A service at w.x.y.z:9999 would configure `9999.z.y.x.w.ip-port.exitlist.example.com` as its DNSBL. ### Type 2, "list" ``` {IP}.{listname}.list.exitlist.example.com ``` Listed iff IP is a Tor exit permitting connections to any member of a list defined by the operator, e.g. ``` ExitList examplenet 192.0.2.10:6667,6697 198.51.100.0/24:6660-6669 ``` ### "exit", the Tor Project's form ``` {IP}.exitlist.example.com ``` Listed iff IP is a Tor exit at all (its exit policy permits connections somewhere). The TXT records give the fingerprints of the relays exiting from IP. This is the form of the Tor Project's exit list service (`dnsel.torproject.org`), so TorDNSEL can stand in for it. ### Type 3, "me" ``` {IP}.{port}.me.exitlist.example.com ``` Listed iff IP is a Tor exit permitting connections to port on the host that sent the query (which is the recursive resolver, if one is used, unless it passes on its client's network with the EDNS client subnet option, RFC 7871). Answers are sent with a TTL of 0 so that resolvers don't share them. `127.0.0.2` is always listed, for testing your setup (RFC 5782). ### HTTP interface The HTTP interface (enabled with `HTTPListenAddress`) serves the same data: | Request | Answer | | --- | --- | | `GET /api/v1/ip-port?ip=IP1&port=PORT&dest=IP2` | Type 1 query | | `GET /api/v1/list?ip=IP&list=NAME` | Type 2 query | | `GET /api/v1/lists` | The configured lists | | `GET /api/v1/me?ip=IP&port=PORT` | Type 3 query | | `GET /api/v1/exit?ip=IP` | "exit" query, with the relays' fingerprints | | `GET /metrics` | Prometheus metrics, for `HTTPMetricsAllowFrom` clients | | `GET /api/ip` | `{"IsTor":...,"IP":...}` like check.torproject.org | | `GET /torbulkexitlist[?ip=IP[&port=PORT]]` | Exit addresses, one per line | | `GET /exit-addresses` | Results of active exit tests | Behind a reverse proxy, set `HTTPTrustedProxy` to the proxy's address so that `/api/ip` and `/api/v1/me` see the real client (from `X-Forwarded-For`), and `HTTPPublicAddress` to its public address. ## Building TorDNSEL is written in Haskell. It builds with GHC 9.4 or newer (tested with 9.4.7 and 9.10.3; see [.github/workflows/ci.yml](.github/workflows/ci.yml) for the CI matrix) and cabal-install 3.8 or newer: ```sh cabal update cabal build cabal test cabal install --installdir=/usr/local/bin ``` On Debian or Ubuntu you can also build with the distribution's packages only, without Hackage access, using the Setup script: ```sh apt-get install ghc libghc-network-dev libghc-conduit-dev \ libghc-conduit-extra-dev libghc-cryptohash-sha256-dev libghc-hunit-dev \ libghc-quickcheck2-dev runhaskell Setup.hs configure --enable-tests runhaskell Setup.hs build runhaskell Setup.hs test runhaskell Setup.hs copy # installs to /usr/local by default ``` No C libraries beyond libc are needed (libcrypto is no longer used). ## Configuring Tor TorDNSEL needs a Tor client (0.4.8 or newer is tested) with a control port and, for active testing, a SOCKS port, e.g. in the torrc: ``` ControlPort 9051 CookieAuthentication 1 SocksPort 9050 ``` The control port and the SOCKS port may also be Unix sockets (`ControlSocket`, `SocksPort unix:`); TorDNSEL connects to them with `TorControlAddress unix:/path` and `TorSocksAddress unix:/path`. Debian's tor package offers both, readable by the `debian-tor` group, so with it no change to the torrc is needed: ``` TorControlAddress unix:/run/tor/control TorSocksAddress unix:/run/tor/socks ``` and run TorDNSEL in the `debian-tor` group (`SupplementaryGroups=debian-tor` in the systemd unit). The cookie file must be readable by the TorDNSEL user (or use `HashedControlPassword` with TorDNSEL's `TorControlPassword`). TorDNSEL authenticates with SAFECOOKIE, never sending the cookie itself, and refuses to authenticate if Tor can't prove it knows the cookie too. (Password authentication sends the password to whatever listens on the control port, so prefer the cookie.) TorDNSEL turns on `FetchUselessDescriptors` and `FetchDirInfoEarly` while it is connected, so that Tor downloads every router descriptor. ## Configuring TorDNSEL Copy [config/tordnsel.conf.sample](config/tordnsel.conf.sample). At the very least, you'll need to uncomment and modify `ZoneOfAuthority`, `DomainName`, `SOARName`, `StateDirectory`, `RuntimeDirectory`, and probably `DNSListenAddress`. Delegate the zone to the host running TorDNSEL with an NS record in the parent zone. TorDNSEL answers over UDP and TCP on that address, so let both through your firewall. `DNSRateLimit` (100 queries a second by default) limits the UDP responses to each client network, against reflection attacks, and ANY queries get a single record (RFC 8482); see the man page. To run exit tests, you'll need to specify at least `EnableActiveTesting`, `TestListenAddress`, and `TestDestinationAddress`. The test destination must be reachable from the Internet; Tor exits connect to it. Load a config file with the `-f` option. Options listed in `tordnsel.conf.sample` can also be specified on the command line, where they override the config file: ```sh tordnsel -f /etc/tordnsel.conf --ZoneOfAuthority exitlist.example.com ``` Check a configuration with `--verify-config`; reload it with SIGHUP or, from inside a chroot, with `tordnsel --reconfigure RUNTIMEDIR < tordnsel.conf`. TorDNSEL needs an accurate system clock, so run an NTP client. ## Running TorDNSEL With systemd, see [contrib/tordnsel.service](contrib/tordnsel.service). A SysV init script is in [contrib/tordnsel-init.d-script.sample](contrib/tordnsel-init.d-script.sample). Either way: ```sh cp config/tordnsel.conf.sample /etc/tordnsel.conf $EDITOR /etc/tordnsel.conf adduser --system --group --no-create-home --home /var/lib/tordnsel tordnsel mkdir -p /var/lib/tordnsel ``` ## Testing against a private Tor network [tests/integration/](tests/integration/) contains a chutney network definition and a script that starts it, runs TorDNSEL with active testing, and checks the DNS and HTTP answers. See [tests/integration/README.md](tests/integration/README.md). ## Limitations Only IPv4 is covered: exits' IPv6 addresses are not listed and queries can only name IPv4 addresses. DNS is served over UDP only. See [TODO.md](TODO.md). mhatta-tordnsel-1d9141b/Setup.hs000077500000000000000000000000741527317632400166210ustar00rootroot00000000000000import Distribution.Simple main :: IO () main = defaultMain mhatta-tordnsel-1d9141b/TODO.md000066400000000000000000000041411527317632400162500ustar00rootroot00000000000000# tordnsel wishlist ## Done in 0.2.0 See [ChangeLog](ChangeLog). - [x] builds with current GHC (9.4 and newer) and libraries - [x] works with current Tor (0.4.8/0.4.9): NEWCONSENSUS, controller-mapped `.exit` exit tests, current descriptor and policy syntax - [x] query types 2 ("list") and 3 ("me") from [torel-design.md](doc/torel-design.md) - [x] a web interface providing the same data as the DNS interface, including a check.torproject.org-style `/api/ip` and `/torbulkexitlist` - [x] EDNS(0), TXT records, QNAME-minimisation-friendly empty non-terminals - [x] more input validation on DNS queries - [x] an end-to-end test against a chutney network ## Done in 0.2.2 - [x] SAFECOOKIE authentication to the control port - [x] DNS over TCP (RFC 7766) and a per-client response rate limit for UDP - [x] property tests for the parsers of untrusted input ## Done in 0.3.0 - [x] the Tor Project's form of query, `{IP}.{zone}` with fingerprints in TXT - [x] honour X-Forwarded-For from a configured reverse proxy in the web interface - [x] EDNS Client Subnet for "me" queries arriving through public resolvers - [x] Prometheus-style metrics - [x] fixes for the problems found in an audit of 0.2.2 (control port, exit test cookies, connection limits, file handling) ## Done in 0.4.0 - [x] Tor's control and SOCKS ports over Unix sockets (as Debian's tor offers them) and IPv6 - [x] fixes for the problems found in an audit of 0.3.0 (privilege dropping, exit test listener limits, DNS amplification, stored test results, statistics socket) ## Still to do - [ ] IPv6 - [ ] list exits' IPv6 exit addresses (descriptors' `or-address` lines and `ipv6-policy` summaries; IPv6 exit tests need an IPv6 test listener) - [ ] accept nibble-format IPv6 addresses in queries (RFC 5782) - [ ] "me" queries and `/api/ip` from IPv6 hosts - [ ] persist the network state (not only exit test results) across restarts, so that answers are available before Tor has delivered all descriptors - [ ] Debian packaging (ITP filed; packaging on Salsa, debian/tordnsel) - [ ] don't trust the local running environment to be sane or safe mhatta-tordnsel-1d9141b/app/000077500000000000000000000000001527317632400157415ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/app/tordnsel.hs000066400000000000000000000012621527317632400201300ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : Main -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, STM, extended exceptions, -- pattern guards, FFI, GHC primitives) -- -- Implements a DNSBL-style interface providing information about whether a -- client for a network service is likely connecting through a Tor exit node. -- -- See @doc/torel-design.md@ for -- details. -- ----------------------------------------------------------------------------- module Main (main) where import TorDNSEL.Main mhatta-tordnsel-1d9141b/cabal.project000066400000000000000000000000141527317632400176060ustar00rootroot00000000000000packages: . mhatta-tordnsel-1d9141b/config/000077500000000000000000000000001527317632400164265ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/config/tordnsel-init.d-script.sample000077500000000000000000000106771527317632400241660ustar00rootroot00000000000000#! /bin/sh ### BEGIN INIT INFO # Provides: TorDNSEL # Required-Start: $local_fs $remote_fs $syslog $network $time # Required-Stop: $local_fs $remote_fs $syslog $network $time # Default-Start: 2 3 4 5 # Default-Stop: 0 1 6 # Short-Description: Starts the TorDNSEL daemon process # Description: Starts TorDNSEL, a name server that provides a # DNSBL-style interface for detecting connections # exiting the Tor network. # ### END INIT INFO # Author: Jacob Appelbaum # Author: tup # # Please remove the "Author" lines above and replace them # with your own name if you copy and modify this script. # Do NOT "set -e" # PATH should only include /usr/* if it runs after the mountnfs.sh script PATH=/sbin:/usr/sbin:/bin:/usr/bin DESC="TorDNSEL daemon" NAME=tordnsel DAEMON=/usr/local/bin/$NAME PIDFILE=/var/run/$NAME.pid SCRIPTNAME=/etc/init.d/$NAME CONFIGFILE="/etc/tordnsel.conf" RUNTIMEDIR="/var/run/tordnsel" USER=tordnsel ARGS="-f $CONFIGFILE " # Exit if the package is not installed [ -x "$DAEMON" ] || exit 0 # Read configuration variable file if it is present [ -r /etc/default/$NAME ] && . /etc/default/$NAME # # Function that starts the daemon/service # do_start() { # Return # 0 if daemon has been started # 1 if daemon was already running # 2 if daemon could not be started start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON --test > /dev/null \ || return 1 start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON -- $ARGS \ || return 2 # Add code here, if necessary, that waits for the process to be ready # to handle requests from services started subsequently which depend # on this one. As a last resort, sleep for some time. } # # Function that stops the daemon/service # do_stop() { # Return # 0 if daemon has been stopped # 1 if daemon was already stopped # 2 if daemon could not be stopped # other if a failure occurred start-stop-daemon --stop --quiet --retry=TERM/30/KILL/5 --pidfile $PIDFILE --name $NAME RETVAL="$?" [ "$RETVAL" = 2 ] && return 2 # Wait for children to finish too if this is a daemon that forks # and if the daemon is only ever run from this initscript. # If the above conditions are not satisfied then add some other code # that waits for the process to drop all resources that could be # needed by services started subsequently. A last resort is to # sleep for some time. start-stop-daemon --stop --quiet --oknodo --retry=0/30/KILL/5 --exec $DAEMON [ "$?" = 2 ] && return 2 # Many daemons don't delete their pidfiles when they exit. rm -f $PIDFILE return "$RETVAL" } case "$1" in start) echo "Starting $DESC: $NAME..." if ! su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER 2> /dev/null; then echo "ABORTED: TorDNSEL configuration invalid:" >&2 su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER exit 1 fi do_start case "$?" in 0|1) echo "done." ;; 2) echo "FAILED." exit 1 ;; esac ;; stop) echo -n "Stopping $DESC: " do_stop case "$?" in 0|1) echo "$NAME." ;; 2) echo "FAILED." exit 1 ;; esac ;; reload|force-reload) echo -n "Reloading $DESC configuration: " if ! su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER 2> /dev/null; then echo "ABORTED: TorDNSEL configuration invalid:" >&2 su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER exit 1 fi # Don't send the process a SIGHUP because it won't be able to read its own # config file when it's chrooted. Instead, use the --reconfigure option to # dump the contents of the config file to a Unix domain socket on which it's # listening for this purpose. ERRMSG=`su -s /bin/sh -c "$DAEMON --reconfigure $RUNTIMEDIR < $CONFIGFILE" $USER 2>&1` case "$?" in 0) echo "$NAME." ;; *) echo "FAILED." echo "$ERRMSG" >&2 exit 1 ;; esac ;; restart) if ! su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER 2> /dev/null; then echo "Restarting TorDNSEL ABORTED: TorDNSEL configuration invalid:" >&2 su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER exit 1 fi echo "Restarting $DESC: $NAME..." do_stop case "$?" in 0|1) do_start case "$?" in 0) echo "done." ;; 1) echo "FAILED ($DAEMON is still running)." ;; *) echo "FAILED." ;; # Failed to start esac ;; *) # Failed to stop echo "FAILED ($DAEMON won't die)." exit 1 ;; esac ;; *) echo "Usage: $SCRIPTNAME {start|stop|restart|reload|force-reload}" >&2 exit 3 ;; esac : mhatta-tordnsel-1d9141b/config/tordnsel.conf.sample000066400000000000000000000164361527317632400224210ustar00rootroot00000000000000## tordnsel.conf.sample ## Sample configuration file for TorDNSEL. ################ Required options ######################################### ## ## These options have no default values. They must be uncommented and ## changed for your system. ## Answer queries authoritatively for this DNS zone. For example, if this ## is set to "exitlist.example.com.", your server would accept queries of ## the form "1.0.0.10.80.4.3.2.1.ip-port.exitlist.example.com.", ## "4.3.2.1.examplenet.list.exitlist.example.com." and ## "4.3.2.1.80.me.exitlist.example.com.". #ZoneOfAuthority exitlist.example.com. ## This name server's own domain name, for use in NS and SOA records. #DomainName exitlist-ns.example.com. ## Use this email address in the RNAME field of SOA records. Usually, this ## should be something like "hostmaster@example.com" in the form of a ## fully-qualified domain name. #SOARName hostmaster.example.com. ## Store exit test results in this directory. This should be an absolute ## path accessible inside the chroot (if one is configured). #StateDirectory /srv/tordnsel/state ## This line is equivalent to the previous line if you've specified ## ChangeRootDirectory as /var/lib/tordnsel. #StateDirectory /state ## Place the statistics and reconfigure sockets in this directory before ## chrooting or dropping privileges. #RuntimeDirectory /srv/tordnsel/tordnsel ################ Optional options ######################################### ## ## These options either have sensible default values or can be left ## unspecified. You will probably need to uncomment and change some of ## these. ## Bind the name server to this IP address and port (UDP and TCP). If you ## want to bind to all interfaces, you might set the address to "0.0.0.0"; ## IPv6 addresses go in brackets, e.g. "[::]:53". The ports are bound before ## dropping privileges. Leave it commented to use the default. #DNSListenAddress 127.0.0.1:53 ## Answer at most this many queries per second over UDP from each client ## network (IPv4 /24, IPv6 /56); see the man page. 0 means no limit; TCP and ## loopback aren't limited. Keep it well above what the recursive resolvers ## that use your list send. #DNSRateLimit 100 ## The IP address that will be returned in response to requests for the A ## record matching our zone of authority. If you don't specify this option, ## no A record will be returned for the zone of authority. #Address 10.0.0.1 ## Make Tor controller connections to this IP address and TCP port, or to a ## Unix socket ("unix:" and an absolute path). You'll need to set this as ## your ControlPort or ControlSocket in Tor's torrc. Leave it commented to ## use the default. With Debian's tor package, use its control socket (and ## run TorDNSEL in the debian-tor group): #TorControlAddress unix:/run/tor/control #TorControlAddress 127.0.0.1:9051 ## The password you used to generate the HashedControlPassword in Tor's ## torrc. This is only required when you have a HashedControlPassword. With ## "CookieAuthentication 1" in the torrc, the cookie file is found through ## PROTOCOLINFO and needs to be readable by the TorDNSEL user. #TorControlPassword password ## Send log messages of at least a minimum severity to a specified stream, ## to the system logger, or to a file. Valid severity levels are debug, ## info, notice, warn, and error. If you specify a log file, it should ## be accessible from inside the chroot (if one is configured), and ## writable after dropping privileges. This may only be specified once. The ## default is "notice stdout". #Log notice stdout #Log info stderr #Log warn syslog #Log notice file /srv/tordnsel/log ## Detach from the controlling terminal and run in the background as a ## daemon. The default is "False". #RunAsDaemon True ## The user name to which you want to drop privileges. This option requires ## root privileges. #User tordnsel ## The group name to which you want to drop privileges. This option also ## requires root privileges. #Group tordnsel ## Call chroot(2) to change our root directory. This option also requires ## root privileges. #ChangeRootDirectory /srv/tordnsel/root ## Write our PID to the specified file before chrooting or dropping ## privileges. This file won't be removed on exit. #PIDFile /srv/tordnsel/run/tordnsel.pid ## Named lists of destinations for "list" queries (query type 2 of the ## design): "{IP}.{listname}.list.{zone}" is listed iff {IP} is a Tor exit ## that permits connections to any member of the list. Each pattern is ## ADDRESS[/BITS]:PORT[-PORT][,PORT[-PORT]...]; masks wider than /8 are ## refused. Repeat the option to define several lists. #ExitList examplenet 192.0.2.10:6667,6697 198.51.100.0/24:6660-6669 #ExitList mail 203.0.113.25:25,465,587 ################ HTTP interface ########################################### ## ## The web interface provides the same data as the DNS interface: ## /api/v1/ip-port?ip=IP1&port=PORT&dest=IP2 /api/v1/list?ip=IP&list=NAME ## /api/v1/me?ip=IP&port=PORT /api/ip /torbulkexitlist /exit-addresses ## Serve HTTP on this address and TCP port. It is bound before dropping ## privileges. The interface is disabled unless this is set. #HTTPListenAddress 127.0.0.1:8080 ## The address and port at which clients reach the HTTP interface, if ## different from HTTPListenAddress (behind NAT or a port redirection). ## /api/ip uses it to check whether an exit can reach us. #HTTPPublicAddress 10.0.0.1:80 ## Behind a reverse proxy, believe the X-Forwarded-For header of requests ## from these addresses (IPv4 addresses or networks, IPv6 addresses), so ## that /api/ip and /api/v1/me see the real client. May be given more than ## once. Set HTTPPublicAddress to the proxy's public address too. #HTTPTrustedProxy 127.0.0.1 ::1 ## Serve Prometheus metrics at /metrics on the HTTP interface to these ## addresses or networks (others get 404). May be given more than once. #HTTPMetricsAllowFrom 127.0.0.1 ::1 ################ Active testing options ################################### ## ## These options are only necessary if you want to enable active testing ## through exit nodes for a more accurate exit list. ## Enable active test connections through exit nodes to determine their ## exit IP addresses. Enabling this will result in a more accurate view ## exit nodes' IP addresses, at the expense of putting a much greater load ## on your local Tor process and the Tor network itself. The default is ## "False". #EnableActiveTesting True ## Make exit test connections through Tor's SocksPort on this IP address ## and TCP port, or Unix socket ("unix:" and an absolute path). Leave it ## commented to use the default. With Debian's tor package: #TorSocksAddress unix:/run/tor/socks #TorSocksAddress 127.0.0.1:9050 ## Bind the exit test listeners to this IP address and these TCP ports. ## These ports are bound before dropping privileges. Don't use the loopback ## interface for TestListenAddress if you're redirecting connections with ## iptables because your redirected packets will be dropped as martians. ## This option is only required when EnableActiveTesting is set to True. #TestListenAddress 10.0.0.1:80,443,110,53,22,5190,6667,9030 ## Make exit test connections to this IP address and these TCP ports. These ## should be publicly accessible from Tor exit nodes. This option is only ## required when EnableActiveTesting is set to True. #TestDestinationAddress 10.0.0.1:80,443,110,53,22,5190,6667,9030 mhatta-tordnsel-1d9141b/contrib/000077500000000000000000000000001527317632400166215ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/contrib/cacti-input.pl000077500000000000000000000012311527317632400213760ustar00rootroot00000000000000#!/usr/bin/perl # A data input script for Cacti's poller to collect TorDNSEL statistics. # Example: ./cacti-input.pl /var/run/tordnsel/statistics.socket use strict; use warnings; use IO::Socket::UNIX; my $usage = "Usage: $0 \n"; if (@ARGV != 1) { print STDERR $usage; exit 1; } if ($ARGV[0] eq '-h' or $ARGV[0] eq '--help') { print $usage; exit; } my $socket_path = shift; my $sock = IO::Socket::UNIX->new(Peer => $socket_path) or die "Failed connecting to statistics socket '$socket_path': $!"; my @fields; $/ = "\015\012"; while (<$sock>) { chomp; push @fields, join ':', split /\s+/; } $sock->close; print "@fields"; mhatta-tordnsel-1d9141b/contrib/tordnsel-init.d-script.sample000066400000000000000000000106771527317632400243560ustar00rootroot00000000000000#! /bin/sh ### BEGIN INIT INFO # Provides: TorDNSEL # Required-Start: $local_fs $remote_fs $syslog $network $time # Required-Stop: $local_fs $remote_fs $syslog $network $time # Default-Start: 2 3 4 5 # Default-Stop: 0 1 6 # Short-Description: Starts the TorDNSEL daemon process # Description: Starts TorDNSEL, a name server that provides a # DNSBL-style interface for detecting connections # exiting the Tor network. # ### END INIT INFO # Author: Jacob Appelbaum # Author: tup # # Please remove the "Author" lines above and replace them # with your own name if you copy and modify this script. # Do NOT "set -e" # PATH should only include /usr/* if it runs after the mountnfs.sh script PATH=/sbin:/usr/sbin:/bin:/usr/bin DESC="TorDNSEL daemon" NAME=tordnsel DAEMON=/usr/local/bin/$NAME PIDFILE=/var/run/$NAME.pid SCRIPTNAME=/etc/init.d/$NAME CONFIGFILE="/etc/tordnsel.conf" RUNTIMEDIR="/var/run/tordnsel" USER=tordnsel ARGS="-f $CONFIGFILE " # Exit if the package is not installed [ -x "$DAEMON" ] || exit 0 # Read configuration variable file if it is present [ -r /etc/default/$NAME ] && . /etc/default/$NAME # # Function that starts the daemon/service # do_start() { # Return # 0 if daemon has been started # 1 if daemon was already running # 2 if daemon could not be started start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON --test > /dev/null \ || return 1 start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON -- $ARGS \ || return 2 # Add code here, if necessary, that waits for the process to be ready # to handle requests from services started subsequently which depend # on this one. As a last resort, sleep for some time. } # # Function that stops the daemon/service # do_stop() { # Return # 0 if daemon has been stopped # 1 if daemon was already stopped # 2 if daemon could not be stopped # other if a failure occurred start-stop-daemon --stop --quiet --retry=TERM/30/KILL/5 --pidfile $PIDFILE --name $NAME RETVAL="$?" [ "$RETVAL" = 2 ] && return 2 # Wait for children to finish too if this is a daemon that forks # and if the daemon is only ever run from this initscript. # If the above conditions are not satisfied then add some other code # that waits for the process to drop all resources that could be # needed by services started subsequently. A last resort is to # sleep for some time. start-stop-daemon --stop --quiet --oknodo --retry=0/30/KILL/5 --exec $DAEMON [ "$?" = 2 ] && return 2 # Many daemons don't delete their pidfiles when they exit. rm -f $PIDFILE return "$RETVAL" } case "$1" in start) echo "Starting $DESC: $NAME..." if ! su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER 2> /dev/null; then echo "ABORTED: TorDNSEL configuration invalid:" >&2 su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER exit 1 fi do_start case "$?" in 0|1) echo "done." ;; 2) echo "FAILED." exit 1 ;; esac ;; stop) echo -n "Stopping $DESC: " do_stop case "$?" in 0|1) echo "$NAME." ;; 2) echo "FAILED." exit 1 ;; esac ;; reload|force-reload) echo -n "Reloading $DESC configuration: " if ! su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER 2> /dev/null; then echo "ABORTED: TorDNSEL configuration invalid:" >&2 su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER exit 1 fi # Don't send the process a SIGHUP because it won't be able to read its own # config file when it's chrooted. Instead, use the --reconfigure option to # dump the contents of the config file to a Unix domain socket on which it's # listening for this purpose. ERRMSG=`su -s /bin/sh -c "$DAEMON --reconfigure $RUNTIMEDIR < $CONFIGFILE" $USER 2>&1` case "$?" in 0) echo "$NAME." ;; *) echo "FAILED." echo "$ERRMSG" >&2 exit 1 ;; esac ;; restart) if ! su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER 2> /dev/null; then echo "Restarting TorDNSEL ABORTED: TorDNSEL configuration invalid:" >&2 su -s /bin/sh -c "$DAEMON --verify-config $ARGS" $USER exit 1 fi echo "Restarting $DESC: $NAME..." do_stop case "$?" in 0|1) do_start case "$?" in 0) echo "done." ;; 1) echo "FAILED ($DAEMON is still running)." ;; *) echo "FAILED." ;; # Failed to start esac ;; *) # Failed to stop echo "FAILED ($DAEMON won't die)." exit 1 ;; esac ;; *) echo "Usage: $SCRIPTNAME {start|stop|restart|reload|force-reload}" >&2 exit 3 ;; esac : mhatta-tordnsel-1d9141b/contrib/tordnsel.service000066400000000000000000000040201527317632400220310ustar00rootroot00000000000000# systemd unit for TorDNSEL. # # Install as /etc/systemd/system/tordnsel.service. TorDNSEL runs as the # unprivileged "tordnsel" user from the start (so don't set User, Group or # ChangeRootDirectory in tordnsel.conf); CAP_NET_BIND_SERVICE lets it bind # port 53 (and port 80 for the HTTP interface or exit tests). In # /etc/tordnsel.conf, use: # # StateDirectory /var/lib/tordnsel # RuntimeDirectory /run/tordnsel # RunAsDaemon False # Log notice syslog # # To authenticate to Tor with its cookie, make the cookie group-readable # (CookieAuthFileGroupReadable 1 in the torrc) and add Tor's group below, # e.g. SupplementaryGroups=debian-tor on Debian. The same group lets TorDNSEL # use Debian's tor control and SOCKS sockets: # # TorControlAddress unix:/run/tor/control # TorSocksAddress unix:/run/tor/socks [Unit] Description=TorDNSEL, a DNS-based list of Tor exit nodes Documentation=man:tordnsel(8) After=network-online.target tor.service Wants=network-online.target [Service] Type=simple User=tordnsel Group=tordnsel #SupplementaryGroups=debian-tor ExecStartPre=/usr/local/bin/tordnsel -f /etc/tordnsel.conf --verify-config ExecStart=/usr/local/bin/tordnsel -f /etc/tordnsel.conf ExecReload=/bin/kill -HUP $MAINPID Restart=on-failure StateDirectory=tordnsel RuntimeDirectory=tordnsel UMask=0077 LimitNOFILE=16384 AmbientCapabilities=CAP_NET_BIND_SERVICE CapabilityBoundingSet=CAP_NET_BIND_SERVICE NoNewPrivileges=yes ProtectSystem=strict ProtectHome=yes PrivateTmp=yes PrivateDevices=yes ProtectKernelTunables=yes ProtectKernelModules=yes ProtectKernelLogs=yes ProtectControlGroups=yes ProtectClock=yes ProtectHostname=yes ProtectProc=invisible RestrictAddressFamilies=AF_INET AF_INET6 AF_UNIX RestrictNamespaces=yes RestrictRealtime=yes RestrictSUIDSGID=yes LockPersonality=yes MemoryDenyWriteExecute=yes SystemCallArchitectures=native # Every system call TorDNSEL makes (traced serving DNS over UDP and TCP and # HTTP) is in @system-service. SystemCallFilter=@system-service SystemCallErrorNumber=EPERM [Install] WantedBy=multi-user.target mhatta-tordnsel-1d9141b/doc/000077500000000000000000000000001527317632400157265ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/doc/tordnsel.8000066400000000000000000000454661527317632400176700ustar00rootroot00000000000000.TH TORDNSEL 8 "5 November 2026" "TORDNSEL 0.4.0" .SH NAME tordnsel \- an active-testing, DNS-based list of Tor exit IP addresses .SH SYNOPSIS .B tordnsel [\fI--OPTION value\fR]... .SH DESCRIPTION \fBtordnsel\fR is a name server providing a DNSBL-style interface to a dynamically-updated list of Tor exit IP addresses. It is designed to be useful to operators of Internet services, such as web sites and IRC networks, who want to detect anonymous clients and treat them differently from non-anonymous clients. Since not every Tor exit allows connections to the entire Internet, \fBtordnsel\fR extends the DNSBL interface to require specifying the service's IP address and port in queries. The same information is available over HTTP. .PP \fBtordnsel\fR runs alongside a local \fBtor\fR client, to which it establishes a persistent controller connection. The \fBtor\fR process fetches up-to-date Tor directory information and serves as \fBtordnsel\fR's entry point into the Tor network for active testing. .PP \fBtordnsel\fR can optionally perform active exit testing by launching an HTTP request to itself through every Tor exit with a suitable exit policy. This allows it to detect exits configured to send outbound connections through a different IP address from the one they advertise in the directory. When configured to run active tests, \fBtordnsel\fR tests through a particular exit each time it publishes a new descriptor. .PP Each test carries a random cookie, which is accepted once. An exit sees the cookie, so a malicious exit can still answer a test from an address of its choosing; to bound what it can make \fBtordnsel\fR list, at most 16 tested addresses are kept per exit, each for 24 hours. .SH DNS INTERFACE Assume \fBZoneOfAuthority\fR is "exitlist.example.com". Addresses in query names are written in reverse, as in other DNSBLs. A listed name has an A record of 127.0.0.2 and a TXT record explaining the listing; an unlisted name doesn't exist (NXDOMAIN). 127.0.0.2 is always listed, for testing. .TP \fB{IP1}.{port}.{IP2}.ip-port.\fR\fIzone\fP Listed iff there is a Tor exit at \fIIP1\fR that permits connections to \fIport\fR on \fIIP2\fR. For example, "1.0.0.10.80.4.3.2.1.ip-port.exitlist.example.com" asks whether 10.0.0.1 is a Tor exit permitting connections to 1.2.3.4:80. .TP \fB{IP}.{listname}.list.\fR\fIzone\fP Listed iff \fIIP\fR is a Tor exit that permits connections to any member of the list \fIlistname\fR, defined with \fBExitList\fR. .TP \fB{IP}.\fR\fIzone\fP Listed iff \fIIP\fR is a Tor exit at all, i.e. its exit policy permits connections somewhere. TXT records give the fingerprints of the relays exiting from \fIIP\fR. This is the form used by the Tor Project's exit list service. .TP \fB{IP}.{port}.me.\fR\fIzone\fP Listed iff \fIIP\fR is a Tor exit that permits connections to \fIport\fR on the host that sent the query. Note that if the query comes through a recursive resolver, that resolver is the host in question, unless the resolver passes on its client's network with the EDNS client subnet option (RFC 7871): then the query is about that network's address (see \fBDNSClientSubnet\fR). Answers have a TTL of zero so that resolvers don't hand them to other clients. .PP Other answers are cached for 30 minutes. EDNS(0) is supported. Queries are answered over UDP and TCP (RFC 7766); UDP responses too large for the client are truncated (TC bit set) so that it retries over TCP. Up to 128 TCP connections are served at a time, at most 8 from one client network (an IPv4 /24 or an IPv6 /56). A connection is closed after 100 queries, or after 10 seconds without a query (2 seconds when more than half of the connections are in use). .SH HTTP INTERFACE When \fBHTTPListenAddress\fR is set, the same data is available over HTTP (GET and HEAD only; put a reverse proxy in front for TLS): .TP \fB/api/v1/ip-port?ip=\fR\fIIP1\fR\fB&port=\fR\fIPORT\fR\fB&dest=\fR\fIIP2\fP JSON answer to the "ip-port" query. .TP \fB/api/v1/list?ip=\fR\fIIP\fR\fB&list=\fR\fINAME\fP and \fB/api/v1/lists\fP JSON answer to the "list" query, and the configured lists. .TP \fB/api/v1/me?ip=\fR\fIIP\fR\fB&port=\fR\fIPORT\fP JSON answer to the "me" query, where the destination is the HTTP client. .TP \fB/api/v1/exit?ip=\fR\fIIP\fP JSON answer to the "exit" query, with the fingerprints of the relays exiting from \fIIP\fR. .TP \fB/api/ip\fP Whether the HTTP client connects from a Tor exit able to reach this server, in the format of check.torproject.org's /api/ip. .TP \fB/torbulkexitlist\fR[\fB?ip=\fR\fIIP\fR[\fB&port=\fR\fIPORT\fR]]\fP All addresses of Tor exits permitting connections to \fIIP\fR:\fIPORT\fR (port 80 by default), or of all exits, one per line. .TP \fB/exit-addresses\fP The results of active exit tests. .PP Up to 64 requests are served at a time, at most 8 from one client address. A client must send its request within 3 seconds, and the whole exchange must end within 10 seconds. If you serve the public, a reverse proxy in front copes better with slow and abusive clients. .SH TOR CONFIGURATION \fBtordnsel\fR needs a \fBtor\fR client with a \fBControlPort\fR or \fBControlSocket\fR (and, for active testing, a \fBSocksPort\fR, which may be a Unix socket too). Debian's \fBtor\fR package offers both as Unix sockets, /run/tor/control and /run/tor/socks, readable by the debian-tor group: set \fBTorControlAddress\fR unix:/run/tor/control and \fBTorSocksAddress\fR unix:/run/tor/socks, and run \fBtordnsel\fR in that group. Cookie and hashed password authentication are supported. With cookie authentication, \fBtordnsel\fR uses the SAFECOOKIE method, so that the cookie itself is never sent, and stops if \fBtor\fR cannot prove that it knows the cookie; plain COOKIE authentication is refused. The cookie file named by \fBtor\fR must be a regular file of exactly 32 bytes. Note that password authentication sends the password itself to whatever listens on the control port, so prefer cookie authentication. \fBtordnsel\fR sets \fBFetchUselessDescriptors\fR and \fBFetchDirInfoEarly\fR for the lifetime of its connection, so that \fBtor\fR downloads every router descriptor; their original values are restored when \fBtordnsel\fR disconnects. Active tests are routed through particular exits with controller address mappings (MAPADDRESS to "\fIaddress\fR.\fIfingerprint\fR.exit"), since \fBtor\fR no longer accepts .exit hostnames on its SOCKS port. .SH OPTIONS .TP \fB-h, --help\fP Display a usage message and exit. .TP \fB-f, --ConfigFile \fR\fIFILE\fP \fIFILE\fR contains further "option value" pairs. .TP \fB--verify-config\fP Verify the configuration file is valid and exit. .TP \fB--reconfigure \fR\fIDIRECTORY\fP Read a configuration file from the standard input stream and use it to reconfigure the \fBtordnsel\fR process whose \fBRuntimeDirectory\fR is located at \fIDIRECTORY\fR. .TP \fB--version\fP Display TorDNSEL version and exit. .PP Other options can be specified either on the command-line (\fI--option value\fR), or in the configuration file (\fIoption value\fR). Options are case-insensitive. .SH REQUIRED OPTIONS The following options must be specified for \fBtordnsel\fR to start: .TP \fBZoneOfAuthority \fR\fIFQDN\fP Answer queries authoritatively for \fIFQDN\fR. For example, if this is set to "exitlist.example.com.", your server would accept queries of the form "1.0.0.10.80.4.3.2.1.ip-port.exitlist.example.com.". .TP \fBDomainName \fR\fIFQDN\fP Use \fIFQDN\fP as this server's own domain name in NS and SOA records. .TP \fBSOARName \fR\fIFQDN\fP Use \fIFQDN\fR as the email address in the RNAME field of SOA records. This should be an address at which the operator of this \fBtordnsel\fR instance can be contacted, e.g. "tordnsel@example.com" in the form of a fully-qualified domain name ("tordnsel.example.com."). .TP \fBStateDirectory \fR\fIDIRECTORY\fP Store exit test results in \fIDIRECTORY\fR. If \fBChangeRootDirectory\fR is specified, this should be an absolute path accessible inside the chroot. .TP \fBRuntimeDirectory \fR\fIDIRECTORY\fP Place the statistics and reconfigure sockets in \fIDIRECTORY\fR before chrooting and dropping privileges. .PP Both directories are created if missing and given to the user \fBtordnsel\fR runs as (the state directory) or starts as (the runtime directory). Neither may be writable by other users: \fBtordnsel\fR refuses to start otherwise. Files and sockets are created with a umask of 077. .SH OPTIONAL OPTIONS The following options either have sensible default values or can be left unspecified: .TP \fBDNSListenAddress \fR\fIIPADDR\fR:\fIPORT\fP Bind the name server to this IP address and port, both UDP and TCP. If you want to bind to all interfaces, set \fIIPADDR\fR to "0.0.0.0". IPv6 addresses are written in brackets, e.g. "[::]:53". The ports are bound before dropping privileges. (Default: 127.0.0.1:53) .TP \fBAddress \fR\fIIPADDR\fP Return \fIIPADDR\fR in response to requests for the A record matching the \fBZoneOfAuthority\fR. (Default: none) .TP \fBTorControlAddress \fR\fIIPADDR\fR:\fIPORT\fR | [\fIIPV6ADDR\fR]:\fIPORT\fR | unix:\fIPATH\fP Connect to \fBtor\fR's controller interface on this IP address and TCP port, or on the Unix socket at this absolute path. You'll need to set this as your \fBControlPort\fR or \fBControlSocket\fR in \fBtor\fR's \fItorrc\fR. With \fBChangeRootDirectory\fR, the path is inside the new root. (Default: 127.0.0.1:9051) .TP \fBTorControlPassword \fR\fIPASSWORD\fP The password you used to generate the \fBHashedControlPassword\fR in \fBtor\fR's \fItorrc\fR. This is only required when you have a \fBHashedControlPassword\fR. (Default: none) .TP \fBLog \fIminSeverity\fR \fBstdout\fR|\fBstderr\fR|\fBsyslog\fP Send log messages of at least \fIminSeverity\fR to the standard output stream, the standard error stream, or to the system logger. Recognized severity levels are debug, info, notice, warn, and error. (Default: Log notice stdout) .TP \fBLog \fIminSeverity\fR \fBfile\fR \fIFILE\fP As above, but send log messages to \fIFILE\fR. If \fBChangeRootDirectory\fR is specified, \fIFILE\fR must be an absolute path accessible inside the chroot. In that case, it's probably better to use \fBsyslog\fR. .TP \fBRunAsDaemon \fR\fBFalse\fR|\fBTrue\fP If \fBTrue\fR, detach from the controlling terminal and run in the background as a daemon. (Default: False) .TP \fBUser \fR\fIUSERNAME\fP On startup, drop privileges to \fIUSERNAME\fP. (Default: none) .TP \fBGroup \fR\fIGROUPNAME\fP On startup, drop privilegs to \fIGROUPNAME\fP. (Default: none) .TP \fBChangeRootDirectory \fR\fIDIRECTORY\fP On startup, call .BR chroot (2) to irreversibly change the root directory of the process to \fIDIRECTORY\fP. (Default: none) .TP \fBPIDFile \fR\fIFILE\fP On startup, write our PID to \fIFILE\fP, which is created afresh (mode 0644), replacing any file or symbolic link of that name. \fIFILE\fP won't be removed on exit. (Default: none) .TP \fBExitList \fR\fINAME\fR \fIPATTERN\fR [\fIPATTERN\fR...]\fP Define the list \fINAME\fR for "list" queries. Each \fIPATTERN\fR is \fIIPADDR\fR[/\fIBITS\fR]:\fIPORT\fR[-\fIPORT\fR][,\fIPORT\fR[-\fIPORT\fR]...]. Network masks wider than /8 are refused. List names are case-insensitive and may contain letters, digits and hyphens. This option may be given several times to define several lists. (Default: none) .TP \fBHTTPListenAddress \fR\fIIPADDR\fR:\fIPORT\fP Serve the HTTP interface on this TCP address. The port is bound before dropping privileges. (Default: none, the HTTP interface is disabled) .TP \fBHTTPPublicAddress \fR\fIIPADDR\fR:\fIPORT\fP The IPv4 address and port at which clients reach the HTTP interface, if it differs from \fBHTTPListenAddress\fR (e.g. behind NAT or a port redirection). Used by /api/ip. (Default: the address of the listening socket) .TP \fBDNSClientSubnet \fR\fBTrue\fR|\fBFalse\fP Answer "me" queries about the client subnet given in the EDNS client subnet option (RFC 7871), if any, rather than about the resolver asking. With a subnet shorter than 32 bits, the query is about its network address. A malformed option is answered with FORMERR. (Default: True) .TP \fBHTTPMetricsAllowFrom \fR\fIADDRESS\fR[\fB/\fR\fIBITS\fR] ...\fP Serve Prometheus metrics at /metrics on the HTTP interface to clients at these IPv4 addresses or networks, or IPv6 addresses (behind a trusted proxy, the client is the one in X-Forwarded-For). Others get "404 Not Found". The metrics are the counters of the statistics socket, plus the number of known, running and exit relays, of exit addresses listed and of addresses found by exit tests. May be given more than once. (Default: none, no metrics) .TP \fBHTTPTrustedProxy \fR\fIADDRESS\fR[\fB/\fR\fIBITS\fR] ...\fP Reverse proxies in front of the HTTP interface: for requests from these IPv4 addresses or networks, or IPv6 addresses, the client is taken from the X-Forwarded-For header, read from the right and skipping these proxies. This affects /api/ip and /api/v1/me, and the proxies are exempt from the limit on connections per client. Without it the header is ignored. May be given more than once. Set \fBHTTPPublicAddress\fR to the proxy's public address as well. (Default: none) .TP \fBDNSRateLimit \fR\fINUM\fP Answer at most \fINUM\fR queries per second over UDP from each client network (an IPv4 /24 or an IPv6 /56), allowing bursts of up to \fINUM\fR queries. Of the queries over the limit, every second one gets a truncated response, so that real clients retry over TCP, and the rest are dropped. This keeps the server from being used to flood a spoofed address. At most 100,000 client networks are tracked; while that many are, queries from other networks are treated as over the limit. Note that a busy recursive resolver sends many queries from one network, so set this well above what your resolvers send. TCP and loopback (127.0.0.0/8, ::1) are not limited; 0 turns the limit off. (Default: 100) .SH ACTIVE TESTING OPTIONS The following options are only necessary if active testing through Tor exits should be enabled: .TP \fBEnableActiveTesting \fR\fBFalse\fR|\fBTrue\fP If \fBTrue\fR, enable active test connections through Tor exits to determine their exit IP addresses. Enabling this will result in a more accurate view of exit IP addresses, at the expense of putting a much greater load on your local Tor process and the Tor network itself. (Default: False) .TP \fBTorSocksAddress \fR\fIIPADDR\fR:\fIPORT\fR | [\fIIPV6ADDR\fR]:\fIPORT\fR | unix:\fIPATH\fP Make exit test connections through \fBtor\fR's \fBSocksPort\fR on this IP address and TCP port, or on the Unix socket at this absolute path (\fBSocksPort unix:\fR\fIPATH\fR in the \fItorrc\fR). (Default: 127.0.0.1:9050) .TP \fBTestListenAddress \fR\fIIPADDR\fR:\fIPORT\fR,\fIPORT\fR,\fI...\fP Bind the exit test listeners to this IP address and these TCP ports. These ports are bound before dropping privileges. Don't use the loopback interface for \fBTestListenAddress\fR if you're redirecting connections with .BR iptables (8) because your redirected packets will be dropped as martians. This option is only required when \fBEnableActiveTesting\fR is set to \fBTrue\fR. (Default: none) .TP \fBTestDestinationAddress \fR\fIIPADDR\fR:\fIPORT\fR,\fIPORT\fR,\fI...\fP Make exit test connections to this IP address and these TCP ports. These should be publicly accessible from Tor exits. This option is only required when \fBEnableActiveTesting\fR is set to \fBTrue\fR. (Default: none) .SH SIGNALS \fBtordnsel\fR catches the following signals: .TP \fBSIGTERM\fP \fBtordnsel\fR will catch this, then clean up and exit. .TP \fBSIGINT\fP The same behavior as with \fBSIGTERM\fR. .TP \fBSIGHUP\fP This signal instructs \fBtordnsel\fR to reload its configuration, including closing and reopening logs. .TP \fBSIGPIPE\fP \fBtordnsel\fR catches this signal and ignores it. .SH FILES .TP \fB/srv/tordnsel/tordnsel.conf\fP The configuration file, which contains "option value" pairs. .TP \fB/srv/tordnsel/state\fP The state directory where test results are stored. .TP \fB/srv/tordnsel/run\fP The runtime directory where statistics and reconfigure sockets are located. .TP \fIStateDirectory\fR\fB/exit-addresses\fR and \fBexit-addresses.new\fP These files hold the results of tests through Tor exits, including exit IP addresses. The ".new" file is an append-only journal; when it gets too large, and when a new network status consensus is received, all entries are merged into a new exit-addresses file. .TP \fIRuntimeDirectory\fR\fB/statistics.socket\fP A Unix domain stream socket that dumps cumulative load information when it accepts a client connection. Only its owner and group (those of \fBUser\fR and \fBGroup\fR, or of the user running \fBtordnsel\fR) may connect to it. See contrib/cacti-input.pl in the TorDNSEL source distribution for an example of using it. .TP \fIRuntimeDirectory\fR\fB/reconfigure.socket\fP A Unix domain stream socket that accepts a new configuration file and reconfigures the process with it. This is typically used by the \fB--reconfigure\fR option. .SH EXIT CODES \fBtordnsel\fR exits with 0 on success, otherwise it exits with an appropriate non-zero exit code from .BR sysexits (3) : .TP \fBEX_USAGE\fR (\fB64\fR) Parsing command-line arguments failed. .TP \fBEX_DATAERR\fR (\fB65\fR) Parsing the configuration file failed. .TP \fBEX_NOINPUT\fR (\fB66\fR) Opening the specified configuration file failed. .TP \fBEX_UNAVAILABLE\fR (\fB69\fR) \fB--reconfigure\fR was specified, but connecting to the reconfigure socket failed. .TP \fBEX_SOFTWARE\fR (\fB70\fR) An unspecified internal error occurred. .TP \fBEX_OSERR\fR (\fB71\fR) Opening a listening socket (DNS, HTTP or exit test) failed. .TP \fBEX_OSFILE\fR (\fB72\fR) The random number device couldn't be opened, or the UID/GID couldn't be looked up. .TP \fBEX_CANTCREAT\fR (\fB73\fR) Preparing a directory, opening the PID file, or binding a Unix domain socket failed. .TP \fBEX_IOERR\fR (\fB74\fR) \fB--reconfigure\fR failed with an I/O error, or closing the DNS listener failed. .TP \fBEX_PROTOCOL\fR (\fB76\fR) \fB--reconfigure\fR failed because the other \fBtordnsel\fR process responded with an unrecognized message. .TP \fBEX_NOPERM\fR (\fB77\fR) One of the following happened: The resource limit on open file descriptors is set too low, but the process isn't running as root. The configuration specified \fBUser\fR, \fBGroup\fR, or \fBChangeRootDirectory\fR, but the process isn't running as root. Reopening a listener failed due to a permission error. .TP \fBEX_CONFIG\fR (\fB78\fR) \fBtordnsel\fR exited due to a configuration error. .SH SEE ALSO .BR tor (8) .PP .B https://www.torproject.org/ .PP .B doc/torel-design.md in the TorDNSEL source distribution .PP .B https://github.com/mhatta/tordnsel .SH CAVEATS Active testing puts a load on the local \fBtor\fR process and the Tor network because \fBtor\fR builds a separate circuit to every exit tested. Also, if a particular exit is down, \fBtor\fR will keep building and failing new circuits until a timeout occurs. .PP Only IPv4 is covered: exits' IPv6 addresses aren't listed, and a "me" query or /api/ip request from an IPv6 host is never listed. .SH AUTHORS tup . Maintained by Masayuki Hatta . mhatta-tordnsel-1d9141b/doc/torel-design.md000066400000000000000000000157751527317632400206630ustar00rootroot00000000000000# Design For A Tor DNS-based Exit List ## Status This is a suggested design for a DNS Exit List (DNSEL) for Tor exit nodes. See for an implementation. ## Why? It's useful for third parties to be able to tell when a given connection is coming from a Tor exit node. Potential applications range from "anonymous user" cloaks on IRC networks like oftc, to networks like Freenode that apply special authentication rules to users from these IPs, to systems like Wikipedia that may want to make a priority of _unblocking_ shared IPs more liberally than non-shared IPs, since shared IPs presumably have non-abusive users as well as abusive ones. Since Tor provides exit policies, not every Tor server will connect to every address:port combination on the Internet. Unless you're trying to penalize hosts for supporting anonymity, it makes more sense to answer the fine-grained question "which Tor servers will connect to _me_?" than the coarse-grained question "which Tor servers exist?" The fine-grained approach also helps Tor server ops who share an IP with their Tor server: if they want to access a site that blocks Tor users, they can exclude that site from their exit policy, and the site can learn that they won't send it anonymous connections. Tor already ships with a tool (the "contrib/exitlist" script) to identify which Tor nodes might open anonymous connections to any given exit address. But this is a bit tricky to set up, so only sites like Freenode and OFTC that are dedicated to privacy use it. Conversely, providers of some DNSEL implementations are providing coarse-grained lists of Tor hosts -- sometimes even listing servers that permit no exit connections at all. This is rather a problem, since support for DNSEL is pretty ubiquitous. ## How? Keep a running Tor instance, and parse the cached-routers and cached-routers.new files as new routers arrive. To tell whether a given server allows connections to a certain address:port combo, look at the definitions in dir-spec.txt or follow the logic of the current exitlist script. If bug 405 is still open when you work on this (), you'll probably want to extend it to look at only the newest descriptor for each server, so you don't use obsolete exit policy data. FetchUselessDescriptors would probably be a good torrc option to enable. If you're also running a directory cache, you get extra-fresh information. ## The DNS interface Standard DNSEL, if I understand right, looks like this: There's some authoritative name server for foo.example.com. You want to know if 1.2.3.4 is in the list, so you query for an A record for 4.3.2.1.foo.example.com. If the record exists and has the value 127.0.0.2 [[DNSBL-EMAIL]](#references), 1.2.3.4 is in the list. If you get an NXDOMAIN error, 1.2.3.4 is not in the list. If you ask for a domain name outside of the foo.example.com zone, you get a Server Failure error [[RFC 1035]](#references). Assume that the DNSEL answers queries authoritatively for some zone, torhosts.example.com. Below are some queries that could be supported, though some of them are possibly a bad idea. ### Query type 1: "General IP:Port" **Format:** ``` {IP1}.{port}.{IP2}.ip-port.torhosts.example.com ``` **Rule:** Iff {IP1} is a Tor server that permits connections to {port} on {IP2}, then there should be an A record with the value 127.0.0.2. **Example:** "1.0.0.10.80.4.3.2.1.ip-port.torhosts.example.com" should have the value 127.0.0.2 if and only if there is a Tor server at 10.0.0.1 that allows connections to port 80 on 1.2.3.4. **Example use:** I'm running an IRC server at w.x.y.z:9999, and I want to tell whether an incoming connection is from a Tor server. I set up my IRC server to give a special mask to any user coming from an IP listed in 9999.z.y.x.w.ip-port.torhosts.example.com. Later, when I get a connection from a.b.c.d, my ircd looks up "d.c.b.a.9999.z.y.x.w.ip-port.torhosts.example.com" to see if it's a Tor server that allows connections to my ircd. ### Query type 2: "IP-port group" **Format:** ``` {IP}.{listname}.list.torhosts.example.com ``` **Rule:** Iff this Tor server is configured with an IP:Port list named {listname}, and {IP} is a Tor server that permits connections to any member of {listname}, then there exists an A record. **Example:** Suppose torhosts.example.com has a list of IP:Port called "foo". There is an A record for 4.3.2.1.foo.list.torhosts.example.com if and only if 1.2.3.4 is a Tor server that permits connections to one of the addresses in list "foo". **Example use:** Suppose torhosts.example.com has a list of hosts in "examplenet", a popular IRC network. Rather than having them each set up to query the appropriate "ip-port" list, they could instead all be set to query a central examplenet.list.torhosts.example.com. **Problems:** We'd be better off if each individual server queried about hosts that allowed connections to itself. That way, if I wanted to allow anonymous connections to foonet, but I wanted to be able to connect to foonet from my own IP without being marked, I could add just a few foonet addresses to my exit policy. ### Query type 3: "My IP, with port" **Format:** ``` {IP}.{port}.me.torhosts.example.com ``` **Rule:** An A record exists iff there is a tor server at {IP} that permits connections to {port} on the host that requested the lookup. **Example:** "4.3.2.1.80.me.torhosts.example.com" should have an A record if and only if there is a Tor server at 1.2.3.4 that allows connections to port 80 of the querying host. **Example use:** Somebody wants to set up a quick-and-dirty Tor detector for a single webserver: just point them at 80.me.torhosts.example.com. **Problem:** This would be easiest to use, but DNS gets in the way. If you create DNS records that give different results depending on who is asking, you mess up caching. There could be a fix here, but might not. **RECOMMENDATION:** Just build ip-port for now, and see what demand is like. There's no point in building mechanisms nobody wants. ## Web interface Should provide the same data as the dns interface. ## Other issues After a Tor server op turns off their server, it stops publishing server descriptors. We should consider that server's IP address to still represent a Tor node until 48 hours after its last descriptor was published. 30-60 minutes is not an unreasonable TTL. There could be some demand for address masks and port lists. Address masks wider than /8 make me nervous here, as do port ranges. We need an answer for what to do about hosts which exit from different IPs than their advertised IP. One approach would be for the DNSEL to launch periodic requests to itself through all exit servers whose policies allow it -- and then see where the requests actually come from. ## References - [DNSBL-EMAIL] Levine, J., "DNS Based Blacklists and Whitelists for E-Mail", , November 2005. - [RFC 1035] Mockapetris, P., "Domain Names - Implementation and Specification", RFC 1035, November 1987. mhatta-tordnsel-1d9141b/src/000077500000000000000000000000001527317632400157505ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/000077500000000000000000000000001527317632400173025ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/AddressPattern.hs000066400000000000000000000056741527317632400225750ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.AddressPattern -- License : Public domain (see LICENSE) -- -- Maintainer : Masayuki Hatta -- Stability : alpha -- Portability : portable -- -- Sets of client addresses given in the configuration, such as the reverse -- proxies whose X-Forwarded-For headers we trust or the hosts allowed to -- fetch metrics: IPv4 addresses or networks (@192.0.2.0\/24@) and IPv6 -- addresses (@::1@). -- ----------------------------------------------------------------------------- module TorDNSEL.AddressPattern ( AddressPattern(..) , parseAddressPatterns , matchesAny , hostAddressOf , HostAddressAny(..) ) where import Control.Monad.Except (MonadError(throwError)) import Data.Bits ((.&.), complement, shiftL) import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import Data.Char (isSpace) import Network.Socket (HostAddress, HostAddress6, SockAddr(..)) import TorDNSEL.Util -- | An IPv4 network (address and mask, the address already masked) or a -- single IPv6 address. data AddressPattern = Net4 !HostAddress !HostAddress | Addr6 !HostAddress6 deriving (Eq, Show) -- | The host part of a socket address, with IPv4-mapped IPv6 addresses -- (as on a dual-stack socket) turned back into IPv4 ones. data HostAddressAny = Host4 !HostAddress | Host6 !HostAddress6 deriving (Eq, Ord, Show) hostAddressOf :: SockAddr -> Maybe HostAddressAny hostAddressOf (SockAddrInet _ a) = Just (Host4 (ntohl a)) hostAddressOf (SockAddrInet6 _ _ (0, 0, 0xffff, a) _) = Just (Host4 a) hostAddressOf (SockAddrInet6 _ _ a _) = Just (Host6 a) hostAddressOf _ = Nothing -- | Does an address match one of the patterns? matchesAny :: [AddressPattern] -> HostAddressAny -> Bool matchesAny pats host = any match pats where match (Net4 net mask) | Host4 a <- host = a .&. mask == net match (Addr6 a6) | Host6 a <- host = a == a6 match _ = False -- | Parse addresses and networks separated by spaces or commas. 'throwError' -- in the monad if one is malformed. parseAddressPatterns :: MonadError ShowS m => ByteString -> m [AddressPattern] parseAddressPatterns = mapM parse1 . filter (not . B.null) . B.splitWith (\c -> isSpace c || c == ',') where parse1 spec | B.elem ':' spec = Addr6 `fmap` inet_atoh6 spec | otherwise = case B.split '/' spec of [a] -> do a' <- inet_atoh a return $! Net4 a' 0xffffffff [a, bits] | Just (n, rest) <- B.readInt bits, B.null rest, n >= 0, n <= 32 -> do a' <- inet_atoh a let mask | n == 0 = 0 | otherwise = complement 0 `shiftL` (32 - n) return $! Net4 (a' .&. mask) mask _ -> throwError $ cat "Malformed address or network " (esc 64 spec) '.' mhatta-tordnsel-1d9141b/src/TorDNSEL/Config.hs000066400000000000000000000014501527317632400210430ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Config -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards, GHC primitives) -- -- Parsing configuration options passed on the command line and present in -- config files. -- ----------------------------------------------------------------------------- module TorDNSEL.Config ( Config(..) , TestConfig(..) , parseConfigFile , parseConfigArgs , makeConfig , staticConfigOptionsChanged , copyStaticConfigOptions , ReconfigServer , bindReconfigSocket , startReconfigServer , terminateReconfigServer , connectToReconfigSocket ) where import TorDNSEL.Config.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/Config/000077500000000000000000000000001527317632400205075ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Config/Internals.hs000066400000000000000000000575361527317632400230220ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Config.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, -- pattern guards, bang patterns, GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- Parsing configuration options passed on the command line and present in -- config files. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.Config.Internals ( Config(..) , TestConfig(..) , ConfigValue(..) , parseConfigFile , parseConfigArgs , knownConfigItems , makeConfig , multiValuedConfigItems , staticConfigOptionsChanged , copyStaticConfigOptions , toItem -- * Reconfigure server , ReconfigServer(..) , State(..) , ReconfigMessage(..) , reconfigSocketPath , connectToReconfigSocket , bindReconfigSocket , startReconfigServer , handleMessage , forkListener , terminateReconfigServer ) where import Prelude hiding (log) import Control.Arrow ((***), second) import Control.Concurrent.MVar import qualified Control.Exception as E import Control.Monad (liftM, liftM2, ap, forever) import Control.Monad.Except (MonadError(..)) import Control.Monad.Fix (fix) import Data.Char (isSpace, toLower) import Data.Maybe (catMaybes) import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import qualified Data.List as L import qualified Data.Map as M import Data.Map (Map) import qualified Data.Set as S import Data.Set (Set) import Network.Socket ( Socket, HostAddress, SockAddr(SockAddrInet, SockAddrInet6, SockAddrUnix) , Family(AF_UNIX) , SocketType(Stream), socket, connect, accept, socketToHandle ) import System.IO (IOMode(ReadWriteMode), hClose) import System.Posix.Files (setOwnerAndGroup) import System.Posix.Types (UserID) import TorDNSEL.AddressPattern import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.DNS import TorDNSEL.ExitList import TorDNSEL.Log import TorDNSEL.Util -- | Configuration options. data Config = Config { cfStateDirectory :: FilePath -- ^ Where to store exit test results. , cfRuntimeDirectory :: FilePath -- ^ Where to place Unix domain sockets. , cfDNSListenAddress :: SockAddr -- ^ Address to bind the DNS listener. -- | Address to connect to the Tor controller interface. , cfTorControlAddress :: SockAddr -- | Address Tor is listening on for SOCKS connections, through which we -- make exit tests. , cfTorSocksAddress :: SockAddr , cfZoneOfAuthority :: DomainName -- ^ DNS zone we're authoritative for. , cfDomainName :: DomainName -- ^ Name for our own NS record. , cfSOARName :: DomainName -- ^ RNAME we return in our SOA record. , cfRunAsDaemon :: Bool -- ^ Should we daemonize on startup? , cfLogConfig :: LogConfig -- ^ Minimum log severity and log target. , cfConfigFile :: Maybe FilePath -- ^ Config file location. , cfTestConfig :: Maybe TestConfig -- ^ Exit test config. -- | A record to return for our zone of authority. , cfAddress :: Maybe HostAddress -- | The password used for Tor controller auth. , cfTorControlPassword :: Maybe ByteString , cfUser :: Maybe String -- ^ User name to run under. , cfGroup :: Maybe String -- ^ Group name to run under. , cfChangeRootDirectory :: Maybe FilePath -- ^ Directory to chroot to. , cfPIDFile :: Maybe FilePath -- ^ Where to record our PID. -- | Named destination lists for \"list\" queries (query type 2). , cfExitLists :: NamedLists -- | Address to bind the web interface's HTTP listener, if enabled. , cfHTTPListenAddress :: Maybe SockAddr -- | The public address and port at which clients reach the web -- interface, if it differs from the listening address (e.g. behind NAT). , cfHTTPPublicAddress :: Maybe (HostAddress, Port) -- | Responses per second allowed over UDP to each client network, or 0 -- for no limit. , cfDNSRateLimit :: Int -- | Reverse proxies whose X-Forwarded-For headers we believe. , cfHTTPTrustedProxies :: [AddressPattern] -- | Use the EDNS client subnet option for \"me\" queries. , cfDNSClientSubnet :: Bool -- | Clients allowed to fetch metrics from the web interface. , cfHTTPMetricsAllowFrom :: [AddressPattern] } deriving Show -- | Exit test configuration options. data TestConfig = TestConfig { -- | Address and ports to bind the exit test listeners. tcfTestListenAddress :: (HostAddress, [Port]) -- | Address and ports to which we make exit test connections. , tcfTestDestinationAddress :: (HostAddress, [Port]) } deriving Show -- | Config items we know about. knownConfigItems :: Set ByteString knownConfigItems = S.fromList . map toItem $ [ "StateDirectory" , "RuntimeDirectory" , "DNSListenAddress" , "TorControlAddress" , "TorSocksAddress" , "ZoneOfAuthority" , "DomainName" , "SOARName" , "RunAsDaemon" , "Log" , "ConfigFile" , "EnableActiveTesting" , "TestListenAddress" , "TestDestinationAddress" , "Address" , "TorControlPassword" , "User" , "Group" , "ChangeRootDirectory" , "PIDFile" , "ExitList" , "HTTPListenAddress" , "HTTPPublicAddress" , "DNSRateLimit" , "HTTPTrustedProxy" , "DNSClientSubnet" , "HTTPMetricsAllowFrom" ] -- | Config items that may be given more than once. Their values are joined -- with newlines. multiValuedConfigItems :: Set ByteString multiValuedConfigItems = S.fromList . map toItem $ [ "ExitList", "HTTPTrustedProxy", "HTTPMetricsAllowFrom" ] -- | Merge in default config options, check for missing options, and parse -- individual config values. makeConfig :: MonadError ShowS m => ConfigMap -> m Config makeConfig conf = return Config `app` "StateDirectory" `app` "RuntimeDirectory" `ap` listenAddress "DNSListenAddress" `app` "TorControlAddress" `app` "TorSocksAddress" `app` "ZoneOfAuthority" `app` "DomainName" `app` "SOARName" `app` "RunAsDaemon" `app` "Log" `app` "ConfigFile" `ap` testConf `app` "Address" `app` "TorControlPassword" `app` "User" `app` "Group" `app` "ChangeRootDirectory" `app` "PIDFile" `app` "ExitList" `ap` (parse (B.pack "HTTPListenAddress") conf' >>= maybe (return Nothing) (fmap Just . checkInet "HTTPListenAddress")) `app` "HTTPPublicAddress" `ap` rateLimit `app` "HTTPTrustedProxy" `app` "DNSClientSubnet" `app` "HTTPMetricsAllowFrom" where conf' = M.union conf . M.fromList . map (toItem *** toItem) $ [ "DNSListenAddress" ~> "127.0.0.1:53" , "TorControlAddress" ~> "127.0.0.1:9051" , "RunAsDaemon" ~> "False" , "EnableActiveTesting" ~> "False" , "TorSocksAddress" ~> "127.0.0.1:9050" , "Log" ~> "notice stdout" , "DNSRateLimit" ~> "100" , "DNSClientSubnet" ~> "True" ] (~>) = (,) f `app` addr = f `ap` parse (B.pack addr) conf' -- We listen for DNS and HTTP on IP addresses only. listenAddress item = parse (B.pack item) conf' >>= checkInet item checkInet item a@(SockAddrUnix _) = throwError $ cat "Parsing \"" item "\" failed: " (show a) " is a Unix socket; an IP address and port are needed." checkInet _ a = return a rateLimit = do r <- parse (B.pack "DNSRateLimit") conf' if r < 0 then throwError ("DNSRateLimit must not be negative." ++) else return (r :: Int) testConf = do concTests <- parse (B.pack "EnableActiveTesting") conf' if concTests then liftM Just $ return TestConfig `app` "TestListenAddress" `app` "TestDestinationAddress" else return Nothing -- | Given an old 'Config' and a new 'Config' generated by re-reading the config -- file, return a list of the non-reconfigurable options that changed between -- them. staticConfigOptionsChanged :: Config -> Config -> [String] staticConfigOptionsChanged old new = map snd . filter fst $ [(changed cfRuntimeDirectory, "RuntimeDirectory") ,(changed cfRunAsDaemon, "RunAsDaemon") ,(changed cfUser, "User") ,(changed cfGroup, "Group") ,(changed cfChangeRootDirectory, "ChangeRootDirectory") ,(changed cfPIDFile, "PIDFile")] where changed f = f old /= f new -- | Given an old 'Config' and a new 'Config' generated by re-reading the config -- file, copy values that can't be reconfigured from the old 'Config' to the new -- 'Config'. copyStaticConfigOptions :: Config -> Config -> Config copyStaticConfigOptions old new = new { cfRuntimeDirectory = cfRuntimeDirectory old , cfRunAsDaemon = cfRunAsDaemon old , cfConfigFile = cfConfigFile old , cfUser = cfUser old , cfGroup = cfGroup old , cfChangeRootDirectory = cfChangeRootDirectory old , cfPIDFile = cfPIDFile old } -- | Configuration information represented as a map from config item to unparsed -- config value. type ConfigMap = Map ByteString ByteString -- | Lookup a config value by config item. 'throwError' in the monad when the -- item isn't present. lookupValue :: MonadError ShowS m => ByteString -> ConfigMap -> m ByteString lookupValue item conf | Just val <- M.lookup (B.map toLower item) conf = return val | otherwise = throwError $ cat "Missing config option " item " is required." -- | Prepend a \"parsing failed\" message to a failure reason. prependOnFail :: MonadError ShowS m => ByteString -> m a -> m a prependOnFail item = prependError (cat "Parsing \"" item "\" failed: ") -- | Values used in config files and passed as command line arguments. class ConfigValue a where -- | Parse a config value. 'throwError' in the monad if parsing fails. parse :: MonadError ShowS m => ByteString -> ConfigMap -> m a instance ConfigValue a => ConfigValue (Maybe a) where parse item conf | M.member (B.map toLower item) conf = Just `liftM` parse item conf | otherwise = return Nothing instance ConfigValue ByteString where parse = lookupValue instance ConfigValue String where parse = (liftM B.unpack .) . lookupValue instance ConfigValue Int where parse item conf = lookupValue item conf >>= prependOnFail item . readInt instance ConfigValue Integer where parse item conf = lookupValue item conf >>= prependOnFail item . readInteger instance ConfigValue Bool where parse item conf = do val <- lookupValue item conf case B.map toLower val of lc | lc == B.pack "true" -> return True | lc == B.pack "false" -> return False | otherwise -> throwError $ cat "Parsing \"" item "\" failed: Got " (esc maxBoolLen val) ", expecting \"True\"\ \ or \"False\"." where maxBoolLen = 32 instance ConfigValue SockAddr where parse item conf = do val <- lookupValue item conf prependOnFail item $ case B.split ':' val of -- A Unix domain socket, written as Tor writes them, e.g. -- unix:/run/tor/control _ | Just path <- B.stripPrefix (B.pack "unix:") val -> if B.pack "/" `B.isPrefixOf` path && B.length path < 108 then return $! SockAddrUnix (B.unpack path) else throwError $ cat "Malformed Unix socket path " (esc maxAddrLen path) "; it must be \ \absolute and shorter than 108 bytes." [addr,port] -> do addr' <- inet_atoh addr Port port' <- parsePort port return $! SockAddrInet (fromIntegral port') (htonl addr') -- An IPv6 address in brackets, e.g. [::1]:53 _ | B.pack "[" `B.isPrefixOf` val , (addr,rest) <- B.break (== ']') (B.drop 1 val) , Just port <- B.stripPrefix (B.pack "]:") rest -> do addr' <- inet_atoh6 addr Port port' <- parsePort port return $! SockAddrInet6 (fromIntegral port') 0 addr' 0 _ -> throwError $ cat "Malformed address/port " (esc maxAddrLen val) '.' where maxAddrLen = 64 instance ConfigValue (HostAddress, Port) where parse item conf = do val <- lookupValue item conf prependOnFail item $ case B.split ':' val of [addr,port] -> liftM2 (,) (inet_atoh addr) (parsePort port) _ -> throwError $ cat "Malformed address/port " (esc 32 val) '.' -- | Addresses and networks, e.g. for @HTTPTrustedProxy@. Optional: none -- given means an empty list. instance ConfigValue [AddressPattern] where parse item conf = case M.lookup (B.map toLower item) conf of Nothing -> return [] Just val -> prependOnFail item $ parseAddressPatterns val -- | Named exit lists, one per (newline-separated) @ExitList@ value. The -- option is optional: no lists means \"list\" queries are disabled. instance ConfigValue NamedLists where parse item conf = case M.lookup (B.map toLower item) conf of Nothing -> return M.empty Just val -> prependOnFail item $ do lists <- mapM parseNamedList . filter (not . B.null) $ B.lines val let dup = [n | (n,k) <- M.toList (M.fromListWith (+) [(n,1::Int) | (n,_) <- lists]), k > 1] case dup of n:_ -> throwError $ cat "Exit list " (esc 64 n) " is defined twice." [] -> return $! M.fromList lists instance ConfigValue (HostAddress, [Port]) where parse item conf = do val <- lookupValue item conf prependOnFail item $ case B.split ':' val of [addr,ports] -> liftM2 (,) (inet_atoh addr) (mapM parsePort $ B.split ',' ports) _ -> throwError $ cat "Malformed address/ports " (esc maxAddrLen val) '.' where maxAddrLen = 256 instance ConfigValue HostAddress where parse item conf = lookupValue item conf >>= prependOnFail item . inet_atoh instance ConfigValue LogConfig where parse item conf = do val <- lookupValue item conf prependError (cat "Parsing log option " (esc maxLogLen val) " failed: ") $ do let (severity,(target,file)) = second (second (B.dropWhile isSpace) . B.break isSpace . B.dropWhile isSpace) . B.break isSpace $ val severity' <- case B.map toLower severity of lc | lc == B.pack "debug" -> return Debug | lc == B.pack "info" -> return Info | lc == B.pack "notice" -> return Notice | lc == B.pack "warn" -> return Warn | lc == B.pack "error" -> return Error | otherwise -> throwError $ cat "Invalid log severity " (esc maxSeverityLen severity) ". Expecting \"debug\", \"info\", \ \\"notice\", \"warn\", or \"error\"." target' <- case B.map toLower target of lc | lc == B.pack "stdout" -> return ToStdOut | lc == B.pack "stderr" -> return ToStdErr | lc == B.pack "syslog" -> return ToSysLog | lc == B.pack "file" -> if B.null file then throwError ("Log file name is missing." ++) else return . ToFile . B.unpack $ file | otherwise -> throwError $ cat "Invalid log target " (esc maxTargetLen target) ". Expecting \"stdout\", \"stderr\", \ \\"syslog\", or \"file\"." return LogConfig { minSeverity = severity' , logTarget = target' , logEnabled = True } where maxLogLen = 512 maxSeverityLen = 32 maxTargetLen = 32 instance ConfigValue DomainName where parse item conf = (DomainName . map Label . reverse . dropWhile B.null . reverse . B.split '.' . B.map toLower) `liftM` lookupValue item conf -- | Parse a config file, skipping comments. 'throwError' in the monad if an -- unknown config item is present. parseConfigFile :: MonadError ShowS m => ByteString -> m ConfigMap parseConfigFile = liftM (fromConfigList . catMaybes) . mapM parseLine . B.lines where parseLine line | B.null line' = return Nothing | lcItem `S.notMember` knownConfigItems = throwError $ cat "Unknown config option " (esc maxOptionLen item) '.' | otherwise = return $ Just (lcItem, value) where lcItem = B.map toLower item (item,value) = second (B.dropWhile isSpace) . B.break isSpace $ line' (line',_) = B.spanEnd isSpace . B.takeWhile (/= '#') $ line maxOptionLen = 64 -- | Given a list of command line arguments, return a map from config item to -- option. 'throwError' in the monad if an unknown item was provided. parseConfigArgs :: MonadError ShowS m => [String] -> m ConfigMap parseConfigArgs = liftM fromConfigList . mapM parseArg . splitPairs . filter notVerifyConfig where notVerifyConfig arg = map toLower arg /= "--verify-config" parseArg ["-f",option] = return (B.pack "configfile", B.pack option) parseArg [item,option] = parseItem item option parseArg args = throwError $ cat "Malformed command line arguments " (esc 128 . B.pack $ unwords args) '.' parseItem item option | S.member lcItem knownConfigItems = return (lcItem, B.pack option) | otherwise = throwError $ cat "Unknown config option " (esc maxOptionLen $ B.pack item') '.' where lcItem = B.pack . map toLower $ item' item' = dropWhile (== '-') item maxOptionLen = 64 splitPairs = takeWhile isPair . map (take 2) . iterate (drop 2) isPair [_,_] = True isPair _ = False -- | Build a 'ConfigMap' from (item, value) pairs in order of appearance. -- Later values of an ordinary item replace earlier ones; the values of -- 'multiValuedConfigItems' accumulate, separated by newlines. fromConfigList :: [(ByteString, ByteString)] -> ConfigMap fromConfigList = L.foldl' insert M.empty where insert m (k,v) | k `S.member` multiValuedConfigItems = M.insertWith (\new old -> B.concat [old, B.pack "\n", new]) k v m | otherwise = M.insert k v m -- | Canonicalize a config item. toItem :: String -> ByteString toItem = B.pack . map toLower -------------------------------------------------------------------------------- -- Reconfigure server -- | A handle to the reconfigure server thread. data ReconfigServer = ReconfigServer ThreadId (ReconfigMessage -> IO ()) instance Thread ReconfigServer where threadId (ReconfigServer tid _) = tid -- | An internal types representing the current reconfigure server state. data State = State { reconfigChan :: !(MsgChan ReconfigMessage) , listenSock :: !Socket , sendNewConfig :: !(Config -> (Maybe String -> IO ()) -> IO ()) , listenerTid :: !ThreadId } -- | An internal type for messages sent to the reconfigure server thread. data ReconfigMessage = NewClient Socket (IO ()) -- ^ A new client has been accepted. | Terminate ExitReason -- ^ Terminate the reconfigure server. | Exit ThreadId ExitReason -- ^ An exit signal sent to the reconfigure server. -- | The path to the reconfigure socket given the runtime directory path. reconfigSocketPath :: FilePath -> FilePath reconfigSocketPath = (++ "/reconfigure.socket") -- | Connect to the reconfigure socket, given the runtime directory. connectToReconfigSocket :: FilePath -> IO Socket connectToReconfigSocket runtimeDir = E.bracketOnError (socket AF_UNIX Stream 0) closeSocket $ \sock -> do connect sock (SockAddrUnix $ reconfigSocketPath runtimeDir) return sock -- | Given the runtime directory and an optional owner uid, bind and return the -- reconfigure socket. bindReconfigSocket :: FilePath -> Maybe UserID -> IO Socket bindReconfigSocket runtimeDir mbUidOwner = E.bracketOnError (bindListeningUnixDomainStreamSocket sockPath 0o600) closeSocket $ \sock -> do whenJust mbUidOwner $ \uidOwner -> setOwnerAndGroup sockPath uidOwner (-1) return sock where sockPath = reconfigSocketPath runtimeDir {- | Start a server listening on a socket in our runtime directory for the contents of a new config file. Link the server thread to the calling thread. In the following description of the reconfiguration protocol, both the server and client are TorDNSEL processes -- the server being the "real" TorDNSEL and the client being a TorDNSEL invoked with the "--reconfigure" command-line argument. After connecting, the client sends the contents of the config file, then shuts down the writing part of the connection. Client: EOF If parsing the config file fails, the server continues running with the old configuration and says: Server: "Parse error: " CRLF EOF If parsing succeeds, but reconfiguring the server using the new config file fails, the server process exits and says: Server: "Config error: " CRLF EOF Otherwise, the server runs with the new configuration and closes the connection: Server: EOF -} startReconfigServer :: Socket -> (Config -> (Maybe String -> IO ()) -> IO ()) -> IO ReconfigServer startReconfigServer sock sendConfig = do log Info "Starting reconfigure server." chan <- newMsgChan tid <- forkLinkIO $ do setTrapExit $ (writeMsgChan chan .) . Exit initListener <- forkListener sock (writeMsgChan chan) fix (\loop (!s) -> readMsgChan chan >>= handleMessage s >>= loop) (State chan sock sendConfig initListener) return $ ReconfigServer tid (writeMsgChan chan) handleMessage :: State -> ReconfigMessage -> IO State handleMessage s (NewClient client signal) = do E.handle (\(e :: E.IOException) -> log Warn "Reading config from reconfigure socket failed: " e) $ E.bracket (socketToHandle client ReadWriteMode) hClose $ \handle -> do -- B.hGetContents would close the (duplex) handle, and we still need -- to write a response, so read up to EOF without closing it. let readAll acc = do chunk <- B.hGetSome handle 4096 if B.null chunk then return (B.concat $ reverse acc) else readAll (chunk : acc) str <- readAll [] case parseConfigFile str >>= makeConfig of Left e -> do hCat handle "Parse error: " e "\r\n" log Warn "Parsing config from reconfigure socket failed: " e Right config -> do mv <- newEmptyMVar sendNewConfig s config (\resp -> tryPutMVar mv resp >> return ()) resp <- takeMVar mv whenJust resp $ \errMsg -> hCat handle "Config error: " errMsg "\r\n" signal return s handleMessage s (Terminate reason) = do log Info "Terminating reconfigure server." terminateThread Nothing (listenerTid s) (killThread $ listenerTid s) msgs <- drainMsgChan $ reconfigChan s sequence_ [closeSocket client | NewClient client _ <- msgs] exit reason handleMessage s (Exit tid reason) | tid == listenerTid s = do log Warn "The reconfigure listener thread exited unexpectedly: " (show reason) "; restarting." newListenerTid <- forkListener (listenSock s) (writeMsgChan $ reconfigChan s) return s { listenerTid = newListenerTid } | isAbnormal reason = exit reason | otherwise = return s -- | Fork the listener thread. forkListener :: Socket -> (ReconfigMessage -> IO ()) -> IO ThreadId forkListener sock send = forkLinkIO . forever $ do (client,_) <- accept sock mv <- newEmptyMVar send $ NewClient client (putMVar mv ()) takeMVar mv -- | Terminate the reconfigure server gracefully. The optional parameter -- specifies the amount of time in microseconds to wait for the thread to -- terminate. If the thread hasn't terminated by the timeout, an uncatchable -- exit signal will be sent. terminateReconfigServer :: Maybe Int -> ReconfigServer -> IO () terminateReconfigServer mbWait (ReconfigServer tid send) = terminateThread mbWait tid (send $ Terminate NormalExit) mhatta-tordnsel-1d9141b/src/TorDNSEL/Control/000077500000000000000000000000001527317632400207225ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Control/Concurrent/000077500000000000000000000000001527317632400230445ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Control/Concurrent/Future.hs000066400000000000000000000033021527317632400246500ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Control.Concurrent.Future -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions) -- -- Implements concurrent futures. -- ----------------------------------------------------------------------------- module TorDNSEL.Control.Concurrent.Future ( Future , spawn , resolve ) where import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, withMVar) import qualified Control.Exception as E import TorDNSEL.Control.Concurrent.Link -- | An abstract type representing a value being evaluated concurrently in -- another thread of execution. newtype Future a = Future (MVar (Either ExitReason a)) -- | Evaluate the given 'IO' action in a separate thread and return a future of -- its result immediately. The future thread is linked to the calling thread so -- the future can receive an exit signal if the calling thread exits, but an -- exit signal from the future thread won't be delivered to the calling thread. spawn :: IO a -> IO (Future a) spawn io = do mv <- newEmptyMVar callingThread <- myThreadId _ <- forkLinkIO $ E.mask $ \restore -> do r <- either (Left . extractReason) (Right . id) `fmap` E.try (restore io) putMVar mv r unlinkThread callingThread either exit (const $ return ()) r return $ Future mv -- | Explicitly unwrap the value contained within a future. Block until the -- value has been evaluated, exiting with the future's exit reason if the future -- failed. resolve :: Future a -> IO a resolve (Future mv) = withMVar mv (either exit return) mhatta-tordnsel-1d9141b/src/TorDNSEL/Control/Concurrent/Link.hs000066400000000000000000000022471527317632400243020ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Control.Concurrent.Link -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, -- pattern guards) -- -- Implements linked threads and monitors for error handling, attempting to -- closely reproduce their behavior in Erlang. -- -- Based on Joe Armstrong's /Making reliable distributed systems in the -- presence of software errors/. -- -- ----------------------------------------------------------------------------- module TorDNSEL.Control.Concurrent.Link ( ThreadId , myThreadId , withLinksDo , forkIO , forkLinkIO , linkThread , unlinkThread , monitorThread , demonitorThread , withMonitor , exit , throwTo , killThread , setTrapExit , unsetTrapExit , ExitReason(..) , exitReason , isAbnormal , throwAbnormal , extractReason , fromExitSignal , LinkException(..) ) where import TorDNSEL.Control.Concurrent.Link.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/Control/Concurrent/Link/000077500000000000000000000000001527317632400237415ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs000066400000000000000000000373311527317632400262430ustar00rootroot00000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-ignore-asserts #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Control.Concurrent.Link.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, -- pattern guards) -- -- /Internals/: should only be imported by the public module and tests. -- -- Implements linked threads and monitors for error handling, attempting to -- closely reproduce their behavior in Erlang. -- -- Based on Joe Armstrong's /Making reliable distributed systems in the -- presence of software errors/. -- -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.Control.Concurrent.Link.Internals where import qualified Control.Exception as E import qualified Control.Concurrent as C import Control.Concurrent.MVar (MVar, newMVar, withMVar, modifyMVar, modifyMVar_) import GHC.Conc (setUncaughtExceptionHandler) import System.Exit (ExitCode) import Control.Monad (unless) import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S import Data.List (nub) import Data.Unique (Unique, newUnique) import System.IO (hPutStrLn, hFlush, stderr) import System.IO.Unsafe (unsafePerformIO) import TorDNSEL.Util -- | An abstract type representing a handle to a linkable thread. Holding a -- 'ThreadId', unlike a 'C.ThreadId', won't prevent a dead thread from being -- garbage collected. newtype ThreadId = Tid Unique deriving (Eq, Ord) -- ( Else an orphaned Show Unique... ) instance Show ThreadId where show _ = "#" -- | Return the 'ThreadId' of the calling thread. myThreadId :: IO ThreadId myThreadId = do me <- C.myThreadId withMVar threadMap $ \tm -> return $! ident (state tm M.! me) type StateModifier = M.Map C.ThreadId ThreadState -> M.Map C.ThreadId ThreadState -- | Holds the 'ThreadId' to 'C.ThreadId' mappings and 'ThreadState' for every -- running thread. data ThreadMap = ThreadMap { ids :: !(M.Map ThreadId C.ThreadId) , state :: !(M.Map C.ThreadId ThreadState) } -- | State necessary for supporting links and monitors. data ThreadState = ThreadState { ident :: !ThreadId , signal :: !(ThreadId -> ExitReason -> IO ()) , links :: !(S.Set C.ThreadId) , monitors :: !(M.Map Unique (ExitReason -> IO (), StateModifier)) , ownedMons :: !(S.Set (C.ThreadId, Unique)) } -- | A mutable variable holding the link and monitor state. threadMap :: MVar ThreadMap {-# NOINLINE threadMap #-} threadMap = unsafePerformIO . newMVar $ ThreadMap M.empty M.empty -- | Erase 'threadMap', making it possible to re-run 'withLinksDo'. For -- debugging only, as it loses track of threads. unsafeResetThreadMap :: IO () unsafeResetThreadMap = modifyMVar_ threadMap $ const . return $ ThreadMap M.empty M.empty -- | Assert various invariants of the global link and monitor state, printing a -- message to stdout if any assertions fail. assertThreadMap :: ThreadMap -> IO () assertThreadMap tm = E.handle (\(E.AssertionFailed msg) -> putStrLn $ "assertThreadMap: " ++ msg) $ E.assert (M.size (ids tm) > 0) $ E.assert (M.size (ids tm) == M.size (state tm)) $ E.assert (M.elems (ids tm) == nub (M.elems (ids tm))) $ E.assert (all (`M.member` state tm) (M.elems (ids tm))) $ E.assert (F.and (M.mapWithKey (\tid tid' -> tid == ident (state tm M.! tid')) (ids tm))) $ E.assert (F.all (F.all (`M.member` state tm) . links) (state tm)) $ E.assert (F.and (M.mapWithKey (\tid ts -> F.all (S.member tid . links . (state tm M.!)) (links ts)) (state tm))) $ E.assert (F.all (F.all (\(tid,monId) -> (M.member monId . monitors) `fmap` M.lookup tid (state tm) == Just True) . ownedMons) (state tm)) $ return () -- | An internal type used to transmit the originating 'ThreadId' in an -- asynchronous exception to a linked thread. data ExitSignal = ExitSignal !ThreadId !ExitReason deriving Show instance E.Exception ExitSignal -- | Extract the 'ExitReason' from an 'ExitSignal' contained within an -- exception. If the exception doesn't contain an 'ExitReason', it becomes the -- exit reason itself. extractReason :: E.SomeException -> ExitReason extractReason (E.fromException -> Just (ExitSignal _ e)) = e extractReason e = AbnormalExit e -- | Extract a particular exception type from an 'ExitSignal', if present. fromExitSignal :: E.Exception e => ExitSignal -> Maybe (ThreadId, e) fromExitSignal (ExitSignal tid (AbnormalExit e)) | Just e' <- E.fromException e = Just (tid, e') fromExitSignal _ = Nothing -- | The default action used to signal a thread. Abnormal 'ExitReason's are -- sent to the thread and normal exits are ignored. defaultSignal :: C.ThreadId -> ThreadId -> ExitReason -> IO () defaultSignal _ _ NormalExit = return () defaultSignal dst src e = E.throwTo dst $ ExitSignal src e -- | Initialize the state supporting links and monitors. It is an error to call -- this function outside the main thread, or to call any other functions in this -- module outside this function. withLinksDo :: IO a -> IO () withLinksDo io = E.mask $ \restore -> do setUncaughtExceptionHandler . const . return $ () main <- C.myThreadId mainId <- Tid `fmap` newUnique let initialState = ThreadState { ident = mainId , signal = defaultSignal main , links = S.empty , monitors = M.empty , ownedMons = S.empty } modifyMVar_ threadMap $ \tm -> E.assert (M.size (ids tm) == 0) $ E.assert (M.size (state tm) == 0) $ return $! initialState `seq` tm { ids = M.insert mainId main (ids tm) , state = M.insert main initialState (state tm) } -- Don't bother propagating signals from the main thread -- since it's about to exit. (() <$ restore io) `E.catch` \(e :: E.SomeException) -> case extractReason e of NormalExit -> return () AbnormalExit (E.fromException -> Just e') -> E.throwIO (e' :: ExitCode) AbnormalExit e' -> do hPutStrLn stderr ("*** Exception: " ++ show e') hFlush stderr E.throwIO e' -- | Evaluate the given 'IO' action in a new thread, returning its 'ThreadId'. forkIO :: IO a -> IO ThreadId forkIO = forkLinkIO' False -- | Like 'forkIO', except a link is atomically established between the new -- thread and the calling thread. forkLinkIO :: IO a -> IO ThreadId forkLinkIO = forkLinkIO' True forkLinkIO' :: Bool -> IO a -> IO ThreadId forkLinkIO' shouldLink io = E.mask $ \restore -> do parent <- C.myThreadId childId <- Tid `fmap` newUnique modifyMVar_ threadMap $ \tm -> do #ifdef DEBUG assertThreadMap tm #endif child <- forkHandler $ do child <- C.myThreadId e <- either (extractReason :: E.SomeException -> ExitReason) (const NormalExit) `fmap` E.try (restore io) -- modifyMVar is interruptible (a misfeature in this case), so an async -- exception could be delivered here. Forking an anonymous thread should -- avoid this race since nobody can throwTo it. forkHandler $ do #ifdef DEBUG withMVar threadMap assertThreadMap #endif (signalAll,notifyAll) <- modifyMVar threadMap $ \tm1 -> let s = state tm1 M.! child unlinkAll = flip (F.foldl' (flip (child `unlinkFrom`))) (links s) deleteMonitors = flip (F.foldl' (\a (_,cleanup) -> cleanup a)) (monitors s) . flip (F.foldl' (\a (tid,monId) -> adjust' (\ts -> ts {monitors = M.delete monId (monitors ts)}) tid a)) (ownedMons s) newIds = M.delete childId (ids tm1) newState = M.delete child . deleteMonitors . unlinkAll $ state tm1 signalThread ex tid = signal (state tm1 M.! tid) childId ex signalAll ex = F.mapM_ (forkHandler . signalThread ex) (links s) notifyAll ex = F.mapM_ (forkHandler . ($ ex) . fst) (monitors s) tm1' = tm1 { ids = newIds, state = newState } in tm1' `seq` return (tm1', (signalAll, notifyAll)) #ifdef DEBUG withMVar threadMap assertThreadMap #endif notifyAll e signalAll e let (linkedThrs, linkToParent) | shouldLink = (S.singleton parent, child `linkTo` parent) | otherwise = (S.empty, id) initialState = ThreadState { ident = childId , signal = defaultSignal child , links = linkedThrs , monitors = M.empty , ownedMons = S.empty } return $! initialState `seq` tm { ids = M.insert childId child $ ids tm , state = M.insert child initialState . linkToParent $ state tm } #ifdef DEBUG withMVar threadMap assertThreadMap #endif return childId where forkHandler a = E.mask_ . C.forkIO $ (() <$ a) `E.catch` \(_ :: E.SomeException) -> return () -- | Establish a bidirectional link between the calling thread and a given -- thread. If either thread terminates, an exit signal will be sent to the other -- thread, causing it to terminate and propagate the signal further if it isn't -- trapping signals. If the given thread doesn't exist, an exit signal of -- 'NonexistentThread' will be sent to the calling thread. linkThread :: ThreadId -> IO () linkThread tid = do me <- C.myThreadId mbSignalSelf <- modifyMVar threadMap $ \tm -> return $! case M.lookup tid (ids tm) of Just tid' | tid' == me -> (tm, Nothing) | otherwise -> (tm', Nothing) where !tm' = tm { state = linkTogether me tid' $ state tm } Nothing -> (tm, Just . signal s tid $ exitReason NonexistentThread) where s = state tm M.! me whenJust mbSignalSelf id where linkTogether x y = (x `linkTo` y) . (y `linkTo` x) -- | Dissolve a link between the calling thread and a given thread, if a link -- exists. unlinkThread :: ThreadId -> IO () unlinkThread tid = do me <- C.myThreadId modifyMVar_ threadMap $ \tm -> return $! case M.lookup tid (ids tm) of Just tid' | tid' /= me -> tm { state = breakLinks me tid' $ state tm } _ -> tm where breakLinks x y = (x `unlinkFrom` y) . (y `unlinkFrom` x) linkTo, unlinkFrom :: C.ThreadId -> C.ThreadId -> StateModifier (linkTo, unlinkFrom) = (adjustLinks S.insert, adjustLinks S.delete) where adjustLinks f tid = adjust' $ \ts -> ts { links = tid `f` links ts } -- | An abstract type representing a handle to a particular monitoring of one -- thread by another. data Monitor = Monitor !ThreadId !Unique deriving (Eq, Ord) -- | The reason a thread was terminated. data ExitReason = NormalExit | AbnormalExit E.SomeException deriving (Show) -- | Construct an 'ExitReason' from any 'E.Exception'. exitReason :: E.Exception e => e -> ExitReason exitReason = AbnormalExit . E.toException isAbnormal :: ExitReason -> Bool isAbnormal (AbnormalExit _) = True isAbnormal _ = False -- | Check the exit reason and re-throw it if it's an 'AbnormalExit'. throwAbnormal :: ExitReason -> IO () throwAbnormal NormalExit = return () throwAbnormal (AbnormalExit e) = E.throwIO e -- | Start monitoring the given thread, invoking an 'IO' action with the -- 'ExitReason' when the thread dies. Return a handle to the monitor, which can -- be passed to 'demonitorThread'. If the thread doesn't exist, the action will -- be immediately called with 'NonexistentThread'. The calling thread becomes -- the monitor's owner; if it dies, the monitoring will be cancelled. monitorThread :: ThreadId -> (ExitReason -> IO ()) -> IO Monitor monitorThread tid notify = do me <- C.myThreadId mon@(Monitor _ monId) <- Monitor tid `fmap` newUnique let cleanup tid' = flip adjust' me $ \ts -> ts { ownedMons = S.delete (tid', monId) (ownedMons ts) } addMon tid' ts = ts { monitors = M.insert monId (notify, cleanup tid') (monitors ts) } addOwned tid' ts = ts {ownedMons = S.insert (tid', monId) (ownedMons ts)} exists <- modifyMVar threadMap $ \tm -> return $! case M.lookup tid (ids tm) of Nothing -> (tm, False) Just tid' -> (tm', True) where !tm' = tm { state = adjust' (addMon tid') tid' . adjust' (addOwned tid') me $ state tm } unless exists $ notify $ exitReason NonexistentThread return mon -- | Cancel a monitor, if it is currently active. demonitorThread :: Monitor -> IO () demonitorThread (Monitor tid monId) = do me <- C.myThreadId modifyMVar_ threadMap $ \tm -> return $! case M.lookup tid (ids tm) of Nothing -> tm Just tid' -> tm { state = adjust' deleteMon tid' . adjust' (deleteOwned tm) me $ state tm } where deleteMon ts = ts { monitors = M.delete monId (monitors ts) } deleteOwned tm ts = ts { ownedMons = S.delete (ids tm M.! tid, monId) (ownedMons ts) } -- | Like 'monitorThread', except an 'IO' action is invoked after the monitoring -- has started, and the monitor is safely released after the action returns, -- even if the action throws an exception. withMonitor :: ThreadId -> (ExitReason -> IO ()) -> IO a -> IO a withMonitor tid notify = E.bracket (monitorThread tid notify) demonitorThread . const -- | Terminate the calling thread with the given 'ExitReason'. exit :: ExitReason -> IO a exit e = E.throwIO . (`ExitSignal` e) =<< myThreadId -- | Send an exit signal with an 'ExitReason' to a thread. If the 'ExitReason' -- is 'NormalExit', the signal will be ignored unless the target thread is trapping -- signals. Otherwise, the target thread will either exit with the same -- 'ExitReason' or be notified of the signal depending on whether it is trapping -- signals. If the target thread doesn't exist, do nothing. throwTo :: ThreadId -> ExitReason -> IO () throwTo tid e = do me <- C.myThreadId mbSignal <- withMVar threadMap $ \tm -> let me' = ident (state tm M.! me) in if tid == me' -- special case: an exception thrown to oneself is untrappable then E.throwIO $ ExitSignal me' e else return $ do tid' <- M.lookup tid (ids tm) return $ signal (state tm M.! tid') me' -- since signal can block, we don't want to hold a lock on threadMap whenJust mbSignal ($ e) -- | Send an untrappable exit signal to a thread, if it exists. killThread :: ThreadId -> IO () killThread tid = do me <- C.myThreadId mbSignal <- withMVar threadMap $ \tm -> return $ do tid' <- M.lookup tid (ids tm) return . E.throwTo tid' $ ExitSignal (ident (state tm M.! me)) (exitReason E.ThreadKilled) whenJust mbSignal id -- | Redirect exit signals destined for the calling thread to the given 'IO' -- action. Exit signals contain the 'ThreadId' of the immediate sender and the -- original 'ExitReason'. setTrapExit :: (ThreadId -> ExitReason -> IO ()) -> IO () setTrapExit notify = do me <- C.myThreadId modifyMVar_ threadMap $ \tm -> return $! tm { state = adjust' (\ts -> ts { signal = notify }) me (state tm) } -- | Deliver exit signals destined for the calling thread normally, that is, -- exit signals will terminate the calling thread and propagate to any threads -- linked to the calling thread. unsetTrapExit :: IO () unsetTrapExit = setTrapExit . defaultSignal =<< C.myThreadId -- | An exception related to links or monitors. data LinkException = NonexistentThread -- ^ deriving Eq instance Show LinkException where show NonexistentThread = "Attempt to link to nonexistent thread" instance E.Exception LinkException mhatta-tordnsel-1d9141b/src/TorDNSEL/Control/Concurrent/Util.hs000066400000000000000000000112531527317632400243170ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Control.Concurrent.Util -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions) -- -- Common concurrency utilities. -- ----------------------------------------------------------------------------- module TorDNSEL.Control.Concurrent.Util where import qualified Control.Exception as E import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, tryPutMVar) import Control.Concurrent.STM (TChan, atomically, newTChanIO, writeTChan, readTChan, tryReadTChan) import Data.Maybe (isJust) import System.Timeout import TorDNSEL.Control.Concurrent.Link -- | A type representing a handle to a thread. class Thread a where threadId :: a -> ThreadId -- ^ The 'ThreadId' contained within a handle. instance Thread ThreadId where threadId = id -- | Terminate the thread @tid@ by calling @terminate@. @mbWait@ specifies the -- amount of time in microseconds to wait for the thread to terminate. If the -- thread hasn't terminated by the timeout, an uncatchable exit signal will be -- sent. terminateThread :: Maybe Int -> ThreadId -> IO () -> IO () terminateThread mbWait tid terminate = do dead <- newEmptyMVar withMonitor tid (const $ putMVar dead ()) $ do terminate case mbWait of Nothing -> takeMVar dead Just wait -> do r <- timeout wait (takeMVar dead) if isJust r then return () else do killThread tid takeMVar dead -- | Send a message to @tid@ by invoking @sendMsg@ with a synchronizing action. -- If the thread exits abnormally before synchronizing, throw its exit signal in -- the calling thread. sendSyncMessage :: (IO () -> IO ()) -> ThreadId -> IO () sendSyncMessage sendMsg tid = do err <- newEmptyMVar withMonitor tid (tryPutMVar_ err) $ do sendMsg $ tryPutMVar_ err NormalExit takeMVar err >>= throwAbnormal -- | Send a message parameterized by a reply action to @tid@, returning the -- response value. If the thread exits before responding to the message, throw -- its exit signal or 'NonexistentThread' in the calling thread. call :: ((a -> IO ()) -> IO ()) -> ThreadId -> IO a call sendMsg tid = do mv <- newEmptyMVar withMonitor tid (tryPutMVar_ mv . Left) $ do sendMsg $ tryPutMVar_ mv . Right response <- takeMVar mv case response of Left NormalExit -> E.throwIO NonexistentThread Left (AbnormalExit e) -> E.throwIO e Right r -> return r -- | Invoke the given 'IO' action in a new thread, passing it an action to -- invoke when it has successfully started. Link the new thread to the calling -- thread. If the thread exits before signaling that it has successfully -- started, throw its exit signal in the calling thread. startLink :: (IO () -> IO a) -> IO ThreadId startLink io = do sync <- newEmptyMVar err <- newEmptyMVar tid <- forkLinkIO $ do takeMVar sync io $ tryPutMVar_ err NormalExit withMonitor tid (tryPutMVar_ err) $ do putMVar sync () takeMVar err >>= throwAbnormal return tid -- | Invoke the given 'IO' action in a temporary thread (linked to the calling -- thread), returning either its exit signal or the thread returned by it. If -- the 'IO' action successfully returns a thread, link it to the calling thread. -- Also return the 'ThreadId' of the temporary thread. tryForkLinkIO :: Thread a => IO a -> IO (Either ExitReason a, ThreadId) tryForkLinkIO io = do sync <- newEmptyMVar resp <- newEmptyMVar intermediate <- forkLinkIO $ do takeMVar sync io >>= tryPutMVar_ resp . Right r <- withMonitor intermediate (tryPutMVar_ resp . Left) $ do putMVar sync () E.mask_ $ do r <- takeMVar resp either (const $ return ()) (linkThread . threadId) r return r return (r, intermediate) -------------------------------------------------------------------------------- -- Drainable message channels -- | An unbounded FIFO channel whose pending messages can be drained without -- blocking. ('Control.Concurrent.Chan.isEmptyChan' was removed from base.) type MsgChan a = TChan a newMsgChan :: IO (MsgChan a) newMsgChan = newTChanIO writeMsgChan :: MsgChan a -> a -> IO () writeMsgChan c = atomically . writeTChan c readMsgChan :: MsgChan a -> IO a readMsgChan = atomically . readTChan -- | Remove and return every message currently queued, without blocking. drainMsgChan :: MsgChan a -> IO [a] drainMsgChan c = atomically (go []) where go acc = tryReadTChan c >>= maybe (return $ reverse acc) (go . (:acc)) tryPutMVar_ :: MVar a -> a -> IO () tryPutMVar_ = ((() <$) .) . tryPutMVar mhatta-tordnsel-1d9141b/src/TorDNSEL/DNS.hs000066400000000000000000000021671527317632400202700ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.DNS -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (imprecise exceptions, pattern guards) -- -- /Internals/: should only be imported by the public module and tests. -- -- Decoding and encoding the subset of DNS necessary for running a DNSBL -- server. -- -- See RFC 1035 and RFC 2308 for details. -- ----------------------------------------------------------------------------- module TorDNSEL.DNS ( -- * I\/O runServer , recvMessageFrom , sendMessageTo , serveTCPConnection , udpPayloadLimit , encodeResponse , truncateMessage -- * Data types , Message(..) , Question(..) , ResourceRecord(..) , DomainName(..) , Label(..) , RCode(..) , OpCode(..) , Type(..) , Class(..) -- * EDNS(0) , EDNS(..) , findEDNS , ednsRecord , badVersRCode , ClientSubnet(..) , clientSubnetOption , parseClientSubnet , renderClientSubnet , clientSubnetIPv4 ) where import TorDNSEL.DNS.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/DNS/000077500000000000000000000000001527317632400177265ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/DNS/Internals.hs000066400000000000000000001023431527317632400222240ustar00rootroot00000000000000{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.DNS.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (imprecise exceptions, pattern guards) -- -- /Internals/: should only be imported by the public module and tests. -- -- Decoding and encoding the subset of DNS necessary for running a DNSBL -- server. -- -- See RFC 1035 and RFC 2308 for details. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.DNS.Internals ( -- * I\/O runServer , recvMessageFrom , sendMessageTo , recvFrom , sendTo -- ** TCP , serveTCPConnection , recvExactly , tcpFrame -- ** Message size , udpPayloadLimit , encodeResponse , truncateMessage -- * Serialization , Packet(..) , encodeMessage , decodeMessage , PutState(..) , initialPutState , PutMessage , runPutMessage , incrOffset , BinaryPacket(..) -- ** Name compression , Offset , TargetMap(..) , emptyTargetMap , compressName , compressNameStatefully -- * Data types , Message(..) , Question(..) , ResourceRecord(..) , DomainName(..) , Label(..) , RCode(..) , OpCode(..) , Type(..) , Class(..) -- * EDNS(0) , EDNS(..) , findEDNS , ednsRecord , parseEDNSOptions , renderEDNSOptions -- ** Client subnet (RFC 7871) , ClientSubnet(..) , clientSubnetOption , parseClientSubnet , renderClientSubnet , clientSubnetIPv4 , ednsUDPSize , badVersRCode ) where import qualified Control.Exception as E import Control.Monad (when, unless, replicateM, liftM2, liftM3, forM, forever, join) import qualified Control.Monad.State as S import Control.Monad.Trans (lift) import Control.DeepSeq import Data.Bits ((.|.), (.&.), xor, shiftL, shiftR, testBit, setBit) import qualified Data.List as List import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) import qualified Data.Map as M import Data.Map (Map) import Network.Socket (HostAddress, Socket, SockAddr(..), sendBufTo, recvBufFrom) import qualified Network.Socket.ByteString as NSB import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr) import System.Timeout (timeout) import Data.Binary (Binary(..), Get, getWord8, putWord8, Word16, Word32) import Data.Binary.Get ( runGet, runGetOrFail, getWord16be, getByteString, bytesRead, lookAhead, skip , isEmpty ) import Data.Word (Word8) import Data.Binary.Put (runPut, putWord16be, putByteString, PutM) import TorDNSEL.Util -------------------------------------------------------------------------------- -- I/O -- | Run a DNS server using a bound UDP socket. Pass received messages to the -- handler and send back responses returned by the handler. Responses that -- don't fit in what the query allows ('udpPayloadLimit') are truncated, which -- tells the client to ask again over TCP. runServer :: Socket -> (Int -> Int -> IO ()) -> (SockAddr -> Message -> IO (Maybe Message)) -> IO () {-# INLINE runServer #-} -- critical runServer sock stats handler = forever $ do (msg,inBytes,addr) <- recvMessageFrom sock outBytes <- handleQuery msg addr stats inBytes outBytes where -- Ignore datagrams from privileged ports: legitimate resolvers never use -- them, and answering them would let us be used in reflection attacks -- against services such as chargen or echo. handleQuery (Just query) sockAddr | Just port <- sourcePort sockAddr, port >= 1024 = do response <- handler sockAddr query case response of Just r -> sendMessageTo sock (udpPayloadLimit query) r sockAddr Nothing -> return 0 handleQuery _ _ = return 0 sourcePort (SockAddrInet port _) = Just (fromIntegral port :: Int) sourcePort (SockAddrInet6 port _ _ _) = Just (fromIntegral port) sourcePort _ = Nothing -- | Read a DNS message from a bound UDP socket. Return the source 'SockAddr', -- the number of bytes read, and @'Just' msg@ if parsing the message succeeded. recvMessageFrom :: Socket -> IO (Maybe Message, Int, SockAddr) recvMessageFrom sock = do -- EDNS(0) queries may be larger than 512 bytes. (pkt,sockAddr) <- recvFrom sock 4096 return (decodeMessage $ Packet pkt, B.length pkt, sockAddr) -- | Send a DNS message of at most @limit@ bytes to a 'SockAddr' with a UDP -- socket (see 'encodeResponse'). Return the number of bytes sent. sendMessageTo :: Socket -> Int -> Message -> SockAddr -> IO Int sendMessageTo sock limit msg sockAddr = case encodeResponse limit msg of Just bs -> sendTo sock bs sockAddr >> return (B.length bs) Nothing -> return 0 -- | The largest UDP response we send to a query: 512 bytes, or the payload -- size the client advertises with EDNS(0) up to our own ('ednsUDPSize') -- (RFC 6891, section 6.2.5). udpPayloadLimit :: Message -> Int udpPayloadLimit query = case findEDNS query of Just e -> fromIntegral . max 512 . min ednsUDPSize $ ednsPayloadSize e Nothing -> 512 -- | Encode a message in at most @limit@ bytes. A response that doesn't fit is -- truncated ('truncateMessage'), as RFC 1035 and RFC 7766 prescribe, so that -- the client retries over TCP. A query that doesn't fit is dropped. encodeResponse :: Int -> Message -> Maybe ByteString encodeResponse limit msg | B.length full <= limit = Just full | msgQR msg, B.length truncated <= limit = Just truncated | otherwise = Nothing where full = unPacket $ encodeMessage msg truncated = unPacket . encodeMessage $ truncateMessage msg -- | Set the TC bit and remove all records except the OPT pseudo-record. truncateMessage :: Message -> Message truncateMessage msg = msg { msgTC = True, msgAnswers = [], msgAuthority = [] , msgAdditional = [ rr | rr@UnsupportedResourceRecord{rrType = TOPT} <- msgAdditional msg ] } -- | Serve DNS queries arriving over an accepted TCP connection (RFC 7766): -- each message is preceded by its length as a 16-bit big-endian integer, and -- a client may send queries one after another. Answer them in order until the -- client closes the connection, sends something that isn't a DNS message, has -- sent @maxQueries@ queries, or makes us wait longer than @idle@ microseconds -- (asked anew for each wait, so that it can depend on how busy we are) for a -- query or for sending a response. The statistics action and handler are as -- for 'runServer'. Doesn't close the socket. serveTCPConnection :: Socket -> SockAddr -> IO Int -> Int -> (Int -> Int -> IO ()) -> (SockAddr -> Message -> IO (Maybe Message)) -> IO () serveTCPConnection sock addr idle maxQueries stats handler = loop maxQueries where loop 0 = return () loop n = do mbLen <- recvTimeout 2 whenJust mbLen $ \lenBytes -> do let len = fromIntegral (B.index lenBytes 0) `shiftL` 8 .|. fromIntegral (B.index lenBytes 1) mbPkt <- if len == 0 then return Nothing else recvTimeout len whenJust mbPkt $ \pkt -> whenJust (decodeMessage (Packet pkt)) $ \query -> do response <- handler addr query sent <- case response >>= encodeResponse 65535 of Just bs -> do -- A client that doesn't read its responses mustn't block us. t <- idle fmap (fmap (const (2 + B.length bs))) . timeout t $ NSB.sendAll sock (tcpFrame bs) Nothing -> return (Just 0) whenJust sent $ \out -> do stats (2 + len) out loop (n - 1 :: Int) recvTimeout k = do t <- idle fmap join . timeout t $ recvExactly sock k -- | Read exactly @n@ bytes from a stream socket. Return 'Nothing' if the -- connection is closed first. recvExactly :: Socket -> Int -> IO (Maybe ByteString) recvExactly sock n = go n [] where go 0 acc = return . Just $! B.concat (reverse acc) go k acc = do bs <- NSB.recv sock k if B.null bs then return Nothing else go (k - B.length bs) (bs : acc) -- | Prefix a message with its length, for DNS over TCP. The message must be -- at most 65535 bytes long. tcpFrame :: ByteString -> ByteString tcpFrame bs = B.pack [fromIntegral (l `shiftR` 8), fromIntegral l] `B.append` bs where l = B.length bs -- | A wrapper for using 'recvBufFrom' with 'ByteString's. recvFrom :: Socket -> Int -> IO (ByteString, SockAddr) recvFrom sock i = do (bs, sockAddr) <- B.createAndTrim' i $ \p -> do (l,addr) <- recvBufFrom sock p i return (0, l, addr) return (bs, sockAddr) -- | A wrapper for using 'sendBufTo' with 'ByteString's. sendTo :: Socket -> ByteString -> SockAddr -> IO Int sendTo _ (B.PS _ _ 0) _ = return 0 sendTo sock (B.PS ps s l) sockAddr = withForeignPtr ps $ \p -> sendBufTo sock (p `plusPtr` s) l sockAddr -------------------------------------------------------------------------------- -- Serialization -- | An encoded DNS message. newtype Packet = Packet { unPacket :: ByteString } deriving (Eq, Show) -- | Encode a DNS message. encodeMessage :: Message -> Packet encodeMessage = Packet . B.concat . L.toChunks . runPutMessage . putPacket -- | Decode a DNS message, returning @'Just' _@ if parsing succeeded. The -- result is fully evaluated. -- -- Decoding is total: since binary 0.7 'Get' is strict and reports every -- failure (short input, bad lengths, bad pointers, ...) through 'fail', which -- 'runGetOrFail' turns into 'Left', and the decoders below use no partial -- functions. (The property tests check this on random input.) So there is no -- need to catch exceptions, and this needn't be in 'IO'. decodeMessage :: Packet -> Maybe Message decodeMessage pkt = case runGetOrFail (getPacket pkt) (L.fromChunks [unPacket pkt]) of Left _ -> Nothing Right (_, _, m) -> Just $!! m -- | A value representing the current name compression targets and current -- offset (in bytes) into the datagram we're serializing. data PutState = PutState { psTargets :: !TargetMap , psCurOff :: !Offset } -- | The initial state before we start writing a datagram. initialPutState :: PutState initialPutState = PutState emptyTargetMap 0 -- | The state\/writer monad we use to serialize messages. type PutMessage = S.StateT PutState PutM () -- | Run an action in the serialization monad, returning a lazy 'ByteString' -- containing the serialized datagram. runPutMessage :: PutMessage -> L.ByteString runPutMessage = runPut . flip S.evalStateT initialPutState -- | Increment the current offset by @n@ bytes. incrOffset :: Offset -> PutMessage incrOffset n = S.modify $ \s -> s { psCurOff = psCurOff s + n } -- | Binary serialization and deserialization of a packet. The entire packet is -- available as context for deserialization, since compressed domain names -- point back into it. (Passing it explicitly is simpler than a ReaderT over -- 'Get', and costs nothing.) class BinaryPacket a where getPacket :: Packet -> Get a putPacket :: a -> PutMessage -------------------------------------------------------------------------------- -- Name compression -- | A byte offset into a datagram. type Offset = Int -- | A tree of labels used as compression targets. The top level represents -- top-level domain names, the second level second-level and so on. Making this -- a newtype triggers a bug in GHC 6.6. data TargetMap = TargetMap !(Map Label (Offset, TargetMap)) deriving Show -- | The empty target map. emptyTargetMap :: TargetMap emptyTargetMap = TargetMap M.empty -- | Given the current offset into a datagram, compress a domain name. Return -- the compressed name and the updated map of compression targets. compressName :: Offset -> DomainName -> TargetMap -> (ByteString, TargetMap) compressName initOff (DomainName labels) = compress Nothing (reverse labels) where compress off lls@(l:ls) targets | Just (off', subTargets) <- lookupZone l targets = let (compressedName, subTargets') = compress (Just off') ls subTargets in (compressedName, insertZone l (off', subTargets') targets) | otherwise = let offs = tail $ scanr (\(Label x) a -> a + 1 + B.length x) initOff lls in (encodeName (reverse lls) off, insertZones (lls `zip` offs) targets) compress off [] targets = (encodeOffset off, targets) insertZones ((l,off):ls) targets = insertZone l (off, insertZones ls emptyTargetMap) targets insertZones [] targets = targets encodeName ls off = B.concat . L.toChunks . runPut $ mapM_ put ls >> putByteString (encodeOffset off) encodeOffset Nothing = B.singleton 0 encodeOffset (Just off) = B.pack . map fromIntegral $ [ptr `shiftR` 8, ptr] where ptr = off .|. 0xc000 lookupZone k (TargetMap targets) = k `M.lookup` targets insertZone k v (TargetMap targets) = TargetMap (M.insert k v targets) -- | Compress a domain name, updating the compression target and current -- offset state. Return the compressed name. compressNameStatefully :: DomainName -> S.StateT PutState PutM ByteString compressNameStatefully name = do s <- S.get let (name', targets) = compressName (psCurOff s) name (psTargets s) S.put $ PutState targets (psCurOff s + B.length name') return name' -------------------------------------------------------------------------------- -- Data types -- | A DNS message containing the header, question, and possibly answers. data Message = Message { -- | A message identifier set by the originator. msgID :: !Word16, -- | Is this message a response? msgQR :: !Bool, -- | The kind of query in this message. msgOpCode :: !OpCode, -- | Is the name server an authority for this domain name? msgAA :: !Bool, -- | Is this a truncated response? msgTC :: !Bool, -- | Does the originator desire the query to be pursued recursively? msgRD :: !Bool, -- | Does the name server support recursive queries? msgRA :: !Bool, -- | Has the data in this response been verified by the name server? msgAD :: !Bool, -- | Is non-verified data acceptable to the resolver sending this query? msgCD :: !Bool, -- | Response code set by the name server. msgRCode :: !RCode, -- | The first question set by the originator. msgQuestion :: !Question, -- | Answers to the question set by the name server. msgAnswers :: ![ResourceRecord], -- | Authority records set by the name server. msgAuthority :: ![ResourceRecord], -- | Additional records set by the name server. msgAdditional :: ![ResourceRecord] } deriving (Eq, Show) instance NFData Message where rnf !msg = msgQuestion msg `deepseq` msgAnswers msg `deepseq` msgAuthority msg `deepseq` msgAdditional msg `deepseq` () instance BinaryPacket Message where getPacket pkt = do i <- get flags <- getWord16be let [qr,aa,tc,rd,ra,ad,cd] = map (testBit flags) [15,10,9,8,7,5,4] opCode = case flags `shiftR` 11 .&. 0xf of 0 -> StandardQuery 1 -> InverseQuery 2 -> ServerStatusRequest _ -> UnknownOpCode (fromIntegral $ flags `shiftR` 11 .&. 0xf) rCode = case flags .&. 0xf of 0 -> NoError 1 -> FormatError 2 -> ServerFailure 3 -> NXDomain 4 -> NotImplemented 5 -> Refused _ -> UnknownRCode (fromIntegral $ flags .&. 0xf) qdCount <- getWord16be anCount <- getWord16be nsCount <- getWord16be arCount <- getWord16be questions <- replicateM (fromIntegral qdCount) (getPacket pkt) question <- case questions of q:_ -> return q [] -> fail "no question" answers <- replicateM (fromIntegral anCount) (getPacket pkt) authority <- replicateM (fromIntegral nsCount) (getPacket pkt) additional <- replicateM (fromIntegral arCount) (getPacket pkt) isEnd <- isEmpty () <- unless isEnd $ fail "unexpected extra bytes after message" return $! Message i qr opCode aa tc rd ra ad cd rCode question answers authority additional putPacket (Message ident qr opCode aa tc rd ra ad cd rCode question answers authority additional) = do lift $ do put ident putWord16be $ flags (opCode' .|. rCode') putWord16be 1 mapM_ (putWord16be . fromIntegral . length) [answers, authority, additional] incrOffset 12 putPacket question mapM_ (mapM_ putPacket) [answers, authority, additional] where flags = List.foldl' (.) id [flip setBit bit | (flag,bit) <- bitFlags, flag] bitFlags = [qr,aa,tc,rd,ra,ad,cd] `zip` [15,10,9,8,7,5,4] opCode' = (`shiftL` 11) $ case opCode of StandardQuery -> 0 InverseQuery -> 1 ServerStatusRequest -> 2 UnknownOpCode c -> fromIntegral c .&. 0xf rCode' = case rCode of NoError -> 0 FormatError -> 1 ServerFailure -> 2 NXDomain -> 3 NotImplemented -> 4 Refused -> 5 UnknownRCode c -> fromIntegral c .&. 0xf -- | A question to the name server. data Question = Question { -- | The domain name this question is about. qName :: !DomainName, -- | The type of this question. We only support 'A' and *. qType :: !Type, -- | The class of this question. We only support 'IN'. qClass :: !Class } deriving (Eq, Show) instance NFData Question where rnf !q = rnf (qName q) instance BinaryPacket Question where getPacket pkt = liftM3 Question (getPacket pkt) get get putPacket (Question name qsType qsClass) = do putPacket name lift $ do put qsType put qsClass incrOffset 4 -- | A resource record. data ResourceRecord -- | A record containing an IPv4 address. = A { -- | The domain name to which this record pertains. rrName :: !DomainName, -- | A time interval, in seconds, that the answer may be cached. rrTTL :: !Word32, -- | An IPv4 address. aAddr :: !HostAddress } -- | An authoritative name server record. | NS { -- | The domain name to which this record pertains. rrName :: !DomainName, -- | A time interval, in seconds, that the answer may be cached. rrTTL :: !Word32, -- | The host that should be authoritative for this zone. nsDName :: !DomainName } -- | A start of zone of authority record. | SOA { -- | The domain name to which this record pertains. rrName :: !DomainName, -- | A time interval, in seconds, that the answer may be cached. rrTTL :: !Word32, -- | The name server that was the original source of data for this zone. soaMName :: !DomainName, -- | A name specifying the email address of the person responsible for -- this zone. soaRName :: !DomainName, -- | The version number of the original copy of this zone. soaSerial :: !Word32, -- | The number of seconds before the zone should be refreshed. soaRefresh :: !Word32, -- | The number of seconds before a failed refresh should be retried. soaRetry :: !Word32, -- | The number of seconds that can elapse before the zone is no longer -- authoritative. soaExpire :: !Word32, -- | The default TTL of records that do not contain a TTL, and the TTL of -- negative responses. soaMinimum :: !Word32 } -- | A record containing one or more character strings. | TXT { -- | The domain name to which this record pertains. rrName :: !DomainName, -- | A time interval, in seconds, that the answer may be cached. rrTTL :: !Word32, -- | The character strings, each at most 255 bytes long. txtStrings :: ![ByteString] } -- | An unsupported record. The EDNS(0) OPT pseudo-record is represented -- this way too. | UnsupportedResourceRecord { -- | The domain name to which this record pertains. rrName :: !DomainName, -- | A time interval, in seconds, that the answer may be cached. rrTTL :: !Word32, -- | The 'Type' of this record. rrType :: !Type, -- | The 'Class' of this record. rrClass :: !Class, -- | An opaque 'ByteString' containing the resource data. rrData :: !ByteString } deriving (Eq, Show) instance NFData ResourceRecord where rnf !rr = rrName rr `deepseq` case rr of A{} -> aAddr rr `deepseq` () NS{} -> nsDName rr `deepseq` () SOA{} -> soaMName rr `deepseq` soaRName rr `deepseq` () TXT{} -> txtStrings rr `deepseq` () _ -> () instance BinaryPacket ResourceRecord where getPacket pkt = do name <- getPacket pkt rType <- get rClass <- get ttl <- get len <- getWord16be begin <- bytesRead rec <- case (rClass, rType) of (IN,TA) -> A name ttl `fmap` get (IN,TTXT) -> TXT name ttl `fmap` getStrings (fromIntegral len) (IN,TNS) -> NS name ttl `fmap` getPacket pkt (IN,TSOA) -> do mName <- getPacket pkt rName <- getPacket pkt serial <- get refresh <- get retry <- get expire <- get minim <- get return $! SOA name ttl mName rName serial refresh retry expire minim _ -> do rData <- getByteString $ fromIntegral len return $! UnsupportedResourceRecord name ttl rType rClass rData end <- bytesRead if end - begin == fromIntegral len then return rec else fail "incorrect rdata length" where getStrings :: Int -> Get [ByteString] getStrings 0 = return [] getStrings n = do l <- getWord8 when (fromIntegral l + 1 > n) $ fail "character string too long" str <- getByteString (fromIntegral l) (str :) `fmap` getStrings (n - 1 - fromIntegral l) putPacket (A name ttl addr) = do putPacket name lift $ put TA >> put IN >> put ttl >> putWord16be 4 >> put addr incrOffset 14 putPacket (NS name ttl dName) = do putPacket name lift $ put TNS >> put IN >> put ttl incrOffset 10 dName' <- compressNameStatefully dName lift $ do putWord16be . fromIntegral . B.length $ dName' putByteString dName' putPacket (SOA name ttl mName rName serial refresh retry expire minim) = do putPacket name lift $ put TSOA >> put IN >> put ttl incrOffset 10 mName' <- compressNameStatefully mName rName' <- compressNameStatefully rName lift $ do putWord16be . fromIntegral $ B.length mName' + B.length rName' + 20 mapM_ putByteString [mName', rName'] mapM_ put [serial, refresh, retry, expire, minim] incrOffset 20 putPacket (TXT name ttl strs) = do putPacket name lift $ do put TTXT >> put IN >> put ttl putWord16be . fromIntegral $ rdLen mapM_ (\s -> putWord8 (fromIntegral $ B.length s) >> putByteString s) strs' incrOffset (10 + rdLen) where strs' = map (B.take 255) strs rdLen = sum $ map ((+ 1) . B.length) strs' -- The wire format is NAME TYPE CLASS TTL RDLENGTH RDATA. putPacket (UnsupportedResourceRecord name ttl rType rClass rData) = do putPacket name lift $ do put rType >> put rClass >> put ttl putWord16be . fromIntegral . B.length $ rData putByteString rData incrOffset (10 + B.length rData) -- | A domain name. newtype DomainName = DomainName [Label] deriving (Eq, Show) instance NFData DomainName where rnf (DomainName ls) = rnf ls instance BinaryPacket DomainName where -- Read a DomainName as a sequence of 'Label's ending with either a null label -- or a pointer to a label in a prior domain name. getPacket (Packet pkt) = do domain <- fmap DomainName . getLabels . fromIntegral =<< bytesRead () <- when (domainLen domain > 255) $ fail "domain name too long" return domain where domainLen (DomainName name) = 1 + sum' (map ((1+) . B.length . unLabel) name) sum' = List.foldl' (+) 0 getLabels p = do len <- lookAhead getWord8 case len of 0 -> skip 1 >> return [] _ | len .&. 0xc0 == 0xc0 -> do ptr <- xor 0xc000 `fmap` getWord16be () <- unless (ptr < p && ptr >= 12) $ fail "invalid name pointer" let priorLen = fromIntegral (p - ptr) -- names can't overlap prior = B.take priorLen . B.drop (fromIntegral ptr) $ pkt case runGetOrFail (getLabels ptr) (L.fromChunks [prior]) of Left (_, _, e) -> fail e Right (_, _, ls) -> return ls | len > 63 -> fail "label too long" | otherwise -> liftM2 (:) get (getLabels p) -- Write a DomainName as a possibly null list of 'Label's terminated by -- either a null label or a pointer to a label from a prior domain name. putPacket = (lift . putByteString =<<) . compressNameStatefully -- | A 'DomainName' is represented as a sequence of labels. newtype Label = Label { unLabel :: ByteString } deriving (Eq, Ord, Show) instance NFData Label where rnf = rwhnf instance Binary Label where get = do len <- getWord8 Label `fmap` getByteString (fromIntegral len) put (Label label) = do putWord8 . fromIntegral . B.length $ label putByteString label -- | A response code set by the name server. data RCode = NoError -- ^ No error condition. | FormatError -- ^ The name server was unable to interpret the query. | ServerFailure -- ^ The name server was unable to process this query due -- to a problem with the name server. | NXDomain -- ^ The domain name referenced in the query does not exist. | NotImplemented -- ^ The name server does not support the requested -- kind of query. | Refused -- ^ The name server refuses to perform the specified -- operation for policy reasons. | UnknownRCode !Word8 -- ^ Any other response code. deriving (Eq, Show) instance NFData RCode where rnf = rwhnf -- | Specifies the kind of query in a message set by the originator. data OpCode = StandardQuery -- ^ A standard query. We only support this opcode. | InverseQuery -- ^ An inverse query. (obsolete) | ServerStatusRequest -- ^ A server status request. | UnknownOpCode !Word8 -- ^ Any other opcode (e.g. NOTIFY or UPDATE). deriving (Eq, Show) instance NFData OpCode where rnf = rwhnf -- | The TYPE or QTYPE values that appear in resource records or questions, -- respectively. data Type = TA -- ^ An IPv4 host address. | TNS -- ^ An authoritative name server. | TSOA -- ^ A start of zone of authority. | TTXT -- ^ Text strings. | TOPT -- ^ The EDNS(0) OPT pseudo-record. | TAny -- ^ A request for all records. | UnsupportedType !Word16 -- ^ Any other type. deriving (Eq, Show) instance NFData Type where rnf = rwhnf instance Binary Type where get = do t <- get case t of 1 -> return TA 2 -> return TNS 6 -> return TSOA 16 -> return TTXT 41 -> return TOPT 255 -> return TAny _ -> return $ UnsupportedType t put TA = putWord16be 1 put TNS = putWord16be 2 put TSOA = putWord16be 6 put TTXT = putWord16be 16 put TOPT = putWord16be 41 put TAny = putWord16be 255 put (UnsupportedType t) = put t -- | The CLASS or QCLASS values that appear in resource records or questions, -- respectively. data Class = IN -- ^ The Internet. We only support this class. | AnyClass -- ^ QCLASS * (255), a request for any class. | UnsupportedClass !Word16 -- ^ Any other class. deriving (Eq, Show) instance NFData Class where rnf = rwhnf instance Binary Class where get = do c <- get case c of 1 -> return IN 255 -> return AnyClass _ -> return $ UnsupportedClass c put IN = putWord16be 1 put AnyClass = putWord16be 255 put (UnsupportedClass c) = put c -------------------------------------------------------------------------------- -- EDNS(0) -- | The EDNS(0) information carried by an OPT pseudo-record (RFC 6891). data EDNS = EDNS { ednsPayloadSize :: !Word16 -- ^ The requestor's UDP payload size. , ednsExtRCode :: !Word8 -- ^ Upper 8 bits of the extended RCODE. , ednsVersion :: !Word8 -- ^ The EDNS version. , ednsDO :: !Bool -- ^ The DNSSEC OK bit. -- | The options, as (code, data), or 'Nothing' if they are malformed. , ednsOptions :: !(Maybe [(Word16, ByteString)]) } deriving (Eq, Show) -- | Find the EDNS information in a message's additional section, if any. findEDNS :: Message -> Maybe EDNS findEDNS msg = case [rr | rr@UnsupportedResourceRecord{rrType = TOPT} <- msgAdditional msg] of UnsupportedResourceRecord _ ttl _ cls rdata : _ -> Just $! EDNS (classValue cls) (fromIntegral $ ttl `shiftR` 24) (fromIntegral $ ttl `shiftR` 16) (testBit ttl 15) (parseEDNSOptions rdata) _ -> Nothing where classValue IN = 1 classValue AnyClass = 255 classValue (UnsupportedClass c) = c -- | Split the RDATA of an OPT record into options: each is a 16-bit code, a -- 16-bit length and that many bytes of data. parseEDNSOptions :: ByteString -> Maybe [(Word16, ByteString)] parseEDNSOptions bs | B.null bs = Just [] | B.length bs < 4 = Nothing | B.length rest < len = Nothing | otherwise = ((code, B.take len rest) :) `fmap` parseEDNSOptions (B.drop len rest) where code = word16 0 len = fromIntegral (word16 2) :: Int rest = B.drop 4 bs word16 :: Int -> Word16 word16 i = fromIntegral (B.index bs i) `shiftL` 8 .|. fromIntegral (B.index bs (i + 1)) -- | The RDATA of an OPT record carrying the given options. renderEDNSOptions :: [(Word16, ByteString)] -> ByteString renderEDNSOptions = B.concat . concatMap render where render (code, d) = [word16 code, word16 (fromIntegral $ B.length d), d] word16 :: Word16 -> ByteString word16 w = B.pack [fromIntegral (w `shiftR` 8), fromIntegral w] -- | An OPT pseudo-record advertising our UDP payload size, carrying the given -- extended RCODE bits and options and echoing the DO bit (RFC 3225). ednsRecord :: Word8 -> Bool -> [(Word16, ByteString)] -> ResourceRecord ednsRecord extRCode dnssecOK options = UnsupportedResourceRecord (DomainName []) ttl TOPT (UnsupportedClass ednsUDPSize) (renderEDNSOptions options) where ttl = (fromIntegral extRCode `shiftL` 24) .|. (if dnssecOK then 0x8000 else 0) -- | The UDP payload size we advertise. 1232 bytes avoids IP fragmentation on -- practically all paths (DNS Flag Day 2020). ednsUDPSize :: Word16 ednsUDPSize = 1232 -- | The EDNS option code of the client subnet option. clientSubnetOption :: Word16 clientSubnetOption = 8 -- | The client subnet option (RFC 7871): a resolver tells us the network of -- the client it's asking for. data ClientSubnet = ClientSubnet { csFamily :: !Word16 -- ^ 1 for IPv4, 2 for IPv6. , csSourcePrefix :: !Word8 -- ^ How many leading bits of the address. , csScopePrefix :: !Word8 -- ^ How many the answer depends on. , csAddress :: !ByteString -- ^ The leading bytes of the address. } deriving (Eq, Show) -- | Parse the data of a client subnet option. Return 'Nothing' for anything -- RFC 7871 (section 7.1.1) says to answer with FORMERR: an unknown family, a -- prefix longer than the address, an address of the wrong length or with -- bits set beyond the prefix, or a non-zero scope in a query. parseClientSubnet :: ByteString -> Maybe ClientSubnet parseClientSubnet bs | B.length bs < 4 = Nothing | family `notElem` [1, 2] = Nothing | fromIntegral source > maxBits = Nothing | scope /= 0 = Nothing | B.length addr /= (fromIntegral source + 7) `div` 8 = Nothing | not (B.null addr), source `mod` 8 /= 0 , B.last addr .&. (0xff `shiftR` fromIntegral (source `mod` 8)) /= 0 = Nothing | otherwise = Just $! ClientSubnet family source scope addr where family = fromIntegral (B.index bs 0) `shiftL` 8 .|. fromIntegral (B.index bs 1) source = B.index bs 2 scope = B.index bs 3 addr = B.drop 4 bs maxBits = if family == 1 then 32 else 128 :: Int -- | The data of a client subnet option. renderClientSubnet :: ClientSubnet -> ByteString renderClientSubnet (ClientSubnet family source scope addr) = B.concat [ B.pack [ fromIntegral (family `shiftR` 8), fromIntegral family , source, scope ] , addr ] -- | The IPv4 address of an IPv4 client subnet, with the bits beyond the -- prefix zero. clientSubnetIPv4 :: ClientSubnet -> Maybe HostAddress clientSubnetIPv4 cs | csFamily cs == 1 = Just . List.foldl' (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 . B.unpack . B.take 4 $ csAddress cs `B.append` B.replicate 4 0 | otherwise = Nothing -- | The extended RCODE BADVERS (16), split into the 4 bits carried in the -- header and the 8 bits carried in the OPT record. badVersRCode :: (RCode, Word8) badVersRCode = (NoError, 1) mhatta-tordnsel-1d9141b/src/TorDNSEL/DNS/Server.hs000066400000000000000000000012231527317632400215260ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.DNS.Server -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards) -- -- Implements a DNS server thread that answers DNS queries for exit list -- information. -- ----------------------------------------------------------------------------- module TorDNSEL.DNS.Server ( DNSConfig(..) , ResponseType(..) , DNSServer , startDNSServer , reconfigureDNSServer , terminateDNSServer , ttl ) where import TorDNSEL.DNS.Server.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/DNS/Server/000077500000000000000000000000001527317632400211745ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/DNS/Server/Internals.hs000066400000000000000000000714251527317632400235000ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.DNS.Server.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards, GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- Implements a DNS server thread that answers DNS queries for exit list -- information, as described in @doc/torel-design.md@: -- -- [Query type 1, \"ip-port\"] -- @{IP1}.{port}.{IP2}.ip-port.{zone}@ is listed iff {IP1} is a Tor exit -- that permits connections to {port} on {IP2}. -- -- [Query type 2, \"list\"] -- @{IP}.{listname}.list.{zone}@ is listed iff {IP} is a Tor exit that -- permits connections to any member of the operator-configured list -- {listname}. -- -- [Query type 0, \"exit\"] -- @{IP}.{zone}@ is listed iff {IP} is a Tor exit (one whose exit policy -- permits connections somewhere). This is the form of the Tor Project's -- own exit list service; TXT records give the relays' fingerprints. -- -- [Query type 3, \"me\"] -- @{IP}.{port}.me.{zone}@ is listed iff {IP} is a Tor exit that permits -- connections to {port} on the host that sent the query. Because the answer -- depends on who asks, it is sent with a TTL of zero so that resolvers -- don't hand it to other clients. -- -- Listed names have an A record of 127.0.0.2 and a TXT record explaining the -- listing. Unlisted names are NXDOMAIN; names that are a proper prefix of a -- valid query exist as empty non-terminals (NOERROR with no data), which keeps -- resolvers using QNAME minimisation (RFC 9156) working. -- -- Queries are answered over UDP and TCP (RFC 7766). Over UDP, responses can -- be rate limited per client network ('rateLimit'). -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.DNS.Server.Internals where import Prelude hiding (log) import qualified Control.Exception as E import Control.Monad (when, guard, forever) import Data.Bits ((.|.), (.&.), shiftL) import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef') import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import Data.Char (toLower, toUpper, isDigit) import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (isJust, isNothing) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Data.Word (Word32) import Network.Socket (Socket, HostAddress, SockAddr(..), accept) import Control.Concurrent (threadDelay) import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.DNS import TorDNSEL.Directory (encodeBase16RouterID) import TorDNSEL.ExitList import TorDNSEL.Log import TorDNSEL.NetworkState import TorDNSEL.NetworkState.Types import TorDNSEL.Util -- | The DNS server configuration. data DNSConfig = DNSConfig { dnsSocket :: !Socket -- ^ The server's bound UDP socket. , dnsTCPSocket :: !Socket -- ^ The server's listening TCP socket. , dnsAuthZone :: !DomainName -- ^ The zone we're authoritative for. , dnsMyName :: !DomainName -- ^ The domain name where we're located. , dnsSOA :: !ResourceRecord -- ^ Our SOA record. , dnsNS :: !ResourceRecord -- ^ Our own NS record. -- | The A record we return for our authoritative zone. , dnsA :: !(Maybe ResourceRecord) -- | Operator-configured lists of destinations for \"list\" queries. , dnsLists :: !NamedLists -- | Responses per second allowed over UDP to each client network, or 0 -- for no limit (see 'rateLimit'). , dnsRateLimit :: !Int -- | Answer \"me\" queries about the client subnet a resolver gives us -- (RFC 7871) rather than about the resolver. , dnsClientSubnet :: !Bool -- | An action invoked with bytes received and sent for recording statistics. , dnsByteStats :: !(Int -> Int -> IO ()) -- | A statistics tracking action invoked with each response. , dnsRespStats :: !(ResponseType -> IO ()) } instance Eq DNSConfig where x == y = all (\(===) -> x === y) [ eq dnsSocket, eq dnsTCPSocket, eq dnsAuthZone, eq dnsMyName, eq dnsSOA , eq dnsNS, eq dnsA, eq dnsLists, eq dnsRateLimit, eq dnsClientSubnet ] where eq :: Eq b => (a -> b) -> a -> a -> Bool eq = on (==) -- | The response type reported in statistics. 'Positive' and 'Negative' are for -- valid DNSEL queries. -- 'Limited' counts queries we didn't answer fully because of the rate -- limit (truncated or dropped). data ResponseType = Positive | Negative | Other | Limited -- | A handle to the DNS server. newtype DNSServer = DNSServer ThreadId instance Thread DNSServer where threadId (DNSServer tid) = tid -- | An internal type for messages sent to the DNS server thread. data DNSMessage = Reconfigure (DNSConfig -> DNSConfig) (IO ()) -- ^ Reconfigure the DNS server | Terminate ExitReason -- ^ Terminate the DNS server gracefully -- This is to please the Exception instance. instance Show DNSMessage where showsPrec _ (Terminate a) = ("Terminate " ++) . shows a showsPrec _ (Reconfigure _ _) = ("Reconfigure" ++) instance E.Exception DNSMessage -- | Given an initial 'DNSConfig', start the DNS server and return a handle to -- it. Link the DNS server to the calling thread. startDNSServer :: DNSConfig -> IO DNSServer startDNSServer initConf = do log Info "Starting DNS server." limiter <- newIORef emptyRateLimiter fmap DNSServer . forkLinkIO $ E.mask $ \restore -> loop limiter restore initConf where loop :: IORef RateLimiter -> (forall a. IO a -> IO a) -> DNSConfig -> IO () loop limiter restore conf = do -- The TCP server runs in its own thread for the current config, and is -- restarted whenever we're reconfigured. tcp <- forkIO . restore $ runTCPServer restore conf r <- E.tryJust fromExitSignal . restore $ runServer (dnsSocket conf) (dnsByteStats conf) (dnsUDPHandler limiter conf) killThread tcp case r of Left (_,Reconfigure reconf signal) -> do let newConf = reconf conf when (conf /= newConf) $ log Notice "Reconfiguring DNS server." when (dnsSocket conf /= dnsSocket newConf) $ closeSocket $ dnsSocket conf when (dnsTCPSocket conf /= dnsTCPSocket newConf) $ closeSocket $ dnsTCPSocket conf signal loop limiter restore newConf Left (_,Terminate reason) -> do log Info "Terminating DNS server." exit reason Right _ -> loop limiter restore conf -- impossible -- | Reconfigure the DNS server synchronously with the given function. If the -- server exits abnormally before reconfiguring itself, throw its exit signal in -- the calling thread. reconfigureDNSServer :: (DNSConfig -> DNSConfig) -> DNSServer -> IO () reconfigureDNSServer reconf (DNSServer tid) = sendSyncMessage (throwTo tid . exitReason . Reconfigure reconf) tid -- | Terminate the DNS server gracefully. The optional parameter specifies the -- amount of time in microseconds to wait for the thread to terminate. If the -- thread hasn't terminated by the timeout, an uncatchable exit signal will be -- sent. terminateDNSServer :: Maybe Int -> DNSServer -> IO () terminateDNSServer mbWait (DNSServer tid) = terminateThread mbWait tid (throwTo tid $ exitReason $ Terminate NormalExit) -- | Accept connections on the TCP socket and serve each in its own thread -- ('serveTCPConnection'): at most 'maxTCPConnections' at a time, and at most -- 'maxTCPConnectionsPerNetwork' from one client network (as for 'rateKey'), -- so that one client can't take them all. Connections beyond that are closed -- right away; clients will retry. Connections are closed after -- 'maxTCPQueriesPerConnection' queries, or when idle for 'tcpIdleTimeout', or -- only 'tcpBusyIdleTimeout' when more than half the connections are in use -- (RFC 7766, section 6.2.3). runTCPServer :: (forall a. IO a -> IO a) -> DNSConfig -> IO () runTCPServer restore conf = do active <- newIORef (0 :: Int, M.empty :: M.Map RateKey Int) let reserve key = atomicModifyIORef' active $ \(n, perNet) -> let k = M.findWithDefault 0 key perNet in if n >= maxTCPConnections || k >= maxTCPConnectionsPerNetwork then ((n, perNet), False) else ((n + 1, M.insert key (k + 1) perNet), True) release key = atomicModifyIORef' active $ \(n, perNet) -> ((n - 1, M.update (\k -> if k <= 1 then Nothing else Just (k - 1)) key perNet), ()) idle = do (n, _) <- readIORef active return $ if 2 * n > maxTCPConnections then tcpBusyIdleTimeout else tcpIdleTimeout forever $ do r <- E.try . accept $ dnsTCPSocket conf case r of -- E.g. too many open files. Don't spin. Left (e :: E.IOException) -> do log Warn "Accepting a DNS connection over TCP failed: " e threadDelay 1000000 Right (sock, addr) -> do let key = rateKey addr ok <- reserve key if not ok then closeSocket sock else do let done = closeSocket sock >> release key serve = serveTCPConnection sock addr idle maxTCPQueriesPerConnection (dnsByteStats conf) (dnsHandler conf) _ <- forkIO (restore (ignoreErrors serve) `E.finally` done) `E.onException` done return () where -- A connection that fails (e.g. the client resets it) concerns no-one -- else. ignoreErrors io = io `E.catch` \(_ :: E.IOException) -> return () -- | How many DNS over TCP connections we serve at the same time. maxTCPConnections :: Int maxTCPConnections = 128 -- | How many of them may come from one client network. maxTCPConnectionsPerNetwork :: Int maxTCPConnectionsPerNetwork = 8 -- | How many queries we answer on one connection before closing it. maxTCPQueriesPerConnection :: Int maxTCPQueriesPerConnection = 100 -- | How long, in microseconds, a DNS over TCP connection may be idle. tcpIdleTimeout :: Int tcpIdleTimeout = 10 * 1000000 -- | ... and when more than half of the connections are in use. tcpBusyIdleTimeout :: Int tcpBusyIdleTimeout = 2 * 1000000 -- | 'dnsHandler' with the per-client rate limit applied, for UDP. dnsUDPHandler :: IORef RateLimiter -> DNSConfig -> SockAddr -> Message -> IO (Maybe Message) dnsUDPHandler limiter conf src msg | dnsRateLimit conf <= 0 || msgQR msg || isLoopback src = dnsHandler conf src msg | otherwise = do now <- getPOSIXTime decision <- atomicModifyIORef' limiter $ \rl -> let (d, rl') = rateLimit (dnsRateLimit conf) now src rl in (rl', d) case decision of Allow -> dnsHandler conf src msg -- A truncated response makes a real client retry over TCP, which -- can't be spoofed; it's no bigger than the query. Slip -> do dnsRespStats conf Limited return . Just . truncateMessage $ msg { msgQR = True, msgAA = False, msgRA = False , msgAD = False, msgAdditional = [] } Drop -> dnsRespStats conf Limited >> return Nothing -- | A stateful wrapper for 'dnsResponse'. dnsHandler :: DNSConfig -> SockAddr -> Message -> IO (Maybe Message) {-# INLINE dnsHandler #-} dnsHandler conf src msg -- draft-arends-dnsext-qr-clarification-00 | msgQR msg = return Nothing | otherwise = do now <- getPOSIXTime ns <- readNetworkState let (typ,resp) = dnsResponse conf src msg now ns dnsRespStats conf typ return $ Just resp -- | Given our config data, the address a query came from and the query itself, -- parse the exit list query contained therein and generate an appropriate DNS -- response based on our knowledge of the current state of the Tor network. dnsResponse :: DNSConfig -> SockAddr -> Message -> POSIXTime -> NetworkState -> (ResponseType, Message) {-# INLINE dnsResponse #-} dnsResponse c src msg now ns = withEDNS $ case () of _ | msgOpCode msg /= StandardQuery -- RFC 3425 -> (Other, r { msgAA = False, msgRCode = NotImplemented , msgAnswers = [], msgAuthority = [dnsSOA c] }) -- RFC 6891: we only speak EDNS version 0 | Just e <- edns, ednsVersion e > 0 -> (Other, r { msgAA = False, msgRCode = fst badVersRCode , msgAnswers = [], msgAuthority = [] }) -- malformed EDNS options (RFC 6891, section 7) or client subnet option -- (RFC 7871, section 7.1.1) | Just e <- edns, isNothing (ednsOptions e) || badSubnet -> (Other, r { msgAA = False, msgRCode = FormatError , msgAnswers = [], msgAuthority = [] }) -- draft-koch-dns-unsolicited-queries-01 | isNothing mbQLabels -> (Other, r { msgAA = False, msgRCode = Refused , msgAnswers = [], msgAuthority = [dnsSOA c] }) -- Our data is all in class IN; QCLASS * asks for that too. | qc /= IN, qc /= AnyClass -> (Other, nxDomain soa) -- a request matching our authoritative zone | Just [] <- mbQLabels -> case qt of TA | Just a <- dnsA c -> (Other, noErr { msgAnswers = [a], msgAuthority = [dnsNS c] }) TNS -> (Other, noErr { msgAnswers = [dnsNS c], msgAuthority = [] }) TSOA -> (Other, noErr { msgAnswers = [dnsSOA c] , msgAuthority = [dnsNS c] }) -- RFC 8482: answer ANY with one RRset, not all of them, so that -- ANY queries can't be used to amplify a flood. TAny -> (Other, noErr { msgAnswers = [dnsSOA c] , msgAuthority = [dnsNS c] }) _ -> (Other, emptyAnswer soa) | Just qLabels <- mbQLabels -> case parseExitListQuery (dnsLists c) qLabels of -- an empty non-terminal on the way to a valid query PartialQuery -> (Other, emptyAnswer soa) NoSuchName -> (Other, nxDomain soa) FullQuery query | isListed query -> positive query | otherwise -> (Negative, nxDomain (soaFor query)) | otherwise -> (Other, nxDomain soa) -- impossible where edns = findEDNS msg withEDNS (typ,resp) = case edns of Nothing -> (typ, resp) Just e -> (typ, resp { msgAdditional = [ednsRecord ext (ednsDO e) subnetReply] }) where ext | ednsVersion e > 0 = snd badVersRCode | otherwise = 0 -- The client subnet option (RFC 7871). A "me" query is about the client -- the resolver asks for, so its answer depends on the subnet, which we -- say with a scope equal to the source prefix; other answers don't -- depend on it (scope 0). subnetData = edns >>= ednsOptions >>= lookup clientSubnetOption subnet = subnetData >>= parseClientSubnet badSubnet = isJust subnetData && isNothing subnet useSubnet q = dnsClientSubnet c && isMeQuery q && isJust subnet subnetReply = case subnet of Just cs | rCodeOK -> [(clientSubnetOption, renderClientSubnet cs { csScopePrefix = if usedSubnet then csSourcePrefix cs else 0 })] _ -> [] rCodeOK = not badSubnet usedSubnet = case mbQLabels >>= Just . parseExitListQuery (dnsLists c) of Just (FullQuery q) -> useSubnet q _ -> False -- The IPv4 address the destination of a "me" query is, if any: the -- client subnet's address if we use it, otherwise the asker's. requester q | useSubnet q = subnet >>= clientSubnetIPv4 | otherwise = requesterIPv4 src isListed q = queryAddr q == testAddress || maybe False (isExitTo now ns (queryAddr q)) (queryDestination (dnsLists c) (requester q) q) positive q | qt `elem` [TA, TTXT, TAny] = (Positive, noErr { msgAnswers = [rr | (t,rr) <- records, wanted t] , msgAuthority = [dnsNS c] }) -- RFC 2308 | otherwise = (Positive, emptyAnswer (soaFor q)) where records = [ (TA, A name (ttlFor q) testAddress) , (TTXT, TXT name (ttlFor q) (txtFor q)) ] -- RFC 8482: ANY gets the A record alone, which is what a DNSBL -- client wants; the TXT record (fingerprints) can be large. wanted t = qt == t || (qt == TAny && t == TA) -- Like the Tor Project's service, "exit" queries are explained by the -- fingerprints of the exits (upper case hex). txtFor q@(IPExit a) | fps@(_:_) <- exitFingerprints now ns a anyDestination = map (B.map toUpper . encodeBase16RouterID) fps | otherwise = [explainListing q] txtFor q = [explainListing q] -- Answers to "me" queries depend on the asker, so they mustn't be cached, -- not even negatively (RFC 2308 uses the SOA's TTL and MINIMUM). ttlFor q | isMeQuery q = 0 | otherwise = ttl soaFor q | isMeQuery q = uncacheable soa | otherwise = soa uncacheable (SOA n _ m rn se re rt ex _) = SOA n 0 m rn se re rt ex 0 uncacheable rr = rr soa = dnsSOA c mbQLabels = dropAuthZone (dnsAuthZone c) name noErr = r { msgAA = True, msgRCode = NoError } emptyAnswer s = noErr { msgAnswers = [], msgAuthority = [s] } nxDomain s = r { msgAA = True, msgRCode = NXDomain, msgAnswers = [] , msgAuthority = [s] } r = msg { msgQR = True, msgTC = False, msgRA = False, msgAD = False , msgAdditional = [] } question = msgQuestion msg name = qName question (qt,qc) = (qType question, qClass question) -- | Given @authZone@, a sequence of labels ordered from top to bottom -- representing our authoritative zone, return @Just labels@ if @name@ is a -- subdomain of @authZone@, where @labels@ is the lower part of @name@ ordered -- from top to bottom. Otherwise, return Nothing. -- -- For example: -- -- > dropAuthZone \"com.example.torhosts\" -- > \"1.0.0.10.80.4.3.2.1.ip-port.torhosts.example.com\" -- -- would return -- -- > Just \"ip-port.1.2.3.4.80.10.0.0.1\" dropAuthZone :: DomainName -> DomainName -> Maybe [Label] {-# INLINE dropAuthZone #-} dropAuthZone (DomainName authZone) (DomainName name) = dropAuthZone' authZone (reverse name) where dropAuthZone' (Label x:xs) (Label y:ys) | x == B.map toLower y = dropAuthZone' xs ys dropAuthZone' [] ys = Just ys dropAuthZone' _ _ = Nothing -------------------------------------------------------------------------------- -- Exit list queries -- | Queries asking whether there's a Tor exit node at a specific IP address. data ExitListQuery -- | Query type 1 from @doc/torel-design.md@: -- @{IP1}.{port}.{IP2}.ip-port.{zone}@. = IPPort { -- | The address of the candidate exit node. queryAddr :: !HostAddress, -- | The destination address. destAddr :: !HostAddress, -- | The destination port. destPort :: !Port } -- | Query type 2: @{IP}.{listname}.list.{zone}@. | IPList { queryAddr :: !HostAddress, -- | The name of the configured destination list. listName :: !ListName } -- | Query type 3: @{IP}.{port}.me.{zone}@. The destination address is the -- address the query came from. | IPMe { queryAddr :: !HostAddress, destPort :: !Port } -- | @{IP}.{zone}@: is the address a Tor exit at all? Compatible with the -- Tor Project's exit list service. | IPExit { queryAddr :: !HostAddress } deriving Eq instance Show ExitListQuery where showsPrec _ (IPPort qAddr dAddr dPort) = cat "query ip: " (inet_htoa qAddr) " dest ip: " (inet_htoa dAddr) " dest port: " dPort showsPrec _ (IPList qAddr name) = cat "query ip: " (inet_htoa qAddr) " list: " name showsPrec _ (IPMe qAddr dPort) = cat "query ip: " (inet_htoa qAddr) " dest: requester port: " dPort showsPrec _ (IPExit qAddr) = cat "query ip: " (inet_htoa qAddr) " dest: anywhere" -- | The result of parsing the part of a query name below our zone. data ParsedQuery = FullQuery !ExitListQuery -- ^ A complete exit list query. | PartialQuery -- ^ A proper prefix of a possible query. | NoSuchName -- ^ Neither. deriving (Eq, Show) -- | Is this a query whose answer depends on who is asking? isMeQuery :: ExitListQuery -> Bool isMeQuery IPMe{} = True isMeQuery _ = False -- | The address used to test DNSBL configurations (RFC 5782, section 5). -- It is always listed. testAddress :: HostAddress testAddress = 0x7f000002 -- | The destination a query asks about, given the configured lists and the -- IPv4 address of the host a \"me\" query is about. 'Nothing' means no Tor -- exit node can reach the destination: an unknown list, or a \"me\" query -- about an IPv6 host (we only have exit policies for IPv4). queryDestination :: NamedLists -> Maybe HostAddress -> ExitListQuery -> Maybe Destination queryDestination _ _ (IPPort _ dAddr dPort) = Just $ DestAddrPort dAddr dPort queryDestination lists _ (IPList _ name) = DestAnyOf `fmap` M.lookup name lists queryDestination _ _ (IPExit _) = Just anyDestination queryDestination _ me (IPMe _ dPort) = (`DestAddrPort` dPort) `fmap` me -- | The IPv4 address of the host a query came from, if it has one. requesterIPv4 :: SockAddr -> Maybe HostAddress requesterIPv4 (SockAddrInet _ addr) = Just (ntohl addr) requesterIPv4 (SockAddrInet6 _ _ (0, 0, 0xffff, addr) _) = Just addr requesterIPv4 _ = Nothing -- | A short human-readable explanation of a positive answer, returned in TXT -- records (RFC 5782, section 2.1). explainListing :: ExitListQuery -> ByteString explainListing q = B.pack $ case q of IPPort a d p -> inet_htoa a ++ " is a Tor exit node permitting connections \ \to " ++ inet_htoa d ++ ":" ++ show p IPList a n -> inet_htoa a ++ " is a Tor exit node permitting connections \ \to list " ++ B.unpack n IPMe a p -> inet_htoa a ++ " is a Tor exit node permitting connections \ \to port " ++ show p ++ " of the querying host" IPExit a -> inet_htoa a ++ " is a Tor exit node" -- | Parse an exit list query from a sequence of labels ordered from top to -- bottom representing the query portion of a domain name, e.g. -- @\"ip-port.{IP2}.{port}.{IP1}\"@. Prefixes of valid queries are recognised -- so that they can be answered as empty non-terminals. parseExitListQuery :: NamedLists -> [Label] -> ParsedQuery parseExitListQuery lists labels = case map (B.map toLower . unLabel) labels of [] -> PartialQuery typ : rest | typ == B.pack "ip-port" -> parseWith [octet, octet, octet, octet, port, octet, octet, octet, octet] ipPort rest | typ == B.pack "list", not (M.null lists) -> parseWith [listLabel, octet, octet, octet, octet] ipList rest | typ == B.pack "me" -> parseWith [port, octet, octet, octet, octet] ipMe rest -- {IP}.{zone}: the labels from the top are the address in the usual order | octet typ -> parseWith [octet, octet, octet, octet] ipExit (typ : rest) _ -> NoSuchName where parseWith fields mk xs | length xs > length fields = NoSuchName | not . and $ zipWith ($) fields xs = NoSuchName | length xs < length fields = PartialQuery | otherwise = maybe NoSuchName FullQuery (mk xs) ipPort [a,b,c,d,p,e,f,g,h] = IPPort `fmap` toAddress [e,f,g,h] `ap'` toAddress [a,b,c,d] `ap'` toPort p ipPort _ = Nothing ipList [n,a,b,c,d] = (`IPList` n) `fmap` toAddress [a,b,c,d] ipList _ = Nothing ipMe [p,a,b,c,d] = IPMe `fmap` toAddress [a,b,c,d] `ap'` toPort p ipMe _ = Nothing ipExit [a,b,c,d] = IPExit `fmap` toAddress [a,b,c,d] ipExit _ = Nothing ap' mf mx = do { f <- mf; x <- mx; return (f x) } octet bs = isDecimal 3 bs && maybe False (<= 255) (readDecimal bs) port bs = isDecimal 5 bs && maybe False (<= 65535) (readDecimal bs) listLabel n = n `M.member` lists isDecimal maxLen bs = not (B.null bs) && B.length bs <= maxLen && B.all isDigit bs readDecimal bs = case B.readInt bs of Just (n,rest) | B.null rest -> Just n _ -> Nothing toPort bs = fromIntegral `fmap` (guard (port bs) >> readDecimal bs) toAddress xs = do os <- mapM readDecimal xs guard $ all (<= 255) os return $! L.foldl' (.|.) 0 . zipWith shiftL (map fromIntegral os) $ [24,16..] -- | The time-to-live set for caching. ttl :: Word32 ttl = 30 * 60 -------------------------------------------------------------------------------- -- Rate limiting -- | What to do with a query from a client that may be over its rate limit. data RateDecision = Allow -- ^ Answer it. | Slip -- ^ Send a truncated response, so that a real client retries -- over TCP. | Drop -- ^ Don't answer. deriving (Eq, Show) -- | The clients we've seen recently: a token bucket per client network. data RateLimiter = RateLimiter { rlBuckets :: !(M.Map RateKey Bucket) , rlLastPurge :: !POSIXTime -- | Queries refused because we track too many networks already. , rlOverflow :: !Int } -- | A client network: an IPv4 /24 or an IPv6 /56. Rate limiting by network -- rather than by address stops an attacker from spreading spoofed queries -- over neighbouring addresses, as other response rate limiting schemes do. data RateKey = Net4 !Word32 | Net6 !Word32 !Word32 deriving (Eq, Ord, Show) -- | Tokens left, when they were last counted, and how many queries have been -- refused since then. data Bucket = Bucket !Double !POSIXTime !Int deriving Show -- | No clients seen. emptyRateLimiter :: RateLimiter emptyRateLimiter = RateLimiter M.empty 0 0 -- | The most client networks we keep track of. Queries spoofed from random -- networks could otherwise make the state grow with the query rate. While we -- track this many, queries from other networks are treated as over their -- limit (so every second one still gets a truncated response). maxRateBuckets :: Int maxRateBuckets = 100000 -- | Given the number of responses per second allowed to each client network, -- the current time and a query's source, decide what to do with the query. -- -- Each network may send bursts of up to @rate@ queries and @rate@ queries per -- second on average. Of the queries over the limit, every second one is -- answered with a truncated response ('Slip') and the rest are dropped: a -- spoofed flood is then reflected at a fraction of its own size, while real -- clients still get through over TCP (cf. BIND's RRL "slip 2"). rateLimit :: Int -> POSIXTime -> SockAddr -> RateLimiter -> (RateDecision, RateLimiter) rateLimit = rateLimitWith maxRateBuckets -- | 'rateLimit' tracking at most the given number of networks. rateLimitWith :: Int -> Int -> POSIXTime -> SockAddr -> RateLimiter -> (RateDecision, RateLimiter) rateLimitWith maxBuckets rate now src (RateLimiter buckets lastPurge overflow) | not (key `M.member` buckets'), M.size buckets' >= maxBuckets = ( if even overflow then Slip else Drop , RateLimiter buckets' lastPurge' (overflow + 1) ) | otherwise = (decision, RateLimiter (M.insert key bucket' buckets') lastPurge' overflow) where rate' = fromIntegral rate :: Double key = rateKey src Bucket tokens _ refused = refill now $ M.findWithDefault (Bucket rate' now 0) key buckets (decision, bucket') | tokens >= 1 = (Allow, Bucket (tokens - 1) now refused) | even refused = (Slip, Bucket tokens now (refused + 1)) | otherwise = (Drop, Bucket tokens now (refused + 1)) refill t (Bucket k t0 n) = Bucket (min rate' (k + rate' * realToFrac (t - t0))) t n -- Forget networks whose buckets are full again, at most once a second. (buckets', lastPurge') | now - lastPurge >= 1 = (M.filter (\b -> not (full (refill now b))) buckets, now) | otherwise = (buckets, lastPurge) full (Bucket k _ _) = k >= rate' -- | Queries over loopback can't be spoofed from outside the host (the kernel -- drops such packets), and often come from a local resolver serving many -- clients: don't rate limit them. isLoopback :: SockAddr -> Bool isLoopback (SockAddrInet _ addr) = ntohl addr .&. 0xff000000 == 0x7f000000 isLoopback (SockAddrInet6 _ _ (0, 0, 0, 1) _) = True isLoopback (SockAddrInet6 _ _ (0, 0, 0xffff, a) _) = a .&. 0xff000000 == 0x7f000000 isLoopback _ = False -- | The client network an address belongs to. rateKey :: SockAddr -> RateKey rateKey (SockAddrInet _ addr) = Net4 (ntohl addr .&. 0xffffff00) rateKey (SockAddrInet6 _ _ (a, b, _, _) _) = Net6 a (b .&. 0xffffff00) rateKey _ = Net4 0 mhatta-tordnsel-1d9141b/src/TorDNSEL/Directory.hs000066400000000000000000000021301527317632400215760ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Directory -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards, type synonym instances, -- GHC primitives) -- -- Parsing and processing router descriptors, exit policies, and router -- status entries from the Tor directory protocol, version 2. We only -- parse information necessary for running the exit list server. -- -- See for details. -- ----------------------------------------------------------------------------- module TorDNSEL.Directory ( -- * Router descriptors Descriptor(..) , parseDescriptor , parseDescriptors -- * Router status entries , RouterStatus(..) , parseRouterStatus , parseRouterStatuses -- * Router identifiers , RouterID , decodeBase16RouterID , encodeBase16RouterID -- * Exit policies , ExitPolicy , exitPolicyAccepts ) where import TorDNSEL.Directory.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/Directory/000077500000000000000000000000001527317632400212465ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Directory/Internals.hs000066400000000000000000000317351527317632400235520ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Directory.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards, type synonym instances, -- GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- Parsing and processing router descriptors, exit policies, and router -- status entries as served by Tor's control port. We only parse information -- necessary for running the exit list server. -- -- See and -- for details. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.Directory.Internals ( -- * Router descriptors Descriptor(..) , parseDescriptor , parseDescriptors -- * Router status entries , RouterStatus(..) , parseRouterStatus , parseRouterStatuses -- * Router identifiers , RouterID(..) , decodeBase16RouterID , decodeBase64RouterID , encodeBase16RouterID -- * Exit policies , ExitPolicy , Rule(..) , RuleType(..) , parseExitPolicy , exitPolicyAccepts , privateNetworks ) where import Control.Monad (when, unless, liftM) import Control.Monad.Except (MonadError(throwError)) import Data.Char ( ord, isSpace, isHexDigit, digitToInt, isAscii, isAsciiUpper , isAsciiLower, isAlpha, isDigit, toLower ) import qualified Data.List as L import Data.Bits ((.|.), (.&.), shiftL, shiftR) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as W import Data.ByteString (ByteString) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import Network.Socket (HostAddress) import TorDNSEL.Document import TorDNSEL.Util -------------------------------------------------------------------------------- -- Router descriptors -- | A router descriptor. data Descriptor = Desc { -- | The IPv4 address at which this router accepts connections. descListenAddr :: !HostAddress, -- | The time when this descriptor was generated. descPublished :: !POSIXTime, -- | This router's identifier. descRouterID :: !RouterID, -- | This router's exit policy. descExitPolicy :: !ExitPolicy } instance Show Descriptor where showsPrec _ d = cat (descRouterID d) ' ' (inet_htoa $ descListenAddr d) ' ' (posixSecondsToUTCTime $ descPublished d) '\n' (L.foldl' (.) id (map (\p -> shows p . ('\n' :)) (descExitPolicy d))) -- | Parse a router descriptor. Return the result or 'throwError' in the monad -- if the format is invalid. parseDescriptor :: MonadError ShowS m => Document -> m Descriptor parseDescriptor items = prependError ("Failed parsing router descriptor: " ++) $ do address <- parseRouter =<< findArg (B.pack "router") items time <- parsePOSIXTime =<< findArg (B.pack "published") items fp <- parseRouterID =<< findArg (B.pack "fingerprint") items exitPolicy <- parseExitPolicy . filter isRule $ items return $! Desc address time fp exitPolicy where isRule = (\k -> k == (B.pack "accept") || k == B.pack("reject")) . iKey parseRouter router | _:address:_ <- B.splitWith isSpace router = inet_atoh address | otherwise = throwError $ cat "Malformed router item " (esc maxRouterLen router) '.' where maxRouterLen = 53 parsePOSIXTime = liftM utcTimeToPOSIXSeconds . parseUTCTime . B.take 19 parseRouterID = decodeBase16RouterID . B.filter (/= ' ') -- | Parse a 'Document' containing multiple router descriptors. parseDescriptors :: Document -> [Either ShowS Descriptor] parseDescriptors = parseSubDocs (B.pack "router") parseDescriptor -------------------------------------------------------------------------------- -- Router status entries -- | A router status entry. data RouterStatus = RS { -- | This router's identifier. rsRouterID :: !RouterID, -- | When this router's most recent descriptor was published. rsPublished :: !UTCTime, -- | Is this router running? rsIsRunning :: !Bool } deriving Show -- | Parse a router status entry. Return the result or 'throwError' in the -- monad if the format is invalid. -- -- Both forms of the \"r\" line are accepted: the one used by the control -- port and the @ns@ consensus flavour, -- -- > r nickname identity digest YYYY-MM-DD HH:MM:SS address orport dirport -- -- and the one used by the @microdesc@ consensus flavour, which has no -- descriptor digest: -- -- > r nickname identity YYYY-MM-DD HH:MM:SS address orport dirport -- -- Since Tor 0.4.8 the publication time in consensus entries is a fixed -- placeholder, so it must not be relied upon. parseRouterStatus :: MonadError ShowS m => Document -> m RouterStatus parseRouterStatus items = do (rid,published) <- prependError ("Failed parsing router status entry: " ++) (parseRouter =<< findArg (B.pack "r") items) return $! RS rid published (parseStatus . hush $ findArg (B.pack "s") items) where parseRouter router = case filter (not . B.null) $ B.splitWith isSpace router of [_, base64RouterID, _, date, time, _, _, _] -> go base64RouterID date time [_, base64RouterID, date, time, _, _, _] -> go base64RouterID date time _ -> throwError $ cat "Malformed status " (esc maxStatusLen router) '.' where maxStatusLen = 160 go base64RouterID date time = do rid <- decodeBase64RouterID base64RouterID published <- parseUTCTime $ B.unwords [date, time] return (rid, published) parseStatus = maybe False (elem (B.pack "Running") . B.splitWith isSpace) -- | Parse a 'Document' containing multiple router status entries. Such a -- document isn't the same as a network-status document as it doesn't contain -- a preamble or a signature. parseRouterStatuses :: Document -> [Either ShowS RouterStatus] parseRouterStatuses = parseSubDocs (B.pack "r") parseRouterStatus -------------------------------------------------------------------------------- -- Router identifiers -- | A digest of a router's identity key. newtype RouterID = RtrId { unRtrId :: ByteString } deriving (Eq, Ord) instance Show RouterID where show = B.unpack . encodeBase16RouterID -- | Decode a 'RouterID' encoded in base16. Return the result or 'throwError' in -- the monad if the format is invalid. decodeBase16RouterID :: MonadError ShowS m => ByteString -> m RouterID decodeBase16RouterID bs = do unless (B.length bs == routerIDLen && B.all isHexDigit bs) $ throwError $ cat "Failed hex-decoding router identifier " (esc routerIDLen bs) '.' return $! RtrId . fst . W.unfoldrN 20 toBytes . B.unpack $ bs where toBytes (x:y:ys) = Just (fromBase16 x `shiftL` 4 .|. fromBase16 y, ys) toBytes _ = Nothing fromBase16 = fromIntegral . digitToInt routerIDLen = 40 -- | Decode a 'RouterID' encoded in base64 with trailing \'=\' signs removed. -- Return the result or 'throwError' in the monad if the format is invalid. decodeBase64RouterID :: MonadError ShowS m => ByteString -> m RouterID decodeBase64RouterID bs = do unless (B.length bs == routerIDLen && B.all isBase64Char bs) $ throwError $ cat "Failed base64-decoding router identifier " (esc routerIDLen bs) '.' return $! RtrId . B.init . toBytes . split 4 $ bs where routerIDLen = 27 toBytes = W.pack . concatMap (indicesToBytes . map base64Index . B.unpack) indicesToBytes is = map (fromIntegral . (0xff .&.) . shiftR buf) [16,8,0] where buf = L.foldl' (.|.) 0 $ zipWith shiftL is [18,12..] base64Index x | isAsciiUpper x = ord x - 65 | isAsciiLower x = ord x - 71 | isDigit x = ord x + 4 base64Index '+' = 62 base64Index '/' = 63 base64Index _ = error "base64Index: invalid base64 index" isBase64Char x = isAscii x && or [isAlpha x, isDigit x, x `elem` "+/"] -- | Encode a 'RouterID' in base16. encodeBase16RouterID :: RouterID -> ByteString encodeBase16RouterID = encodeBase16 . unRtrId -------------------------------------------------------------------------------- -- Exit policies -- | An exit policy consisting of a sequence of rules. type ExitPolicy = [Rule] -- | An exit policy rule consisting of a 'RuleType' and an address\/mask and -- port range pattern. data Rule = Rule { -- | Whether an exit connection is allowed. ruleType :: !RuleType, -- | The IPv4 address part of the pattern. ruleAddress :: !HostAddress, -- | The IPv4 address mask part of the pattern. ruleMask :: !HostAddress, -- | The first port in the pattern's port range. ruleBeginPort :: !Port, -- | The last port in the pattern's port range. ruleEndPort :: !Port } deriving (Eq, Ord) instance Show Rule where showsPrec _ p = cat (ruleType p) ' ' (inet_htoa $ ruleAddress p) '/' (inet_htoa $ ruleMask p) ':' (ruleBeginPort p) '-' (ruleEndPort p) -- | Whether a rule allows an exit connection. data RuleType = Accept -- ^ The rule accepts connections. | Reject -- ^ The rule rejects connections. deriving (Show, Eq, Ord) -- | Parse an 'ExitPolicy' from a list of accept or reject items. Return the -- result or 'throwError' in the monad if the format is invalid. -- -- Only the IPv4 part of a policy is represented. Rules whose pattern is an -- IPv6 address (@[...]@) or @*6@ can never match an IPv4 destination and are -- dropped; @private@ is expanded to the networks Tor considers private. parseExitPolicy :: MonadError ShowS m => [Item] -> m ExitPolicy parseExitPolicy xs = do policy <- mapM (prependError ("Failed parsing exit rule: " ++) . parseRule) xs return $! concat policy where parseRule (Item key (Just arg) _) | (addrSpec',portSpec) <- B.spanEnd (/= ':') arg , Just (addrSpec,':') <- unsnoc addrSpec' , not (B.null portSpec) = do ruleType' <- parseRuleType key (beginPort,endPort) <- prependError (cat "Malformed port specifier " (esc maxPortLen portSpec) ": ") (parsePortSpec portSpec) nets <- prependError (cat "Malformed address specifier " (esc maxAddrLen addrSpec) ": ") (parseAddrSpec addrSpec) return [ Rule ruleType' address mask beginPort endPort | (address,mask) <- nets ] parseRule (Item key arg _) = throwError $ cat "Malformed exit rule " (esc maxRuleTypeLen key) ' ' (maybe id (esc maxRuleLen) arg) '.' parseRuleType key | key == (B.pack "accept") = return Accept | key == (B.pack "reject") = return Reject | otherwise = throwError $ cat "Invalid rule type " (esc maxRuleTypeLen key) '.' parseAddrSpec bs | bs == B.pack "*" || bs == B.pack "*4" = return [(0, 0)] | bs == B.pack "*6" = return [] | B.pack "[" `B.isPrefixOf` bs = return [] -- IPv6 pattern | B.map toLower bs == B.pack "private" = return privateNetworks | [addr,mask] <- B.split '/' bs = do addr' <- inet_atoh addr mask' <- either (const $ bitsToMask =<< readInt mask) return (inet_atoh mask) return [(addr' .&. mask', mask')] | otherwise = do addr <- inet_atoh bs return [(addr, 0xffffffff)] parsePortSpec bs | bs == (B.pack "*") = return (0, 65535) | [b,e] <- B.split '-' bs = do begin <- parsePort b end <- parsePort e when (begin > end) $ throwError $ cat "Begin port is greater then end port." return (begin, end) | otherwise = do port <- parsePort bs return (port, port) bitsToMask x | 0 <= x, x <= 32 = return $ 0xffffffff `shiftL` (32 - x) | otherwise = throwError $ cat "Prefix length " x " is out of range." maxRuleLen = maxAddrLen + 1 + maxPortLen maxRuleTypeLen = 6 maxAddrLen = 64 maxPortLen = 11 -- | The IPv4 networks Tor's @private@ address pattern expands to, as -- (address, mask) pairs. privateNetworks :: [(HostAddress, HostAddress)] privateNetworks = [ (0x00000000, 0xff000000) -- 0.0.0.0/8 , (0xa9fe0000, 0xffff0000) -- 169.254.0.0/16 , (0x7f000000, 0xff000000) -- 127.0.0.0/8 , (0xc0a80000, 0xffff0000) -- 192.168.0.0/16 , (0x0a000000, 0xff000000) -- 10.0.0.0/8 , (0xac100000, 0xfff00000) ] -- 172.16.0.0/12 -- | Return whether the exit policy allows an exit connection to the given IPv4 -- address and port. The first matching rule determines the result. If no rule -- matches, the address\/port are accepted. exitPolicyAccepts :: HostAddress -> Port -> ExitPolicy -> Bool {-# INLINE exitPolicyAccepts #-} exitPolicyAccepts addr port exitPolicy | Reject:_ <- matchingRules = False | otherwise = True where matchingRules = map ruleType . filter matches $ exitPolicy matches r = addr .&. ruleMask r == ruleAddress r && ruleBeginPort r <= port && port <= ruleEndPort r mhatta-tordnsel-1d9141b/src/TorDNSEL/DistinctQueue.hs000066400000000000000000000052451527317632400224320ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.DistinctQueue -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : portable -- -- A FIFO queue of distinct elements. -- ----------------------------------------------------------------------------- module TorDNSEL.DistinctQueue ( DistinctQueue , empty , null , length , enqueue , unGetQueue , dequeue , isConsistent ) where import Prelude hiding (null, length) import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import Data.Sequence (Seq, (<|), (|>), viewr, ViewR(..)) import qualified Data.Set as Set import Data.Set (Set) -- | A FIFO queue of distinct elements. data Ord a => DistinctQueue a = DistinctQueue !(Seq a) !(Set a) -- | The empty distinct queue. empty :: Ord a => DistinctQueue a empty = DistinctQueue Seq.empty Set.empty -- | Is this the empty distinct queue? null :: Ord a => DistinctQueue a -> Bool null (DistinctQueue q _) = Seq.null q -- | The number of elements in the distinct queue. length :: Ord a => DistinctQueue a -> Int length (DistinctQueue q _) = Seq.length q -- | Add an element to the left end of the queue, if the element isn't already -- present in the queue. Also return whether an element was added to the queue. enqueue :: Ord a => a -> DistinctQueue a -> (Bool, DistinctQueue a) enqueue x oldQ@(DistinctQueue q set) | x `Set.notMember` set = (True, DistinctQueue (x <| q) (Set.insert x set)) | otherwise = (False, oldQ) -- | Add an element to the right end of the queue, if the element isn't already -- present in the queue. Also return whether an element was added to the queue. unGetQueue :: Ord a => a -> DistinctQueue a -> (Bool, DistinctQueue a) unGetQueue x oldQ@(DistinctQueue q set) | x `Set.notMember` set = (True, DistinctQueue (q |> x) (Set.insert x set)) | otherwise = (False, oldQ) -- | Remove an element from the right end of the queue, returning the element -- and the rest of the queue. Return 'Nothing' if this is the empty queue. -- -- With a list of distinct elements, the following identity holds: -- -- > nub == id ==> unfoldr dequeue . foldl ((snd .) . flip enqueue) empty == id dequeue :: Ord a => DistinctQueue a -> Maybe (a, DistinctQueue a) dequeue (DistinctQueue q set) = case viewr q of q' :> x -> Just (x, DistinctQueue q' (Set.delete x set)) EmptyR -> Nothing -- | An invariant: is the queue internally consistent? isConsistent :: Ord a => DistinctQueue a -> Bool isConsistent (DistinctQueue q set) = Seq.length q == Set.size set && Foldable.all (`Set.member` set) q mhatta-tordnsel-1d9141b/src/TorDNSEL/Document.hs000066400000000000000000000065311527317632400214210ustar00rootroot00000000000000 ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Document -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards, GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- Parsing the document meta-format used by the Tor directory protocol, -- version 2. -- -- See for details. -- ----------------------------------------------------------------------------- module TorDNSEL.Document ( Document , Item(..) , Object(..) , parseDocument , parseSubDocs , findArg ) where import Control.Arrow (first, (***)) import Control.Monad.Except (MonadError(throwError)) import Data.Char (isSpace) import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import Data.List (find, unfoldr) import TorDNSEL.Util -- | A document consisting of a sequence of one or more items. type Document = [Item] -- | An item consisting of a keyword, possibly arguments, and zero or more -- objects. data Item = Item { iKey :: !ByteString -- ^ Keyword , iArg :: !(Maybe ByteString) -- ^ Arguments , iObj :: ![Object] -- ^ Objects } deriving Show -- | An object consisting of a keyword and a block of base64-encoded data. data Object = Object { objKey :: !ByteString -- ^ Keyword , objData :: !ByteString -- ^ Base64-encoded data } deriving Show -- | Parse a 'Document' from a list of lines. parseDocument :: [ByteString] -> Document parseDocument = unfoldr parseDocument' where parseDocument' [] = Nothing parseDocument' (x:xs) = Just . first (Item key args) . parseObjects $ xs where (key,x') = B.break isSpace . dropOpt $ x dropOpt = if B.pack "opt " `B.isPrefixOf` x then B.drop 4 else id args | B.null x' = Nothing | otherwise = Just . B.dropWhile isSpace $ x' -- | Parse a list of 'Object's from a list of lines, returning the remaining -- lines. parseObjects :: [ByteString] -> ([Object], [ByteString]) parseObjects = unfoldAccumR parseObjects' where parseObjects' (x:xs) | B.pack "-----BEGIN " `B.isPrefixOf` x, B.pack "-----" `B.isSuffixOf` x = Left . ((Object key . B.unlines) *** drop 1) . break (== endLine) $ xs where key = B.take (B.length x - 16) . B.drop 11 $ x endLine = B.pack "-----END " `B.append` key `B.append` B.pack "-----" parseObjects' xs = Right xs -- | Break a document into sub-documents each beginning with an item that has -- the keyword @firstKey@. Apply @parseDoc@ to each sub-document, returning -- either an error message or the parsed document. parseSubDocs :: ByteString -> (Document -> Either ShowS a) -> Document -> [Either ShowS a] parseSubDocs firstKey parseDoc = unfoldr parseSubDocs' where parseSubDocs' [] = Nothing parseSubDocs' (x:xs) = Just (parseDoc (x : items), xs') where (items,xs') = break ((firstKey ==) . iKey) xs -- | Return the arguments from the first item whose key matches the given key. -- 'throwError' in the monad if no such item is found. findArg :: MonadError ShowS m => ByteString -> Document -> m ByteString findArg bs items | Just item <- find ((bs ==) . iKey) items, Just arg <- iArg item = return arg | otherwise = throwError $ cat "Item " bs " not found." mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitList.hs000066400000000000000000000261321527317632400214070ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.ExitList -- License : Public domain (see LICENSE) -- -- Maintainer : Masayuki Hatta -- Stability : alpha -- Portability : portable -- -- Answering exit list questions against our current view of the Tor network. -- This is shared by the DNS interface and the web interface, which by design -- provide the same data (see @doc/torel-design.md@). -- -- The basic question is always the same: /is there a running Tor exit node -- whose traffic leaves the Tor network from address A, and whose exit policy -- permits connections to some destination D?/ The destination is -- -- * a single address and port (query type 1, \"ip-port\"), -- -- * any member of a named, operator-configured list of address\/port -- patterns (query type 2, \"list\"), or -- -- * a port on the host asking the question (query type 3, \"me\"). -- ----------------------------------------------------------------------------- module TorDNSEL.ExitList ( -- * Destinations Destination(..) , AddrPortPattern(..) , parseAddrPortPattern , showAddrPortPattern , policyAcceptsDestination , policyAcceptsSome -- * Named lists , ListName , NamedLists , parseNamedList , maxListPrefix -- * Queries , isExitTo , exitAddressesTo , routersExitingFrom , exitFingerprints , isRunning , maxRouterAge , anyDestination ) where import Control.Monad (when, unless) import Control.Monad.Except (MonadError(throwError)) import Data.Bits ((.&.), (.|.), complement, shiftL, popCount) import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import Data.Char (isAlphaNum, toLower) import qualified Data.Map as M import Data.Map (Map) import Data.Maybe (mapMaybe) import qualified Data.Set as S import Data.Time.Clock.POSIX (POSIXTime) import Data.Word (Word32) import Network.Socket (HostAddress) import TorDNSEL.Directory import TorDNSEL.Directory.Internals (Rule(..), RuleType(..)) import TorDNSEL.NetworkState.Types import TorDNSEL.Util -------------------------------------------------------------------------------- -- Destinations -- | Where a connection leaving the Tor network is headed. data Destination = DestAddrPort !HostAddress !Port -- ^ A single IPv4 address and port. | DestAnyOf ![AddrPortPattern] -- ^ Any member of a set of patterns. deriving (Eq, Show) -- | An IPv4 network and an inclusive port range, e.g. @192.0.2.0/24:6660-6669@. data AddrPortPattern = AddrPortPattern { patAddress :: !HostAddress -- ^ Network address (already masked). , patMask :: !HostAddress -- ^ Network mask. , patBeginPort :: !Port -- ^ First port of the range. , patEndPort :: !Port -- ^ Last port of the range. } deriving (Eq, Ord, Show) -- | The widest network prefix accepted in a named list. The design document -- warns that address masks wider than \/8 are worrying, so we refuse them. maxListPrefix :: Int maxListPrefix = 8 -- | Parse an address\/port pattern of the form -- @ADDRESS[\/BITS]:PORT[-PORT][,PORT[-PORT]...]@, returning one pattern per -- port range. 'throwError' in the monad if the pattern is malformed. parseAddrPortPattern :: MonadError ShowS m => ByteString -> m [AddrPortPattern] parseAddrPortPattern bs | (addrSpec',portSpecs) <- B.spanEnd (/= ':') bs , Just (addrSpec,':') <- unsnoc addrSpec' , not (B.null portSpecs) = prependError (cat "Malformed address/port pattern " (esc 64 bs) ": ") $ do (addr,mask) <- parseNet addrSpec ranges <- mapM parseRange $ B.split ',' portSpecs return [AddrPortPattern addr mask b e | (b,e) <- ranges] | otherwise = throwError $ cat "Malformed address/port pattern " (esc 64 bs) '.' where parseNet spec = case B.split '/' spec of [addr] -> do a <- inet_atoh addr return (a, 0xffffffff) [addr,bits] -> do a <- inet_atoh addr n <- readInt bits when (n < maxListPrefix || n > 32) $ throwError $ cat "Prefix length " n " is out of range (must be \ \between " maxListPrefix " and 32)." let mask = 0xffffffff `shiftL` (32 - n) :: Word32 return (a .&. mask, mask) _ -> throwError ("Malformed network." ++) parseRange spec = case B.split '-' spec of [p] -> do port <- parsePort p return (port, port) [b,e] -> do b' <- parsePort b e' <- parsePort e unless (b' <= e') $ throwError ("Begin port is greater than end port." ++) return (b', e') _ -> throwError ("Malformed port range." ++) -- | Render a pattern in the syntax accepted by 'parseAddrPortPattern'. showAddrPortPattern :: AddrPortPattern -> String showAddrPortPattern p = inet_htoa (patAddress p) ++ bits ++ ":" ++ ports where bits | patMask p == 0xffffffff = "" | otherwise = '/' : show (popCount $ patMask p) ports | patBeginPort p == patEndPort p = show (patBeginPort p) | otherwise = show (patBeginPort p) ++ "-" ++ show (patEndPort p) -- | Does an exit policy accept a connection to the destination? policyAcceptsDestination :: Destination -> ExitPolicy -> Bool {-# INLINE policyAcceptsDestination #-} policyAcceptsDestination (DestAddrPort a p) = exitPolicyAccepts a p policyAcceptsDestination (DestAnyOf pats) = policyAcceptsSome pats -- | Does an exit policy accept a connection to at least one address\/port -- covered by the given patterns? -- -- Tor applies the first rule matching a connection, and accepts the -- connection if none matches. We track the part of the destination space not -- yet decided by an earlier rule: an accept rule that overlaps it means some -- destination is accepted; a reject rule removes its rectangle from it. policyAcceptsSome :: [AddrPortPattern] -> ExitPolicy -> Bool policyAcceptsSome pats = go (map patternRect pats) where go [] _ = False go _ [] = True go undecided (r:rs) | ruleType r == Accept = any (overlaps rect) undecided || go undecided rs | otherwise = go (concatMap (`subtractRect` rect) undecided) rs where rect = ruleRect r -- | A rectangle in (address, port) space; all bounds are inclusive. data Rect = Rect !Word32 !Word32 !Int !Int patternRect :: AddrPortPattern -> Rect patternRect p = netRect (patAddress p) (patMask p) (fromIntegral $ patBeginPort p) (fromIntegral $ patEndPort p) ruleRect :: Rule -> Rect ruleRect r = netRect (ruleAddress r) (ruleMask r) (fromIntegral $ ruleBeginPort r) (fromIntegral $ ruleEndPort r) -- Masks are assumed to be contiguous prefixes, which is all Tor emits. netRect :: Word32 -> Word32 -> Int -> Int -> Rect netRect addr mask = Rect lo (lo .|. complement mask) where lo = addr .&. mask overlaps :: Rect -> Rect -> Bool overlaps (Rect a1 a2 p1 p2) (Rect b1 b2 q1 q2) = a1 <= b2 && b1 <= a2 && p1 <= q2 && q1 <= p2 -- | The part of the first rectangle not covered by the second, as at most -- four disjoint rectangles. subtractRect :: Rect -> Rect -> [Rect] subtractRect r@(Rect a1 a2 p1 p2) s@(Rect b1 b2 q1 q2) | not (overlaps r s) = [r] | otherwise = concat [ [Rect a1 (b1 - 1) p1 p2 | b1 > a1] , [Rect (b2 + 1) a2 p1 p2 | b2 < a2] , [Rect lo hi p1 (q1 - 1) | q1 > p1] , [Rect lo hi (q2 + 1) p2 | q2 < p2] ] where lo = max a1 b1 hi = min a2 b2 -- | A destination matching every IPv4 address and port. anyDestination :: Destination anyDestination = DestAnyOf [AddrPortPattern 0 0 0 65535] -------------------------------------------------------------------------------- -- Named lists -- | The name of an operator-configured list, in lower case. type ListName = ByteString -- | Operator-configured lists of address\/port patterns, by name. type NamedLists = Map ListName [AddrPortPattern] -- | Parse the value of an @ExitList@ config line: -- @NAME PATTERN [PATTERN ...]@. List names are case-insensitive DNS labels. parseNamedList :: MonadError ShowS m => ByteString -> m (ListName, [AddrPortPattern]) parseNamedList line = case B.words line of name:pats@(_:_) -> do unless (validName name) $ throwError $ cat "Invalid exit list name " (esc 64 name) "; list names \ \must be DNS labels made of letters, digits and '-'." pats' <- concat `fmap` mapM parseAddrPortPattern pats return (B.map toLower name, pats') _ -> throwError $ cat "Malformed exit list " (esc 128 line) "; expected a name followed by address/port patterns." where validName n = not (B.null n) && B.length n <= 63 && B.all (\c -> isAlphaNum c || c == '-') n && B.head n /= '-' && B.last n /= '-' -------------------------------------------------------------------------------- -- Queries -- | We consider a router to be running if it published a descriptor less than -- 48 hours ago: \"After a Tor server op turns off their server, it stops -- publishing server descriptors. We should consider that server's IP address -- to still represent a Tor node until 48 hours after its last descriptor was -- published.\" maxRouterAge :: POSIXTime maxRouterAge = 60 * 60 * 48 -- | Is the router whose descriptor this is still considered running? isRunning :: POSIXTime -> Descriptor -> Bool {-# INLINE isRunning #-} isRunning now d = now - descPublished d < maxRouterAge -- | The descriptors of routers whose traffic may leave the Tor network from -- the given address: either the address they advertise, or an address we saw -- in an exit test through them. routersExitingFrom :: NetworkState -> HostAddress -> [Descriptor] routersExitingFrom s addr = maybe [] (mapMaybe lookupDesc . S.elems) (addr `M.lookup` nsAddrs s) where lookupDesc rid = rtrDescriptor =<< rid `M.lookup` nsRouters s -- | Is there a running Tor exit node exiting from the given address whose exit -- policy permits connections to the destination? isExitTo :: POSIXTime -> NetworkState -> HostAddress -> Destination -> Bool {-# INLINE isExitTo #-} isExitTo now s addr dest = any ok (routersExitingFrom s addr) where ok d = isRunning now d && policyAcceptsDestination dest (descExitPolicy d) -- | The identities of the running Tor exit nodes exiting from the given -- address whose exit policy permits connections to the destination. exitFingerprints :: POSIXTime -> NetworkState -> HostAddress -> Destination -> [RouterID] exitFingerprints now s addr dest = [ descRouterID d | d <- routersExitingFrom s addr, isRunning now d , policyAcceptsDestination dest (descExitPolicy d) ] -- | All addresses from which running Tor exit nodes whose exit policy permits -- connections to the destination may exit, in ascending order. exitAddressesTo :: POSIXTime -> NetworkState -> Destination -> [HostAddress] exitAddressesTo now s dest = [addr | (addr,rids) <- M.toAscList (nsAddrs s), any ok (S.elems rids)] where ok rid = case rtrDescriptor =<< rid `M.lookup` nsRouters s of Just d -> isRunning now d && policyAcceptsDestination dest (descExitPolicy d) Nothing -> False mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitTest/000077500000000000000000000000001527317632400210535ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitTest/Initiator.hs000066400000000000000000000015501527317632400233520ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.ExitTest.Initiator -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, STM, extended exceptions, -- pattern guards, rank-2 types, GHC primitives) -- -- A thread that initiates test connections through exit nodes to determine the -- IP addresses they exit through. -- ----------------------------------------------------------------------------- module TorDNSEL.ExitTest.Initiator ( ExitTestInitiator , ExitTestInitiatorConfig(..) , startExitTestInitiator , notifyNewDirInfo , scheduleNextExitTest , reconfigureExitTestInitiator , terminateExitTestInitiator ) where import TorDNSEL.ExitTest.Initiator.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitTest/Initiator/000077500000000000000000000000001527317632400230155ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitTest/Initiator/Internals.hs000066400000000000000000000526211527317632400253160ustar00rootroot00000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.ExitTest.Initiator.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, pattern guards, -- bang patterns, rank-2 types, GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- A thread that initiates test connections through exit nodes to determine the -- IP addresses they exit through. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.ExitTest.Initiator.Internals ( ExitTestInitiator(..) , InitiatorMessage(..) , ExitTestInitiatorConfig(..) , InitiatorState(..) , TestStatus(..) , startExitTestInitiator , handleMessage , notifyNewDirInfo , scheduleNextExitTest , reconfigureExitTestInitiator , terminateExitTestInitiator -- * Scheduling exit tests , testsToSchedule , testsToExecute -- * Threads , forkTestClient , forkTestTimer , forkPeriodicTestTimer -- * Exit test history , historyRetentionPeriod , maxTestInterval , TestHistoryEntry(..) , TestHistory(..) , emptyTestHistory , appendTestsToHistory , removeExpiredTests , currentTestInterval ) where import Prelude hiding (log) import Control.Arrow (first, second) import Control.Concurrent (threadDelay) import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) import qualified Control.Exception as E import Control.Monad (replicateM_, guard, when) import qualified Data.ByteString.Char8 as B import qualified Data.Foldable as F import qualified Data.List as L import Data.List (unfoldr, mapAccumL) import qualified Data.Map as M import Data.Map (Map) import Data.Maybe (mapMaybe ) import qualified Data.Sequence as Seq import Data.Sequence (Seq, ViewL((:<)), viewl, (<|), (|>), ViewR((:>)), viewr) import qualified Data.Set as Set import Data.Set (Set) import Data.Time (UTCTime, NominalDiffTime, getCurrentTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Network.Socket (HostAddress, SockAddr, socketToHandle) import System.IO (hClose, IOMode(ReadWriteMode)) import System.Timeout import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.Directory import qualified TorDNSEL.DistinctQueue as Q import TorDNSEL.DistinctQueue (DistinctQueue) import TorDNSEL.ExitTest.Request import TorDNSEL.Log import TorDNSEL.NetworkState.Types import TorDNSEL.Socks import TorDNSEL.TorControl (TorControlError) import TorDNSEL.Util -------------------------------------------------------------------------------- -- Exit test initiator -- | A handle to the exit test initiator thread. data ExitTestInitiator = ExitTestInitiator (InitiatorMessage -> IO ()) ThreadId instance Thread ExitTestInitiator where threadId (ExitTestInitiator _ tid) = tid -- | An internal type for messages sent to the exit test initiator. data InitiatorMessage -- | Use new directory information to schedule exit tests. = NewDirInfo [(RouterID, Router)] -- | Place a router at the front of the exit test queue. | ScheduleNextExitTest RouterID -- | Reconfigure the exit test initiator. | Reconfigure (ExitTestInitiatorConfig -> ExitTestInitiatorConfig) (IO ()) | Terminate ExitReason -- ^ Terminate the exit test initiator gracefully. -- | An exit signal sent to the exit test initiator. | Exit ThreadId ExitReason -- | The exit test initiator configuration. data ExitTestInitiatorConfig = ExitTestInitiatorConfig { -- | An action for fetching the current network state. eticfGetNetworkState :: !(IO NetworkState), -- | A safe wrapper for allocating an exit test cookie. eticfWithCookie :: !(forall a. RouterID -> UTCTime -> Port -> (Cookie -> IO a) -> IO a), -- | Arrange for connections to the hostname passed to the action to exit -- through the given router and reach the given test address. Called with -- the test address, the router and the test's cookie. eticfWithExitMapping :: !(forall a. HostAddress -> RouterID -> Cookie -> (B.ByteString -> IO a) -> IO a), -- | The maximum number of exit test clients to run concurrently. eticfConcClientLimit :: !Integer, -- | Where Tor is listening for SOCKS connections. eticfSocksServer :: !SockAddr, -- | The IP address to which we make exit test connections through Tor. eticfTestAddress :: !HostAddress, -- | The ports to which we make exit test connections through Tor. eticfTestPorts :: ![Port] } instance Eq ExitTestInitiatorConfig where x == y = all (\(===) -> x === y) [ eq eticfConcClientLimit, eq eticfSocksServer, eq eticfTestAddress , eq eticfTestPorts ] where eq :: Eq b => (a -> b) -> a -> a -> Bool eq = on (==) -- | An internal type representing the current exit test initiator state. data InitiatorState = InitiatorState { initiatorChan :: !(Chan InitiatorMessage) , runningClients :: !(Set ThreadId) , pendingTests :: !(DistinctQueue RouterID) , testHistory :: !TestHistory , testStatus :: !TestStatus , periodicTestTimer :: !ThreadId } -- | The status of the next scheduled exit test. data TestStatus = TimerRunning !ThreadId -- ^ We're waiting for a timer to expire. | TestWaiting !RouterID ![Port] !UTCTime -- ^ Run this test next. | NoTestsPending -- ^ No timer is currently running. deriving Eq -- | Start the exit test initiator thread, given an initial config. Return a -- handle to the thread. Link the exit test initiator thread to the calling -- thread. startExitTestInitiator :: ExitTestInitiatorConfig -> IO ExitTestInitiator startExitTestInitiator initConf = do log Info "Starting exit test initiator." chan <- newChan initiatorTid <- forkLinkIO $ do setTrapExit ((writeChan chan .) . Exit) tid <- forkPeriodicTestTimer loop initConf $ InitiatorState chan Set.empty Q.empty emptyTestHistory NoTestsPending tid return $ ExitTestInitiator (writeChan chan) initiatorTid where -- An exit test can be run immediately if forking its test clients would -- keep the number of currently running clients below eticfConcClientLimit. canRunExitTest conf s ports = toInteger (Set.size (runningClients s) + length ports) <= eticfConcClientLimit conf loop !conf !s | TestWaiting rid ports published <- testStatus s , canRunExitTest conf s ports = do log Info "Forking exit test clients for router " rid " ports " ports '.' newClients <- mapM (forkTestClient conf rid published) ports let newRunningClients = L.foldl' (flip Set.insert) (runningClients s) newClients log Info "Exit test clients currently running: " (Set.size newRunningClients) '.' if Q.length (pendingTests s) == 0 then do log Info "Pending exit tests: 0." loop conf s { runningClients = newRunningClients , testStatus = NoTestsPending } else do now <- getCurrentTime let newS = s { runningClients = newRunningClients , testHistory = removeExpiredTests now $ testHistory s } tid <- forkTestTimer newS loop conf newS { testStatus = TimerRunning tid } | otherwise = readChan (initiatorChan s) >>= handleMessage conf s >>= uncurry loop -- | Process an 'InitiatorMessage' and return the new config and state, given -- the current config and state. Only 'Reconfigure' returns a changed config. handleMessage :: ExitTestInitiatorConfig -> InitiatorState -> InitiatorMessage -> IO (ExitTestInitiatorConfig, InitiatorState) handleMessage conf s (NewDirInfo routers) | nRouterTests == 0 = return (conf, s) | otherwise = do log Info "Scheduling exit tests for " nRouterTests " routers." now <- getCurrentTime let newS = s { pendingTests = newPendingTests , testHistory = appendTestsToHistory now nRouterTests . removeExpiredTests now $ testHistory s } if testStatus s == NoTestsPending then do tid <- forkTestTimer newS return (conf, newS { testStatus = TimerRunning tid }) else return (conf, newS) where (newPendingTests,nRouterTests) = second (toInteger . length . filter id) $ mapAccumL ((swap .) . flip Q.enqueue) (pendingTests s) (testsToSchedule conf routers) handleMessage conf s (ScheduleNextExitTest rid) | not testAdded = return (conf, s) | otherwise = do now <- getCurrentTime let newS = s { pendingTests = newPendingTests , testHistory = removeExpiredTests now $ testHistory s } if testStatus s == NoTestsPending then do tid <- forkTestTimer newS return (conf, newS { testStatus = TimerRunning tid }) else return (conf, newS) where (testAdded,newPendingTests) = Q.unGetQueue rid (pendingTests s) handleMessage conf s (Reconfigure reconf signal) = do let newConf = reconf conf when (conf /= newConf) $ log Notice "Reconfiguring exit test initiator." signal return (newConf, s) handleMessage _ s (Terminate reason) = do log Info "Terminating exit test initiator." F.forM_ (runningClients s) $ \client -> terminateThread Nothing client (killThread client) exit reason handleMessage conf s (Exit tid reason) | tid `Set.member` runningClients s = return (conf, s { runningClients = Set.delete tid (runningClients s) }) -- Run the next queued exit test, if any are still eligible for testing. | TimerRunning timerThread <- testStatus s , tid == timerThread = do routers <- nsRouters `fmap` eticfGetNetworkState conf case testsToExecute conf routers (pendingTests s) of Nothing -> do log Info "Pending exit tests: 0." return (conf, s { pendingTests = Q.empty , testStatus = NoTestsPending }) Just (rid,ports,published,newPendingTests) -> do log Info "Pending exit tests: " (Q.length newPendingTests + 1) '.' log Debug "Waiting to run exit test for router " rid " ports " ports '.' return (conf, s { pendingTests = newPendingTests , testStatus = TestWaiting rid ports published }) -- Periodically, add every eligible router to the exit test queue. This should -- catch some routers for which previous exit tests failed. | tid == periodicTestTimer s = do (_,newS) <- handleMessage conf s . NewDirInfo . M.assocs . nsRouters =<< eticfGetNetworkState conf newTid <- forkPeriodicTestTimer return (conf, newS { periodicTestTimer = newTid }) | isAbnormal reason = exit reason | otherwise = return (conf, s) -- | Notify the exit test initiator of new directory information. notifyNewDirInfo :: [(RouterID, Router)] -> ExitTestInitiator -> IO () notifyNewDirInfo routers (ExitTestInitiator send _) = send $ NewDirInfo routers -- | Schedule a router for immediate exit testing, placing it ahead of any -- already-queued routers. scheduleNextExitTest :: RouterID -> ExitTestInitiator -> IO () scheduleNextExitTest rid (ExitTestInitiator send _) = send $ ScheduleNextExitTest rid -- | Reconfigure the exit test initiator synchronously with the given function. -- If the initiator exits abnormally before reconfiguring itself, throw its exit -- signal in the calling thread. reconfigureExitTestInitiator :: (ExitTestInitiatorConfig -> ExitTestInitiatorConfig) -> ExitTestInitiator -> IO () reconfigureExitTestInitiator reconf (ExitTestInitiator send tid) = sendSyncMessage (send . Reconfigure reconf) tid -- | Terminate the exit test initiator gracefully. The optional parameter -- specifies the amount of time in microseconds to wait for the thread to -- terminate. If the thread hasn't terminated by the timeout, an uncatchable -- exit signal will be sent. terminateExitTestInitiator :: Maybe Int -> ExitTestInitiator -> IO () terminateExitTestInitiator mbWait (ExitTestInitiator send tid) = terminateThread mbWait tid (send $ Terminate NormalExit) -------------------------------------------------------------------------------- -- Scheduling exit tests -- | Given a list of routers that should be considered for exit testing, return -- a list of routers that should be added to the exit test queue. testsToSchedule :: ExitTestInitiatorConfig -> [(RouterID, Router)] -> [RouterID] testsToSchedule conf routers = [rid | (rid,rtr) <- routers, isEligibleForTesting rtr] where -- A router is eligible for being added to the exit test queue if it's -- marked running, we have its descriptor, and we haven't completed any -- exit tests through it since we received its current descriptor. isEligibleForTesting r | not $ rtrIsRunning r = False | otherwise = case rtrDescriptor r of Nothing -> False Just d | Just t <- rtrTestResults r , tstPublished t >= posixSecondsToUTCTime (descPublished d) -> False | otherwise -> anyAllowedPorts (descExitPolicy d) anyAllowedPorts policy = any (\port -> exitPolicyAccepts (eticfTestAddress conf) port policy) (eticfTestPorts conf) -- | Given the current network state and the queue of pending exit tests, return -- the router identifier, ports, and descriptor publication time of the next -- exit test we should execute. Also return the new queue of pending tests. If -- none of the routers in the pending test queue are still eligible for testing, -- return 'Nothing'. testsToExecute :: ExitTestInitiatorConfig -> Map RouterID Router -> DistinctQueue RouterID -> Maybe (RouterID, [Port], UTCTime, DistinctQueue RouterID) testsToExecute conf routers q -- Take the first scheduled router that's still eligible for testing. | test:_ <- mapMaybe toTest $ queueTails q = Just test | otherwise = Nothing where -- A router is eligible for immediate exit testing if it's marked running, -- we have its descriptor, and its exit policy allows connections to at -- least one of our listening ports. toTest (rid,q') = do r <- M.lookup rid routers guard $ rtrIsRunning r d <- rtrDescriptor r ports'@(_:_) <- return . allowedPorts $ descExitPolicy d return (rid, ports', posixSecondsToUTCTime $ descPublished d, q') allowedPorts policy = filter (\port -> exitPolicyAccepts (eticfTestAddress conf) port policy) (eticfTestPorts conf) queueTails = unfoldr (maybe Nothing (\r@(_,q') -> Just (r,q')) . Q.dequeue) -------------------------------------------------------------------------------- -- Threads -- | Fork an exit test client thread for a given router identifier, descriptor -- publication time, and port. The exit test client associates a new cookie with -- the test information and passes it to the exit test server with an HTTP -- request through Tor. forkTestClient :: ExitTestInitiatorConfig -> RouterID -> UTCTime -> Port -> IO ThreadId forkTestClient conf rid published port = forkLinkIO $ do r <- E.try . eticfWithCookie conf rid published port $ \cookie -> eticfWithExitMapping conf (eticfTestAddress conf) rid cookie $ \exitHost -> timeout connectionTimeout . E.bracket connectToSocksServer hClose $ \handle -> withSocksConnection handle (Addr exitHost) port $ do B.hPut handle $ createRequest testHost port cookie B.hGet handle 1024 -- ignore response return () case r of Left (E.fromException -> Just (e :: SocksError)) -> do log Info "Exit test for router " rid " port " port " failed: " e E.throwIO e Left (E.fromException -> Just (e :: TorControlError)) -> do log Info "Exit test for router " rid " port " port " failed: " e E.throwIO e Left (E.fromException -> Just (e :: E.IOException)) -> do log Warn "Exit test for router " rid " port " port " failed : " e ". This might indicate a problem with making application \ \connections through Tor. Is Tor running? Is its SocksPort \ \listening on " (eticfSocksServer conf) '?' E.throwIO e Left e -> E.throwIO e Right Nothing -> log Info "Exit test for router " rid " port " port " timed out." _ -> log Debug "Exit test client for router " rid " port " port " finished." where testHost = B.pack . inet_htoa . eticfTestAddress $ conf connectToSocksServer = E.bracketOnError (connectStreamSocket $ eticfSocksServer conf) closeSocket $ \sock -> socketToHandle sock ReadWriteMode connectionTimeout = 120 * 10^6 -- | Fork a timer thread for the next exit test, returning its 'ThreadId'. forkTestTimer :: InitiatorState -> IO ThreadId forkTestTimer s = forkLinkIO $ do log Debug "Total routers scheduled in exit test history: " (nTotalRouters $ testHistory s) ". " (show . F.toList . historySeq $ testHistory s) log Info "Running next exit test in " currentInterval " microseconds." threadDelay $ fromIntegral currentInterval where currentInterval = currentTestInterval nPending (testHistory s) nPending = toInteger . Q.length . pendingTests $ s -- | Fork a timer thread for periodic exit tests, returning its 'ThreadId'. forkPeriodicTestTimer :: IO ThreadId forkPeriodicTestTimer = forkLinkIO . replicateM_ 2 $ threadDelay halfPeriodicTestInterval where halfPeriodicTestInterval = 30 * 60 * 10^6 -------------------------------------------------------------------------------- -- Exit test history -- | The period from which we consider past scheduled exit tests when -- calculating the current interval between tests. historyRetentionPeriod :: NominalDiffTime historyRetentionPeriod = 150 * 60 -- | The maximum interval in microseconds between running scheduled exit tests. maxTestInterval :: Integer maxTestInterval = 20 * 10^6 -- | A record of when a single set of exit tests were scheduled in the test -- history. data TestHistoryEntry = TestHistoryEntry { scheduledAt :: !UTCTime -- ^ When the tests were added to the queue. , nRouters :: !Integer -- ^ The number of routers added to the queue. } instance Show TestHistoryEntry where showsPrec _ entry = cat (nRouters entry) '@' (showUTCTime $ scheduledAt entry) -- | An abstract type representing a persistent record of how many exit tests -- were scheduled in the last 'historyRetentionPeriod' seconds. data TestHistory = TestHistory { -- | The total number of routers added to the queue in the test history. nTotalRouters :: !Integer, -- | The rolling sequence of recently scheduled exit tests. historySeq :: !(Seq TestHistoryEntry) } -- | The empty test history. emptyTestHistory :: TestHistory emptyTestHistory = TestHistory 0 Seq.empty -- | Given the current time and a count of exit tests being added to the pending -- test queue, add those tests to the test history appendTestsToHistory :: UTCTime -> Integer -> TestHistory -> TestHistory appendTestsToHistory _ 0 history = history appendTestsToHistory now nTests history -- If the latest history entry was added in the last 5 minutes, attribute new -- tests to it. This prevents bloating the test history length with -- unnecessarily fine-grained information. | history' :> latestEntry <- viewr (historySeq history) , scheduledAt latestEntry > addUTCTime (negate entryMergePeriod) now = let updatedEntry = latestEntry { nRouters = nTests + nRouters latestEntry } in newHistory { historySeq = history' |> updatedEntry } | otherwise = let newEntry = TestHistoryEntry { scheduledAt = now, nRouters = nTests } in newHistory { historySeq = historySeq history |> newEntry } where newHistory = history { nTotalRouters = nTests + nTotalRouters history } entryMergePeriod = 300 -- | Remove the record of exit tests older than 'historyRetentionPeriod' from -- the test history, given the current time. removeExpiredTests :: UTCTime -> TestHistory -> TestHistory removeExpiredTests now history | Seq.length expired > 0 = history { nTotalRouters = nTotalRouters history - F.sum (fmap nRouters expired) , historySeq = rest } | otherwise = history where (expired,rest) = spanL ((< cutoff) . scheduledAt) $ historySeq history cutoff = addUTCTime (negate historyRetentionPeriod) now spanL p xxs | x :< xs <- viewl xxs, p x = first (x <|) $ spanL p xs | otherwise = (Seq.empty, xxs) -- | Given the number of pending exit tests in the test queue and the test -- history, return the interval of time in microseconds we should wait before -- running the next exit test. currentTestInterval :: Integer -> TestHistory -> Integer currentTestInterval nPendingTests history | nConsideredTests == 0 = maxTestInterval | otherwise = testInterval `min` maxTestInterval where -- The idea here is to schedule a historyRetentionPeriod's worth of exit -- tests in 25% of a 'historyRetentionPeriod'. testInterval = touSec historyRetentionPeriod `div` nConsideredTests `div` 4 nConsideredTests = nTotalRouters history `max` nPendingTests touSec = truncate . (10^6 *) mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitTest/Request.hs000066400000000000000000000071321527317632400230420ustar00rootroot00000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.ExitTest.Request -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (GHC primitives) -- -- Functions for parsing and generating HTTP requests used to make test -- connections through exit nodes. Also implements cookies (nonces) for -- authenticating test connections. -- ----------------------------------------------------------------------------- module TorDNSEL.ExitTest.Request ( -- * HTTP requests createRequest , getRequest -- * Cookies , Cookie(..) , newCookie , cookieLen ) where import Control.Arrow ((***)) import Control.Monad import qualified Data.ByteString.Char8 as B import Data.Char (isSpace, toLower) import qualified Data.Map as M import System.IO (Handle) import Data.Conduit import qualified Data.Conduit.Binary as CB import TorDNSEL.Util -------------------------------------------------------------------------------- -- HTTP requests -- | Create an HTTP request that POSTs a cookie to one of our listening ports. createRequest :: B.ByteString -> Port -> Cookie -> B.ByteString createRequest host port cookie = B.intercalate "\r\n" -- POST should force caching proxies to forward the request. [ "POST / HTTP/1.0" -- Host doesn't exist in HTTP 1.0. We'll use it anyway to help the request -- traverse transparent proxies. , "Host: " <> hostValue , "Content-Type: application/octet-stream" , "Content-Length: " <> bshow cookieLen , "Connection: close" , "\r\n" <> unCookie cookie ] where hostValue | port == 80 = host | otherwise = B.concat [host, ":", bshow port] -- | Given an HTTP client, return the cookie contained in the body of the HTTP -- request if it's well-formatted, otherwise return 'Nothing'. getRequest :: Handle -> IO (Maybe Cookie) getRequest client = runConduit $ CB.sourceHandle client .| CB.isolate maxReqLen .| do reqline <- c_line_crlf hs <- accHeaders [] case checkHeaders reqline hs of Nothing -> return Nothing Just _ -> Just . Cookie <$> c_take cookieLen where maxReqLen = 2048 + cookieLen accHeaders hs = c_line_crlf >>= \ln -> do if ln == "" then return $ M.fromList hs else accHeaders (parseHeader ln : hs) -- A line without a colon has an empty value (and fails the checks -- below if it matters); don't use the partial 'B.tail' on it. parseHeader = (B.map toLower *** B.dropWhile isSpace . B.drop 1) . B.break (== ':') checkHeaders reqline headers = do contentType <- "content-type" `M.lookup` headers contentLen <- hush . readInt =<< "content-length" `M.lookup` headers guard $ reqline `elem` ["POST / HTTP/1.0", "POST / HTTP/1.1"] guard $ contentType == "application/octet-stream" guard $ contentLen == cookieLen -------------------------------------------------------------------------------- -- Cookies -- | A cookie containing pseudo-random data that we send in an HTTP request. We -- associate it with the exit node we're testing through and use it look up that -- exit node when we receive it on a listening port. newtype Cookie = Cookie { unCookie :: B.ByteString } deriving (Eq, Ord, Show) -- | Create a new cookie from pseudo-random data. newCookie :: (Int -> IO B.ByteString) -> IO Cookie newCookie getRandBytes = Cookie `fmap` getRandBytes cookieLen -- | The cookie length in bytes. cookieLen :: Int cookieLen = 32 mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitTest/Server.hs000066400000000000000000000015001527317632400226510ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.ExitTest.Server -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, pattern guards, -- bang patterns, GHC primitives) -- -- A thread that accepts test connections we have initiated through exit nodes -- to determine the IP addresses exit nodes make connections through. -- ----------------------------------------------------------------------------- module TorDNSEL.ExitTest.Server ( ExitTestServer , ExitTestServerConfig(..) , startExitTestServer , reconfigureExitTestServer , terminateExitTestServer ) where import TorDNSEL.ExitTest.Server.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitTest/Server/000077500000000000000000000000001527317632400223215ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/ExitTest/Server/Internals.hs000066400000000000000000000347101527317632400246210ustar00rootroot00000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.ExitTest.Server.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, pattern guards, -- bang patterns, GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- A thread that accepts test connections we have initiated through exit nodes -- to determine the IP addresses exit nodes make connections through. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.ExitTest.Server.Internals where import Prelude hiding (log) import Control.Concurrent.QSemN (QSemN, newQSemN, waitQSemN, signalQSemN) import qualified Control.Exception as E import Control.Monad (when, forM, foldM, forever) import Control.Monad.Fix (fix) import Control.Monad.Trans (lift) import qualified Data.ByteString.Char8 as B import qualified Data.Foldable as F import qualified Data.Map as M import Data.Map (Map) import Data.Maybe import qualified Data.Set as S import Data.Set (Set) import Data.Time (UTCTime, getCurrentTime) import Network.Socket ( HostAddress, Socket, SockAddr(SockAddrInet), accept, getSocketName , socketToHandle ) import System.IO (hClose, IOMode(ReadWriteMode)) import System.IO.Error (isEOFError) import System.Timeout import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.ExitTest.Request import TorDNSEL.Log import TorDNSEL.Util -- | A handle to the exit test server thread. data ExitTestServer = ExitTestServer (ServerMessage -> IO ()) ThreadId instance Thread ExitTestServer where threadId (ExitTestServer _ tid) = tid -- | The exit test server configuration. data ExitTestServerConfig = ExitTestServerConfig { -- | Notify the network state manager of a received exit test request. etscfNotifyNewExitAddress :: !(UTCTime -> Cookie -> HostAddress -> IO ()), -- | The maximum number of exit test clients to serve concurrently. etscfConcClientLimit :: !Integer, -- | The addresses on which the server should listen for connections. etscfListenAddrs :: !(Set SockAddr) } instance Eq ExitTestServerConfig where x == y = etscfConcClientLimit x == etscfConcClientLimit y && etscfListenAddrs x == etscfListenAddrs y -- | An internal type representing the current exit test server state. data ServerState = ServerState { serverChan :: !(MsgChan ServerMessage) , handlerSem :: !QSemN , handlers :: !(Map ThreadId HostAddress) -- | How many handlers are serving each client address. , perClient :: !(Map HostAddress Int) , listenerThreads :: !(Map ThreadId Listener) , deadListeners :: !(Set ThreadId) } -- | An exit test listener. data Listener = Listener { listenAddr :: !SockAddr -- ^ The address to which the listener is bound. , listenSock :: !Socket -- ^ The listening socket. , socketOwner :: !SocketOwner -- ^ The listening socket's owner thread. } -- | The thread responsible for a given listening socket. If a socket is owned -- by the supervisor, we won't attempt to 'closeSocket' it. The idea is to prevent -- unnecessarily closing a socket that requires root privileges to open. data SocketOwner = SupervisorOwned -- ^ Owned by the supervisor thread. | ExitTestServerOwned -- ^ Owned by the exit test server thread. deriving Eq -- | An internal type for messages sent to the exit test server. data ServerMessage = NewClient Socket HostAddress -- ^ A new client accepted by a listener. -- | Reconfigure the exit test server. | Reconfigure (ExitTestServerConfig -> ExitTestServerConfig) (IO ()) | Terminate ExitReason -- ^ Terminate the exit test server gracefully. | Exit ThreadId ExitReason -- ^ An exit signal sent to the exit test server. -- | Start the exit test server thread, given an initial config and a list of -- listeners, returning a handle to the thread. If the exit test server exits -- abnormally before initializing itself, throw its exit signal in the calling -- thread. Link the exit test server thread to the calling thread. If the exit -- test server exits before completely starting, throw its exit signal in the -- calling thread. startExitTestServer :: [(SockAddr, Maybe Socket)] -> ExitTestServerConfig -> IO ExitTestServer startExitTestServer socks initConf = do log Info "Starting exit test server." chan <- newMsgChan tid <- startLink $ \signal -> do setTrapExit $ (writeMsgChan chan .) . Exit sem <- newQSemN . fromIntegral . etscfConcClientLimit $ initConf listeners <- fmap catMaybes . forM socks $ \(addr,mbSock) -> runMaybeT $ do sock <- reopenSocketIfClosed addr mbSock let owner | mbSock == Just sock = SupervisorOwned | otherwise = ExitTestServerOwned tid <- lift $ startListenerThread ((writeMsgChan chan .) . NewClient) sem owner sock addr return (tid, Listener addr sock owner) signal let initConf' = initConf { etscfListenAddrs = S.fromList $ map (listenAddr . snd) listeners } initState = ServerState chan sem M.empty M.empty (M.fromList listeners) S.empty fix (\loop (!conf,!s) -> readMsgChan chan >>= handleMessage conf s >>= loop) (initConf', initState) return $ ExitTestServer (writeMsgChan chan) tid -- | How many exit test connections one address may have open at once. A host -- may run several exits, each tested on several ports at once. maxTestClientsPerAddress :: Int maxTestClientsPerAddress = 16 -- | Start a listener thread, returning its 'ThreadId'. startListenerThread :: (Socket -> HostAddress -> IO ()) -> QSemN -> SocketOwner -> Socket -> SockAddr -> IO ThreadId startListenerThread notifyServerNewClient sem owner listener addr = forkLinkIO $ E.mask $ \restore -> finallyCloseSocket . forever $ do waitQSemN sem 1 (client,SockAddrInet _ clientAddr) <- restore (accept listener) `E.catch` \(e :: E.SomeException) -> signalQSemN sem 1 >> E.throwIO e let clientAddr' = ntohl clientAddr log Debug "Accepted exit test client from " (inet_htoa clientAddr') '.' notifyServerNewClient client clientAddr' where finallyCloseSocket = case owner of ExitTestServerOwned -> flip E.finally $ do log Notice "Closing exit test listener on " addr '.' closeSocket listener SupervisorOwned -> id -- | Given an optional listening socket, return it if it's open. Otherwise, -- attempt to reopen it, returning the new socket if successful. reopenSocketIfClosed :: SockAddr -> Maybe Socket -> MaybeT IO Socket reopenSocketIfClosed addr mbSock = MaybeT $ do isOpen <- isListeningSocketOpen mbSock if isOpen then return mbSock else do whenJust mbSock closeSocket log Notice "Opening exit test listener on " addr '.' r <- E.try $ bindListeningTCPSocket addr case r of Left (e :: E.IOException ) -> do log Warn "Opening exit test listener on " addr " failed: " e "; \ \skipping listener." return Nothing Right sock -> do log Info "Opened exit test listener on " addr '.' return $ Just sock where isListeningSocketOpen Nothing = return False isListeningSocketOpen (Just sock) = (True <$ getSocketName sock) `E.catch` \(_ :: E.SomeException) -> return False -- | Process a 'ServerMessage' and return the new config and state, given the -- current config and state. handleMessage :: ExitTestServerConfig -> ServerState -> ServerMessage -> IO (ExitTestServerConfig, ServerState) handleMessage conf s (NewClient sock addr) -- Anyone can connect here. One host may not take all the handlers, which -- would stop our exit tests (the exits connecting to us). | M.findWithDefault 0 addr (perClient s) >= maxTestClientsPerAddress = do log Debug "Exit test client " (inet_htoa addr) " has too many connections; closing." closeSocket sock `E.finally` signalQSemN (handlerSem s) 1 return (conf, s) | otherwise = do tid <- forkLinkIO . (`E.finally` signalQSemN (handlerSem s) 1) . E.bracket (socketToHandle sock ReadWriteMode) hClose $ \client -> do -- Anyone can connect here: whatever goes wrong with a request (short of -- an asynchronous exception) concerns that request only. r <- timeout readTimeout . E.tryJust syncExceptions $ do r <- getRequest client case r of Just cookie -> do now <- getCurrentTime etscfNotifyNewExitAddress conf now cookie addr B.hPut client $ B.pack "HTTP/1.0 204 No Content\r\n\ \Connection: close\r\n\r\n" _ -> do log Debug "Received invalid HTTP request from " (inet_htoa addr) "; discarding." B.hPut client $ B.pack "HTTP/1.0 400 Bad Request\r\n\ \Connection: close\r\n\r\n" case r of Just (Left e) -> do let msg | Just e' <- E.fromException e, isEOFError e' = "Connection closed by other side" | otherwise = show e log Debug "Error reading HTTP request from " (inet_htoa addr) ": " msg Nothing -> log Debug "Reading HTTP request from " (inet_htoa addr) " timed out." _ -> return () return (conf, s { handlers = M.insert tid addr (handlers s) , perClient = M.insertWith (+) addr 1 (perClient s) }) where -- An exit sends its test request as soon as it has connected. readTimeout = 15 * 10^6 handleMessage conf s (Reconfigure reconf signal) = do when (conf /= newConf) $ log Notice "Reconfiguring exit test server." when (limitDiff /= 0) $ signalQSemN (handlerSem s) (fromIntegral limitDiff) if etscfListenAddrs conf == etscfListenAddrs newConf then signal >> return (newConf, s) else do deadListeners' <- foldM killListener (deadListeners s) (M.keys closeListeners) listeners' <- (M.union unchangedListeners . M.fromList . catMaybes) `fmap` mapM openListener (S.elems open) signal return ( newConf { etscfListenAddrs = S.fromList . map listenAddr . M.elems $ listeners' } , s { listenerThreads = listeners' , deadListeners = deadListeners' } ) where killListener dead tid = do terminateThread Nothing tid (killThread tid) return $! S.insert tid dead openListener addr = runMaybeT $ do sock <- reopenSocketIfClosed addr Nothing tid <- lift $ startListenerThread ((writeMsgChan (serverChan s) .) . NewClient) (handlerSem s) ExitTestServerOwned sock addr return (tid, Listener addr sock ExitTestServerOwned) (closeListeners,unchangedListeners) = M.partition ((`S.member` close) . listenAddr) (listenerThreads s) (close,open) = S.partition (`S.member` etscfListenAddrs conf) changed changed = S.difference (etscfListenAddrs conf `S.union` etscfListenAddrs newConf) (etscfListenAddrs conf `S.intersection` etscfListenAddrs newConf) limitDiff = etscfConcClientLimit newConf - etscfConcClientLimit conf newConf = reconf conf handleMessage _conf s (Terminate reason) = do log Info "Terminating exit test server." mapM_ (\tid -> terminateThread Nothing tid (killThread tid)) (M.keys $ listenerThreads s) F.mapM_ (\tid -> terminateThread Nothing tid (killThread tid)) (M.keys $ handlers s) msgs <- drainMsgChan $ serverChan s sequence_ [closeSocket client | NewClient client _ <- msgs] exit reason handleMessage conf s (Exit tid reason) | Just addr <- M.lookup tid (handlers s) = do case reason of AbnormalExit _ -> log Warn "Bug: An exit test client handler exited \ \abnormally: " reason NormalExit -> return () return (conf, s { handlers = M.delete tid (handlers s) , perClient = M.update (\n -> if n <= 1 then Nothing else Just (n - 1)) addr (perClient s) }) | tid `S.member` deadListeners s = return (conf, s { deadListeners = S.delete tid (deadListeners s) }) | Just (Listener addr sock owner) <- tid `M.lookup` listenerThreads s = do log Warn "An exit test listener thread for " addr " exited unexpectedly: " reason "; restarting." mbSock <- runMaybeT $ reopenSocketIfClosed addr (Just sock) case mbSock of -- The socket couldn't be reopened, so drop the listener. Nothing -> return ( conf { etscfListenAddrs = S.delete addr (etscfListenAddrs conf) } , s { listenerThreads = M.delete tid (listenerThreads s) } ) Just sock' -> do -- If the socket was reopened, we own it now. let owner' | sock /= sock' = ExitTestServerOwned | otherwise = owner listener' = Listener addr sock' owner' tid' <- startListenerThread ((writeMsgChan (serverChan s) .) . NewClient) (handlerSem s) owner sock addr listener' `seq` return (conf, s { listenerThreads = M.insert tid' listener' . M.delete tid $ listenerThreads s }) | isAbnormal reason = exit reason | otherwise = return (conf, s) -- | Reconfigure the exit test server synchronously with the given function. If -- the server exits abnormally before reconfiguring itself, throw its exit -- signal in the calling thread. reconfigureExitTestServer :: (ExitTestServerConfig -> ExitTestServerConfig) -> ExitTestServer -> IO () reconfigureExitTestServer reconf (ExitTestServer send tid) = sendSyncMessage (send . Reconfigure reconf) tid -- | Terminate the exit test server gracefully. The optional parameter specifies -- the amount of time in microseconds to wait for the thread to terminate. If -- the thread hasn't terminated by the timeout, an uncatchable exit signal will -- be sent. terminateExitTestServer :: Maybe Int -> ExitTestServer -> IO () terminateExitTestServer mbWait (ExitTestServer send tid) = terminateThread mbWait tid (send $ Terminate NormalExit) mhatta-tordnsel-1d9141b/src/TorDNSEL/Files.hs000066400000000000000000000062541527317632400207070ustar00rootroot00000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Files -- License : Public domain (see LICENSE) -- -- Maintainer : Masayuki Hatta -- Stability : alpha -- Portability : non-portable (POSIX) -- -- Opening files whose names we don't fully trust, without following -- symbolic links into places we didn't mean, blocking on FIFOs, or reading -- endless devices. -- ----------------------------------------------------------------------------- module TorDNSEL.Files ( readSmallRegularFile , createFileExclusively , isGroupOrWorldWritable ) where import qualified Control.Exception as E import Data.Bits ((.&.)) import qualified Data.ByteString as B import System.IO (Handle, hClose) import System.IO.Error (mkIOError, userErrorType, isDoesNotExistError) import System.Posix.Files ( getFdStatus, isRegularFile, removeLink, groupWriteMode, otherWriteMode , setFdMode ) import System.Posix.IO ( openFd, OpenMode(..), OpenFileFlags(..), defaultFileFlags, fdToHandle , closeFd ) import System.Posix.Types (Fd, FileMode) -- | Read at most @n@ bytes from a regular file. The file is opened without -- blocking, so that a FIFO can't stall us, and anything other than a regular -- file (a FIFO, a device such as @\/dev\/zero@) is refused. Throw an -- 'IOError' if the file can't be read or isn't a regular file. readSmallRegularFile :: Int -> FilePath -> IO B.ByteString readSmallRegularFile n path = do fd <- openReadNonBlocking path h <- fdToHandle fd `E.onException` closeFd fd (`E.finally` hClose h) $ do st <- getFdStatus fd if isRegularFile st then B.hGet h n else E.throwIO $ mkIOError userErrorType "not a regular file" Nothing (Just path) -- | Create a new file for writing with the given mode, replacing any file or -- symbolic link of that name. The file is created with @O_CREAT|O_EXCL@, -- which never follows a symbolic link: if one appears between removing the -- old name and creating the file, creating it fails instead. createFileExclusively :: FilePath -> FileMode -> IO Handle createFileExclusively path mode = do removeLink path `E.catch` \e -> if isDoesNotExistError e then return () else E.throwIO e fd <- openCreateExclusive path mode -- The mode given to open(2) is subject to the umask; set it as asked. (setFdMode fd mode >> fdToHandle fd) `E.onException` closeFd fd -- | Can users other than the owner write to this file or directory? isGroupOrWorldWritable :: FileMode -> Bool isGroupOrWorldWritable m = m .&. (groupWriteMode + otherWriteMode) /= 0 openReadNonBlocking :: FilePath -> IO Fd openCreateExclusive :: FilePath -> FileMode -> IO Fd #if MIN_VERSION_unix(2,8,0) openReadNonBlocking path = openFd path ReadOnly defaultFileFlags { nonBlock = True } openCreateExclusive path mode = openFd path WriteOnly defaultFileFlags { exclusive = True , creat = Just mode } #else openReadNonBlocking path = openFd path ReadOnly Nothing defaultFileFlags { nonBlock = True } openCreateExclusive path mode = openFd path WriteOnly (Just mode) defaultFileFlags { exclusive = True } #endif mhatta-tordnsel-1d9141b/src/TorDNSEL/Log.hs000066400000000000000000000016641527317632400203660ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Log -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, -- type synonym instances, overlapping instances, -- foreign function interface) -- -- Implements a logger thread and functions to log messages, reconfigure the -- logger, and terminate the logger. -- ----------------------------------------------------------------------------- module TorDNSEL.Log ( LogConfig(..) , LogTarget(..) , Severity(..) , LogType , log , Logger , startLogger , reconfigureLogger , terminateLogger , SysLogOptions(..) , SysLogFacility(..) , openSystemLogger , closeSystemLogger ) where import Prelude hiding (log) import TorDNSEL.Log.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/Log/000077500000000000000000000000001527317632400200235ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Log/Internals.hsc000066400000000000000000000211051527317632400224600ustar00rootroot00000000000000{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Log.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, -- type synonym instances, overlapping instances, -- foreign function interface) -- -- /Internals/: should only be imported by the public module and tests. -- -- Implements a logger thread and functions to log messages, reconfigure the -- logger, and terminate the logger. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.Log.Internals where import Prelude hiding (log) import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) import qualified Control.Exception as E import Control.Monad (when, liftM2) import Control.Monad.Fix (fix) import Control.Monad.Trans (MonadIO, liftIO) import Data.Bits ((.|.)) import qualified Data.ByteString.Char8 as B import qualified Data.List as L import Data.Time (UTCTime, getCurrentTime) import Foreign.C (CString, CInt(..), withCString) import System.IO (Handle, stdout, stderr, openFile, IOMode(AppendMode), hFlush, hClose) import System.IO.Unsafe (unsafePerformIO) import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.Util #include -- | The logging configuration. data LogConfig = LogConfig { minSeverity :: !Severity -- ^ Minimum severity level to log , logTarget :: !LogTarget -- ^ Where to send log messages , logEnabled :: !Bool -- ^ Is logging enabled? } deriving (Eq, Show) -- | Where log messages should be sent. data LogTarget = ToStdOut | ToStdErr | ToSysLog | ToFile FilePath deriving Eq instance Show LogTarget where show ToStdOut = "stdout" show ToStdErr = "stderr" show ToSysLog = "syslog" show (ToFile fp) = esc maxPathLen (B.pack fp) "" where maxPathLen = 256 -- | Open a handle associated with a given 'LogTarget' and pass it to an 'IO' -- action, ensuring that the handle is closed or flushed as appropriate when the -- action terminates. Exceptions generated by the action are re-thrown. withLogTarget :: LogTarget -> (Maybe Handle -> IO a) -> IO a withLogTarget ToStdOut io = E.bracket (return stdout) hFlush (io . Just) withLogTarget ToStdErr io = E.bracket (return stderr) hFlush (io . Just) withLogTarget ToSysLog io = io Nothing withLogTarget (ToFile fp) io = E.bracket (openFile fp AppendMode) hClose (io . Just) -- | An internal type for messages sent to the logger. data LogMessage = Log UTCTime Severity ShowS -- ^ A log message | Reconfigure (LogConfig -> LogConfig) (IO ()) -- ^ Reconfigure the logger | Terminate ExitReason -- ^ Terminate the logger gracefully -- | Logging severities. data Severity = Debug | Info | Notice | Warn | Error deriving (Eq, Ord, Show) -- | The logger's 'ThreadId' and channel, if it is running. logger :: MVar (Maybe (ThreadId, Chan LogMessage)) {-# NOINLINE logger #-} logger = unsafePerformIO $ newMVar Nothing -- | If the logger is running, invoke an 'IO' action with its 'ThreadId' and -- channel. withLogger :: (ThreadId -> Chan LogMessage -> IO ()) -> IO () withLogger io = readMVar logger >>= flip whenJust (uncurry io) -- | A handle to the logger thread. newtype Logger = Logger ThreadId instance Thread Logger where threadId (Logger tid) = tid -- | Start the global logger with an initial 'LogConfig', returning a handle to -- it. Link the logger to the calling thread. If the logger exits before fully -- starting, throw its exit signal in the calling thread. startLogger :: LogConfig -> IO Logger startLogger initConf = fmap Logger . startLink $ \initSignal -> do curLogger@(_,logChan) <- liftM2 (,) myThreadId newChan setTrapExit . const $ writeChan logChan . Terminate E.bracket_ (swapMVar logger $ Just curLogger) (swapMVar logger Nothing) $ flip fix (initConf, initSignal) $ \resetLogger (conf, signal) -> (resetLogger =<<) . withLogTarget (logTarget conf) $ \mbHandle -> do log Notice "Opened log to " (logTarget conf) '.' signal fix $ \nextMsg -> do msg <- readChan logChan case msg of Log time severity logMsg -> do when (logEnabled conf && severity >= minSeverity conf) $ case mbHandle of Just h -> do hCat h (showUTCTime time) " [" severity "] " logMsg '\n' hFlush h Nothing -> sysLog severity (logMsg "") nextMsg Reconfigure reconf newSignal -> do let newConf = reconf conf when (conf /= newConf) $ log Info "Reconfigured logger." return (reconf conf, newSignal) Terminate reason -> exit reason -- | Implements the variable parameter support for 'log'. class LogType r where log' :: CatArg a => ShowS -> Severity -> a -> r instance {-# OVERLAPPABLE #-} MonadIO m => LogType (m a) where log' str sev arg = liftIO $ do now <- getCurrentTime mbLogger <- readMVar logger case mbLogger of Just (_,logChan) -> writeChan logChan (Log now sev (cat' str arg)) Nothing | sev >= Notice -> do hCat stdout (showUTCTime now) " [" sev "] " str arg '\n' hFlush stdout | otherwise -> return () return undefined -- to omit type annotations in do blocks instance {-# OVERLAPPING #-} LogType (Severity, ShowS) where log' str sev arg = (sev, cat' str arg) instance {-# OVERLAPPING #-} (CatArg a, LogType r) => LogType (a -> r) where log' str sev arg = log' (cat' str arg) sev -- | Log a message asynchronously. log :: (CatArg a, LogType r) => Severity -> a -> r log = log' id -- | Reconfigure the logger synchronously with the given function. If the logger -- exits abnormally before reconfiguring itself, throw its exit signal in the -- calling thread. reconfigureLogger :: (LogConfig -> LogConfig) -> IO () reconfigureLogger reconf = withLogger $ \tid logChan -> sendSyncMessage (writeChan logChan . Reconfigure reconf) tid -- | Terminate the logger gracefully: process any pending messages, flush the -- log handle, and close the handle when logging to a file. The optional -- parameter specifies the amount of time in microseconds to wait for the thread -- to terminate. If the thread hasn't terminated by the timeout, an uncatchable -- exit signal will be sent. terminateLogger :: Maybe Int -> IO () terminateLogger mbWait = withLogger $ \tid logChan -> terminateThread mbWait tid (writeChan logChan $ Terminate NormalExit) -------------------------------------------------------------------------------- -- System logger -- | Options to pass to syslog(3)'s openlog(). data SysLogOptions = SysLogOptions { noDelay -- ^ Open the connection to the logger immediately. , logPid :: !Bool -- ^ Log the PID with each message. } -- | The facility to which log messages should be assigned. data SysLogFacility = Daemon -- ^ System daemons. -- | Open a connection to the system logger using the given process identifier, -- options, and facility. openSystemLogger :: String -> SysLogOptions -> SysLogFacility -> IO () openSystemLogger identifier options facility = withCString identifier $ \c_identifier -> c_openlog c_identifier c_options c_facility where c_options = L.foldl' (.|.) 0 [ x | (flag,x) <- [(noDelay, #{const LOG_NDELAY}) ,(logPid, #{const LOG_PID})] , flag options ] c_facility = case facility of Daemon -> #{const LOG_DAEMON} foreign import ccall unsafe "syslog.h openlog" c_openlog :: CString -> CInt -> CInt -> IO () -- | Close the connection to the system logger. closeSystemLogger :: IO () closeSystemLogger = c_closelog foreign import ccall unsafe "syslog.h closelog" c_closelog :: IO () -- | Send a message of the given 'Severity' to the system logger. sysLog :: Severity -> String -> IO () sysLog severity message = withCString "%s" $ \c_format -> withCString message $ \c_message -> c_syslog c_severity c_format c_message where c_severity = case severity of Error -> #{const LOG_ERR} Warn -> #{const LOG_WARNING} Notice -> #{const LOG_NOTICE} Info -> #{const LOG_INFO} Debug -> #{const LOG_DEBUG} foreign import ccall unsafe "syslog.h syslog" c_syslog :: CInt -> CString -> CString -> IO () mhatta-tordnsel-1d9141b/src/TorDNSEL/Main.hsc000066400000000000000000001265221527317632400206750ustar00rootroot00000000000000{-# LANGUAGE ForeignFunctionInterface, CPP #-} {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-missing-fields -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Main -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions, -- pattern guards, bang patterns, FFI, -- GHC primitives) -- -- Implements a DNSBL-style interface providing information about whether a -- client for a network service is likely connecting through a Tor exit node. -- -- See @doc/torel-design.md@ for -- details. -- ----------------------------------------------------------------------------- module TorDNSEL.Main ( -- * Constants minFileDesc , maxFileDesc , extraFileDesc -- * Top level functionality , StaticState(..) , State(..) , MainThreadMessage(..) , main , verifyConfig , runMainThread , handleMessage , mkDNSServerConfig , mkExitTestConfig , initializeLogger , initializeNetworkStateManager , reconfigureOrRestartLogger , reconfigureListenersAndNetworkStateManager , reconfigureDNSListenerAndServer , reconfigureHTTPListenerAndServer , mkWebConfig , terminateProcess -- * Daemon operations , Privileges(..) , getIDs , supplementaryGroups , dropPrivileges , changeRootDirectory , daemonize -- * Helpers , setMaxOpenFiles , checkDirectory , checkLogTarget , SysExitCode(..) , fromSysExitCode , bindErrorCode , exitLeft , exitPrint , liftMb ) where import Prelude hiding (log) import Control.Concurrent (rtsSupportsBoundThreads) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import qualified Control.Exception as E import Control.Monad (when, liftM, forM, forM_, mplus) import Control.Monad.Fix (fix) import Control.Monad.State.Strict (StateT, runStateT, liftIO, get, put) import Data.Bits ((.&.), (.|.)) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (toLower) import Data.List (intersperse) import qualified Data.List as L import qualified Data.Map as M import Data.Map (Map) import Data.Maybe (isJust, isNothing, fromMaybe) import qualified Data.Set as S import Data.Set (Set) import System.Environment (getArgs) import System.IO ( openFile, hPutStrLn, hClose, Handle, stdout, stderr , IOMode(AppendMode) ) import System.IO.Error (isPermissionError) import Network.Socket (Socket, SockAddr(SockAddrInet), shutdown, ShutdownCmd(ShutdownSend)) import qualified Network.Socket.ByteString as NSB import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith) import System.Directory (setCurrentDirectory, createDirectoryIfMissing) import System.Posix.IO ( openFd, closeFd, stdInput, stdOutput, stdError, OpenMode(ReadWrite) , defaultFileFlags, dupTo ) import System.Posix.Process (forkProcess, createSession, exitImmediately, getProcessID) import System.Posix.Signals ( installHandler, Signal, Handler(Ignore, Catch) , sigHUP, sigPIPE, sigINT, sigTERM ) import System.Posix.Error (throwErrnoPathIfMinus1_) import System.Posix.Files ( getFileStatus, fileOwner, fileMode, setFileMode, setOwnerAndGroup , setFileCreationMask ) import System.Posix.Resource ( ResourceLimits(..), ResourceLimit(..), Resource(ResourceOpenFiles) , getResourceLimit, setResourceLimit ) import System.Posix.Types (UserID, GroupID) -- unix >= 2.8 exports UserEntry/GroupEntry as pattern synonyms, so import the -- module whole to get the field selectors with any unix version. import System.Posix.User import Foreign.C (CString, CInt(..), withCString) import TorDNSEL.Config import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.DNS import TorDNSEL.DNS.Server import TorDNSEL.Files (createFileExclusively, isGroupOrWorldWritable) import TorDNSEL.Log import TorDNSEL.NetworkState import TorDNSEL.Random import TorDNSEL.Statistics import TorDNSEL.Util import TorDNSEL.Web #include #include #include -------------------------------------------------------------------------------- -- Constants -- | Minimum limit on open file descriptors under which we can run. minFileDesc :: Integer minFileDesc = 128 -- | Maximum limit on open file descriptors we can set with 'setResourceLimit'. -- The threaded RTS uses epoll(7)\/kqueue(2), so this no longer needs to be as -- low as it was with the select(2)-based I\/O manager. maxFileDesc :: Integer maxFileDesc = 16384 -- | Number of file descriptors the process might need for everything but exit -- tests. extraFileDesc :: Integer extraFileDesc = 96 -------------------------------------------------------------------------------- -- Top level functionality -- | State that is initialized once on startup, then never changed. data StaticState = StaticState { availableFileDesc :: Integer -- ^ Number of file descriptors available. , randomHandle :: Handle -- ^ Handle to a random number device. , statsSocket :: Socket -- ^ Listening statistics socket. , reconfigSocket :: Socket -- ^ Listening reconfigure socket. } -- | Mutable state used by the main thread. data State = State { logger :: Maybe Logger -- ^ The logger thread, if it's running. , reconfigServer :: Maybe ReconfigServer -- ^ The reconfigure server thread, if it's running. , statsServer :: Maybe StatsServer -- ^ The statistics server thread, if it's running. , networkStateManager :: NetworkStateManager -- ^ The network state manager thread. , dnsServer :: DNSServer -- ^ The DNS server thread. , exitTestListeners :: Map SockAddr (Maybe Socket) -- ^ Listening exit test sockets. , dnsListener :: Socket -- ^ The DNS socket (UDP). , dnsTCPListener :: Socket -- ^ The listening DNS socket (TCP). , webServer :: Maybe WebServer -- ^ The web interface thread, if enabled. , httpListener :: Maybe Socket -- ^ The listening HTTP socket, if enabled. , deadThreads :: Set ThreadId -- ^ Dead threads linked to the main thread. } -- | Messages the main thread can receive. data MainThreadMessage -- | Reconfigure the process given an optional config. If the config isn't -- given, try to reload our config file. Either way, the log file (if open) -- will be closed and re-opened. If the config is given, pass an error message -- to the given action if reconfiguring the process fails and we're about to -- exit. = Reconfigure (Maybe (Config, (Maybe String -> IO ()))) | Terminate Signal -- ^ Terminate the process with the given Posix signal. | Exit ThreadId ExitReason -- ^ An exit signal sent by a linked thread. -- | The main entry point for the server. This handles parsing config options, -- various daemon operations, forking the network state handler, Tor controller, -- exit test threads, and starting the DNS server. main :: IO () main = do args <- getArgs case args of _ | args == ["-h"] || args == ["--help"] -> exitUsage stdout ExitSuccess | args == ["-v"] || args == ["--version"] -> putStrLn ("TorDNSEL " ++ VERSION) >> exitWith ExitSuccess | any (\arg -> map toLower arg == "--verify-config") args -> verifyConfig args ["--reconfigure",runtimeDir] -> do sock <- connectToReconfigSocket runtimeDir `E.catch` \(e :: E.SomeException) -> do hCat stderr "Connecting to reconfigure socket failed: " e '\n' exitWith $ fromSysExitCode Unavailable r <- E.handle (\(e :: E.IOException) -> do hCat stderr "An I/O error occurred while reconfiguring: " e '\n' exitWith $ fromSysExitCode IOError) $ (`E.finally` closeSocket sock) $ do -- network >= 3 invalidates a socket handed to socketToHandle, so -- talk to the socket directly to be able to half-close it. L.getContents >>= NSB.sendAll sock . B.concat . L.toChunks shutdown sock ShutdownSend let readAll acc = do chunk <- NSB.recv sock 4096 if B.null chunk then return (B.concat $ reverse acc) else readAll (chunk : acc) readAll [] B.hPut stderr r exitWith . fromSysExitCode $ case () of _| B.null r -> OK | B.pack "Parse error:" `B.isPrefixOf` r -> DataError | B.pack "Config error:" `B.isPrefixOf` r -> ConfigError | otherwise -> ProtocolError _ -> return () -- Files and sockets we create are ours alone unless we say otherwise. _ <- setFileCreationMask 0o077 log Notice "Starting TorDNSEL " VERSION "." conf <- do conf <- exitLeft Usage $ parseConfigArgs args case B.pack "configfile" `M.lookup` conf of Just fp -> do file <- catchIO (B.readFile $ B.unpack fp) (exitPrint NoInput . cat "Opening config file failed: ") exitLeft DataError $ makeConfig . M.union conf =<< parseConfigFile file Nothing -> exitLeft Usage $ makeConfig conf availFileDesc <- setMaxOpenFiles minFileDesc maxFileDesc random <- exitLeft OSFile =<< openRandomDevice seedPRNG random openSystemLogger "TorDNSEL" SysLogOptions { noDelay = True, logPid = True } Daemon euid <- getEffectiveUserID when (any (isJust . ($ conf)) [cfUser, cfGroup, cfChangeRootDirectory] && euid /= 0) $ exitPrint NoPermission ("You must be root to drop privileges or chroot." ++) ids <- catchIO (getIDs (cfUser conf) (cfGroup conf)) (exitPrint OSFile . cat "Looking up uid/gid failed: ") catchIO (checkDirectory (privUser ids) (cfChangeRootDirectory conf) (cfStateDirectory conf)) (exitPrint Can'tCreate . cat "Preparing state directory failed: ") catchIO (checkDirectory Nothing Nothing (cfRuntimeDirectory conf)) (exitPrint Can'tCreate . cat "Preparing runtime directory failed: ") statsSock <- catchIO (bindStatsSocket (cfRuntimeDirectory conf) (privUser ids) (privGroup ids)) (exitPrint Can'tCreate . cat "Opening statistics listener failed: ") reconfigSock <- catchIO (bindReconfigSocket (cfRuntimeDirectory conf) (privUser ids)) (exitPrint Can'tCreate . cat "Opening reconfigure listener failed: ") -- Created afresh, never through a symbolic link: we're probably root here, -- and the PID file's directory may be writable by the user we run as. pidHandle <- catchIO ((`createFileExclusively` 0o644) `liftMb` cfPIDFile conf) (exitPrint Can'tCreate . cat "Opening PID file failed: ") log Notice "Opening DNS listener on " (cfDNSListenAddress conf) '.' dnsSocks <- catchIO (bindDNSSockets $ cfDNSListenAddress conf) (\e -> exitPrint (bindErrorCode e) $ cat "Opening DNS listener on " (cfDNSListenAddress conf) " failed: " e) httpSock <- case cfHTTPListenAddress conf of Nothing -> return Nothing Just addr -> do log Notice "Opening HTTP listener on " addr '.' fmap Just . catchIO (bindListeningTCPSocket addr) $ \e -> exitPrint (bindErrorCode e) $ cat "Opening HTTP listener on " addr " failed: " e testListeners <- case cfTestConfig conf of Nothing -> return M.empty Just testConf -> fmap M.fromList . forM (snd $ tcfTestListenAddress testConf) $ \port -> do let sockAddr = SockAddrInet (fromIntegral port) (htonl . fst $ tcfTestListenAddress testConf) log Notice "Opening exit test listener on " sockAddr '.' sock <- catchIO (bindListeningTCPSocket sockAddr) (\e -> exitPrint (bindErrorCode e) $ cat "Opening exit test listener on " sockAddr " failed: " e) return (sockAddr, Just sock) -- We lose any other running threads when we 'forkProcess', so don't 'forkIO' -- before this point. (if cfRunAsDaemon conf then daemonize else id) . withLinksDo $ do whenJust pidHandle $ \handle -> do hPutStrLn handle . show =<< getProcessID hClose handle whenJust (cfChangeRootDirectory conf) $ \dir -> do changeRootDirectory dir setCurrentDirectory "/" dropPrivileges ids let static = StaticState availFileDesc random statsSock reconfigSock runMainThread static testListeners dnsSocks httpSock conf -- | Given the command line arguments, check whether config options provided on -- the command line and in an optional config file are well-formed. If they are, -- exit with a successful status code. Otherwise, print an error message to -- stderr and exit with an appropriate error code. verifyConfig :: [String] -> IO a verifyConfig args = case parseConfigArgs args of Left e -> exitStdErr Usage e Right conf -> case B.pack "configfile" `M.lookup` conf of Just fp -> do file <- catchIO (B.readFile $ B.unpack fp) $ \e -> do hCat stderr "Opening config file failed: " e '\n' exitWith $ fromSysExitCode NoInput check DataError $ parseConfigFile file >>= makeConfig . M.union conf Nothing -> check Usage $ makeConfig conf where exitStdErr code e = hCat stderr e '\n' >> exitWith (fromSysExitCode code) check code = either (exitStdErr code) (const $ exitWith ExitSuccess) -- | Install signal handlers, start children of the main thread, and enter the -- main message-processing loop. Exit if we fail to start any threads. runMainThread :: StaticState -> Map SockAddr (Maybe Socket) -> (Socket, Socket) -> Maybe Socket -> Config -> IO () runMainThread static initTestListeners (initDNSListener, initDNSTCPListener) initHTTPListener initConf = do mainChan <- newChan setTrapExit $ (writeChan mainChan .) . Exit installHandler sigPIPE Ignore Nothing let hupHandler = writeChan mainChan (Reconfigure Nothing) termHandler = writeChan mainChan . Terminate installHandler sigHUP (Catch hupHandler) Nothing installHandler sigINT (Catch $ termHandler sigINT) Nothing initState <- E.handle (\(e :: E.SomeException) -> do log Error "Starting failed: " e terminateLogger Nothing closeSystemLogger exitWith $ fromSysExitCode ConfigError) $ do initLogger <- initializeLogger initConf whenJust (cfChangeRootDirectory initConf) $ \dir -> log Notice "Chrooted in " (esc 256 $ B.pack dir) '.' when (any (isJust . ($ initConf)) [cfUser, cfGroup]) $ log Notice "Dropped privileges to " (fromMaybe "" $ cfUser initConf) ':' (fromMaybe "" $ cfGroup initConf) '.' initReconfig <- startReconfigServer (reconfigSocket static) (((writeChan mainChan . Reconfigure) .) . curry Just) let cleanup = terminateReconfigServer Nothing initReconfig stats <- startStatsServer (statsSocket static) `E.onException` cleanup let cleanup' = cleanup >> terminateStatsServer Nothing stats netState <- initializeNetworkStateManager static (mkExitTestConfig static initTestListeners initConf) initConf `E.onException` cleanup' dns <- startDNSServer (mkDNSServerConfig initDNSListener initDNSTCPListener initConf) web <- (startWebServer . mkWebConfig initConf) `liftMb` initHTTPListener return $ State (Just initLogger) (Just initReconfig) (Just stats) netState dns initTestListeners initDNSListener initDNSTCPListener web initHTTPListener S.empty log Notice "Successfully initialized all main subsystems. If no warnings " "appear above, it looks like everything is working." installHandler sigTERM (Catch $ termHandler sigTERM) Nothing flip fix (initConf, initState) $ \loop (!conf,!s) -> readChan mainChan >>= handleMessage mainChan static conf s >>= loop -- | Process a 'MainThreadMessage', returning a new config and state. handleMessage :: Chan MainThreadMessage -> StaticState -> Config -> State -> MainThreadMessage -> IO (Config, State) handleMessage _ static conf s (Reconfigure reconf) = flip runStateT s $ do (mbNewConf,respond) <- case reconf of Just (newConf, respond) -> do log Notice "Reloaded config from reconfigure socket." return (Just newConf, respond) Nothing | Just configFile <- cfConfigFile conf -> do log Notice "Caught SIGHUP. Reloading config file." r <- liftIO . E.try $ B.readFile configFile case r of Left (e :: E.IOException) -> do -- If we're chrooted, it's not suprising that we can't read our -- config file. when (isNothing $ cfChangeRootDirectory conf) $ log Warn "Reading config file failed: " e '.' return (Nothing, const $ return ()) Right file -> case parseConfigFile file >>= makeConfig of Left e -> do log Warn "Parsing config file failed: " e '.' return (Nothing, const $ return ()) Right newConf -> return (Just newConf, const $ return ()) | otherwise -> return (Nothing, const $ return ()) let errorRespond msg = liftIO $ respond (Just msg) >> log Error msg case mbNewConf of Nothing | Just logger' <- logger s, ToFile _ <- logTarget (cfLogConfig conf) -> do -- Close and re-open the log file to allow for log rotation. r <- liftIO . E.tryJust syncExceptions $ reconfigureLogger id case r of Left _ -> modify' $ \s' -> s' { logger = Nothing , deadThreads = S.insert (threadId logger') (deadThreads s') } Right _ -> return () return conf | otherwise -> return conf Just newConf -> do let changedStatic = staticConfigOptionsChanged conf newConf when (not $ null changedStatic) $ log Notice "Ignoring changed values for static config options " (concat $ intersperse ", " changedStatic) '.' let newConf' = copyStaticConfigOptions conf newConf when (cfStateDirectory conf /= cfStateDirectory newConf') $ liftIO $ checkDirectory Nothing Nothing (cfStateDirectory newConf') `catchIO` \e -> do errorRespond $ cat "Preparing new state directory failed: " e "; exiting gracefully." terminateProcess Can'tCreate static s Nothing reconfigureOrRestartLogger newConf' reconfigureListenersAndNetworkStateManager static newConf' errorRespond reconfigureDNSListenerAndServer static conf newConf' errorRespond reconfigureHTTPListenerAndServer static conf newConf' errorRespond liftIO $ respond Nothing return newConf' handleMessage _mainChan static _conf s (Terminate signal) = do log Notice "Caught signal (" signalStr "); exiting gracefully." terminateProcess OK static s $ if signal == sigINT then Nothing else Just exitWaitPeriod where signalStr | signal == sigINT = "SIGINT" | signal == sigTERM = "SIGTERM" | otherwise = show signal exitWaitPeriod = 2 * 10^6 handleMessage mainChan static conf s (Exit tid reason) | deadThreadIs logger = do (r,dead) <- tryForkLinkIO $ initializeLogger conf mbNewLogger <- case r of Left _ -> return Nothing Right newLogger -> do log Warn "The logger thread exited unexpectedly: " (show reason) "; restarted." return $ Just newLogger return (conf, s { logger = mbNewLogger , deadThreads = S.insert dead (deadThreads s) }) | deadThreadIs reconfigServer = do log Warn "The reconfigure server thread exited unexpectedly: " (show reason) "; restarting." (r,dead) <- tryForkLinkIO $ startReconfigServer (reconfigSocket static) (((writeChan mainChan . Reconfigure) .) . curry Just) mbNewReconfigServer <- case r of Left e -> do log Warn "Restarting reconfigure server failed: " (show e) "; disabling reconfigure server." return Nothing Right newReconfigServer -> return $ Just newReconfigServer return (conf, s { reconfigServer = mbNewReconfigServer , deadThreads = S.insert dead (deadThreads s) }) | deadThreadIs statsServer = do log Warn "The statistics server thread exited unexpectedly: " (show reason) "; restarting." (r,dead) <- tryForkLinkIO . startStatsServer $ statsSocket static mbNewStatsServer <- case r of Left e -> do log Warn "Restarting statistics server failed: " (show e) "; disabling statistics server." return Nothing Right newStatsServer -> return $ Just newStatsServer return (conf, s { statsServer = mbNewStatsServer , deadThreads = S.insert dead (deadThreads s) }) | tid == threadId (networkStateManager s) = do log Warn "The network state manager thread exited unexpectedly: " (show reason) "; restarting." newManager <- initializeNetworkStateManager static (mkExitTestConfig static (exitTestListeners s) conf) conf `E.catch` \(e :: E.SomeException) -> do log Error "Restarting network state manager failed: " e "; exiting gracefully." terminateProcess Internal static s Nothing return (conf, s { networkStateManager = newManager }) | tid == threadId (dnsServer s) = do log Warn "The DNS server thread exited unexpectedly: " (show reason) "; restarting." newDNSServer <- startDNSServer $ mkDNSServerConfig (dnsListener s) (dnsTCPListener s) conf return (conf, s { dnsServer = newDNSServer }) | Just web <- webServer s, tid == threadId web , Just sock <- httpListener s = do log Warn "The web server thread exited unexpectedly: " (show reason) "; restarting." newWebServer <- startWebServer $ mkWebConfig conf sock return (conf, s { webServer = Just newWebServer }) | tid `S.member` deadThreads s = return (conf, s { deadThreads = S.delete tid (deadThreads s) }) | otherwise = do log Warn "Bug: Received unexpected exit signal: " (show reason) return (conf, s) where deadThreadIs thr = ((tid ==) . threadId) `fmap` thr s == Just True -- | Open the DNS sockets for an address: a UDP socket and a listening TCP -- socket (RFC 7766 requires authoritative servers to answer over TCP). bindDNSSockets :: SockAddr -> IO (Socket, Socket) bindDNSSockets addr = E.bracketOnError (bindUDPSocket addr) closeSocket $ \udp -> do tcp <- bindListeningTCPSocket addr return (udp, tcp) -- | Return the DNS server config given the DNS sockets (UDP and listening -- TCP) and the 'Config'. mkDNSServerConfig :: Socket -> Socket -> Config -> DNSConfig mkDNSServerConfig dnsSock dnsTCPSock conf = DNSConfig { dnsSocket = dnsSock , dnsTCPSocket = dnsTCPSock , dnsAuthZone = DomainName $ reverse authLabels , dnsMyName = cfDomainName conf , dnsSOA = SOA (cfZoneOfAuthority conf) ttl (cfDomainName conf) (cfSOARName conf) 0 ttl ttl ttl ttl , dnsNS = NS (cfZoneOfAuthority conf) ttl (cfDomainName conf) , dnsA = A (cfZoneOfAuthority conf) ttl `fmap` cfAddress conf , dnsLists = cfExitLists conf , dnsRateLimit = cfDNSRateLimit conf , dnsClientSubnet = cfDNSClientSubnet conf , dnsByteStats = incrementBytes , dnsRespStats = incrementResponses } where DomainName authLabels = cfZoneOfAuthority conf -- | Return the web interface config given the listening HTTP socket. mkWebConfig :: Config -> Socket -> WebConfig mkWebConfig conf sock = WebConfig { webSocket = sock , webLists = cfExitLists conf , webPublicAddress = cfHTTPPublicAddress conf , webTrustedProxies = cfHTTPTrustedProxies conf , webMetricsAllowFrom = cfHTTPMetricsAllowFrom conf , webMetrics = currentMetrics VERSION , webRequestStats = incrementHTTPRequests } -- | Return the exit test config. mkExitTestConfig :: StaticState -> Map SockAddr (Maybe Socket) -> Config -> TestConfig -> ExitTestConfig mkExitTestConfig static testListeners conf testConf = ExitTestConfig { etcfListeners = testListeners , etcfConcClientLimit = (availableFileDesc static - extraFileDesc) `div` 2 , etcfGetRandBytes = randBytes $ randomHandle static , etcfTorSocksAddr = cfTorSocksAddress conf , etcfTestAddress = fst $ tcfTestDestinationAddress testConf , etcfTestPorts = snd $ tcfTestDestinationAddress testConf } -- | Start the logger thread, resetting the log target or disabling logging if -- necessary. initializeLogger :: Config -> IO Logger initializeLogger conf = do newLogTarget <- checkLogTarget . logTarget . cfLogConfig $ conf let newLogConfig = (cfLogConfig conf) { logTarget = newLogTarget } if cfRunAsDaemon conf && any (newLogTarget ==) [ToStdOut, ToStdErr] then startLogger newLogConfig { logEnabled = False } else startLogger newLogConfig -- | Start the network state manager thread. initializeNetworkStateManager :: StaticState -> (TestConfig -> ExitTestConfig) -> Config -> IO NetworkStateManager initializeNetworkStateManager static exitTestConfig conf = do startNetworkStateManager NetworkStateManagerConfig { nsmcfTorControlAddr = cfTorControlAddress conf , nsmcfTorControlPasswd = cfTorControlPassword conf , nsmcfStateDir = cfStateDirectory conf , nsmcfRandom = randomHandle static , nsmcfExitTestConfig = exitTestConfig `fmap` cfTestConfig conf } -- | Reconfigure the logger if it's running, or attempt to restart it if it's -- not running, given the new config. reconfigureOrRestartLogger :: Config -> StateT State IO () reconfigureOrRestartLogger conf = do s <- get case logger s of Just logger' -> do logConf <- if cfRunAsDaemon conf && any (logTarget (cfLogConfig conf) ==) [ToStdOut, ToStdErr] then do log Warn "Cannot log to " (logTarget $ cfLogConfig conf) " when daemonized. Disabling logging." return (cfLogConfig conf) { logEnabled = False } else return $ cfLogConfig conf r <- liftIO . E.tryJust syncExceptions $ reconfigureLogger (const logConf) case r of Left _ -> put $! s { logger = Nothing , deadThreads = S.insert (threadId logger') (deadThreads s) } Right _ -> return () Nothing -> do (r,dead) <- liftIO . tryForkLinkIO $ initializeLogger conf let mbNewLogger = either (const Nothing) Just r put $! s { logger = mbNewLogger , deadThreads = S.insert dead (deadThreads s) } -- | Reconfigure the exit test listeners and network state manager. reconfigureListenersAndNetworkStateManager :: StaticState -> Config -> (String -> StateT State IO ()) -> StateT State IO () reconfigureListenersAndNetworkStateManager static conf errorRespond = do s <- get let (mbNewListeners,newListenerMap) = updateListeners s r <- liftIO . E.tryJust syncExceptions $ reconfigureNetworkStateManager (\c -> c { nsmcfTorControlAddr = cfTorControlAddress conf , nsmcfTorControlPasswd = cfTorControlPassword conf , nsmcfStateDir = cfStateDirectory conf , nsmcfExitTestConfig = mkExitTestConfig static newListenerMap conf `fmap` cfTestConfig conf }) (networkStateManager s) case r of Left e -> do errorRespond $ cat "Reconfiguring network state manager failed: " e "; exiting gracefully." get >>= liftIO . flip (terminateProcess ConfigError static) Nothing Right _ -> do put $! s { exitTestListeners = newListenerMap } whenJust mbNewListeners $ \newListeners -> forM_ (M.assocs $ exitTestListeners s `M.difference` newListeners) $ \(addr,mbSock) -> whenJust mbSock $ \sock -> do log Notice "Closing exit test listener on " addr '.' liftIO $ closeSocket sock where updateListeners s = case cfTestConfig conf of Just testConf -> let addr = htonl . fst $ tcfTestListenAddress testConf newListeners = M.fromList $ map (\port -> (SockAddrInet (fromIntegral port) addr, Nothing)) (snd $ tcfTestListenAddress testConf) in ( Just newListeners , M.intersection (exitTestListeners s) newListeners `M.union` newListeners ) Nothing -> (Nothing, exitTestListeners s) -- | Reconfigure the DNS server, and the DNS listener if necessary. reconfigureDNSListenerAndServer :: StaticState -> Config -> Config -> (String -> StateT State IO ()) -> StateT State IO () reconfigureDNSListenerAndServer static oldConf newConf errorRespond = do when (cfDNSListenAddress oldConf /= cfDNSListenAddress newConf) $ do log Notice "Opening DNS listener on " (cfDNSListenAddress newConf) '.' r <- liftIO . E.try $ bindDNSSockets $ cfDNSListenAddress newConf case r of Left (e :: E.IOException) -> do errorRespond $ cat "Opening DNS listener on " (cfDNSListenAddress newConf) " failed: " e "; exiting gracefully." s <- get liftIO $ terminateProcess (bindErrorCode e) static s Nothing Right (sock, tcpSock) -> do log Notice "Closing DNS listener on " (cfDNSListenAddress oldConf) '.' modify' $ \s -> s { dnsListener = sock, dnsTCPListener = tcpSock } s <- get r <- liftIO . E.tryJust syncExceptions $ reconfigureDNSServer (const $ mkDNSServerConfig (dnsListener s) (dnsTCPListener s) newConf) (dnsServer s) case r of Left e -> do errorRespond $ cat "Reconfiguring DNS Server failed: " e "; exiting gracefully." get >>= liftIO . flip (terminateProcess IOError static) Nothing Right _ -> return () -- | Start, stop, or reconfigure the web interface and its listener according -- to the new config. reconfigureHTTPListenerAndServer :: StaticState -> Config -> Config -> (String -> StateT State IO ()) -> StateT State IO () reconfigureHTTPListenerAndServer static oldConf newConf errorRespond = do s <- get case (cfHTTPListenAddress newConf, httpListener s, webServer s) of -- disabled (Nothing, mbSock, mbWeb) -> do whenJust mbWeb $ \web -> do liftIO $ terminateWebServer Nothing web modify' $ \s' -> s' { deadThreads = S.insert (threadId web) (deadThreads s') } whenJust mbSock $ \sock -> do log Notice "Closing HTTP listener." liftIO . ignoreIOExn $ closeSocket sock modify' $ \s' -> s' { webServer = Nothing, httpListener = Nothing } -- enabled, possibly on a new address (Just addr, mbSock, mbWeb) -> do sock <- case mbSock of Just sock | cfHTTPListenAddress oldConf == Just addr -> return sock _ -> do log Notice "Opening HTTP listener on " addr '.' r <- liftIO . E.try $ bindListeningTCPSocket addr case r of Left (e :: E.IOException) -> do errorRespond $ cat "Opening HTTP listener on " addr " failed: " e "; exiting gracefully." get >>= \s' -> liftIO $ terminateProcess (bindErrorCode e) static s' Nothing Right sock -> do -- An old web server closes its old listener when reconfigured -- with the new one; without a server, close it ourselves. when (isNothing mbWeb) $ whenJust mbSock $ liftIO . ignoreIOExn . closeSocket return sock case mbWeb of Nothing -> do web <- liftIO . startWebServer $ mkWebConfig newConf sock modify' $ \s' -> s' { webServer = Just web, httpListener = Just sock } Just web -> do r <- liftIO . E.tryJust syncExceptions $ reconfigureWebServer (const $ mkWebConfig newConf sock) web case r of Left e -> do errorRespond $ cat "Reconfiguring web server failed: " e "; exiting gracefully." get >>= liftIO . flip (terminateProcess IOError static) Nothing Right _ -> modify' $ \s' -> s' { httpListener = Just sock } where ignoreIOExn = (`catchIO` \_ -> return ()) -- | Terminate the process by first asking all our linked, child threads to -- terminate gracefully, then releasing the resources held in 'StaticState'. terminateProcess :: SysExitCode -> StaticState -> State -> Maybe Int -> IO a terminateProcess status static s mbWait = do whenJust (reconfigServer s) (terminateReconfigServer mbWait) terminateNetworkStateManager mbWait $ networkStateManager s terminateDNSServer mbWait $ dnsServer s whenJust (webServer s) (terminateWebServer mbWait) whenJust (statsServer s) (terminateStatsServer mbWait) forM_ (M.assocs $ exitTestListeners s) $ \(addr,mbSock) -> whenJust mbSock $ \sock -> do log Info "Closing exit test listener on " addr '.' ignoreIOExn $ closeSocket sock log Info "Closing DNS listener." ignoreIOExn . closeSocket $ dnsListener s ignoreIOExn . closeSocket $ dnsTCPListener s whenJust (httpListener s) $ \sock -> do log Info "Closing HTTP listener." ignoreIOExn $ closeSocket sock log Info "Closing statistics listener." ignoreIOExn . closeSocket $ statsSocket static log Info "Closing reconfigure listener." ignoreIOExn . closeSocket $ reconfigSocket static ignoreIOExn . hClose $ randomHandle static log Notice "All subsystems have terminated. Exiting now." terminateLogger mbWait closeSystemLogger exitWith $ fromSysExitCode status where ignoreIOExn = (`catchIO` \_ -> return ()) -------------------------------------------------------------------------------- -- Daemon operations -- | The identity we drop privileges to: a user, a group, and the -- supplementary groups. data Privileges = Privileges { privUser :: !(Maybe UserID) , privGroup :: !(Maybe GroupID) , privGroups :: ![GroupID] } deriving (Eq, Show) -- | Look up the identity for a user and group name. Without a group, use the -- user's primary group, not root's. The supplementary groups are the user's -- (as initgroups(3) would set them, so that e.g. membership in Tor's group, -- needed to read its control cookie, survives), or none without a user. Look -- them up now: there may be no group database after chrooting. getIDs :: Maybe String -> Maybe String -> IO Privileges getIDs user group = do userEntry <- getUserEntryForName `liftMb` user groupEntry <- getGroupEntryForName `liftMb` group let gid = (groupID `fmap` groupEntry) `mplus` (userGroupID `fmap` userEntry) groups <- case (userEntry, gid) of (Just u, Just g) -> do entries <- getAllGroupEntries return $ supplementaryGroups (userName u) g [(groupID e, groupMembers e) | e <- entries] (Nothing, Just g) -> return [g] _ -> return [] return $ Privileges (userID `fmap` userEntry) gid groups -- | The supplementary groups for a user: its primary group and every group -- that lists it as a member. supplementaryGroups :: String -> GroupID -> [(GroupID, [String])] -> [GroupID] supplementaryGroups user primary entries = primary : L.nub [g | (g, members) <- entries, user `elem` members , g /= primary] -- | Drop privileges: set the supplementary groups first, so that none of -- root's (group 0 in particular) are kept, then the group, then the user. dropPrivileges :: Privileges -> IO () dropPrivileges p | isNothing (privUser p) && isNothing (privGroup p) = return () | otherwise = do setGroups (privGroups p) whenJust (privGroup p) setGroupID whenJust (privUser p) setUserID -- | Call chroot(2) using the given directory path. Throws an 'IOError' if the -- call fails. changeRootDirectory :: FilePath -> IO () changeRootDirectory dir = withCString dir $ \s -> throwErrnoPathIfMinus1_ "changeRootDirectory" dir (c_chroot s) -- | Run an IO action as a daemon. This action doesn't return. daemonize :: IO () -> IO () daemonize io = do forkProcess $ do createSession forkProcess $ do setCurrentDirectory "/" mapM_ closeFd stdFds #if MIN_VERSION_unix(2,8,0) nullFd <- openFd "/dev/null" ReadWrite defaultFileFlags #else nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags #endif mapM_ (dupTo nullFd) stdFds closeFd nullFd io exitImmediately ExitSuccess exitImmediately ExitSuccess where stdFds = [stdInput, stdOutput, stdError] -------------------------------------------------------------------------------- -- Helpers -- | Ensure that the current limit on open file descriptors is at least -- @lowerLimit@, raising the soft limit (and the hard limit, if we're root) to -- at most @cap@. Return the new current limit. -- -- With the threaded RTS, GHC's I\/O manager uses epoll(7)\/kqueue(2), so the -- old FD_SETSIZE restriction of the select(2)-based non-threaded RTS only -- applies when we were linked without @-threaded@. setMaxOpenFiles :: Integer -> Integer -> IO Integer setMaxOpenFiles lowerLimit cap0 = do euid <- getEffectiveUserID limits <- getResourceLimit ResourceOpenFiles let fdSetSize = #{const FD_SETSIZE} :: Integer cap | rtsSupportsBoundThreads = cap0 | otherwise = cap0 `min` fdSetSize hard = limitValue (hardLimit limits) when (euid /= 0 && maybe False (< lowerLimit) hard) $ exitPrint NoPermission $ cat "The hard limit on file descriptors is set to " (showLimit $ hardLimit limits) ", but we need at least " lowerLimit '.' when (cap < lowerLimit) $ exitPrint Internal $ cat "FD_SETSIZE is " fdSetSize ", but we need at least " lowerLimit " file descriptors." let newLimits limit | euid /= 0 = limits { softLimit = ResourceLimit limit } | otherwise = limits { softLimit = ResourceLimit limit , hardLimit = ResourceLimit limit } most | euid /= 0 = maybe cap (min cap) hard | otherwise = cap catchIO (setResourceLimit ResourceOpenFiles (newLimits most) >> return most) $ \e -> if isPermissionError e && euid == 0 then -- root without CAP_SYS_RESOURCE (in a container, say) can't raise -- the hard limit; make do with it. case hard of Just h | h >= lowerLimit -> do let most' = min cap h setResourceLimit ResourceOpenFiles limits { softLimit = ResourceLimit most' } return most' _ -> E.throwIO e else do #ifdef OPEN_MAX -- For macOS, where the kernel refuses limits above OPEN_MAX. let openMax = #{const OPEN_MAX} :: Integer if not (isPermissionError e) && openMax < most then do setResourceLimit ResourceOpenFiles (newLimits openMax) return openMax else E.throwIO e #else E.throwIO e #endif where limitValue (ResourceLimit n) = Just n limitValue _ = Nothing showLimit (ResourceLimit n) = show n showLimit ResourceLimitInfinity = "infinity" showLimit ResourceLimitUnknown = "unknown" -- | Set up the state or runtime directory with proper ownership and -- permissions. Refuse a directory that users other than its owner can write -- to: we create sockets and files in it as root and change their ownership -- and mode, which others could redirect with symbolic links; and such a -- directory (e.g. \/tmp, set by mistake) isn't ours to take over. checkDirectory :: Maybe UserID -> Maybe FilePath -> FilePath -> IO () checkDirectory uid newRoot path = do createDirectoryIfMissing True fullPath desiredUID <- maybe getEffectiveUserID return uid st <- getFileStatus fullPath when (isGroupOrWorldWritable (fileMode st)) $ ioError . userError $ cat (esc 256 $ B.pack fullPath) " is writable by users other than its owner; refusing to use it." when (fileOwner st /= desiredUID) $ setOwnerAndGroup fullPath desiredUID (-1) when (fileMode st .&. 0o700 /= 0o700) $ setFileMode fullPath (fileMode st .|. 0o700) where fullPath = maybe id ((++) . (++ "/")) newRoot path -- | Check if the log target can be used. If it can, return it. Otherwise, -- return 'ToStdOut'. checkLogTarget :: LogTarget -> IO LogTarget checkLogTarget target@(ToFile logPath) = E.bracket (openFile logPath AppendMode) hClose (\_ -> return target) `catchIO` (\_ -> return ToStdOut) checkLogTarget target = return target -- | System exit status codes from sysexits.h. data SysExitCode = OK -- ^ Successful termination | Usage -- ^ Command line usage error | DataError -- ^ Data format error | NoInput -- ^ Cannot open input | NoUser -- ^ Addressee unknown | NoHost -- ^ Host name unknown | Unavailable -- ^ Service unavailable | Internal -- ^ Internal software error | OSError -- ^ System error (e.g., can't fork) | OSFile -- ^ Critical OS file missing | Can'tCreate -- ^ Can't create (user) output file | IOError -- ^ Input/output error | TempFailure -- ^ Temp failure; user is invited to retry | ProtocolError -- ^ Remote error in protocol | NoPermission -- ^ Permission denied | ConfigError -- ^ Configuration error -- | Convert a system exit status code to an 'ExitCode' for 'exitWith'. fromSysExitCode :: SysExitCode -> ExitCode fromSysExitCode status = case status of OK -> ExitSuccess Usage -> ExitFailure #{const EX_USAGE} DataError -> ExitFailure #{const EX_DATAERR} NoInput -> ExitFailure #{const EX_NOINPUT} NoUser -> ExitFailure #{const EX_NOUSER} NoHost -> ExitFailure #{const EX_NOHOST} Unavailable -> ExitFailure #{const EX_UNAVAILABLE} Internal -> ExitFailure #{const EX_SOFTWARE} OSError -> ExitFailure #{const EX_OSERR} OSFile -> ExitFailure #{const EX_OSFILE} Can'tCreate -> ExitFailure #{const EX_CANTCREAT} IOError -> ExitFailure #{const EX_IOERR} TempFailure -> ExitFailure #{const EX_TEMPFAIL} ProtocolError -> ExitFailure #{const EX_PROTOCOL} NoPermission -> ExitFailure #{const EX_NOPERM} ConfigError -> ExitFailure #{const EX_CONFIG} -- | Return the system exit code corresponding to an 'IOError' generated by the -- failure to open a listening socket. bindErrorCode :: IOError -> SysExitCode bindErrorCode e | isPermissionError e = NoPermission | otherwise = OSError -- | Lift an @Either ShowS@ computation into the 'IO' monad by logging @Left e@ -- as an error message and exiting. exitLeft :: SysExitCode -> Either ShowS a -> IO a exitLeft status = either (exitPrint status) return -- | Print the given string as an error message and exit with the given status. exitPrint :: SysExitCode -> ShowS -> IO a exitPrint status msg = do log Error msg exitUsage stderr $ fromSysExitCode status -- | Lift a 'Maybe' into a monadic action. liftMb :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) liftMb f = maybe (return Nothing) (liftM Just . f) infixr 8 `liftMb` -- | Specialization of 'E.catch' for 'E.IOException'. catchIO :: IO a -> (E.IOException -> IO a) -> IO a catchIO = E.catch foreign import ccall unsafe "unistd.h chroot" c_chroot :: CString -> IO CInt mhatta-tordnsel-1d9141b/src/TorDNSEL/NetworkState.hs000066400000000000000000000015161527317632400222730ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.NetworkState -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, pattern guards, bang patterns) -- -- Manages our current view of the Tor network, initiating test connections -- through exit nodes when necessary and storing results of those tests in -- the file system. -- ----------------------------------------------------------------------------- module TorDNSEL.NetworkState ( NetworkStateManager , NetworkStateManagerConfig(..) , ExitTestConfig(..) , startNetworkStateManager , readNetworkState , reconfigureNetworkStateManager , terminateNetworkStateManager ) where import TorDNSEL.NetworkState.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/NetworkState/000077500000000000000000000000001527317632400217345ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/NetworkState/Internals.hs000066400000000000000000001116641527317632400242400ustar00rootroot00000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.NetworkState.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, pattern guards, bang patterns) -- -- /Internals/: should only be imported by the public module and tests. -- -- Manages our current view of the Tor network, initiating test connections -- through exit nodes when necessary and storing results of those tests in -- the file system. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.NetworkState.Internals ( NetworkStateManager(..) , networkStateMV , NetworkStateManagerConfig(..) , ExitTestConfig(..) , ManagerState(..) , ExitTestState(..) , startNetworkStateManager , reconfigureNetworkStateManager , terminateNetworkStateManager , handleMessage , withCookie , lookupRouters , modifyNetworkState , readNetworkState , modify' -- * Tor controller , startTorController , controlConnMV , withExitMapping , exitMappingName -- * Exit tests , initExitTestServerConfig , initExitTestInitiatorConfig , initializeExitTests , terminateExitTests -- * Pure network state updates , mergeExitAddrsWithNetState , newExitAddress , acceptTestedAddress , takeCookie , maxTestedAddresses , keepLatestAddresses , newDescriptor , newRouterStatus , newConsensus , expireOldInfo , insertAddress , deleteAddress ) where import Prelude hiding (log) import Control.Arrow ((&&&)) import Control.Monad (liftM2, when) import Control.Monad.Fix (fix) import Control.Monad.State.Strict (StateT, runStateT, execStateT, get, gets, put, MonadIO, liftIO) import Control.Concurrent (threadDelay) import Control.Concurrent.Chan (newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) import qualified Control.Exception as E import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) import qualified Data.List as L import Data.Ord (comparing, Down(..)) import Data.Maybe import qualified Data.Map as M import Data.Map (Map) import qualified Data.Set as S import Data.Set (Set) import Data.Time (UTCTime, getCurrentTime, diffUTCTime) import Network.Socket (HostAddress, SockAddr, Socket, socketToHandle) import System.IO (Handle, IOMode(ReadWriteMode)) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.Directory import TorDNSEL.ExitTest.Initiator import TorDNSEL.ExitTest.Request import TorDNSEL.ExitTest.Server import TorDNSEL.Log import TorDNSEL.NetworkState.Storage import TorDNSEL.NetworkState.Types import TorDNSEL.Random (randBytes) import TorDNSEL.TorControl import TorDNSEL.Util -- | A handle to the network state manager thread. data NetworkStateManager = NetworkStateManager (ManagerMessage -> IO ()) ThreadId instance Thread NetworkStateManager where threadId (NetworkStateManager _ tid) = tid -- | A mutable variable containing the current network state. networkStateMV :: MVar NetworkState {-# NOINLINE networkStateMV #-} networkStateMV = unsafePerformIO $ newMVar emptyNetworkState -- | The network state manager configuration. data NetworkStateManagerConfig = NetworkStateManagerConfig { -- | Address to connect to the Tor controller interface. nsmcfTorControlAddr :: !SockAddr, -- | The password used for Tor controller auth. nsmcfTorControlPasswd :: !(Maybe ByteString), -- | Where to store exit test results. nsmcfStateDir :: !FilePath, -- | A handle to the random number device, for the nonce of SAFECOOKIE -- authentication. nsmcfRandom :: !Handle, -- | The exit test configuration, if exit tests are enabled. nsmcfExitTestConfig :: !(Maybe ExitTestConfig) } deriving Eq -- | The exit test configuration. data ExitTestConfig = ExitTestConfig { -- | Addresses on which to listen for exit test connection and the -- associated listening sockets, when they are open. etcfListeners :: !(Map SockAddr (Maybe Socket)), -- | The maximum number of exit tests to run concurrently. etcfConcClientLimit :: !Integer, -- | Get an arbitrary number of bytes from OpenSSL's PRNG. etcfGetRandBytes :: !(Int -> IO ByteString), -- | Where Tor is listening for SOCKS connections. etcfTorSocksAddr :: !SockAddr, -- | The IP address to which we make exit test connections through Tor. etcfTestAddress :: !HostAddress, -- | The ports to which we make exit test connections through Tor. etcfTestPorts :: ![Port] } instance Eq ExitTestConfig where x == y = all (\(===) -> x === y) [ eq etcfListeners, eq etcfConcClientLimit, eq etcfTorSocksAddr , eq etcfTestAddress, eq etcfTestPorts ] where eq :: Eq b => (a -> b) -> a -> a -> Bool eq = on (==) -- | An internal type representing the current exit test manager state. data ManagerState = ManagerState { networkState :: !NetworkState , torControlConn :: !(Either (ThreadId, Int) Connection) , deadThreads :: !(Set ThreadId) , exitTestState :: !(Maybe ExitTestState) } -- | An internal type representing the current exit test state. data ExitTestState = ExitTestState { storageManager :: !StorageManager , exitTestServer :: !ExitTestServer , exitTestInitiator :: !ExitTestInitiator , cookies :: !(Map Cookie (RouterID, UTCTime, Port)) } -- | An internal type for messages sent to the network state manager. data ManagerMessage = NewDescriptors [Descriptor] -- ^ New descriptors are available. | NewNetworkStatus [RouterStatus] -- ^ New router status entries are available -- | A new consensus listing every router that is currently in the network. | NewConsensus [RouterStatus] -- | Map a new cookie to an exit node identifier, descriptor published time, -- and port. | MapCookie Cookie RouterID UTCTime Port | UnmapCookie Cookie -- ^ Remove a cookie to exit node identity mapping. -- | We've received a cookie from an incoming exit test connection. | NewExitAddress UTCTime Cookie HostAddress -- | Reconfigure the network state manager. | Reconfigure (NetworkStateManagerConfig -> NetworkStateManagerConfig) (IO ()) | Terminate ExitReason -- ^ Terminate the network state manager gracefully. -- | An exit signal sent to the network state manager. | Exit ThreadId ExitReason -- | Start the network state manager given an initial config, returning a handle -- to it. Link the network state manager to the calling thread. If the network -- state manager exits before completely starting, throw its exit signal in the -- calling thread. startNetworkStateManager :: NetworkStateManagerConfig -> IO NetworkStateManager startNetworkStateManager initConf = do log Info "Starting network state manager." chan <- newChan tid <- startLink $ \signal -> do setTrapExit $ (writeChan chan .) . Exit net <- NetworkStateManager (writeChan chan) `fmap` myThreadId (controller,deadTid) <- startTorController net initConf Nothing let emptyState = ManagerState emptyNetworkState controller (S.singleton deadTid) Nothing initState <- case nsmcfExitTestConfig initConf of -- Only fork exit test threads when the controller is running. Just testConf | Right conn <- controller -> execStateT (initializeExitTests net (nsmcfStateDir initConf) testConf) emptyState `E.onException` closeConnection conn _ -> return emptyState swapMVar networkStateMV $! networkState initState signal flip fix (initConf, initState) $ \loop (!conf,!s) -> do msg <- readChan chan runStateT (handleMessage net conf msg) s >>= loop return $ NetworkStateManager (writeChan chan) tid -- | Reconfigure the network state mananger synchronously with the given -- function. If the thread exits abnormally before reconfiguring itself, throw -- its exit signal in the calling thread. reconfigureNetworkStateManager :: (NetworkStateManagerConfig -> NetworkStateManagerConfig) -> NetworkStateManager -> IO () reconfigureNetworkStateManager reconf (NetworkStateManager send tid) = sendSyncMessage (send . Reconfigure reconf) tid -- | Terminate the network state manager gracefully. The optional parameter -- specifies the amount of time in microseconds to wait for the thread to -- terminate. If the thread hasn't terminated by the timeout, an uncatchable -- exit signal will be sent. terminateNetworkStateManager :: Maybe Int -> NetworkStateManager -> IO () terminateNetworkStateManager mbWait (NetworkStateManager send tid) = terminateThread mbWait tid (send $ Terminate NormalExit) -- | Process a 'ManagerMessage' and return the new config and state, given the -- current config and state. handleMessage :: NetworkStateManager -> NetworkStateManagerConfig -> ManagerMessage -> StateT ManagerState IO NetworkStateManagerConfig handleMessage _net conf (NewDescriptors ds) = do now <- liftIO getCurrentTime networkState' <- gets $ \s -> L.foldl' (newDescriptor now) (networkState s) ds modifyNetworkState networkState' mbTestState <- gets exitTestState whenJust mbTestState $ \testState -> liftIO $ notifyNewDirInfo (lookupRouters networkState' descRouterID ds) (exitTestInitiator testState) return conf handleMessage _net conf (NewNetworkStatus rss) = do now <- liftIO getCurrentTime networkState' <- gets $ \s -> expireOldInfo now $ L.foldl' (newRouterStatus now) (networkState s) rss modifyNetworkState networkState' mbTestState <- gets exitTestState whenJust mbTestState $ \testState -> liftIO $ do notifyNewDirInfo (lookupRouters networkState' rsRouterID rss) (exitTestInitiator testState) rebuildExitAddressStorage (nsRouters networkState') (storageManager testState) return conf handleMessage _net conf (NewConsensus rss) = do now <- liftIO getCurrentTime networkState' <- gets $ expireOldInfo now . newConsensus now rss . networkState modifyNetworkState networkState' mbTestState <- gets exitTestState whenJust mbTestState $ \testState -> liftIO $ do notifyNewDirInfo (lookupRouters networkState' rsRouterID rss) (exitTestInitiator testState) rebuildExitAddressStorage (nsRouters networkState') (storageManager testState) return conf handleMessage _net conf (MapCookie cookie rid published port) = do mbTestState <- gets exitTestState case mbTestState of Just testState -> modify' $ \s -> s { exitTestState = Just $! testState { cookies = M.insert cookie (rid, published, port) (cookies testState) } } Nothing -> log Debug "Ignoring request to map a cookie for router " rid " since exit tests are disabled." return conf handleMessage _net conf (UnmapCookie cookie) = do mbTestState <- gets exitTestState case mbTestState of Just testState -> modify' $ \s -> s { exitTestState = Just $! testState { cookies = M.delete cookie (cookies testState) } } Nothing -> log Debug "Ignoring request to unmap a cookie since exit tests \ \are disabled." return conf handleMessage _net conf (NewExitAddress tested cookie address) = do mbTestState <- gets exitTestState case mbTestState of Nothing -> log Info "Ignoring exit test request from " (inet_htoa address) " since exit tests are disabled." Just testState -> case takeCookie cookie (cookies testState) of (Nothing, _) -> log Info "Received unrecognized (or already used) \ \cookie from " (inet_htoa address) "; discarding." (Just (rid,published,port), cookies') -> do modify' $ \s -> s { exitTestState = Just $! testState { cookies = cookies' } } mbRouter <- gets (M.lookup rid . nsRouters . networkState) case mbRouter of Nothing -> log Info "Received cookie for unrecognized router " rid "; discarding." Just router | not (acceptTestedAddress router address) -> log Info "Exit test through router " rid " port " port " accepted from " (inet_htoa address) ", but the router \ \already has " maxTestedAddresses " tested exit \ \addresses; ignoring this one." | otherwise -> do log Info "Exit test through router " rid " port " port " accepted from " (inet_htoa address) '.' (router',networkState') <- gets $ newExitAddress tested published router rid address . networkState modifyNetworkState networkState' when ((M.member address . tstAddresses) `fmap` rtrTestResults router == Just False) $ -- If we haven't seen this address before, test through this -- router again in case the router is rotating exit addresses. liftIO $ scheduleNextExitTest rid (exitTestInitiator testState) liftIO $ storeNewExitAddress rid router' (nsRouters networkState') (storageManager testState) return conf handleMessage net conf (Reconfigure reconf signal) | conf == newConf = liftIO signal >> return newConf | otherwise = do log Notice "Reconfiguring network state manager." when (nsmcfTorControlAddr conf /= nsmcfTorControlAddr newConf) $ do controlConn <- gets torControlConn deadTid1 <- case controlConn of Left (tid,_) -> return tid Right conn -> do log Notice "Closing Tor controller connection." liftIO $ forgetConnection >> closeConnection conn return $ threadId conn (controller,deadTid2) <- startTorController net newConf Nothing modify' $ \s -> s { torControlConn = controller , deadThreads = S.insert deadTid2 . S.insert deadTid1 $ deadThreads s } s <- get case exitTestState s of Nothing | Just testConf <- nsmcfExitTestConfig newConf , Right _ <- torControlConn s -> initializeExitTests net (nsmcfStateDir newConf) testConf >>= liftIO . notifyNewDirInfo (M.assocs . nsRouters $ networkState s) | otherwise -> return () Just testState | Just testConf <- nsmcfExitTestConfig newConf , Right _ <- torControlConn s -> liftIO $ do flip reconfigureExitTestInitiator (exitTestInitiator testState) $ \c -> c { eticfConcClientLimit = etcfConcClientLimit testConf , eticfSocksServer = etcfTorSocksAddr testConf , eticfTestAddress = etcfTestAddress testConf , eticfTestPorts = etcfTestPorts testConf } flip reconfigureExitTestServer (exitTestServer testState) $ \c -> c { etscfConcClientLimit = etcfConcClientLimit testConf , etscfListenAddrs = M.keysSet $ etcfListeners testConf } reconfigureStorageManager (\c -> c { stcfStateDir = nsmcfStateDir newConf }) (storageManager testState) | otherwise -> terminateExitTests testState liftIO signal return newConf where newConf = reconf conf handleMessage _net _conf (Terminate reason) = do log Info "Terminating network state manager." s <- get either (const $ return ()) (\c -> liftIO $ forgetConnection >> closeConnection c) (torControlConn s) whenJust (exitTestState s) $ \testState -> do terminateExitTests testState return () liftIO $ exit reason handleMessage net conf (Exit tid reason) = get >>= handleExit where handleExit s | Left (timer,delay) <- torControlConn s, tid == timer = do (controller,deadTid) <- startTorController net conf (Just delay) put $! s { torControlConn = controller , deadThreads = S.insert deadTid (deadThreads s) } case controller of Right _ | Just testConf <- nsmcfExitTestConfig conf -> initializeExitTests net (nsmcfStateDir conf) testConf >>= liftIO . notifyNewDirInfo (M.assocs . nsRouters . networkState $ s) _ -> return () return conf | Right conn <- torControlConn s, tid == threadId conn = do log Warn "The Tor controller thread exited unexpectedly: " (show reason) "; restarting." (controller,deadTid) <- startTorController net conf Nothing put $! s { torControlConn = controller , deadThreads = S.insert deadTid (deadThreads s) } case controller of Left _ | Just testState <- exitTestState s -> terminateExitTests testState _ -> return () return conf | tid `S.member` deadThreads s = do put $! s { deadThreads = S.delete tid (deadThreads s) } return conf | otherwise = case liftM2 (,) (nsmcfExitTestConfig conf) (exitTestState s) of Just (testConf,testState) | tid == toTid storageManager -> do log Warn "The storage manager thread exited unexpectedly: " (show reason) "; restarting." storage <- liftIO . startStorageManager . StorageConfig $ nsmcfStateDir conf liftIO $ rebuildExitAddressStorage (nsRouters $ networkState s) storage putTestState testState { storageManager = storage } return conf | tid == toTid exitTestServer -> do log Warn "The exit test server thread exited unexpectedly: " (show reason) "; restarting." server <- liftIO $ startExitTestServer (M.assocs $ etcfListeners testConf) (initExitTestServerConfig net testConf) putTestState testState { exitTestServer = server } return conf | tid == toTid exitTestInitiator -> do log Warn "The exit test initiator thread exited unexpectedly: " (show reason) "; restarting." initiator <- liftIO $ startExitTestInitiator (initExitTestInitiatorConfig net testConf) putTestState testState { exitTestInitiator = initiator } return conf where toTid f = threadId $ f testState putTestState x = put $! s { exitTestState = Just $! x} _ | isAbnormal reason -> liftIO $ exit reason | otherwise -> return conf -- | Register a mapping from cookie to router identifier, descriptor published -- time and port, passing the cookie to the given 'IO' action. The cookie is -- guaranteed to be released when the action terminates. withCookie :: NetworkStateManager -> (Int -> IO ByteString) -> RouterID -> UTCTime -> Port -> (Cookie -> IO a) -> IO a withCookie (NetworkStateManager send _) getRandBytes rid published port = E.bracket addNewCookie (send . UnmapCookie) where addNewCookie = do cookie <- newCookie getRandBytes send $ MapCookie cookie rid published port return cookie -- | Lookup a list of routers in the network state. lookupRouters :: NetworkState -> (a -> RouterID) -> [a] -> [(RouterID, Router)] lookupRouters ns f = mapMaybe $ \x -> let rid = f x in (,) rid `fmap` M.lookup rid (nsRouters ns) -- | Replace the current network state with a new network state. modifyNetworkState :: NetworkState -> StateT ManagerState IO () modifyNetworkState ns = do liftIO $ swapMVar networkStateMV $! ns modify' $ \s -> s { networkState = ns } -- | Read the current network state. readNetworkState :: IO NetworkState readNetworkState = readMVar networkStateMV -------------------------------------------------------------------------------- -- Tor controller -- | The current Tor controller connection, if one is open. Exit test clients -- use it to install address mappings. controlConnMV :: MVar (Maybe Connection) {-# NOINLINE controlConnMV #-} controlConnMV = unsafePerformIO $ newMVar Nothing -- | Stop handing out the current controller connection. forgetConnection :: IO () forgetConnection = () <$ swapMVar controlConnMV Nothing -- | The hostname we ask Tor's SOCKS port for when testing through an exit -- node, derived from the test's cookie so that it's unique per test. exitMappingName :: Cookie -> ByteString exitMappingName cookie = B.concat [ B.pack "t", B.take 20 . encodeBase16 $ unCookie cookie , B.pack ".tordnsel-test.invalid" ] -- | Make an exit test connection go through a particular exit node. -- -- Tor refuses @.exit@ hostnames received on its SOCKS port, but still honours -- a @.exit@ target installed through the controller with MAPADDRESS. So we -- map a unique hostname to @testAddr.FINGERPRINT.exit@, pass that hostname to -- the action (which connects to it through the SOCKS port), and remove the -- mapping afterwards. Throw a 'TorControlError' if no controller connection is -- available or Tor refuses the mapping. withExitMapping :: HostAddress -> RouterID -> Cookie -> (ByteString -> IO a) -> IO a withExitMapping testAddr rid cookie io = do mbConn <- readMVar controlConnMV conn <- maybe (E.throwIO ConnectionClosed) return mbConn E.bracket_ (mapAddress [(name, target)] conn) (unmapAddress [name] conn `E.catch` \(_ :: TorControlError) -> return ()) (io name) where name = exitMappingName cookie target = B.concat [ B.pack (inet_htoa testAddr), B.pack "." , encodeBase16RouterID rid, B.pack ".exit" ] -- | Attempt to start the Tor controller, given a delay in seconds to wait -- before trying again if starting it fails. If starting the controller fails, -- return the 'ThreadId' of a timer thread counting down until the next attempt -- to start the controller. Also return the next delay period, subject to an -- exponential backoff. If starting the controller succeeds, return its -- 'ThreadId'. startTorController :: MonadIO m => NetworkStateManager -> NetworkStateManagerConfig -> Maybe Int -> m (Either (ThreadId, Int) Connection, ThreadId) startTorController net conf mbDelay = liftIO $ do log Info "Starting Tor controller." (r,tid) <- tryForkLinkIO $ do bracketOnError' (connectStreamSocket $ nsmcfTorControlAddr conf) closeSocket $ \sock -> do -- Whatever answers on the control port may not be Tor and may never -- finish the handshake; don't let it hold us up. bracketOnError' ( timeout handshakeTimeout ( socketToHandle sock ReadWriteMode >>= \h -> openConnection h (nsmcfTorControlPasswd conf) (randBytes (nsmcfRandom conf)) ) >>= maybe (E.throwIO $ userError "The Tor control port handshake timed out.") return ) closeConnection $ \conn -> do setConfWithRollback fetchUselessDescriptors (Just True) conn when (torVersion (protocolInfo conn) >= TorVersion 0 2 0 13 B.empty) $ setConfWithRollback fetchDirInfoEarly (Just True) conn -- NS events only carry entries that changed, and since Tor 0.4.8 -- unchanged relays may never reappear in them. NEWCONSENSUS events -- list every router, so use those to keep our view complete. let newCons = newConsensusEvent $ \errors ns -> do logTorControlErrors "NEWCONSENSUS" errors updateConsensus net ns newDesc = flip newDescriptorsEvent conn $ \errors ds -> do logTorControlErrors "NEWDESC" errors updateDescriptors net ds registerEventHandlers [newCons, newDesc] conn getNetworkStatus conn >>= logParseErrors >>= updateConsensus net getAllDescriptors conn >>= logParseErrors >>= updateDescriptors net swapMVar controlConnMV (Just conn) return conn case r of Left reason -> do log Warn "Initializing Tor controller connection failed: " (show reason) "; I'll try again in " delay " seconds." timerTid <- forkLinkIO $ threadDelay (delay * 10^6) return (Left (timerTid, nextDelay), tid) Right conn -> do log Info "Successfully initialized Tor controller connection." return (Right conn, tid) where logTorControlErrors :: (CatArg a) => String -> [a] -> IO () logTorControlErrors event = mapM_ (log Warn "Error in " event " event: ") logParseErrors :: (CatArg b) => ([a], [b]) -> IO [a] logParseErrors (xs,errors) = mapM_ (log Warn) errors >> return xs updateDescriptors (NetworkStateManager send _) = send . NewDescriptors updateConsensus (NetworkStateManager send _) = send . NewConsensus nextDelay | delay' < maxDelay = delay' | otherwise = maxDelay delay' = delay * backoffFactor delay = fromMaybe minDelay mbDelay backoffFactor = 2 minDelay = 3 -- Tor is restarted now and then (on upgrades, say); reconnecting to a -- local Tor is cheap, so don't wait long to try again. maxDelay = 60 handshakeTimeout = 30 * 10^(6 :: Int) -------------------------------------------------------------------------------- -- Exit tests -- | The initial exit test server config. initExitTestServerConfig :: NetworkStateManager -> ExitTestConfig -> ExitTestServerConfig initExitTestServerConfig net conf = ExitTestServerConfig { etscfNotifyNewExitAddress = updateExitAddress net , etscfConcClientLimit = etcfConcClientLimit conf , etscfListenAddrs = M.keysSet $ etcfListeners conf } where updateExitAddress (NetworkStateManager send _) tested cookie address = send $ NewExitAddress tested cookie address -- | The initial exit test initiator config. initExitTestInitiatorConfig :: NetworkStateManager -> ExitTestConfig -> ExitTestInitiatorConfig initExitTestInitiatorConfig net conf = ExitTestInitiatorConfig { eticfGetNetworkState = readNetworkState , eticfWithCookie = withCookie net (etcfGetRandBytes conf) , eticfWithExitMapping = withExitMapping , eticfConcClientLimit = etcfConcClientLimit conf , eticfSocksServer = etcfTorSocksAddr conf , eticfTestAddress = etcfTestAddress conf , eticfTestPorts = etcfTestPorts conf } -- | Enable exit testing by starting the storage manager, merging exit addresses -- from the store into the current network state, starting the exit test server, -- and starting the exit test initiator. initializeExitTests :: NetworkStateManager -> FilePath -> ExitTestConfig -> StateT ManagerState IO ExitTestInitiator initializeExitTests net stateDir conf = do log Info "Initializing exit tests." storage <- liftIO . startStorageManager $ StorageConfig stateDir exitAddrs <- liftIO $ readExitAddressesFromStorage storage now <- liftIO getCurrentTime modify' $ \s -> s { networkState = expireOldInfo now . mergeExitAddrsWithNetState exitAddrs . networkState $ s } routers <- gets (nsRouters . networkState) liftIO $ rebuildExitAddressStorage routers storage testServer <- liftIO $ startExitTestServer (M.assocs $ etcfListeners conf) (initExitTestServerConfig net conf) testInitiator <- liftIO . startExitTestInitiator $ initExitTestInitiatorConfig net conf let newTestState = ExitTestState storage testServer testInitiator M.empty modify' $ \s -> s { exitTestState = Just $! newTestState } return testInitiator -- | Terminate all the threads enabling and supporting exit tests. terminateExitTests :: ExitTestState -> StateT ManagerState IO () terminateExitTests testState = do log Info "Halting exit tests." liftIO $ do terminateExitTestInitiator Nothing $ exitTestInitiator testState terminateExitTestServer Nothing $ exitTestServer testState terminateStorageManager Nothing $ storageManager testState modify' $ \s -> s { exitTestState = Nothing , deadThreads = L.foldl' (flip S.insert) (deadThreads s) [ threadId $ exitTestInitiator testState , threadId $ exitTestServer testState , threadId $ storageManager testState ] } -------------------------------------------------------------------------------- -- Pure network state updates -- | Merge a list of exit addresses from the store with the network state. mergeExitAddrsWithNetState :: [ExitAddress] -> NetworkState -> NetworkState mergeExitAddrsWithNetState = flip $ L.foldl' mergeAddr where mergeAddr (NetworkState addrs rtrs) (ExitAddress rid pub status exits) = NetworkState addrs' (M.insert rid router' rtrs) where old = M.lookup rid rtrs oldTests = old >>= rtrTestResults oldExits = maybe M.empty tstAddresses oldTests -- The file may hold more addresses than we'd accept now (written by a -- version without the limit, say): keep the most recently seen. exits' = keepLatestAddresses maxTestedAddresses (M.unionWith max oldExits exits) dropped = M.keys (oldExits `M.difference` exits') listenAddr = descListenAddr `fmap` (rtrDescriptor =<< old) addrs' = flip (L.foldl' (\as a -> insertAddress a rid as)) (M.keys exits') $ L.foldl' (\as a -> deleteAddress a rid as) addrs (filter ((/= listenAddr) . Just) dropped) tests' = TestResults (maybe pub (max pub . tstPublished) oldTests) exits' router' = case old of Nothing -> Router Nothing (Just $! tests') False status Just r -> r { rtrTestResults = Just $! tests' } -- | Keep the @n@ addresses seen most recently. keepLatestAddresses :: Int -> Map HostAddress UTCTime -> Map HostAddress UTCTime keepLatestAddresses n m | M.size m <= n = m | otherwise = M.fromList . take n . L.sortBy (comparing (Down . snd)) $ M.toList m -- | Look up a cookie and forget it. A cookie is good for one connection: it -- travels in the clear through the exit, so the exit could otherwise send it -- again from other addresses (open proxies, shared NAT or VPN egress, ...) and -- have them all listed as its exit addresses. takeCookie :: Cookie -> Map Cookie a -> (Maybe a, Map Cookie a) takeCookie = M.updateLookupWithKey (\_ _ -> Nothing) -- | The most exit addresses we record for a router from exit tests (on top of -- the address in its descriptor) until older ones expire. A legitimate exit -- rarely exits from more than a few; the limit bounds what a malicious one can -- make us list. maxTestedAddresses :: Int maxTestedAddresses = 16 -- | Should we record @addr@ as an exit address of this router? Yes if we -- already have it or have room for it. acceptTestedAddress :: Router -> HostAddress -> Bool acceptTestedAddress router addr = case rtrTestResults router of Nothing -> True Just test -> addr `M.member` tstAddresses test || M.size (tstAddresses test) < maxTestedAddresses -- | Update the network state with the results of an exit test. Return the -- updated router information. newExitAddress :: UTCTime -> UTCTime -> Router -> RouterID -> HostAddress -> NetworkState -> (Router, NetworkState) newExitAddress tested published r rid addr s | Just test <- rtrTestResults r = results $ TestResults (tstPublished test `max` published) (M.insert addr tested $ tstAddresses test) | otherwise = results $ TestResults published (M.singleton addr tested) where results test = (id &&& s') r { rtrTestResults = Just $! test } s' !r' = s { nsAddrs = insertAddress addr rid (nsAddrs s) , nsRouters = M.insert rid r' (nsRouters s) } -- | Update the network state with a new router descriptor. newDescriptor :: UTCTime -> NetworkState -> Descriptor -> NetworkState newDescriptor now s !newD -- we know about this router already, but we might not have its descriptor | Just router <- M.lookup rid (nsRouters s) = case rtrDescriptor router of -- we have a descriptor, and therefore a possibly outdated address Just oldD -- the descriptor we already have is newer than this one | descPublished oldD > descPublished newD -> s -- address changed: delete old address, insert new address | descListenAddr newD /= descListenAddr oldD -> s { nsAddrs = insertAddr newD . deleteAddr oldD . nsAddrs $ s , nsRouters = updateRoutersTests (descListenAddr oldD) } -- address hasn't changed: don't update addrs | otherwise -> s { nsRouters = updateRouters } -- we didn't have an address before: insert new address _ -> s { nsAddrs = insertAddr newD (nsAddrs s) , nsRouters = updateRouters } -- this is a new router: insert into routers and addrs | otherwise = s { nsAddrs = insertAddr newD (nsAddrs s) , nsRouters = insertRouters } where updateRouters = adjust' (\r -> r { rtrDescriptor = Just newD }) rid (nsRouters s) updateRoutersTests oldAddr = adjust' (\r -> r { rtrDescriptor = Just newD , rtrTestResults = updateTests oldAddr r }) rid (nsRouters s) updateTests oldAddr (Router _ (Just test) _ _) | not (M.null addrs') = Just $! test { tstAddresses = addrs' } where addrs' = M.delete oldAddr (tstAddresses test) updateTests _ _ = Nothing insertRouters = mapInsert' rid (Router (Just newD) Nothing False now) (nsRouters s) insertAddr d = insertAddress (descListenAddr d) rid deleteAddr d = deleteAddress (descListenAddr d) rid rid = descRouterID newD -- | Update the network state with a complete consensus: every listed router is -- refreshed and routers absent from it are no longer considered running. newConsensus :: UTCTime -> [RouterStatus] -> NetworkState -> NetworkState newConsensus now rss s = L.foldl' (newRouterStatus now) s' rss where listed = S.fromList $ map rsRouterID rss s' = s { nsRouters = M.mapWithKey markAbsent (nsRouters s) } markAbsent rid r | rid `S.member` listed = r | otherwise = r { rtrIsRunning = False } -- | Update the network state with a new router status entry. newRouterStatus :: UTCTime -> NetworkState -> RouterStatus -> NetworkState newRouterStatus now s rs = s { nsRouters = alter' (Just . maybe newRouter updateRouter) (rsRouterID rs) (nsRouters s) } where newRouter = Router Nothing Nothing (rsIsRunning rs) now updateRouter r = r { rtrIsRunning = rsIsRunning rs, rtrLastStatus = now } -- | Discard routers whose last status update was received more than -- @maxRouterAge@ seconds ago and exit test results older than @maxExitTestAge@. expireOldInfo :: UTCTime -> NetworkState -> NetworkState expireOldInfo now s = s { nsAddrs = addrs'', nsRouters = routers'' } where (addrs'',routers'') = M.mapAccumWithKey updateTests addrs' routers' updateTests addrs rid r@(Router d (Just test) _ _) | M.null oldExits = (addrs, r) | M.null recentExits = update Nothing | otherwise = update (Just $! test {tstAddresses = recentExits}) where update test' = (recentAddrs, r { rtrTestResults = test' }) recentAddrs = L.foldl' (\as addr -> deleteAddress addr rid as) addrs (M.keys $ maybe id (M.delete . descListenAddr) d oldExits) (oldExits,recentExits) = M.partition isTestOld (tstAddresses test) updateTests addrs _ r = (addrs, r) (oldRouters,routers') = M.partition isRouterOld (nsRouters s) addrs' = L.foldl' deleteAddrs (nsAddrs s) (M.toList oldRouters) isRouterOld r = now `diffUTCTime` rtrLastStatus r > maxRouterAge isTestOld tested = now `diffUTCTime` tested > maxExitTestAge deleteAddrs addrs (rid,r) = maybe id (\d -> deleteAddress (descListenAddr d) rid) (rtrDescriptor r) . maybe id (deleteExitAddresses rid) (rtrTestResults r) $ addrs deleteExitAddresses rid test addrs = L.foldl' (\as addr -> deleteAddress addr rid as) addrs (M.keys $ tstAddresses test) maxRouterAge = 24 * 60 * 60 maxExitTestAge = 24 * 60 * 60 -- | Add a new router associated with an address to the address map. insertAddress :: HostAddress -> RouterID -> Map HostAddress (Set RouterID) -> Map HostAddress (Set RouterID) insertAddress addr !rid = alter' (Just . maybe (S.singleton rid) (S.insert rid)) addr -- | Remove a router associated with an address from the address map. deleteAddress :: HostAddress -> RouterID -> Map HostAddress (Set RouterID) -> Map HostAddress (Set RouterID) deleteAddress addr rid = update' deleteRouterID addr where deleteRouterID set | S.null set' = Nothing | otherwise = Just set' where set' = S.delete rid set -------------------------------------------------------------------------------- mhatta-tordnsel-1d9141b/src/TorDNSEL/NetworkState/Storage.hs000066400000000000000000000015371527317632400237020ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.NetworkState.Storage -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, pattern guards, GHC primitives) -- -- Implements a thread that manages the storage of exit test results in the -- file system. -- ----------------------------------------------------------------------------- module TorDNSEL.NetworkState.Storage ( StorageConfig(..) , StorageManager , ExitAddress(..) , mkExitAddress , renderExitAddress , startStorageManager , readExitAddressesFromStorage , rebuildExitAddressStorage , storeNewExitAddress , reconfigureStorageManager , terminateStorageManager ) where import TorDNSEL.NetworkState.Storage.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/NetworkState/Storage/000077500000000000000000000000001527317632400233405ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/NetworkState/Storage/Internals.hs000066400000000000000000000313131527317632400256340ustar00rootroot00000000000000 ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.NetworkState.Storage.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (concurrency, pattern guards, GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- Implements a thread that manages the storage of exit test results in the -- file system. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.NetworkState.Storage.Internals where import Prelude hiding (log) import Control.Arrow (second) import Control.Concurrent.Chan (newChan, readChan, writeChan) import qualified Control.Exception as E import Control.Monad (liftM2, when, forM) import Control.Monad.Except (MonadError(throwError)) import Control.Monad.Fix (fix) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (toUpper, isSpace) import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (mapMaybe, catMaybes) import Data.Time (UTCTime) import Network.Socket (HostAddress) import System.Directory (renameFile) import System.IO (Handle, openFile, hFlush, hClose, IOMode(AppendMode, WriteMode)) import System.Posix.IO (handleToFd, closeFd) import System.Posix.Unistd (fileSynchronise) import System.IO.Error (isDoesNotExistError) import System.Posix.Files (getFileStatus, fileSize) import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.Directory import TorDNSEL.Document import TorDNSEL.Log import TorDNSEL.NetworkState.Types import TorDNSEL.Util storePath, tempStorePath, journalPath :: FilePath storePath = "/exit-addresses" -- ^ Path to our exit addresses store. -- | Path to a new exit addresses store while writing to it. tempStorePath = "/exit-addresses.tmp" journalPath = "/exit-addresses.new" -- ^ Path to the exit addresses journal. -- | The storage manager configuration. data StorageConfig = StorageConfig { stcfStateDir :: FilePath -- ^ The path to our state directory. } deriving Show -- | An internal type for messages sent to the storage manager. data StorageMessage = ReadExitAddresses ([ExitAddress] -> IO ()) | RebuildExitAddressStorage (Map RouterID Router) | StoreNewExitAddress ExitAddress (Map RouterID Router) | Reconfigure (StorageConfig -> StorageConfig) (IO ()) | Terminate ExitReason -- | A handle to the storage manager thread. data StorageManager = StorageManager (StorageMessage -> IO ()) ThreadId instance Thread StorageManager where threadId (StorageManager _ tid) = tid -- | An internal type containing the storage manager state. data StorageManagerState = StorageManagerState { storageConf :: StorageConfig , exitAddrLen, journalLen :: !Integer } -- | Start the storage manager with an initial 'StorageConfig', returning a -- handle to it. If the storage manager exits before completely starting, throw -- its exit signal in the calling thread. Link the storage manager to the -- calling thread. startStorageManager :: StorageConfig -> IO StorageManager startStorageManager initConf = do log Info "Starting storage manager." initState <- liftM2 (StorageManagerState initConf) (getFileSize (stcfStateDir initConf ++ storePath)) (getFileSize (stcfStateDir initConf ++ journalPath)) when (exitAddrLen initState == 0) $ writeFile (stcfStateDir initConf ++ storePath) "" storageChan <- newChan let runStorageManager io = startLink $ \initSig -> fix io (initState, initSig) storageTid <- runStorageManager $ \reset (state,signal) -> do let openJournal = openFile (stcfStateDir (storageConf state) ++ journalPath) AppendMode (reset =<<) . E.bracket openJournal hClose $ \journalHandle -> do signal flip fix state $ \loop s -> do message <- readChan storageChan case message of ReadExitAddresses respond -> do hClose journalHandle (readExitAddresses . stcfStateDir . storageConf) s >>= respond return (s, nullSignal) RebuildExitAddressStorage routers -> rebuildExitAddresses journalHandle routers s StoreNewExitAddress addr routers -> do len <- appendExitAddressToJournal journalHandle addr if isJournalTooLarge (exitAddrLen s) (journalLen s + len) then rebuildExitAddresses journalHandle routers s else loop s { journalLen = journalLen s + len } Reconfigure reconf newSignal | stcfStateDir newConf /= stcfStateDir (storageConf s) -> do log Notice "Reconfiguring storage manager." mapM_ (\fp -> renameFile (stcfStateDir (storageConf s) ++ fp) (stcfStateDir newConf ++ fp)) [storePath, journalPath] newSignal loop s { storageConf = newConf } | otherwise -> newSignal >> loop s { storageConf = newConf } where newConf = reconf (storageConf s) Terminate reason -> do log Info "Terminating storage manager." exit reason return $ StorageManager (writeChan storageChan) storageTid where rebuildExitAddresses journalHandle routers s = do hClose journalHandle addrLen <- replaceExitAddresses (stcfStateDir $ storageConf s) routers return (s { exitAddrLen = addrLen, journalLen = 0 }, nullSignal) getFileSize fp = E.catch ((fromIntegral . fileSize) `fmap` getFileStatus fp) (\e -> if isDoesNotExistError e then return 0 else E.throwIO e) nullSignal = return () -- | Read all the exit address entries from our state directory. If the storage -- manager exits before returning the entries, throw its exit signal or -- 'NonexistentThread' in the calling thread. readExitAddressesFromStorage :: StorageManager -> IO [ExitAddress] readExitAddressesFromStorage (StorageManager tellStorageManager tid) = call (tellStorageManager . ReadExitAddresses) tid -- | Asynchronously rebuild the exit address store using the given network -- information. rebuildExitAddressStorage :: Map RouterID Router -> StorageManager -> IO () rebuildExitAddressStorage routers (StorageManager tellStorageManager _) = tellStorageManager $ RebuildExitAddressStorage routers -- | Asynchronously add an exit address entry with new information to the -- journal, using the given network information to rebuild the store if -- necessary. storeNewExitAddress :: RouterID -> Router -> Map RouterID Router -> StorageManager -> IO () storeNewExitAddress rid rtr routers (StorageManager tellStorageManager _) = whenJust (mkExitAddress (rid, rtr)) $ \addr -> tellStorageManager $ StoreNewExitAddress addr routers -- | Reconfigure the storage manager synchronously with the given function. If -- the server exits abnormally before reconfiguring itself, throw its exit -- signal in the calling thread. reconfigureStorageManager :: (StorageConfig -> StorageConfig) -> StorageManager -> IO () reconfigureStorageManager reconf (StorageManager tellStorageManager tid) = sendSyncMessage (tellStorageManager . Reconfigure reconf) tid -- | Terminate the storage manager gracefully. The optional parameter specifies -- the amount of time in microseconds to wait for the thread to terminate. If -- the thread hasn't terminated by the timeout, an uncatchable exit signal will -- be sent. terminateStorageManager :: Maybe Int -> StorageManager -> IO () terminateStorageManager mbWait (StorageManager tellStorageManager tid) = terminateThread mbWait tid (tellStorageManager $ Terminate NormalExit) -- | An exit address entry stored in our state directory. The design here is the -- same as Tor uses for storing router descriptors. data ExitAddress = ExitAddress { -- | The identity of the exit node we tested through. eaRouterID :: !RouterID, -- | The current descriptor published time when the test was initiated. We -- don't perform another test until a newer descriptor arrives. eaPublished :: !UTCTime, -- | When we last received a network status update for this router. This -- helps us decide when to discard a router. eaLastStatus :: !UTCTime, -- | A map from exit address to when the address was last seen. eaAddresses :: !(Map HostAddress UTCTime) } deriving Eq instance Show ExitAddress where showsPrec _ = cat . renderExitAddress -- | Exit test results are represented using the same document meta-format Tor -- uses for router descriptors and network status documents. renderExitAddress :: ExitAddress -> B.ByteString renderExitAddress x = B.unlines $ [ B.pack "ExitNode " `B.append` renderID (eaRouterID x) , B.pack "Published " `B.append` renderTime (eaPublished x) , B.pack "LastStatus " `B.append` renderTime (eaLastStatus x) ] ++ (map renderTest . sortBy (compare `on` snd) . M.assocs . eaAddresses $ x) where renderID = B.map toUpper . encodeBase16RouterID renderTest (addr,time) = B.unwords [B.pack "ExitAddress", B.pack $ inet_htoa addr, renderTime time] renderTime = B.pack . take 19 . show -- | Parse a single exit address entry. Return the result or 'throwError' in the -- monad if parsing fails. parseExitAddress :: MonadError ShowS m => Document -> m ExitAddress parseExitAddress items = prependError ("Failed parsing exit address entry: " ++) $ do rid <- decodeBase16RouterID =<< findArg (B.pack "ExitNode") items published <- parseUTCTime =<< findArg (B.pack "Published") items lastStatus <- parseUTCTime =<< findArg (B.pack "LastStatus") items addrs <- mapM parseAddr . filter ((B.pack "ExitAddress" ==) . iKey) $ items return $! ExitAddress rid published lastStatus (M.fromList addrs) where parseAddr Item { iArg = Just line } = let (addr,testTime) = B.dropWhile isSpace `second` B.break isSpace line in prependError ("Failed parsing exit address item: " ++) (liftM2 (,) (inet_atoh addr) (parseUTCTime testTime)) parseAddr _ = throwError ("Failed parsing exit address item." ++) -- | On startup, read the exit test results from the state directory. Return the -- results in ascending order of their fingerprints. readExitAddresses :: FilePath -> IO [ExitAddress] readExitAddresses stateDir = M.elems `fmap` liftM2 (M.unionWith merge) (M.fromListWith merge `fmap` parseFile journalPath) (M.fromListWith merge `fmap` parseFile storePath) where merge new old = new { eaAddresses = (M.union `on` eaAddresses) new old } parseFile fp = do let path = stateDir ++ fp file <- E.catch (B.readFile path) (\e -> if isDoesNotExistError e then return B.empty else E.throwIO e) addrs <- forM (parseSubDocs (B.pack "ExitNode") parseExitAddress . parseDocument . B.lines $ file) $ \exitAddr -> do case exitAddr of Left e -> log Warn e >> return Nothing Right addr -> return $ Just (eaRouterID addr, addr) return $ catMaybes addrs -- | On startup, and when the journal becomes too large, replace the -- exit-addresses file with our most current test results and clear the journal. -- Return the new exit-addresses file's size in bytes. replaceExitAddresses :: FilePath -> Map RouterID Router -> IO Integer replaceExitAddresses stateDir routers = do -- Make sure the new file is on disk before it replaces the old one, or a -- crash could leave us with an empty file and no test results. h <- openFile (stateDir ++ tempStorePath) WriteMode (L.hPut h (L.fromChunks $ addrs routers) >> handleToFd h) `E.onException` hClose h >>= \fd -> fileSynchronise fd `E.finally` closeFd fd renameFile (stateDir ++ tempStorePath) (stateDir ++ storePath) writeFile (stateDir ++ journalPath) "" (toInteger . fileSize) `fmap` getFileStatus (stateDir ++ storePath) where addrs = mapMaybe (fmap renderExitAddress . mkExitAddress) . M.toList -- | Return an exit address entry if we have enough information to create one. mkExitAddress :: (RouterID, Router) -> Maybe ExitAddress mkExitAddress (rid,r) = do t <- rtrTestResults r return $! ExitAddress rid (tstPublished t) (rtrLastStatus r) (tstAddresses t) -- | Add an exit address entry to the journal. Return the entry's length in -- bytes. appendExitAddressToJournal :: Handle -> ExitAddress -> IO Integer appendExitAddressToJournal journal addr = do B.hPut journal bs hFlush journal return $! toInteger . B.length $ bs where bs = renderExitAddress addr -- | Is the exit address journal large enough that it should be cleared? isJournalTooLarge :: Integer -> Integer -> Bool isJournalTooLarge addrSize journalSize | addrSize > 65536 = journalSize > addrSize | otherwise = journalSize > 65536 mhatta-tordnsel-1d9141b/src/TorDNSEL/NetworkState/Types.hs000066400000000000000000000032311527317632400233730ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.NetworkState.Types -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : portable -- -- Common network state types. -- ----------------------------------------------------------------------------- module TorDNSEL.NetworkState.Types where import Data.Map (Map) import qualified Data.Map as M import Data.Time (UTCTime) import Data.Set (Set) import Network.Socket (HostAddress) import TorDNSEL.Directory -- | A Tor router. data Router = Router { -- | This router's descriptor, if we have it yet. rtrDescriptor :: !(Maybe Descriptor), -- | This router's exit test results, if one has been completed. rtrTestResults :: !(Maybe TestResults), -- | Whether we think this router is running. rtrIsRunning :: !Bool, -- | The last time we received a router status entry for this router. rtrLastStatus :: !UTCTime } -- | The results of exit tests. data TestResults = TestResults { -- | The descriptor's published time when the last exit test was initiated. tstPublished :: !UTCTime, -- | A map from exit address to when the address was last seen. tstAddresses :: !(Map HostAddress UTCTime) } -- | Our current view of the Tor network. data NetworkState = NetworkState { -- | A map from listen address to routers. nsAddrs :: !(Map HostAddress (Set RouterID)), -- | All the routers we know about. nsRouters :: !(Map RouterID Router) } -- | The empty network state. emptyNetworkState :: NetworkState emptyNetworkState = NetworkState M.empty M.empty mhatta-tordnsel-1d9141b/src/TorDNSEL/Random.hs000066400000000000000000000046271527317632400210670ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Random -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : portable -- -- Generating cryptographically strong random data. -- -- Earlier versions seeded OpenSSL's PRNG from a kernel random device and used -- @RAND_bytes@. Modern kernels provide a non-blocking, cryptographically -- strong CSPRNG through @\/dev\/urandom@, so we simply keep a handle to it -- open (it is opened before we chroot or drop privileges) and read from it -- directly. This removes the dependency on libcrypto. -- ----------------------------------------------------------------------------- module TorDNSEL.Random ( randBytes , openRandomDevice , seedPRNG ) where import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Monad (filterM) import qualified Data.ByteString as B import System.Directory (doesFileExist) import System.IO (Handle, openFile, IOMode(ReadMode), hSetBuffering, BufferMode(NoBuffering)) import System.IO.Unsafe (unsafePerformIO) -- | Serialise reads from the random device so that concurrent callers never -- receive overlapping or short reads. randomLock :: MVar () {-# NOINLINE randomLock #-} randomLock = unsafePerformIO $ newMVar () -- | Return @n@ bytes of random data read from the given random device. randBytes :: Handle -> Int -> IO B.ByteString randBytes random n = withMVar randomLock $ \_ -> go n [] where go 0 acc = return $! B.concat (reverse acc) go k acc = do bs <- B.hGetSome random k if B.null bs then ioError $ userError "randBytes: unexpected EOF on random device" else go (k - B.length bs) (bs : acc) -- | Open a kernel random number device if one exists. @\/dev\/urandom@ is -- preferred because it never blocks once the kernel CSPRNG is initialised. openRandomDevice :: IO (Either ShowS Handle) openRandomDevice = do devs <- filterM doesFileExist ["/dev/urandom", "/dev/random"] case devs of dev:_ -> do h <- openFile dev ReadMode hSetBuffering h NoBuffering return (Right h) [] -> return $ Left ("Kernel random number device not found." ++) -- | Retained for compatibility: make sure the random device is readable. -- There is no user-space PRNG to seed any more. seedPRNG :: Handle -> IO () seedPRNG random = randBytes random 1 >> return () mhatta-tordnsel-1d9141b/src/TorDNSEL/Socks.hs000066400000000000000000000013231527317632400207170ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Socks -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (dynamic exceptions, newtype deriving) -- -- Making a TCP connection using the SOCKS4A protocol. Support for various -- Tor extensions to SOCKS is sketched out. -- -- See for -- details. -- ----------------------------------------------------------------------------- module TorDNSEL.Socks ( -- * Connections withSocksConnection -- * Errors , SocksError(..) ) where import TorDNSEL.Socks.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/Socks/000077500000000000000000000000001527317632400203645ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Socks/Internals.hs000066400000000000000000000135511527317632400226640ustar00rootroot00000000000000{-# OPTIONS_GHC -fno-warn-unused-binds #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Socks.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (dynamic exceptions, newtype deriving) -- -- /Internals/: should only be imported by the public module and tests. -- -- Making a TCP connection using the SOCKS4A protocol. Support for various -- Tor extensions to SOCKS is sketched out. -- -- See for -- details. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.Socks.Internals ( -- * Connections withSocksConnection -- * Data types , Request(..) , Command(..) , Response(..) , Result(..) -- * Serialization , encodeRequest , decodeResponse -- * Errors , SocksError(..) ) where import qualified Control.Exception as E import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) import Network.Socket (HostAddress) import System.IO (Handle, BufferMode(NoBuffering), hClose, hSetBuffering) import Control.DeepSeq import Data.Binary (Binary(..), getWord8, putWord8) import Data.Binary.Get (runGetOrFail, getWord32be) import Control.Monad (when) import Data.Binary.Put (runPut, putWord32be, putByteString) import TorDNSEL.Util -------------------------------------------------------------------------------- -- Connections -- | Open a Socks connection to an IP address\/domain name and port. The handle -- will be closed if an exception occurs during the given 'IO' action. Throw a -- 'SocksError' if the connection request fails. withSocksConnection :: Handle -> Address -> Port -> IO a -> IO a withSocksConnection handle addr port io = (`E.finally` hClose handle) $ do hSetBuffering handle NoBuffering B.hPut handle . encodeRequest $ Request Connect addr port r <- decodeResponse `fmap` B.hGet handle 8 case r of Just (Response Granted _ _) -> io Just (Response result _ _) -> E.throwIO (SocksError result) _ -> E.throwIO SocksProtocolError -------------------------------------------------------------------------------- -- Data types -- | A Socks4a request. data Request = Request { -- | The Socks4 command code (with Tor extensions). soCommand :: !Command, -- | The requested destination: either an IPv4 address or a domain name. soReqDest :: !Address, -- | The requested destination port. soReqPort :: !Port } -- A Socks4a command (with Tor extensions). data Command = Connect -- ^ Connect to the requested destination. | Resolve -- ^ Resolve a domain name. | ConnectDir -- ^ Establish a secure connection to a Tor directory. -- | A Socks4 response. data Response = Response { soResult :: !Result -- ^ The result code. , soRespAddr :: !HostAddress -- ^ The destination address. , soRespPort :: !Port -- ^ The destination port. } instance NFData Response where rnf = rwhnf -- | A Socks4 result code. data Result = Granted -- ^ Request granted | Failed -- ^ Request rejected or failed | IdentdUnreachable -- ^ Request rejected because SOCKS server cannot connect -- to identd on the client | IdentdMismatch -- ^ Request rejected because the client program and -- identd report different user-ids deriving Eq instance Show Result where show Granted = "Request granted" show Failed = "Request rejected or failed" show IdentdUnreachable = "Request rejected because SOCKS server cannot \ \connect to identd on the client" show IdentdMismatch = "Request rejected because the client program and \ \identd report different user-ids" -------------------------------------------------------------------------------- -- Serialization -- | Encode a Socks4 request. encodeRequest :: Request -> ByteString encodeRequest = B.concat . L.toChunks . runPut . putRequest where putRequest req = do putWord8 4 putWord8 $ case soCommand req of Connect -> 1 Resolve -> 0xf0 ConnectDir -> 0xf2 put $ soReqPort req case soReqDest req of IPv4Addr addr -> do put addr putWord8 0 Addr addr -> do putWord32be 1 putWord8 0 putByteString addr putWord8 0 -- | Decode a Socks4 response, returning @'Just' _@ if parsing succeeded. As -- with 'TorDNSEL.DNS.decodeMessage', decoding is total: every failure goes -- through 'fail' and comes back as 'Left' from 'runGetOrFail'. The response -- must be exactly 8 bytes long. decodeResponse :: ByteString -> Maybe Response decodeResponse resp = case runGetOrFail getResponse (L.fromChunks [resp]) of Right (rest, _, r) | L.null rest -> Just $!! r _ -> Nothing where getResponse = do v <- getWord8 when (v /= 0) $ fail "unexpected socks4 response version" cd <- getWord8 res <- case cd of 90 -> return Granted 91 -> return Failed 92 -> return IdentdUnreachable 93 -> return IdentdMismatch _ -> fail "unknown socks4 result code" port <- get addr <- getWord32be return $! Response res addr port -------------------------------------------------------------------------------- -- Errors -- | A Socks error. data SocksError = SocksError !Result -- ^ A known Socks error code. | SocksProtocolError -- ^ The response doesn't follow the Socks protocol. instance Show SocksError where showsPrec _ (SocksError result) = cat "Socks error: " result showsPrec _ SocksProtocolError = cat "Socks protocol error" instance E.Exception SocksError mhatta-tordnsel-1d9141b/src/TorDNSEL/Statistics.hs000066400000000000000000000012411527317632400217660ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Statistics -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (GHC primitives) -- -- Making load information available external to the process. -- ----------------------------------------------------------------------------- module TorDNSEL.Statistics ( StatsServer , bindStatsSocket , startStatsServer , terminateStatsServer , incrementBytes , incrementResponses , incrementHTTPRequests , currentMetrics ) where import TorDNSEL.Statistics.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/Statistics/000077500000000000000000000000001527317632400214345ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Statistics/Internals.hs000066400000000000000000000265601527317632400237400ustar00rootroot00000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Statistics.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (bang patterns, GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- Making load information available external to the process. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.Statistics.Internals where import Prelude hiding (log) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, readMVar) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Map as M import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem) import qualified Control.Exception as E import Control.Monad (when, forever) import Control.Monad.Fix (fix) import qualified Data.ByteString.Char8 as B import Data.Maybe import qualified Data.Set as S import Network.Socket (accept, socketToHandle, Socket, close) import System.Posix.Files (setOwnerAndGroup) import System.Posix.Types (UserID, GroupID) import System.IO (hClose, IOMode(ReadWriteMode)) import System.IO.Unsafe (unsafePerformIO) import System.Timeout import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.DNS.Server import TorDNSEL.Directory (Descriptor(..)) import TorDNSEL.ExitList import TorDNSEL.NetworkState (readNetworkState) import TorDNSEL.NetworkState.Types import TorDNSEL.Log import TorDNSEL.Util -- | Cumulative counts of bytes transferred, datagrams received, and responses -- sent. data Stats = Stats { bytesRecv, bytesSent, dgramsRecv, positives , negatives, others, httpRequests, rateLimited :: !Integer } -- | The current statistics state. statsState :: MVar Stats {-# NOINLINE statsState #-} statsState = unsafePerformIO . newMVar $ Stats 0 0 0 0 0 0 0 0 -- | When we started, for metrics. Set by 'startStatsServer'. startTimeRef :: IORef POSIXTime {-# NOINLINE startTimeRef #-} startTimeRef = unsafePerformIO $ newIORef 0 -- | An internal type for messages sent to the stats server thread. data StatsMessage = NewClient Socket -- ^ A new client has connected. | Terminate ExitReason -- ^ Terminate the stats server gracefully. | Exit ThreadId ExitReason -- ^ An exit signal sent to the stats server. -- | A handle to a stats server. data StatsServer = StatsServer (StatsMessage -> IO ()) ThreadId instance Thread StatsServer where threadId (StatsServer _ tid) = tid -- | An internal type representing the current stats server state. data StatsState = StatsState { listenerTid :: !(ThreadId) , handlers :: !(S.Set ThreadId) , terminateReason :: !(Maybe ExitReason) } -- | Given the runtime directory, bind and return the listening statistics -- socket. Only its owner and group may connect: give it the user and group -- we'll run as, if we drop privileges. bindStatsSocket :: FilePath -> Maybe UserID -> Maybe GroupID -> IO Socket bindStatsSocket runtimeDir mbUid mbGid = E.bracketOnError (bindListeningUnixDomainStreamSocket path 0o660) close $ \sock -> do when (isJust mbUid || isJust mbGid) $ setOwnerAndGroup path (fromMaybe (-1) mbUid) (fromMaybe (-1) mbGid) return sock where path = statsSocketPath runtimeDir -- | Given a listening socket, start a server offering access to load statistics -- through a Unix domain stream socket in our runtime directory. Link the server -- thread to the calling thread. startStatsServer :: Socket -> IO StatsServer startStatsServer listenSock = do log Info "Starting statistics server." getPOSIXTime >>= writeIORef startTimeRef statsChan <- newChan statsServerTid <- forkLinkIO $ do setTrapExit $ (writeChan statsChan .) . Exit handlerQSem <- newQSem maxStatsHandlers initListenerTid <- forkListener statsChan listenSock handlerQSem flip fix (StatsState initListenerTid S.empty Nothing) $ \loop (!s) -> do message <- readChan statsChan case message of NewClient client -> do handlerTid <- forkLinkIO . (`E.finally` signalQSem handlerQSem) . E.bracket (socketToHandle client ReadWriteMode) hClose $ \handle -> timeout handlerTimeout $ B.hPut handle . renderStats =<< readMVar statsState loop s { handlers = S.insert handlerTid (handlers s) } Terminate reason -> do log Info "Terminating statistics server." terminateThread Nothing (listenerTid s) (killThread $ listenerTid s) if S.null (handlers s) then exit reason else loop s { terminateReason = Just reason } Exit tid reason | tid == listenerTid s -> if isNothing $ terminateReason s then do log Warn "The statistics listener thread exited unexpectedly:\ \ " (show reason) "; restarting." newListenerTid <- forkListener statsChan listenSock handlerQSem loop s { listenerTid = newListenerTid } else loop s | tid `S.member` handlers s -> do when (isAbnormal reason) $ log Warn "Bug: A statistics client handler exited abnormally: " let newHandlers = S.delete tid (handlers s) case terminateReason s of -- all the handlers have finished, so let's exit Just reason | S.null newHandlers -> exit reason _ -> loop s { handlers = newHandlers } | isAbnormal reason -> exit reason | otherwise -> loop s return $ StatsServer (writeChan statsChan) statsServerTid where maxStatsHandlers = 32 handlerTimeout = 10 * 10^6 -- | Fork the listener thread. forkListener :: Chan StatsMessage -> Socket -> QSem -> IO ThreadId forkListener statsChan listenSock sem = forkLinkIO $ E.mask $ \restore -> forever $ do waitQSem sem (client,_) <- restore $ accept listenSock `E.onException` signalQSem sem writeChan statsChan $ NewClient client -- | Terminate the stats server gracefully. The optional parameter specifies the -- amount of time in microseconds to wait for the thread to terminate. If the -- thread hasn't terminated by the timeout, an uncatchable exit signal will be -- sent. terminateStatsServer :: Maybe Int -> StatsServer -> IO () terminateStatsServer mbWait (StatsServer tellStatsServer statsServerTid) = terminateThread mbWait statsServerTid (tellStatsServer $ Terminate NormalExit) -- | Render 'Stats' to text as a sequence of CRLF-terminated lines. renderStats :: Stats -> B.ByteString renderStats s = B.concat . map line $ [ B.pack "BytesReceived " ~> bytesRecv , B.pack "BytesSent " ~> bytesSent , B.pack "DatagramsReceived " ~> dgramsRecv , B.pack "PositivesSent " ~> positives , B.pack "NegativesSent " ~> negatives , B.pack "OthersSent " ~> others , B.pack "HTTPRequests " ~> httpRequests , B.pack "RateLimited " ~> rateLimited ] where line (x,f) = x `B.append` (B.pack . show $ f s) `B.append` B.pack "\r\n" (~>) = (,) -- | Generate the statistics socket path from the runtime directory path. statsSocketPath :: FilePath -> FilePath statsSocketPath = (++ "/statistics.socket") -- | Increment the count of bytes transferred. incrementBytes :: Int -> Int -> IO () incrementBytes received sent = modifyMVar_ statsState $ \s -> return $! s { bytesRecv = bytesRecv s + fromIntegral received , bytesSent = bytesSent s + fromIntegral sent , dgramsRecv = dgramsRecv s + 1 } -- | Increment the count of HTTP requests to the web interface. incrementHTTPRequests :: IO () incrementHTTPRequests = modifyMVar_ statsState $ \s -> return $! s { httpRequests = httpRequests s + 1 } -- | Increment the count of DNSEL responses. incrementResponses :: ResponseType -> IO () incrementResponses resp = modifyMVar_ statsState $ \s -> return $! case resp of Negative -> s { negatives = negatives s + 1 } Positive -> s { positives = positives s + 1 } Other -> s { others = others s + 1 } Limited -> s { rateLimited = rateLimited s + 1 } -- | The current statistics and network state in the Prometheus text -- exposition format, for the web interface's @\/metrics@, given our version. currentMetrics :: String -> IO B.ByteString currentMetrics version = do s <- readMVar statsState start <- readIORef startTimeRef now <- getPOSIXTime ns <- readNetworkState return $! renderMetrics version s start now ns -- | Render statistics and a summary of the network state as Prometheus -- metrics, given our version, when we started and the current time. renderMetrics :: String -> Stats -> POSIXTime -> POSIXTime -> NetworkState -> B.ByteString renderMetrics version s start now ns = B.pack . unlines $ concat [ metric "tordnsel_build_info" "gauge" "The version of TorDNSEL, as a label." [("{version=\"" ++ version ++ "\"}", 1)] , metric "tordnsel_start_time_seconds" "gauge" "When TorDNSEL started, in seconds since the epoch." [("", floor start)] , counter "tordnsel_dns_received_bytes_total" "Bytes of DNS queries received (UDP and TCP)." (bytesRecv s) , counter "tordnsel_dns_sent_bytes_total" "Bytes of DNS responses sent (UDP and TCP)." (bytesSent s) , counter "tordnsel_dns_messages_received_total" "DNS messages received (UDP and TCP)." (dgramsRecv s) , metric "tordnsel_dns_responses_total" "counter" "Exit list queries answered, by result; rate_limited counts UDP \ \queries truncated or dropped by DNSRateLimit." [ ("{result=\"positive\"}", positives s) , ("{result=\"negative\"}", negatives s) , ("{result=\"other\"}", others s) , ("{result=\"rate_limited\"}", rateLimited s) ] , counter "tordnsel_http_requests_total" "Requests to the web interface." (httpRequests s) , metric "tordnsel_relays" "gauge" "Relays we know of, and those we think are running." [ ("{state=\"known\"}", fromIntegral (M.size routers)) , ("{state=\"running\"}", count running) ] , metric "tordnsel_running_exits" "gauge" "Running relays whose exit policy permits connections somewhere." [("", count runningExit)] , metric "tordnsel_exit_addresses" "gauge" "Addresses listed as exit addresses (from descriptors and exit tests)." [("", fromIntegral . length $ exitAddressesTo now ns anyDestination)] , metric "tordnsel_tested_exit_addresses" "gauge" "Exit addresses found by our exit tests." [("", sum [ fromIntegral (M.size (tstAddresses t)) | r <- M.elems routers, Just t <- [rtrTestResults r] ])] ] where routers = nsRouters ns descs = [ d | r <- M.elems routers, Just d <- [rtrDescriptor r] ] running d = isRunning now d runningExit d = isRunning now d && policyAcceptsDestination anyDestination (descExitPolicy d) count p = fromIntegral . length $ filter p descs counter name help v = metric name "counter" help [("", v)] metric :: String -> String -> String -> [(String, Integer)] -> [String] metric name typ help samples = ("# HELP " ++ name ++ " " ++ help) : ("# TYPE " ++ name ++ " " ++ typ) : [ name ++ labels ++ " " ++ show v | (labels, v) <- samples ] mhatta-tordnsel-1d9141b/src/TorDNSEL/TorControl.hs000066400000000000000000000040121527317632400217400ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.TorControl -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards, concurrency, extended exceptions, -- multi-parameter type classes, existentially -- quantified types, GHC primitives) -- -- Interfacing with Tor using the Tor control protocol, version 1. We support -- fetching router descriptors and router status entries, including those sent -- in asynchronous events that Tor generates when it receives new information -- from directories. -- -- See for details. -- ----------------------------------------------------------------------------- module TorDNSEL.TorControl ( -- * Connections Connection , withConnection , openConnection , closeConnection , protocolInfo -- * Commands , getDescriptor , getAllDescriptors , getRouterStatus , getNetworkStatus , getCircuitStatus , getStreamStatus , CircuitPurpose(..) , createCircuit , extendCircuit , attachStream , cedeStream , redirectStream , CloseCircuitFlags(..) , emptyCloseCircuitFlags , closeCircuit , mapAddress , unmapAddress -- ** Config variables , ConfVar , getConf , setConf , resetConf , onCloseSetConf , onCloseRollback , setConfWithRollback , fetchUselessDescriptors , fetchDirInfoEarly -- * Asynchronous events , EventHandler , registerEventHandlers , newDescriptorsEvent , networkStatusEvent , newConsensusEvent , streamEvent , circuitEvent , addressMapEvent -- * Data types , TorVersion(..) , AuthMethods(..) , ProtocolInfo(..) , CircuitID , CircuitStatus(..) , CircuitState(..) , StreamID , StreamStatus(..) , StreamState(..) , AddressMap(..) , Expiry(..) -- * Errors , ReplyCode , TorControlError(..) ) where import TorDNSEL.TorControl.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/TorControl/000077500000000000000000000000001527317632400214075ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/TorControl/Internals.hs000066400000000000000000001515241527317632400237120ustar00rootroot00000000000000{-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.TorControl.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards, concurrency, extended exceptions, -- multi-parameter type classes, existentially -- quantified types, GHC primitives) -- -- /Internals/: should only be imported by the public module and tests. -- -- Interfacing with Tor using the Tor control protocol, version 1. We support -- fetching router descriptors and router status entries, including those sent -- in asynchronous events that Tor generates when it receives new directory -- information. -- -- See for details. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.TorControl.Internals ( -- * Connections Connection(..) , Connection' , toConn' , ConfSetting(..) , withConnection , openConnection , closeConnection , closeConnection' , protocolInfo -- * Commands , Command(..) , Reply(..) , authenticate , safeCookieHashes , parseAuthChallenge , Feature(..) , useFeature , getDescriptor , getAllDescriptors , getRouterStatus , getNetworkStatus , getDocument , getCircuitStatus , getStreamStatus , getStatus , CircuitPurpose(..) , createCircuit , extendCircuit , extendCircuit' , attachStream , cedeStream , attachStream' , redirectStream , CloseCircuitFlags(..) , emptyCloseCircuitFlags , closeCircuit , mapAddress , unmapAddress , getConf' , setConf' , resetConf' , setConf'' , sendCommand , sendCommand' -- ** Config variables , ConfVal(..) , SameConfVal , ConfVar(..) , getConf , setConf , resetConf , onCloseSetConf , onCloseRollback , setConfWithRollback , fetchUselessDescriptors , fetchDirInfoEarly , boolVar -- * Asynchronous events , EventHandler(..) , registerEventHandlers , newDescriptorsEvent , networkStatusEvent , newConsensusEvent , streamEvent , circuitEvent , lineEvent , addressMapEvent -- * Backend connection manager , IOMessage(..) , startIOManager , startSocketReader , c_replies -- * Data types , TorVersion(..) , parseTorVersion , AuthMethods(..) , ProtocolInfo(..) , parseProtocolInfo , CircuitID(..) , nullCircuitID , parseID , CircuitStatus(..) , parseCircuitStatus , CircuitState(..) , parseCircuitState , StreamID(..) , StreamStatus(..) , parseStreamStatus , StreamState(..) , parseStreamState , AddressMap(..) , parseAddressMap , Expiry(..) -- * Errors , ReplyCode , commandFailed , protocolError , parseError , TorControlError(..) , toTCError , parseReplyCode , throwIfNotPositive , isPositive ) where import Control.Arrow (first, second) import Control.Concurrent.Chan (newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, takeMVar, tryPutMVar, withMVar, modifyMVar_) import qualified Control.Exception as E import Control.Monad (when, unless, liftM, mzero, mplus) import Control.Monad.Except (MonadError(..)) import Control.Monad.Fix (fix) import Control.Monad.State (StateT(StateT), get, put, lift, evalStateT) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Bits (xor, (.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import Data.Char (isSpace, isAlphaNum, isDigit, isAlpha, toLower) import Data.List (find) import qualified Data.Map as M import Data.Maybe import qualified Data.Sequence as S import Data.Sequence ((<|), ViewR((:>)), viewr) import Data.Time (UTCTime, TimeZone, localTimeToUTC, getCurrentTimeZone, utc) import System.IO (Handle, hClose, hSetBuffering, BufferMode(..), hFlush) import System.IO.Error (isEOFError) import System.Timeout (timeout) import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Future import TorDNSEL.Control.Concurrent.Util import TorDNSEL.Directory import TorDNSEL.Files (readSmallRegularFile) import TorDNSEL.Document import TorDNSEL.Util -------------------------------------------------------------------------------- -- Connections -- | A Tor control connection. data Connection = Conn (IOMessage -> IO ()) -- send a message to the I\/O manager ThreadId -- the I\/O manager's 'ThreadId' ProtocolInfo -- protocol information for this connection (MVar [ConfSetting]) -- conf settings that should be rolled back instance Thread Connection where threadId (Conn _ tid _ _) = tid -- | A synonym for the values making up an incompletely initialized -- 'Connection'. type Connection' = (IOMessage -> IO (), ThreadId) -- | Convert a 'Connection' to a 'Connection\'' toConn' :: Connection -> Connection' toConn' (Conn tellIOManager ioManagerTid _ _) = (tellIOManager, ioManagerTid) -- | An existential type containing a reference to a conf variable and a value -- to which it should be rolled back when the connection is closed. data ConfSetting = forall a b. (ConfVal b, SameConfVal a b) => ConfSetting (ConfVar a b) (Maybe b) -- | Open a connection with a handle, an optional password and a source of -- random bytes (see 'authenticate') and pass it to an 'IO' action. If an -- exception interrupts execution, close the connection gracefully before -- re-throwing the exception. withConnection :: Handle -> Maybe ByteString -> (Int -> IO ByteString) -> (Connection -> IO a) -> IO a withConnection handle mbPasswd getRandBytes = bracket' (openConnection handle mbPasswd getRandBytes) closeConnection -- | Open a connection with a handle, an optional password and a source of -- random bytes (see 'authenticate'). Throw a 'TorControlError' or 'IOError' -- if initializing the connection fails. openConnection :: Handle -> Maybe ByteString -> (Int -> IO ByteString) -> IO Connection openConnection handle mbPasswd getRandBytes = do hSetBuffering handle LineBuffering conn@(tellIOManager,ioManagerTid) <- startIOManager handle confSettings <- newMVar [] ( do let protInfoCommand = Command (B.pack "protocolinfo") [B.pack "1"] [] rs@(r:_) <- sendCommand' protInfoCommand False Nothing conn throwIfNotPositive protInfoCommand r protInfo <- either (protocolError protInfoCommand) return (parseProtocolInfo rs) let conn' = Conn tellIOManager ioManagerTid protInfo confSettings authenticate mbPasswd getRandBytes conn' useFeature [VerboseNames] conn' return conn' ) `onException'` closeConnection' conn confSettings -- | Close a connection gracefully, blocking the current thread until the -- connection has terminated. closeConnection :: Connection -> IO () closeConnection conn@(Conn _ _ _ confSettings) = closeConnection' (toConn' conn) confSettings -- | 'closeConnection' with unpacked parameters. closeConnection' :: Connection' -> MVar [ConfSetting] -> IO () closeConnection' conn@(tellIOManager,ioManagerTid) confSettingsMv = -- hold a lock here until the connection has terminated so onCloseSetConf -- blocks in other threads while we're trying to close the connection withMVar confSettingsMv $ \confSettings -> -- roll back all the registered conf settings foldl E.finally (return ()) (map set confSettings) `E.finally` -- Don't wait forever for the reply: whatever is on the other end may not -- be Tor, or may be hung. (timeout quitTimeout (sendCommand' quit True Nothing conn) >>= maybe (return ()) (throwIfNotPositive quit . head)) `E.finally` terminateThread Nothing ioManagerTid (tellIOManager CloseConnection) where set (ConfSetting var val) = setConf_ var val conn quit = Command (B.pack "quit") [] [] quitTimeout = 5 * 10^(6 :: Int) -- | 'ProtocolInfo' associated with a 'Connection'. protocolInfo :: Connection -> ProtocolInfo protocolInfo (Conn _ _ protInfo _) = protInfo -------------------------------------------------------------------------------- -- Commands -- | A command to send to Tor. data Command = Command { -- | A command keyword. comKey :: !ByteString, -- | Command arguments. comArgs :: ![ByteString], -- | A list of lines sent in the data section. comData :: ![ByteString] } deriving Show -- | A reply sent by Tor in response to a command. data Reply = Reply { -- | A reply code. repCode :: !(Char, Char, Char) -- | Reply text. , repText :: !ByteString -- | A list of lines from the data section. , repData :: ![ByteString] } deriving Show -- | Authenticate with Tor. Throw a 'TorControlError' if authenticating fails -- or an 'IOError' if reading the authentication cookie fails. -- -- Methods are tried in this order: none needed, the configured password, then -- the cookie with SAFECOOKIE, in which both sides prove knowledge of the -- cookie without revealing it. @getRandBytes@ supplies the client nonce. -- -- We never use plain COOKIE authentication, which sends the cookie itself: -- whatever answers on the control port names the cookie file in its -- PROTOCOLINFO reply, so if something other than Tor holds the port (say, -- after Tor died) it could make us send it the contents of any file we can -- read. Every Tor since 0.2.3 that offers COOKIE also offers SAFECOOKIE. For -- the same reason the cookie file is read with 'readSmallRegularFile' and -- must be exactly 32 bytes long. -- -- Note that HASHEDPASSWORD authentication sends the password as it is; that's -- how the protocol works. authenticate :: Maybe ByteString -> (Int -> IO ByteString) -> Connection -> IO () authenticate mbPasswd getRandBytes conn = do let methods = authMethods $ protocolInfo conn secret <- case () of _| nullAuth methods -> return Nothing | hashedPasswordAuth methods, Just _ <- mbPasswd -> return $ encodeBase16 `fmap` mbPasswd | Just cookiePath <- cookieAuth methods, safeCookieAuth methods -> Just `fmap` (readCookie cookiePath >>= safeCookie) | Just _ <- cookieAuth methods -> protocolError authCommand' ("Tor offers COOKIE but not SAFECOOKIE \ \authentication; refusing to send the cookie itself." ++) | otherwise -> return Nothing let authCommand = Command (B.pack "authenticate") (maybeToList secret) [] sendCommand authCommand False Nothing conn >>= throwIfNotPositive authCommand { comArgs = [B.pack "[scrubbed]"] } . head where safeCookie cookie = do clientNonce <- getRandBytes nonceLength let challenge = Command (B.pack "authchallenge") [B.pack "SAFECOOKIE", encodeBase16 clientNonce] [] r:_ <- sendCommand challenge False Nothing conn throwIfNotPositive challenge r (serverHash, serverNonce) <- either (protocolError challenge) return (parseAuthChallenge (repText r)) let (expected, clientHash) = safeCookieHashes cookie clientNonce serverNonce -- If Tor doesn't know the cookie, we're not talking to the Tor that -- wrote it: don't send it anything derived from the cookie. unless (constantTimeEq expected serverHash) $ protocolError challenge ("Tor's SERVERHASH doesn't match our cookie; not authenticating." ++) return $! encodeBase16 clientHash nonceLength = 32 authCommand' = Command (B.pack "authenticate") [] [] readCookie path = do cookie <- readSmallRegularFile (cookieLength + 1) path unless (BS.length cookie == cookieLength) $ protocolError authCommand' $ cat "The cookie file " (esc 256 $ B.pack path) " isn't " cookieLength " bytes long; not authenticating." return cookie cookieLength = 32 -- | Given the authentication cookie, the client nonce and the server nonce, -- the hash Tor must send us and the one we must send Tor in SAFECOOKIE -- authentication (control-spec, AUTHCHALLENGE). safeCookieHashes :: ByteString -> ByteString -> ByteString -> (ByteString, ByteString) safeCookieHashes cookie clientNonce serverNonce = (hmac serverKey, hmac clientKey) where msg = B.concat [cookie, clientNonce, serverNonce] hmac key = SHA256.hmac key msg serverKey = B.pack "Tor safe cookie authentication server-to-controller hash" clientKey = B.pack "Tor safe cookie authentication controller-to-server hash" -- | Parse the text of a reply to AUTHCHALLENGE, returning the decoded -- server hash and server nonce. 'throwError' in the monad if parsing fails. parseAuthChallenge :: MonadError ShowS m => ByteString -> m (ByteString, ByteString) parseAuthChallenge text | w:args <- B.words text, w == B.pack "AUTHCHALLENGE" , Just hash <- lookup (B.pack "SERVERHASH") (map keyValue args) , Just nonce <- lookup (B.pack "SERVERNONCE") (map keyValue args) , Just hash' <- decodeHex hash, BS.length hash' == 32 , Just nonce' <- decodeHex nonce, BS.length nonce' == 32 = return (hash', nonce') | otherwise = throwError $ cat "Malformed AUTHCHALLENGE reply " (esc maxLen text) '.' where keyValue = second (B.drop 1) . B.break (== '=') maxLen = 256 -- | Decode an even-length string of hexadecimal digits. decodeHex :: ByteString -> Maybe ByteString decodeHex hex | even (B.length hex), B.all isHexDigit' hex = Just . BS.pack . map pair . split 2 $ hex | otherwise = Nothing where isHexDigit' c = isDigit c || toLower c `elem` "abcdef" pair p = fromIntegral (digit (B.head p) * 16 + digit (B.last p)) digit c | isDigit c = fromEnum c - fromEnum '0' | otherwise = fromEnum (toLower c) - fromEnum 'a' + 10 -- | Compare two strings in time that depends only on their lengths. constantTimeEq :: ByteString -> ByteString -> Bool constantTimeEq a b = BS.length a == BS.length b && BS.foldl' (.|.) 0 (BS.pack (BS.zipWith xor a b)) == 0 -- | Control protocol extensions data Feature = ExtendedEvents -- ^ Extended event syntax | VerboseNames -- ^ Identify routers by long name -- | Enable control protocol extensions. Throw a 'TorControlError' if the reply -- code indicates failure. useFeature :: [Feature] -> Connection -> IO () useFeature features conn = sendCommand command False Nothing conn >>= throwIfNotPositive command . head where command = Command (B.pack "usefeature") (map renderFeature features) [] renderFeature ExtendedEvents = B.pack "extended_events" renderFeature VerboseNames = B.pack "verbose_names" -- | Fetch the most recent descriptor for a given router. Throw a -- 'TorControlError' if the reply code isn't 250 or parsing the descriptor -- fails. getDescriptor :: RouterID -> Connection -> IO Descriptor getDescriptor rid conn = do (r,command) <- getDocument arg parseDescriptor conn either (parseError command) return r where arg = B.pack "desc/id/" `B.append` encodeBase16RouterID rid -- | Fetch the most recent descriptor for every router Tor knows about. Throw a -- 'TorControlError' if the reply code isn't 250. Also return error messages for -- any descriptors that failed to be parsed. getAllDescriptors :: Connection -> IO ([Descriptor], [ShowS]) getAllDescriptors conn = do (r,command) <- getDocument arg parseDescriptors conn return $ map (cat (commandFailed command)) `second` swap (partitionEither r) where arg = B.pack "desc/all-recent" -- | Fetch the current status entry for a given router. Throw a -- 'TorControlError' if the reply code isn't 250 or parsing the router status -- entry fails. getRouterStatus :: RouterID -> Connection -> IO RouterStatus getRouterStatus rid conn = do (r,command) <- getDocument arg parseRouterStatus conn either (parseError command) return r where arg = B.pack "ns/id/" `B.append` encodeBase16RouterID rid -- | Fetch the current status entries for every router Tor has an opinion about. -- Throw a 'TorControlError' if the reply code isn't 250. Also return error -- messages for any router status entries that failed to be parsed. getNetworkStatus :: Connection -> IO ([RouterStatus], [ShowS]) getNetworkStatus conn = do (r,command) <- getDocument arg parseRouterStatuses conn return $ map (cat (commandFailed command)) `second` swap (partitionEither r) where arg = B.pack "ns/all" -- | Send a GETINFO command using @key@ as a single keyword. If the reply code -- is 250, pass the document contained in data from the first reply to @parse@ -- and return the parsed document. Otherwise, throw a 'TorControlError'. Also -- return the GETINFO 'Command' itself. getDocument :: ByteString -> (Document -> a) -> Connection -> IO (a, Command) getDocument key parse conn = do reply:_ <- sendCommand command False Nothing conn case reply of Reply ('2','5','0') text doc | text == B.snoc key '=' -> return (parse $ parseDocument doc, command) | otherwise -> protocolError command $ cat "Got " (esc maxRepLen text) '.' _ -> E.throwIO $ toTCError command reply where command = Command (B.pack "getinfo") [key] [] maxRepLen = 64 -- | Get the current status of all open circuits. Throw a 'TorControlError' if -- the reply code isn't 250. getCircuitStatus :: Connection -> IO [CircuitStatus] getCircuitStatus = getStatus (B.pack "circuit-status") parseCircuitStatus -- | Get the current status of all open streams. Throw a 'TorControlError' if -- the reply code isn't 250. getStreamStatus :: Connection -> IO [StreamStatus] getStreamStatus = getStatus (B.pack "stream-status") parseStreamStatus -- | Get the current status of all open circuits or streams. The GETINFO key is -- specified by @key@, and the line-parsing function by @parse@. Throw a -- 'TorControlError' if the reply code isn't 250. getStatus :: ByteString -> (ByteString -> Either ShowS a) -> Connection -> IO [a] getStatus key parse conn = do reply:_ <- sendCommand command False Nothing conn let prefix = B.snoc key '=' validKey = prefix `B.isPrefixOf` repText reply case reply of Reply ('2','5','0') text dataLines | prefix == text , null dataLines -> return [] | not validKey -> protocolError command $ cat "Got " (esc maxRepLen text) '.' | null dataLines -> check (:[]) (parse $ B.drop (B.length key + 1) text) | otherwise -> check id $ mapM parse dataLines _ -> E.throwIO $ toTCError command reply where command = Command (B.pack "getinfo") [key] [] check f = either (parseError command) (return . f) maxRepLen = 64 -- | A circuit's purpose data CircuitPurpose = CrGeneral -- ^ General | CrController -- ^ Controller -- | Build a new circuit, setting the @purpose@ if specified. Return the newly -- created 'CircuitID'. Throw a 'TorControlError' if the reply code isn't 250. createCircuit :: [RouterID] -> Maybe CircuitPurpose -> Connection -> IO CircuitID createCircuit = extendCircuit' Nothing -- | Extend an existing circuit according to the specified @path@. Throw a -- 'TorControlError' if the reply code isn't 250. extendCircuit :: CircuitID -> [RouterID] -> Connection -> IO () extendCircuit cid path = (>> return ()) . extendCircuit' (Just cid) path Nothing -- | Send an EXTENDCIRCUIT command. Build a new circuit according to the -- specified @path@ and @purpose@ if @circuit@ is 'Nothing'. Otherwise, extend -- an existing circuit according to @path@. Return the (possibly new) -- 'CircuitID'. Throw a 'TorControlError' if the reply code isn't 250. extendCircuit' :: Maybe CircuitID -> [RouterID] -> Maybe CircuitPurpose -> Connection -> IO CircuitID extendCircuit' circuit path purpose conn = do reply:_ <- sendCommand command False Nothing conn case reply of Reply ('2','5','0') text _ | msg:cid':_ <- B.split ' ' text, msg == B.pack "EXTENDED" , maybe True (== CircId cid') circuit -> return $ CircId (B.copy cid') | otherwise -> protocolError command $ cat "Got " (esc maxRepLen text) '.' _ -> E.throwIO $ toTCError command reply where command = Command (B.pack "extendcircuit") args [] args = add purpose [cid, B.intercalate (B.pack ",") $ map encodeBase16RouterID path] CircId cid = fromMaybe nullCircuitID circuit renderPurpose CrGeneral = B.pack "general" renderPurpose CrController = B.pack "controller" add = maybe id (\p -> (++ [B.pack "purpose=" `B.append` renderPurpose p])) maxRepLen = 64 -- | Attach an unattached stream to a completed circuit, exiting from @hop@ if -- specified. Throw a 'TorControlError' if the reply code indicates failure. attachStream :: StreamID -> CircuitID -> Maybe Integer -> Connection -> IO () attachStream sid cid = attachStream' sid (Just cid) -- | Cede the responsibility for attaching a given unattached stream to Tor. Throw -- a 'TorControlError' if the reply code indicates failure. cedeStream :: StreamID -> Connection -> IO () cedeStream sid = attachStream' sid Nothing Nothing -- | Send an ATTACHSTREAM command. Attach an unattached stream to the specified -- completed circuit, exiting from @hop@ if specified. If the circuit isn't -- specified, return the responsibility for attaching the stream to Tor. Throw a -- 'TorControlError' if the reply code indicates failure. attachStream' :: StreamID -> Maybe CircuitID -> Maybe Integer -> Connection -> IO () attachStream' (StrmId sid) circuit hop conn = sendCommand command False Nothing conn >>= throwIfNotPositive command . head where command = Command (B.pack "attachstream") (add hop [sid,cid]) [] CircId cid = fromMaybe nullCircuitID circuit add = maybe id (flip (++) . (:[]) . B.append (B.pack "HOP=") . B.pack . show) -- | Change a stream's destination address and port, if specified. Throw a -- 'TorControlError' if the reply code indicates failure. redirectStream :: StreamID -> Address -> Maybe Port -> Connection -> IO () redirectStream (StrmId sid) addr port conn = sendCommand command False Nothing conn >>= throwIfNotPositive command . head where command = Command (B.pack "redirectstream") args [] args = [sid, showAddress addr] ++ maybeToList ((B.pack . show) `fmap` port) -- | Flags to pass to 'closeCircuit' data CloseCircuitFlags = CloseCircuitFlags { -- | Don't close the circuit unless it's unused ifUnused :: Bool } -- | All 'CloseCircuitFlags' unset emptyCloseCircuitFlags :: CloseCircuitFlags emptyCloseCircuitFlags = CloseCircuitFlags False -- | Close the specified circuit. Throw a 'TorControlError' if the reply code -- indicates failure. closeCircuit :: CircuitID -> CloseCircuitFlags -> Connection -> IO () closeCircuit (CircId cid) flags conn = sendCommand command False Nothing conn >>= throwIfNotPositive command . head where command = Command (B.pack "closecircuit") (cid : flagArgs) [] flagArgs = [flag | (p,flag) <- [(ifUnused, B.pack "IfUnused")], p flags] -- | Send a MAPADDRESS command registering each @(from, to)@ pair. Tor -- rewrites SOCKS requests for @from@ to @to@. Unlike a @.exit@ hostname given -- directly to the SOCKS port (rejected by Tor since 0.3.x), a @.exit@ address -- installed by the controller is honoured. Throw a 'TorControlError' if any -- mapping is refused. mapAddress :: [(ByteString, ByteString)] -> Connection -> IO () mapAddress pairs conn = sendCommand command False Nothing conn >>= mapM_ (throwIfNotPositive command) where command = Command (B.pack "mapaddress") [B.concat [from, B.pack "=", to] | (from,to) <- pairs] [] -- | Remove address mappings previously installed with 'mapAddress'. (Mapping -- an address to itself removes the mapping.) unmapAddress :: [ByteString] -> Connection -> IO () unmapAddress addrs = mapAddress [(a, a) | a <- addrs] -- | Send a GETCONF command with a set of config variable names, returning -- a set of key-value pairs. Throw a 'TorControlError' if the reply code -- indicates failure. getConf' :: [ByteString] -> Connection' -> IO [(ByteString, Maybe ByteString)] getConf' keys conn = do rs@(r:_) <- sendCommand' command False Nothing conn throwIfNotPositive command r either (protocolError command) return (mapM (parseText . repText) rs) where command = Command (B.pack "getconf") keys [] parseText text | B.null eq = return (key, Nothing) | eq == (B.pack "=") = return (key, Just val) | otherwise = throwError $ cat "Malformed GETCONF reply " (esc maxTextLen text) '.' where (key,(eq,val)) = B.splitAt 1 `second` B.span isAlpha text maxTextLen = 128 -- | Send a SETCONF command with a set of key-value pairs. Throw a -- 'TorControlError' if the reply code indicates failure. setConf' :: [(ByteString, Maybe ByteString)] -> Connection' -> IO () setConf' = setConf'' (B.pack "setconf") -- | Send a RESETCONF command with a set of key-value pairs. Throw a -- 'TorControlError' if the reply code indicates failure. resetConf' :: [(ByteString, Maybe ByteString)] -> Connection' -> IO () resetConf' = setConf'' (B.pack "resetconf") -- | Send a SETCONF or RESETCONF command with a set of key-value pairs. Throw a -- 'TorControlError' if the reply code indicates failure. setConf'' :: ByteString -> [(ByteString, Maybe ByteString)] -> Connection' -> IO () setConf'' name args conn = sendCommand' command False Nothing conn >>= throwIfNotPositive command . head where command = Command name (map renderArg args) [] renderArg (key, Just val) = B.intercalate (B.pack "=") [key, val] renderArg (key, _) = key -- | Send a command using a connection, blocking the current thread until all -- replies have been received. The optional @mbEvHandlers@ parameter specifies -- a list of event handlers to replace the currently installed event handlers. -- @isQuit@ specifies whether this is a QUIT command. sendCommand :: Command -> Bool -> Maybe [EventHandler] -> Connection -> IO [Reply] sendCommand command isQuit mbEvHandlers = sendCommand' command isQuit mbEvHandlers . toConn' -- | 'sendCommand' with unpacked parameters. sendCommand' :: Command -> Bool -> Maybe [EventHandler] -> Connection' -> IO [Reply] sendCommand' command isQuit mbEvHandlers (tellIOManager,ioManagerTid) = do mv <- newEmptyMVar let putResponse = (>> return ()) . tryPutMVar mv withMonitor ioManagerTid (putResponse . Left) $ do tellIOManager $ SendCommand command isQuit mbEvHandlers (putResponse.Right) response <- takeMVar mv case response of Left NormalExit -> E.throwIO ConnectionClosed Left (AbnormalExit (E.fromException -> Just NonexistentThread)) -> E.throwIO ConnectionClosed Left (AbnormalExit e) -> E.throwIO e Right replies -> return replies -------------------------------------------------------------------------------- -- Config variables -- | The type of config values. class ConfVal a where -- | Encode a config value for the control protocol. encodeConfVal :: a -> ByteString -- | Decode a config value from the control protocol. 'throwError' in the -- monad if decoding fails. decodeConfVal :: MonadError ShowS m => ByteString -> m a instance ConfVal Bool where encodeConfVal True = (B.pack "1") encodeConfVal False = (B.pack "0") decodeConfVal bool | bool == (B.pack "1") = return True | bool == (B.pack "0") = return False | otherwise = throwError $ cat "Malformed boolean conf value " (esc maxBoolLen bool) '.' where maxBoolLen = 32 -- | A constraint requiring 'setConf' and 'resetConf' to take the same type of -- config value as 'getConf' returns. class SameConfVal a b where -- | Convert a value returned by 'getConf' to a value suitable for 'setConf'. getToSet :: a -> Maybe b instance SameConfVal a a where getToSet = Just instance SameConfVal (Maybe a) a where getToSet = id -- | A functional reference to a config variable. data (ConfVal b, SameConfVal a b) => ConfVar a b = ConfVar { getConf_ :: Connection' -> IO a , setConf_ , resetConf_ :: Maybe b -> Connection' -> IO () } -- | Retrieve the value of a config variable, throwing a 'TorControlError' -- if the command fails. getConf :: (ConfVal b, SameConfVal a b) => ConfVar a b -> Connection -> IO a getConf var = getConf_ var . toConn' -- | Set the value of a config variable, throwing a 'TorControlError' if the -- command fails. setConf :: (ConfVal b, SameConfVal a b) => ConfVar a b -> Maybe b -> Connection -> IO () setConf var val = setConf_ var val . toConn' -- | Reset the value of a config variable, throwing a 'TorControlError' if -- the command fails. resetConf :: (ConfVal b, SameConfVal a b) => ConfVar a b -> Maybe b -> Connection -> IO () resetConf var val = resetConf_ var val . toConn' -- | When the connection is closed, set the given conf variable to the given -- value. onCloseSetConf :: (ConfVal b, SameConfVal a b) => ConfVar a b -> Maybe b -> Connection -> IO () onCloseSetConf var val (Conn _ _ _ confSettings) = modifyMVar_ confSettings (return . (ConfSetting var val :)) -- | Get the current value of a conf variable, then ensure that the variable -- will be rolled back to that value when the connection is closed. Throw a -- 'TorControlError' if a command fails. onCloseRollback :: (ConfVal b, SameConfVal a b) => ConfVar a b -> Connection -> IO () onCloseRollback var conn = do val <- getConf var conn onCloseSetConf var (getToSet val) conn -- | Get the current value of a conf variable. If the current value is different -- from the given value, ensure that the original value is rolled back when the -- connection is closed, then set the variable to the given value. Throw a -- 'TorControlError' if a command fails. setConfWithRollback :: (Eq b, ConfVal b, SameConfVal a b) => ConfVar a b -> Maybe b -> Connection -> IO () setConfWithRollback var newVal conn = do origVal <- getToSet `fmap` getConf var conn when (origVal /= newVal) $ do onCloseSetConf var origVal conn setConf var newVal conn -- | Enables fetching descriptors for non-running routers. fetchUselessDescriptors :: ConfVar Bool Bool fetchUselessDescriptors = boolVar (B.pack "fetchuselessdescriptors") -- | Enables fetching directory info on the mirror schedule, preferably from -- authorities. fetchDirInfoEarly :: ConfVar Bool Bool fetchDirInfoEarly = boolVar (B.pack "fetchdirinfoearly") -- | Given the name of a boolean conf variable, return the corresponding -- 'ConfVar'. boolVar :: ByteString -> ConfVar Bool Bool boolVar var = ConfVar getc (setc setConf') (setc resetConf') where getc conn = do (key,val):_ <- getConf' [var] conn case fmap decodeConfVal val of Nothing -> psErr $ cat "Unexpected empty value for \"" var "\"." Just (Left e) -> psErr $ cat "Failed parsing value for \"" var "\": " e Just (Right val') | B.map toLower key /= var -> psErr $ cat "Received conf value " (esc maxVarLen key) ", expecting \"" var "\"." | otherwise -> return val' setc f val = f [(var, fmap encodeConfVal val)] psErr = E.throwIO . ParseError maxVarLen = 64 -------------------------------------------------------------------------------- -- Asynchronous events -- | An asynchronous event handler. data EventHandler = EventHandler { evCode :: !ByteString -- ^ The event code. , evHandler :: !([Reply] -> IO ()) -- ^ The event handler. } -- | Register a set of handlers for asynchronous events. This deregisters any -- previously registered event handlers for this connection. Throw a -- 'TorControlError' if the reply code indicates failure. registerEventHandlers :: [EventHandler] -> Connection -> IO () registerEventHandlers handlers conn = sendCommand command False (Just handlers) conn >>= throwIfNotPositive command . head where command = Command (B.pack "setevents") (map evCode handlers) [] -- | Create an event handler for new router descriptor events. newDescriptorsEvent :: ([TorControlError] -> [Descriptor] -> IO ()) -> Connection -> EventHandler newDescriptorsEvent handler conn = EventHandler (B.pack "NEWDESC") handleNewDesc where safeGetDescriptor rid = Right `fmap` getDescriptor rid conn `E.catch` \(e :: TorControlError) -> return (Left e) handleNewDesc (Reply _ text _:_) = do -- pipeline descriptor requests (es',ds) <- fmap partitionEither . mapM resolve =<< mapM (spawn . safeGetDescriptor) rids handler (map ParseError es ++ es') ds where (es,rids) = partitionEither . map decodeBase16RouterID . map (B.take 40 . B.drop 1) . B.split ' ' . B.drop 8 $ text handleNewDesc _ = return () -- | Create an event handler for network status events. networkStatusEvent :: ([TorControlError] -> [RouterStatus] -> IO ()) -> EventHandler networkStatusEvent handler = EventHandler (B.pack "NS") handleNS where handleNS (Reply _ _ doc@(_:_):_) = handler (map ParseError es) rs where (es,rs) = partitionEither . parseRouterStatuses $ parseDocument doc handleNS _ = return () -- | Create an event handler for new consensus events. Unlike @NS@ events, -- which only carry the entries that changed, a @NEWCONSENSUS@ event carries -- the status entry of every router listed in the new consensus. newConsensusEvent :: ([TorControlError] -> [RouterStatus] -> IO ()) -> EventHandler newConsensusEvent handler = EventHandler (B.pack "NEWCONSENSUS") handleNC where handleNC (Reply _ _ doc@(_:_):_) = handler (map ParseError es) rs where (es,rs) = partitionEither . parseRouterStatuses $ parseDocument doc handleNC _ = return () -- | Create an event handler for stream status change events. streamEvent :: (Either TorControlError StreamStatus -> IO ()) -> EventHandler streamEvent = lineEvent (B.pack "STREAM") parseStreamStatus -- | Create an event handler for circuit status change events. circuitEvent :: (Either TorControlError CircuitStatus -> IO ()) -> EventHandler circuitEvent = lineEvent (B.pack "CIRC") parseCircuitStatus -- | Create an event handler for circuit/stream status change events. The event -- code is specified by @code@, and the line-parsing function by @parse@. lineEvent :: ByteString -> (ByteString -> Either ShowS a) -> (Either TorControlError a -> IO ()) -> EventHandler lineEvent code parse handler = EventHandler code handleStatus where handleStatus (Reply _ text _:_) = handler . either (Left . ParseError) Right . parse . B.drop (B.length code + 1) $ text handleStatus _ = return () -- | Create an event handler for new address mapping events. addressMapEvent :: (Either TorControlError AddressMap -> IO ()) -> EventHandler addressMapEvent handler = EventHandler (B.pack "ADDRMAP") handleAddrMap where handleAddrMap (Reply _ text _:_) = do -- Only needed for very old Tors, which don't send EXPIRES (in UTC). tz <- getCurrentTimeZone handler . either (Left . ParseError) Right . parseAddressMap tz . B.drop 8 $ text handleAddrMap _ = return () -------------------------------------------------------------------------------- -- Backend connection manager -- | A message sent to the I\/O manager. data IOMessage -- | Send a command to Tor. = SendCommand Command -- the command to send to Tor Bool -- is this a QUIT command? (Maybe [EventHandler]) -- event handlers to register ([Reply] -> IO ()) -- invoke this action with replies -- | Handle a sequence of replies from Tor. | Replies [Reply] -- | Terminate the connection with Tor. | CloseConnection -- | An exit signal sent to the I\/O manager. | Exit ThreadId ExitReason -- | An internal type containing the I\/O manager state. data IOManagerState = IOManagerState { -- | A sequence of actions used to respond to outstanding commands. responds :: S.Seq ([Reply] -> IO ()), -- | The thread in which event handlers are invoked. evHandlerTid :: ThreadId, -- | A map from event name to event handler. evHandlers :: M.Map ByteString ([Reply] -> IO ()), -- | Has the QUIT command been sent? quitSent :: Bool } -- | Start the thread that manages all I\/O associated with a Tor control -- connection, linking it to the calling thread. We receive messages sent with -- the returned 'Connection\'' and send the appropriate command to Tor. When we -- receive replies from Tor, we pass them in a message to the thread that -- requested the corresponding command. Asynchronous event handlers are -- maintained as local state, invoked as necessary for incoming events. startIOManager :: Handle -> IO Connection' startIOManager handle = do ioChan <- newChan ioManagerTid <- forkLinkIO $ do setTrapExit ((writeChan ioChan .) . Exit) socketReaderTid <- startSocketReader handle (writeChan ioChan . Replies) eventChan <- newChan initEventTid <- startEventHandler eventChan let runIOManager io = fix io (IOManagerState S.empty initEventTid M.empty False) `E.finally` hClose handle runIOManager $ \loop s -> do message <- readChan ioChan case message of Exit tid _ | tid == evHandlerTid s -> do newEvHandlerTid <- startEventHandler eventChan loop s { evHandlerTid = newEvHandlerTid } Exit _ NormalExit -> loop s Exit tid (AbnormalExit (E.fromException -> Just e)) | tid == socketReaderTid , isEOFError e , quitSent s , S.null (responds s) -> kill $ evHandlerTid s Exit _ reason -> exit reason CloseConnection -> mapM_ kill [socketReaderTid, evHandlerTid s] Replies replies@(r:_) | ('6',_,_) <- repCode r -> do whenJust (eventCode r `M.lookup` evHandlers s) $ writeChan eventChan . Right . ($ replies) loop s | responds' :> respond <- viewr (responds s) -> do respond replies loop s { responds = responds' } Replies _ -> loop s SendCommand command isQuit mbEvHandlers respond -> do B.hPut handle $ renderCommand command hFlush handle case mbEvHandlers of Just hs -> loop s' { evHandlers = M.fromList . map (\(EventHandler c h) -> (c, h)) $ hs } _ -> loop s' where s' = s { responds = respond <| responds s, quitSent = isQuit } return (writeChan ioChan, ioManagerTid) where startEventHandler eventChan = do ioManagerTid <- myThreadId forkLinkIO $ do setTrapExit (curry $ writeChan eventChan . Left) fix $ \loop -> do message <- readChan eventChan case message of Left (tid,reason) | tid == ioManagerTid -> exit reason | otherwise -> loop Right event -> event >> loop kill tid = terminateThread Nothing tid . throwTo tid $ exitReason E.ThreadKilled renderCommand (Command key args []) = B.intercalate (B.pack " ") (key : args) `B.append` B.pack "\r\n" renderCommand c@(Command _ _ data') = B.cons '+' (renderCommand c { comData = [] }) `B.append` renderData data' renderData = B.concat . foldr (\line xs -> line : B.pack "\r\n" : xs) [B.pack ".\r\n"] eventCode = B.takeWhile (/= ' ') . repText -- | Start a thread that reads replies from @handle@ and passes them to -- @sendRepliesToIOManager@, linking it to the calling thread. startSocketReader :: Handle -> ([Reply] -> IO ()) -> IO ThreadId startSocketReader handle sendRepliesToIOManager = forkLinkIO . runConduit $ CB.sourceHandle handle .| c_replies .| CL.mapM_ sendRepliesToIOManager -- | Stream decoded 'Reply' groups. c_replies :: ConduitT B.ByteString [Reply] IO () c_replies = c_lines_any .| line0 [] where line0 acc = await >>= return () `maybe` \line -> do let (code, (typ, text)) = B.splitAt 1 `second` B.splitAt 3 line code' <- either throwProtoError return $ parseReplyCode code case () of _ | typ == B.pack "-" -> line0 (acc' []) | typ == B.pack "+" -> rest [] >>= line0 . acc' | typ == B.pack " " -> yield (reverse $ acc' []) >> line0 [] | otherwise -> throwProtoError $ cat "Malformed reply line type " (esc 1 typ) '.' where acc' xs = Reply code' text xs : acc rest acc = await >>= \mline -> case mline of Nothing -> return $ reverse acc Just line | B.null line -> rest acc | line == B.pack "." -> return $ reverse acc | otherwise -> rest (line:acc) throwProtoError = lift . E.throw . ProtocolError -------------------------------------------------------------------------------- -- Data types -- | A new-style (since 0.1.0) Tor version number. data TorVersion = TorVersion Integer -- major Integer -- minor Integer -- micro Integer -- patch level ByteString -- status tag deriving (Eq, Ord) instance Show TorVersion where showsPrec _ (TorVersion major minor micro patchLevel statusTag) | B.null statusTag = prefix | otherwise = cat prefix '-' statusTag where prefix = cat major '.' minor '.' micro '.' patchLevel -- | Parse a new-style (since 0.1.0) Tor version number. 'throwError' in the -- monad if parsing fails. parseTorVersion :: MonadError ShowS m => ByteString -> m TorVersion parseTorVersion bs | Just v <- evalStateT version bs = return v | otherwise = throwError $ cat "Malformed Tor version " (esc maxVerLen bs) '.' where version :: StateT ByteString Maybe TorVersion version = do major <- int; dot minor <- int; dot micro <- int patchLevel <- (dot >> int) `mplus` return 0 statusTag <- (hyphen >> get) `mplus` (eof >> return B.empty) return $! TorVersion major minor micro patchLevel statusTag int = StateT (maybe mzero return . B.readInteger) (dot,hyphen) = (str (B.pack "."), str (B.pack "-")) str x = do (x',rest) <- B.splitAt (B.length x) `fmap` get if x == x' then put rest else lift mzero eof = get >>= flip unless (lift mzero) . B.null maxVerLen = 32 -- | Authentication methods accepted by Tor. data AuthMethods = AuthMethods { nullAuth -- ^ No authentication is required , hashedPasswordAuth -- ^ The original password must be supplied , safeCookieAuth :: Bool -- ^ Knowledge of the cookie may be proven -- with AUTHCHALLENGE (SAFECOOKIE) , cookieAuth :: Maybe FilePath -- ^ The contents of a cookie must be supplied } deriving Show -- | Control protocol information for a connection. data ProtocolInfo = ProtocolInfo { torVersion :: TorVersion , authMethods :: AuthMethods } deriving Show -- | Parse a response to a PROTOCOLINFO command. 'throwError' in the monad if -- parsing fails. parseProtocolInfo :: MonadError ShowS m => [Reply] -> m ProtocolInfo parseProtocolInfo [] = throwError ("Missing PROTOCOLINFO reply." ++) parseProtocolInfo (Reply _ text _:rs) | not $ B.isPrefixOf (B.pack "PROTOCOLINFO") text = throwError ("Malformed PROTOCOLINFO reply." ++) | B.drop 13 text /= (B.pack "1") = throwError ("Unsupported PROTOCOLINFO version." ++) | otherwise = do authLine <- findPrefix (B.pack "AUTH METHODS=") let (methods,restAuth) = B.split ',' `first` B.span (/= ' ') authLine cookiePath <- if (B.pack " COOKIEFILE=") `B.isPrefixOf` restAuth then (Just . fst) `liftM` parseQuotedString (B.drop 12 restAuth) else return Nothing versionLine <- findPrefix (B.pack "VERSION Tor=") version <- parseTorVersion . fst =<< parseQuotedString versionLine return $! ProtocolInfo version AuthMethods { nullAuth = B.pack "NULL" `elem` methods , hashedPasswordAuth = B.pack "HASHEDPASSWORD" `elem` methods , safeCookieAuth = B.pack "SAFECOOKIE" `elem` methods , cookieAuth = B.unpack `liftM` cookiePath } where findPrefix prefix | Just r <- find (B.isPrefixOf prefix . repText) rs = return . B.drop (B.length prefix) . repText $ r | otherwise = throwError $ cat "Missing " (B.takeWhile (/= ' ') prefix) " line." -- | A circuit identifier. newtype CircuitID = CircId ByteString deriving (Eq, Ord) instance Show CircuitID where showsPrec _ (CircId cid) = cat "(CID " cid ')' -- | A special 'CircuitID' of "0". nullCircuitID :: CircuitID nullCircuitID = CircId (B.pack "0") -- | Parse an identifier using the constructor @con@. 'throwError' in the monad -- if parsing fails. parseID :: MonadError ShowS m => (ByteString -> a) -> ByteString -> m a parseID con bs | B.all isAlphaNum bs = return $! con bs | otherwise = throwError $ cat "Malformed identifier " (esc maxIDLen bs) '.' where maxIDLen = 32 -- | A circuit status entry. data CircuitStatus = CircStatus CircuitID CircuitState [RouterID] deriving Show -- | Parse a circuit status entry line. 'throwError' in the monad if parsing -- fails. parseCircuitStatus :: MonadError ShowS m => ByteString -> m CircuitStatus parseCircuitStatus line | cid:state:rest <- B.split ' ' line = prependError ("Failed parsing circuit status: " ++) $ do cid' <- parseID CircId (B.copy cid) state' <- parseCircuitState state return $! CircStatus cid' state' (fromMaybe [] (parsePath =<< listToMaybe rest)) | otherwise = throwError $ cat "Malformed circuit status " (esc maxStatusLen line) '.' where parsePath = hush . mapM (decodeBase16RouterID . B.take 40 . B.drop 1) . B.split ',' maxStatusLen = 512 -- | A circuit's current state. data CircuitState = CrLaunched -- ^ Circuit ID assigned to new circuit | CrBuilt -- ^ All hops finished, can now accept streams | CrExtended -- ^ One more hop has been completed | CrFailed -- ^ circuit closed (was not built) | CrClosed -- ^ Circuit closed (was built) deriving Show -- | Parse a circuit state. 'throwError' in the monad if parsing fails. parseCircuitState :: MonadError ShowS m => ByteString -> m CircuitState parseCircuitState bs | bs == (B.pack "LAUNCHED") = return CrLaunched | bs == (B.pack "BUILT") = return CrBuilt | bs == (B.pack "EXTENDED") = return CrExtended | bs == (B.pack "FAILED") = return CrFailed | bs == (B.pack "CLOSED") = return CrClosed | otherwise = throwError $ cat "Unknown circuit state " (esc maxStateLen bs) '.' where maxStateLen = 32 -- | A stream identifier. newtype StreamID = StrmId ByteString deriving (Eq, Ord) instance Show StreamID where showsPrec _ (StrmId sid) = cat "(SID " sid ')' -- | A stream status entry. data StreamStatus = StrmStatus StreamID StreamState (Maybe CircuitID) Address Port deriving Show -- | Parse a stream status entry line. 'throwError' in the monad if parsing -- fails. parseStreamStatus :: MonadError ShowS m => ByteString -> m StreamStatus parseStreamStatus line | sid:state:cid:target:_ <- B.split ' ' line , [addr,port] <- B.split ':' target = prependError ("Failed parsing stream status: " ++) $ do sid' <- parseID StrmId (B.copy sid) state' <- parseStreamState state cid' <- parseID CircId (B.copy cid) port' <- parsePort port let mbCId = if cid' == nullCircuitID then Nothing else Just cid' return $! StrmStatus sid' state' mbCId (readAddress $ B.copy addr) port' | otherwise = throwError $ cat "Malformed stream status " (esc maxStatusLen line) '.' where maxStatusLen = 512 -- | A stream's current state. data StreamState = StNew -- ^ New request to connect | StNewResolve -- ^ New request to resolve an address | StRemap -- ^ Address re-mapped to another | StSentConnect -- ^ Sent a connect cell along a circuit | StSentResolve -- ^ Sent a resolve cell along a circuit | StSucceeded -- ^ Received a reply; stream established | StFailed -- ^ Stream failed and not retriable | StClosed -- ^ Stream closed | StDetached -- ^ Detached from circuit; still retriable deriving Show -- | Parse a stream state. 'throwError' in the monad if parsing fails. parseStreamState :: MonadError ShowS m => ByteString -> m StreamState parseStreamState bs | bs == (B.pack "NEW") = return StNew | bs == (B.pack "NEWRESOLVE") = return StNewResolve | bs == (B.pack "REMAP") = return StRemap | bs == (B.pack "SENTCONNECT") = return StSentConnect | bs == (B.pack "SENTRESOLVE") = return StSentResolve | bs == (B.pack "SUCCEEDED") = return StSucceeded | bs == (B.pack "FAILED") = return StFailed | bs == (B.pack "CLOSED") = return StClosed | bs == (B.pack "DETACHED") = return StDetached | otherwise = throwError $ cat "Unknown stream state " (esc maxStateLen bs) '.' where maxStateLen = 32 -- | An address mapping. data AddressMap = AddrMap Address -- old address Address -- new address Expiry -- expiry time deriving Show -- | Parse an address mapping, using the specified time zone to convert an -- expiry time to UTC. 'throwError' in the monad if parsing fails. -- -- The expiry is given in local time, and since Tor 0.2.0.x also in UTC as -- @EXPIRES=\"...\"@; we use the latter when it's there, so that the local -- time zone (which may differ between us and Tor) doesn't matter. parseAddressMap :: MonadError ShowS m => TimeZone -> ByteString -> m AddressMap parseAddressMap tz line | fst (breakWS rest) == (B.pack "NEVER") = return $! mapping Never | (_, expires) <- B.breakSubstring (B.pack " EXPIRES=\"") rest , not (B.null expires), _:time:_ <- B.split '"' expires = prependError ("Failed parsing address mapping: " ++) ((mapping . Expiry . localTimeToUTC utc) `liftM` parseLocalTime time) | (B.pack "\"") `B.isPrefixOf` rest, _:time:_ <- B.split '"' rest = prependError ("Failed parsing address mapping: " ++) ((mapping . Expiry . localTimeToUTC tz) `liftM` parseLocalTime time) | otherwise = throwError $ cat "Malformed address mapping " (esc maxMappingLen line) '.' where mapping = AddrMap (readAddress old) (readAddress new) (old,(new,rest)) = second breakWS $ breakWS line breakWS = second (B.dropWhile isSpace) . B.break isSpace maxMappingLen = 256 -- | An address mapping expiry time. data Expiry = Expiry UTCTime | Never instance Show Expiry where show (Expiry expiry) = take 19 (show expiry) show Never = "Never" -------------------------------------------------------------------------------- -- Errors -- | A reply code designating a status, subsystem, and fine-grained information. type ReplyCode = (Char, Char, Char) -- | An error type used in dynamic exceptions. data TorControlError -- | A command, negative reply code, and human-readable status message. = TCError Command ReplyCode ByteString | ParseError ShowS -- ^ Parsing a reply from Tor failed. | ProtocolError ShowS -- ^ A reply from Tor didn't follow the protocol. | ConnectionClosed -- ^ The control connection is closed. instance Show TorControlError where showsPrec _ (TCError command (x,y,z) text) = cat (commandFailed command) [x,y,z,' '] (esc 512 text) showsPrec _ (ParseError msg) = cat "Parsing error: " msg showsPrec _ (ProtocolError msg) = cat "Protocol error: " msg showsPrec _ ConnectionClosed = ("Connection is already closed" ++) instance E.Exception TorControlError -- | Given a command, return a \"command failed\" message. commandFailed :: Command -> ShowS commandFailed (Command key args _) = cat "Command \"" key ' ' (B.unwords args) "\" failed with: " -- | Throw a 'ProtocolError' given a command and error message. protocolError :: Command -> ShowS -> IO a protocolError command = E.throwIO . ProtocolError . cat (commandFailed command) -- | Throw a 'ParseError' given a command and an error message. parseError :: Command -> ShowS -> IO a parseError command = E.throwIO . ParseError . cat (commandFailed command) -- | Convert a command and negative reply to a 'TorControlError'. toTCError :: Command -> Reply -> TorControlError toTCError command (Reply code text _) = TCError command code text -- | Parse a reply code. 'throwError' in the monad if parsing fails. parseReplyCode :: MonadError ShowS m => ByteString -> m ReplyCode parseReplyCode bs | all isDigit cs, [x,y,z] <- cs = return (x, y, z) | otherwise = throwError $ cat "Malformed reply code " (esc 3 bs) '.' where cs = B.unpack bs -- | Throw a 'TorControlError' if the reply indicates failure. throwIfNotPositive :: Command -> Reply -> IO () throwIfNotPositive command reply = unless (isPositive $ repCode reply) $ E.throwIO $ toTCError command reply -- | Is a reply successful? isPositive :: ReplyCode -> Bool isPositive ('2',_,_) = True isPositive _ = False mhatta-tordnsel-1d9141b/src/TorDNSEL/Util.hsc000066400000000000000000000624011527317632400207210ustar00rootroot00000000000000{-# LANGUAGE ForeignFunctionInterface, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Util -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (pattern guards, bang patterns, concurrency, -- FFI, type synonym instances, overlapping -- instances, undecidable instances) -- -- Common utility functions. -- ----------------------------------------------------------------------------- module TorDNSEL.Util ( -- * Parsing functions readInt , readInteger , inet_atoh , inet_atoh6 , parseUTCTime , parseLocalTime , parseQuotedString , prependError , replaceError , handleError -- * Show functions , bshow -- * Strict functions , adjust' , alter' , update' , mapInsert' , modify' -- * Miscellaneous functions , on , unfoldAccumR , swap , partitionEither , whenJust , untilM , untilM_ , muntil , inet_htoa , encodeBase16 , split , unsnoc , syncExceptions , bracket' , finally' , bracketOnError' , onException' , exitUsage , trySync , inBoundsOf , htonl , ntohl , showUTCTime -- * Conduit utilities , c_take , c_breakDelim , c_line_crlf , c_lines_any -- * Network functions , closeSocket , bindUDPSocket , bindListeningTCPSocket , bindListeningUnixDomainStreamSocket , connectStreamSocket -- * Monads , MaybeT(..) , hush -- * Address , Address(..) , showAddress , readAddress -- * Ports , Port(..) , parsePort -- * Escaped strings , EscapedString , escaped , unescLen , escape , showEscaped , esc -- * Constants , tcpProtoNum , udpProtoNum -- * Variable-parameter string concatenation , CatArg , CatType(..) , cat , HCatType , hCat ) where import Control.Arrow ((&&&), first, second) import Control.Monad import qualified Control.Exception as E import Control.Monad.Except (MonadError(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import qualified Control.Monad.State as State import Control.Monad.State (MonadState) import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Char ( intToDigit, showLitChar, isPrint, isControl, chr, ord, digitToInt, isAscii , isHexDigit ) import qualified Data.List as L import Data.List (intersperse) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Internal as B (c2w) import Data.ByteString (ByteString) import qualified Data.Map as M import Data.Ratio (numerator, denominator, (%)) import Data.Time ( fromGregorian, UTCTime(..), LocalTime(LocalTime) , timeOfDayToTime, timeToTimeOfDay ) import Data.Word (Word16, Word32) import Network.Socket ( HostAddress, HostAddress6, ProtocolNumber, Socket, SockAddr(..), SocketOption(ReuseAddr, IPv6Only) , SocketType(Datagram, Stream), Family(AF_INET, AF_INET6, AF_UNIX), socket, bind , listen, setSocketOption, close, maxListenQueue, connect, defaultProtocol ) import System.Directory (doesFileExist, removeFile) import System.Environment (getProgName) import System.Exit (exitWith, ExitCode) import System.IO (Handle, hPutStr) import System.Posix.Files (setFileMode) import System.Posix.Types (FileMode) import Text.Printf (printf) import Data.Binary (Binary(..)) import Data.Conduit (ConduitT) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB #include -------------------------------------------------------------------------------- -- Parsing functions -- | Parse an 'Int' from a 'B.ByteString'. Return the result or 'throwError' in -- the monad if parsing fails. readInt :: MonadError ShowS m => ByteString -> m Int readInt bs = case B.readInt bs of Just (int,rest) | B.null rest -> return int _ -> throwError $ cat "Malformed integer " (esc maxIntLen bs) '.' where maxIntLen = 10 -- | Parse an 'Integer' from a 'B.ByteString'. Return the result or 'throwError' -- in the monad if parsing fails. readInteger :: MonadError ShowS m => ByteString -> m Integer readInteger bs = case B.readInteger bs of Just (int,rest) | B.null rest -> return int _ -> throwError $ cat "Malformed integer " (esc maxIntegerLen bs) '.' where maxIntegerLen = 32 -- | Convert an IPv4 address in dotted-quad form to a 'HostAddress'. Return the -- result or 'throwError' in the monad if the format is invalid. inet_atoh :: MonadError ShowS m => ByteString -> m HostAddress inet_atoh bs | Right os@[_,_,_,_] <- mapM readInt $ B.split '.' bs , all (\o -> o .&. 0xff == o) os = return . L.foldl' (.|.) 0 . zipWith shiftL (map fromIntegral os) $ [24,16..] inet_atoh bs = throwError $ cat "Malformed IP address " (esc maxAddrLen bs) '.' where maxAddrLen = 15 -- | Convert an IPv6 address in RFC 4291 text form (e.g. @2001:db8::1@ or -- @::ffff:192.0.2.1@) to a 'HostAddress6'. Return the result or 'throwError' -- in the monad if the format is invalid. inet_atoh6 :: MonadError ShowS m => ByteString -> m HostAddress6 inet_atoh6 bs = maybe failure return $ do groups <- case B.breakSubstring (B.pack "::") bs of (front,rest) | B.null rest -> do gs <- parseGroups front guard $ length gs == 8 return gs | otherwise -> do let back = B.drop 2 rest guard . B.null . snd $ B.breakSubstring (B.pack "::") back fs <- if B.null front then return [] else parseGroups front bs' <- if B.null back then return [] else parseGroups back let missing = 8 - length fs - length bs' guard $ missing >= 1 return $ fs ++ replicate missing 0 ++ bs' case groups of [a,b,c,d,e,f,g,h] -> return (w a b, w c d, w e f, w g h) _ -> Nothing where failure = throwError $ cat "Malformed IPv6 address " (esc 45 bs) '.' w :: Word32 -> Word32 -> Word32 w hi lo = hi `shiftL` 16 .|. lo parseGroups s = do let parts = B.split ':' s (initParts,lastPart) <- unsnocList parts hexes <- mapM hexGroup initParts lastGroups <- case hush (inet_atoh lastPart) of Just v4 | B.elem '.' lastPart -> return [v4 `shiftR` 16, v4 .&. 0xffff] _ -> (:[]) `fmap` hexGroup lastPart return $ hexes ++ lastGroups hexGroup g = do guard $ not (B.null g) && B.length g <= 4 && B.all isHexDigit g return . L.foldl' (\acc c -> acc * 16 + fromIntegral (digitToInt c)) 0 $ B.unpack g unsnocList [] = Nothing unsnocList xs = Just (init xs, last xs) -- | Parse a UTCTime in this format: \"YYYY-MM-DD HH:MM:SS\". parseUTCTime :: MonadError ShowS m => ByteString -> m UTCTime parseUTCTime bs = do LocalTime day timeOfDay <- parseLocalTime bs return $! UTCTime day (timeOfDayToTime timeOfDay) -- | Parse a LocalTime in this format: \"YYYY-MM-DD HH:MM:SS\". parseLocalTime :: MonadError ShowS m => ByteString -> m LocalTime parseLocalTime bs | B.length bs == timeLen, [date,time] <- B.split ' ' bs = prependError (cat "Malformed time " (esc timeLen bs) ": ") $ do (year,month,day) <- triple =<< mapM readInt (B.split '-' date) (hour,minute,sec) <- triple =<< mapM readInt (B.split ':' time) when (month < 1 || month > 12 || day < 1 || day > 31 || hour < 0 || hour > 24 || minute < 0 || minute > 59 || sec < 0 || sec > 61) $ throwError $ cat "Failed sanity check." let diff = fromInteger . toInteger $ hour * 3600 + minute * 60 + sec return $! LocalTime (fromGregorian (toInteger year) month day) (timeToTimeOfDay diff) | otherwise = throwError $ cat "Malformed time " (esc timeLen bs) '.' where timeLen = 19 triple [x,y,z] = return (x, y, z) triple _ = throwError ("Wrong number of fields." ++) -- | Parse a quoted string with C-style escape sequences. Also return the -- remainder of the input string. 'throwError' in the monad if parsing fails. parseQuotedString :: MonadError ShowS m => ByteString -> m (ByteString, ByteString) parseQuotedString input = maybe (throwError ("Malformed quoted string." ++)) return $ do guard $ B.take 1 input == B.pack "\"" (content,rest) <- parseContent . B.span isText . B.drop 1 $ input guard $ B.take 1 rest == B.pack "\"" return (B.concat content, B.drop 1 rest) where parseContent (text,rest) | B.take 1 rest /= B.pack "\\" = return ([text], rest) | otherwise = do guard $ B.length rest >= 2 (char,escLen) <- case B.head (B.drop 1 rest) of '\\' -> return ('\\', 2) '"' -> return ('"', 2) '\'' -> return ('\'', 2) 'n' -> return ('\n', 2) 't' -> return ('\t', 2) 'r' -> return ('\r', 2) _ -> do guard $ B.length ds == 3 && B.all isOctal ds && n <= 0xff return (chr n, 4) where n = d1 * 8^2 + d2 * 8 + d3 [d1,d2,d3] = map (digitToInt . B.index ds) [0..2] ds = B.take 3 (B.drop 1 rest) isOctal x = 48 <= ord x && ord x <= 55 (parsed,unparsed) <- parseContent . B.span isText $ B.drop escLen rest return (text : B.singleton char : parsed, unparsed) isText x = isAscii x && isPrint x && x /= '\\' && x /= '"' -- | Prepend a string to any error message thrown by the given action. prependError :: MonadError ShowS m => ShowS -> m a -> m a prependError msg = handleError (throwError . (msg .)) -- | Substitute another error for an error thrown by the given action. replaceError :: MonadError e m => e -> m a -> m a replaceError e = handleError (const $ throwError e) -- | 'catchError' with the argument order reversed. handleError :: MonadError e m => (e -> m a) -> m a -> m a handleError = flip catchError -------------------------------------------------------------------------------- -- Show functions bshow :: (Show a) => a -> B.ByteString bshow = B.pack . show -------------------------------------------------------------------------------- -- Strict functions -- | Same as 'M.adjust', but the adjusting function is applied strictly. adjust' :: Ord k => (a -> a) -> k -> M.Map k a -> M.Map k a adjust' = M.update . ((Just $!) .) -- | Same as 'M.alter', but the new value is evaluated before being inserted. alter' :: Ord k => (Maybe a -> Maybe a) -> k -> M.Map k a -> M.Map k a alter' = M.alter . (maybe Nothing (Just $!) .) -- | Same as 'M.update', but the new value is evaluated before being inserted. update' :: Ord k => (a -> Maybe a) -> k -> M.Map k a -> M.Map k a update' = M.update . (maybe Nothing (Just $!) .) -- | Same as 'M.insert', but the new value is evaluated before being inserted. mapInsert' :: Ord k => k -> a -> M.Map k a -> M.Map k a mapInsert' k !x = M.insert k x -- | Same as 'modify', but the new state is evaluated before replacing the -- current state. modify' :: MonadState s m => (s -> s) -> m () modify' f = State.get >>= (State.put $!) . f -------------------------------------------------------------------------------- -- Miscellaneous functions -- | A useful combinator for applying a binary function to the result of -- applying a unary function to each of two arguments. on :: (b -> b -> c) -> (a -> b) -> a -> a -> c (f `on` g) x y = g x `f` g y -- | Like 'unfoldr', except the return value contains the final accumulator -- parameter. unfoldAccumR :: (acc -> Either (x, acc) acc) -> acc -> ([x], acc) unfoldAccumR f acc = case f acc of Left (x,acc') -> (x :) `first` unfoldAccumR f acc' Right acc' -> ([], acc') -- | Swap the elements of a pair. swap :: (a, b) -> (b, a) swap (x,y) = (y,x) -- | Partition the elements of a list into two separate lists corresponding to -- elements tagged 'Left' and 'Right'. partitionEither :: [Either a b] -> ([a], [b]) partitionEither [] = ([], []) partitionEither (Left x:xs) = (x :) `first` partitionEither xs partitionEither (Right x:xs) = (x :) `second` partitionEither xs -- | When the argument matches @Just x@, pass @x@ to a monadic action. whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust = flip . maybe . return $ () -- | Repeat an 'IO' action until a predicate is satisfied, collecting the -- results into a list. The predicate is evaluated before the 'IO' action. untilM :: Monad m => m Bool -> m a -> m [a] untilM p io = p >>= \p' -> if p' then return [] else liftM2 (:) io $ untilM p io -- | Like 'untilM', but ignoring the results of the 'IO' action. untilM_ :: Monad m => m Bool -> m a -> m () untilM_ p io = p >>= (`unless` (io >> untilM_ p io)) -- | Like 'untilM', but the predicate is not monadic. muntil :: Monad m => (a -> Bool) -> m a -> m [a] muntil p a = a >>= \a' -> if p a' then return [] else (a':) `liftM` muntil p a -- | Convert an IPv4 address to a 'String' in dotted-quad form. inet_htoa :: HostAddress -> String inet_htoa addr = concat . intersperse "." . map (show . (0xff .&.) . shiftR addr) $ [24,16..0] -- | Encode a 'ByteString' in base16. encodeBase16 :: ByteString -> ByteString encodeBase16 = B.pack . concat . B.foldr ((:) . toBase16 . B.c2w) [] where toBase16 x = map (intToDigit . fromIntegral) [x `shiftR` 4, x .&. 0xf] -- | Split a 'ByteString' into blocks of @x@ length. split :: Int -> ByteString -> [ByteString] split x = takeWhile (not . B.null) . map (B.take x) . iterate (B.drop x) -- | Deconstruct a 'ByteString' at the tail. unsnoc :: ByteString -> Maybe (ByteString, Char) unsnoc bs | B.null bs = Nothing | otherwise = Just (B.init bs, B.last bs) -- | Try an action, catching every exception except asynchronous ones (see -- 'syncExceptions'). trySync :: IO a -> IO (Either E.SomeException a) trySync = E.tryJust syncExceptions -- | Like 'E.bracket', but if cleanup re-throws while handling a throw, don't -- eat the original exception. bracket' :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket' before after act = E.mask $ \restore -> do a <- before r <- restore (act a) `E.onException` trySync (after a) _ <- after a return r -- | Like 'E.finally', but if cleanup re-throws while handling a throw, don't -- eat the original exception. finally' :: IO a -> IO b -> IO a finally' act after = bracket' (return ()) (const after) (const act) -- | Like 'E.bracketOnError', but if cleanup re-throws while handling a throw, -- don't eat the original exception. bracketOnError' :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracketOnError' before after act = E.mask $ \restore -> do a <- before restore (act a) `E.onException` trySync (after a) -- | Like 'E.onException' onException' :: IO a -> IO b -> IO a onException' io act = io `E.catch` \e -> trySync act >> E.throwIO (e :: E.SomeException) -- | A predicate matching exceptions that aren't asynchronous. -- -- Strictly speaking, the type of an exception doesn't say how it was thrown, -- but by convention (since base 4.7) exceptions meant to be thrown to other -- threads are wrapped in 'E.SomeAsyncException': 'E.ThreadKilled' and -- 'E.UserInterrupt' ('E.AsyncException') and the exception of -- 'System.Timeout.timeout'. Those must never be swallowed. (This replaces -- matching on @show e == \"<>\"@; the result is the same.) -- -- The exit signals of "TorDNSEL.Control.Concurrent.Link" are ordinary -- exceptions, so they still count as synchronous here, as before. syncExceptions :: E.SomeException -> Maybe E.SomeException syncExceptions e | Just (_ :: E.SomeAsyncException) <- E.fromException e = Nothing | otherwise = Just e -- | Print a usage message to the given handle and exit with the given code. exitUsage :: Handle -> ExitCode -> IO a exitUsage handle exitCode = do progName <- getProgName hCat handle "Usage: " progName " [-f ] [options...]\n" exitWith exitCode -- | Is an integral value inside the bounds of another integral type? -- Unchecked precondition: @b@ is a subset of @a@. inBoundsOf :: (Integral a, Integral b, Bounded b) => a -> b -> Bool x `inBoundsOf` y = x >= fromIntegral (minBound `asTypeOf` y) && x <= fromIntegral (maxBound `asTypeOf` y) instance Show ShowS where showsPrec _ s = shows (s "") -- | Discard the error message of a failed computation. hush :: Either e a -> Maybe a hush = either (const Nothing) Just foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32 foreign import ccall unsafe "ntohl" ntohl :: Word32 -> Word32 -- | Convert a 'UTCTime' to a string in ISO 8601 format. showUTCTime :: UTCTime -> String showUTCTime time = printf "%s %02d:%02d:%s" date hours mins secStr' where date = show (utctDay time) (n,d) = (numerator &&& denominator) (toRational $ utctDayTime time) (seconds,frac) = n `divMod` d (hours,(mins,sec)) = second (`divMod` 60) (seconds `divMod` (60^2)) secs = fromRational (frac % d) + fromIntegral sec secStr = printf "%02.4f" (secs :: Double) secStr' = (if length secStr < 7 then ('0':) else id) secStr -------------------------------------------------------------------------------- -- Conduit utilities -- | 'CB.take' for strict 'ByteString's. c_take :: Monad m => Int -> ConduitT ByteString o m ByteString c_take = fmap (mconcat . BL.toChunks) . CB.take -- | Read until the delimiter and return the parts before and after, not -- including delimiter. c_breakDelim :: Monad m => ByteString -> ConduitT ByteString o m (Maybe (ByteString, ByteString)) c_breakDelim delim = wait_input $ B.empty where wait_input front = C.await >>= (Nothing <$ C.leftover front) `maybe` \bs -> let (front', bs') = (<> bs) `second` B.splitAt (B.length front - d_len + 1) front in case B.breakSubstring delim bs' of (part, rest) | B.null rest -> wait_input $ front' <> bs' | otherwise -> return $ Just (front' <> part, B.drop d_len rest) d_len = B.length delim -- | Take a CRLF-delimited line from the input. c_line_crlf :: Monad m => ConduitT ByteString o m ByteString c_line_crlf = c_breakDelim (B.pack "\r\n") >>= return B.empty `maybe` \(line, rest) -> line <$ C.leftover rest -- | Stream lines delimited by either LF or CRLF. c_lines_any :: Monad m => ConduitT ByteString ByteString m () c_lines_any = CB.lines C..| CL.map strip where strip bs = case unsnoc bs of Just (bs', '\r') -> bs' _ -> bs -------------------------------------------------------------------------------- -- Network functions -- | Close a socket. (Called @sClose@ in network < 2.4.) closeSocket :: Socket -> IO () closeSocket = close -- | Open a new UDP socket and bind it to the given 'SockAddr'. bindUDPSocket :: SockAddr -> IO Socket bindUDPSocket sockAddr = E.bracketOnError (socket (sockAddrFamily sockAddr) Datagram udpProtoNum) close $ \sock -> do setSocketOption sock ReuseAddr 1 setV6Only sockAddr sock bind sock sockAddr return sock -- | Open a new TCP socket, bind it to the given 'SockAddr', then pass it to -- 'listen'. bindListeningTCPSocket :: SockAddr -> IO Socket bindListeningTCPSocket sockAddr = do E.bracketOnError (socket (sockAddrFamily sockAddr) Stream tcpProtoNum) close $ \sock -> do setSocketOption sock ReuseAddr 1 setV6Only sockAddr sock bind sock sockAddr listen sock maxListenQueue return sock -- | Open a listening Unix domain stream socket at @sockPath@, unlinking it -- first if it exists, then setting it to the given mode. bindListeningUnixDomainStreamSocket :: FilePath -> FileMode -> IO Socket bindListeningUnixDomainStreamSocket sockPath mode = do sockExists <- doesFileExist sockPath when sockExists $ removeFile sockPath E.bracketOnError (socket AF_UNIX Stream 0) close $ \sock -> do bind sock $ SockAddrUnix sockPath setFileMode sockPath mode listen sock maxListenQueue return sock -- | Open a stream socket connected to the given address: TCP over IPv4 or -- IPv6, or a Unix domain socket (as Tor's ControlSocket and @SocksPort -- unix:@ offer). connectStreamSocket :: SockAddr -> IO Socket connectStreamSocket addr = E.bracketOnError (socket (sockAddrFamily addr) Stream defaultProtocol) close $ \sock -> connect sock addr >> return sock -- | The address family of a 'SockAddr'. sockAddrFamily :: SockAddr -> Family sockAddrFamily SockAddrInet{} = AF_INET sockAddrFamily SockAddrInet6{} = AF_INET6 sockAddrFamily SockAddrUnix{} = AF_UNIX -- | Restrict IPv6 sockets to IPv6 traffic so that an IPv4 and an IPv6 -- listener can be bound to the same port. setV6Only :: SockAddr -> Socket -> IO () setV6Only SockAddrInet6{} sock = setSocketOption sock IPv6Only 1 setV6Only _ _ = return () -------------------------------------------------------------------------------- -- Addresses -- | An IP address or domain name. data Address = IPv4Addr HostAddress | Addr ByteString instance Show Address where show (IPv4Addr addr) = inet_htoa addr show (Addr addr) = B.unpack addr -- | Show an 'Address' as text. showAddress :: Address -> ByteString showAddress (IPv4Addr addr) = B.pack $ inet_htoa addr showAddress (Addr addr) = addr -- | Parse an 'Address'. readAddress :: ByteString -> Address readAddress bs | Right addr <- inet_atoh bs = IPv4Addr addr | otherwise = Addr bs -------------------------------------------------------------------------------- -- Ports -- | A TCP or UDP port. newtype Port = Port { unPort :: Word16 } deriving (Eq, Ord, Bounded, Num, Real, Enum, Integral) instance Show Port where show (Port port) = show port instance Binary Port where get = Port `fmap` get put = put . unPort -- | Parse a port, returning the result or 'throwError' in the monad if parsing -- fails. parsePort :: MonadError ShowS m => ByteString -> m Port parsePort bs = do (port,int) <- replaceError (cat "Malformed port " (esc maxPortLen bs) '.') ((fromIntegral &&& id) `liftM` readInt bs) unless (int `inBoundsOf` port) $ throwError $ cat "Port " int " is out of range." return port where maxPortLen = 5 -------------------------------------------------------------------------------- -- Escaped strings -- | A string with non-printable characters escaped. data EscapedString = Escaped { escaped :: B.ByteString, unescLen :: Int } instance Show EscapedString where show = B.unpack . escaped -- | Replace non-printable characters with standard Haskell escape sequences. escape :: ByteString -> EscapedString escape = uncurry Escaped . (B.concat . build &&& B.length) where build bs | B.null bs = [] | B.null unescd = [escd] | otherwise = escd : escape' unescd : build rest where (escd,(unescd,rest)) = B.span isControl `second` B.span isPrint bs escape' = B.pack . flip (L.foldl' (.) id) "" . map showLitChar . B.unpack -- | Quote an 'EscapedString', truncating it if its escaped length exceeds -- @maxLen@. When truncated, append a \"[truncated, n total bytes]\" message -- after the end quote. showEscaped :: Int -> EscapedString -> ShowS showEscaped maxLen (Escaped s len) | B.length s > maxLen = cat '"' (B.take maxLen s) '"' "[truncated, " len " total bytes]" | otherwise = cat '"' s '"' -- | Show a quoted and escaped 'ByteString', truncating it to the given length -- if necessary. esc :: Int -> ByteString -> ShowS esc maxLen = showEscaped maxLen . escape -------------------------------------------------------------------------------- -- Constants tcpProtoNum, udpProtoNum :: ProtocolNumber tcpProtoNum = #{const IPPROTO_TCP} udpProtoNum = #{const IPPROTO_UDP} -------------------------------------------------------------------------------- -- Variable-parameter string concatenation -- | The type of an argument to 'cat'. class CatArg a where -- | Convert a 'CatArg' to a string for constant-time concatenation. showsCatArg :: a -> ShowS instance {-# OVERLAPPING #-} CatArg String where showsCatArg = (++) instance {-# OVERLAPPING #-} CatArg ShowS where showsCatArg = id instance {-# OVERLAPPING #-} CatArg Char where showsCatArg = (:) instance {-# OVERLAPPING #-} CatArg ByteString where showsCatArg = (++) . B.unpack instance {-# OVERLAPPABLE #-} Show a => CatArg a where showsCatArg = shows -- | Implements the variable parameter support for 'cat'. class CatType r where cat' :: CatArg a => ShowS -> a -> r instance CatType (IO a) where cat' str arg = putStr (cat' str arg) >> return undefined instance CatType String where cat' str arg = cat' str arg "" instance {-# OVERLAPPING #-} CatType ShowS where cat' str arg = str . showsCatArg arg instance CatType ByteString where cat' str arg = B.pack (cat' str arg) instance {-# OVERLAPPABLE #-} (CatArg a, CatType r) => CatType (a -> r) where cat' str arg = cat' (cat' str arg) -- | Concatentate a variable number of parameters that can be converted to -- strings. cat :: (CatArg a, CatType r) => a -> r cat = cat' id -- | Implements the variable parameter support for 'hCat'. class HCatType r where hCat' :: CatArg a => ShowS -> Handle -> a -> r instance HCatType (IO a) where hCat' str handle arg = hPutStr handle (cat' str arg) >> return undefined instance (CatArg a, HCatType r) => HCatType (a -> r) where hCat' str handle arg = hCat' (cat' str arg) handle -- | Concatentate and output to a 'Handle' a variable number of parameters that -- can be converted to strings. hCat :: (CatArg a, HCatType r) => Handle -> a -> r hCat = hCat' id mhatta-tordnsel-1d9141b/src/TorDNSEL/Web.hs000066400000000000000000000011621527317632400203530ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Web -- License : Public domain (see LICENSE) -- -- Maintainer : Masayuki Hatta -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions) -- -- The web interface, providing the same data as the DNS interface over HTTP. -- ----------------------------------------------------------------------------- module TorDNSEL.Web ( WebConfig(..) , WebServer , startWebServer , reconfigureWebServer , terminateWebServer ) where import TorDNSEL.Web.Internals mhatta-tordnsel-1d9141b/src/TorDNSEL/Web/000077500000000000000000000000001527317632400200175ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/src/TorDNSEL/Web/Internals.hs000066400000000000000000000670571527317632400223310ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Web.Internals -- License : Public domain (see LICENSE) -- -- Maintainer : Masayuki Hatta -- Stability : alpha -- Portability : non-portable (concurrency, extended exceptions) -- -- /Internals/: should only be imported by the public module and tests. -- -- The web interface. @doc/torel-design.md@ says it \"should provide the same -- data as the dns interface\", so each DNS query type has an HTTP equivalent -- returning JSON, and the exit list can also be fetched in bulk: -- -- [@GET \/api\/v1\/ip-port?ip=IP1&port=PORT&dest=IP2@] -- Query type 1: is IP1 a Tor exit that permits connections to PORT on IP2? -- -- [@GET \/api\/v1\/list?ip=IP&list=NAME@] -- Query type 2: is IP a Tor exit that permits connections to any member of -- the configured list NAME? (@GET \/api\/v1\/lists@ shows the lists.) -- -- [@GET \/api\/v1\/me?ip=IP&port=PORT@] -- Query type 3: is IP a Tor exit that permits connections to PORT on the -- host making this HTTP request? -- -- [@GET \/api\/v1\/exit?ip=IP@] -- Is IP a Tor exit at all, and which relays exit from it? The same as the -- DNS query @{IP}.{zone}@ (and the Tor Project's exit list service). -- -- [@GET \/api\/ip@] -- Is the host making this request connecting from a Tor exit (that permits -- connections to this web server)? The JSON has the same shape as the one -- returned by check.torproject.org's @\/api\/ip@. -- -- [@GET \/torbulkexitlist?ip=IP&port=PORT@] -- The addresses of all Tor exits permitting connections to IP:PORT, one per -- line, compatible with check.torproject.org's @\/torbulkexitlist@. Without -- parameters, every address from which some Tor exit may exit is listed. -- -- [@GET \/exit-addresses@] -- The results of our active exit tests, in the @exit-addresses@ format. -- -- The server is deliberately small: HTTP\/1.1 with one request per -- connection, @GET@ and @HEAD@ only. Put a reverse proxy in front of it if you -- need TLS. -- ----------------------------------------------------------------------------- -- #not-home module TorDNSEL.Web.Internals ( -- * Server WebConfig(..) , WebServer(..) , WebMessage(..) , startWebServer , reconfigureWebServer , terminateWebServer -- * Requests and responses , Request(..) , Response(..) , parseRequest , renderResponse , handleRequest , metricsResponse , clientAddress , urlDecode , JSON(..) , renderJSON ) where import Prelude hiding (log) import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem) import qualified Control.Exception as E import Control.Monad (when, forever, unless, join) import Control.Monad.Fix (fix) import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import Data.Char (chr, digitToInt, isHexDigit, toLower, toUpper, isDigit) import qualified Data.Map as M import Data.Maybe (isJust, isNothing, mapMaybe) import qualified Data.Set as S import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Network.Socket (Socket, SockAddr(..), HostAddress, HostAddress6, accept, getSocketName) import Network.Socket.ByteString (recv, sendAll) import System.Timeout (timeout) import TorDNSEL.AddressPattern import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Util import TorDNSEL.Directory (encodeBase16RouterID) import TorDNSEL.ExitList import TorDNSEL.Log import TorDNSEL.NetworkState import TorDNSEL.NetworkState.Storage (mkExitAddress, renderExitAddress) import TorDNSEL.NetworkState.Types import TorDNSEL.Util -------------------------------------------------------------------------------- -- Server -- | The web interface configuration. data WebConfig = WebConfig { -- | The listening HTTP socket. webSocket :: !Socket -- | Operator-configured lists of destinations for \"list\" queries. , webLists :: !NamedLists -- | The address and port at which clients reach us, if it differs from -- the address we're listening on. Used by @\/api\/ip@. , webPublicAddress :: !(Maybe (HostAddress, Port)) -- | Count requests for statistics. , webRequestStats :: !(IO ()) -- | Reverse proxies whose X-Forwarded-For headers we believe. , webTrustedProxies :: ![AddressPattern] -- | Clients allowed to fetch @\/metrics@ (none: it doesn't exist). , webMetricsAllowFrom :: ![AddressPattern] -- | Render the metrics. , webMetrics :: !(IO ByteString) } instance Eq WebConfig where x == y = webSocket x == webSocket y && webLists x == webLists y && webPublicAddress x == webPublicAddress y && webTrustedProxies x == webTrustedProxies y && webMetricsAllowFrom x == webMetricsAllowFrom y -- | A handle to the web server thread. data WebServer = WebServer (WebMessage -> IO ()) ThreadId instance Thread WebServer where threadId (WebServer _ tid) = tid -- | Messages the web server thread can receive. data WebMessage = NewClient Socket SockAddr -- ^ A new client has connected. | Reconfigure (WebConfig -> WebConfig) (IO ()) -- ^ Reconfigure the server. | Terminate ExitReason -- ^ Terminate the server gracefully. | Exit ThreadId ExitReason -- ^ An exit signal sent to the server. -- | The server's state. data WebState = WebState { webConf :: !WebConfig , listenerTid :: !ThreadId -- | Running handlers and the client each one serves. , handlers :: !(M.Map ThreadId ClientKey) -- | How many handlers each client has. , perClient :: !(M.Map ClientKey Int) -- | Listener threads we killed ourselves, whose exit signals we ignore. , deadListeners :: !(S.Set ThreadId) , terminateReason :: !(Maybe ExitReason) } -- | Start the web server with an initial config, returning a handle to it. -- Link the server thread to the calling thread. startWebServer :: WebConfig -> IO WebServer startWebServer initConf = do log Info "Starting web server." chan <- newMsgChan sem <- newQSem maxHandlers tid <- forkLinkIO $ do setTrapExit $ (writeMsgChan chan .) . Exit initListener <- forkListener chan sem (webSocket initConf) flip fix (WebState initConf initListener M.empty M.empty S.empty Nothing) $ \loop (!s) -> do message <- readMsgChan chan case message of NewClient client _ -- Accepted before we were told to terminate; don't serve it. | isJust (terminateReason s) -> do closeSocket client `E.finally` signalQSem sem loop s NewClient client addr -- One client may not take all the handlers (except a reverse proxy -- we trust, which speaks for many). | not (trusted addr) , M.findWithDefault 0 key (perClient s) >= maxPerClient -> do log Debug "Web client " addr " has too many connections." closeSocket client `E.finally` signalQSem sem loop s | otherwise -> do let conf = webConf s handler <- forkLinkIO . (`E.finally` signalQSem sem) . (`E.finally` closeSocket client) $ do webRequestStats conf r <- E.try . timeout handlerTimeout $ serveClient conf client addr case r of Left (e :: E.IOException) -> log Debug "Error serving web client " addr ": " e Right Nothing -> log Debug "Web client " addr " timed out." Right _ -> return () loop s { handlers = M.insert handler key (handlers s) , perClient = M.insertWith (+) key 1 (perClient s) } where key = clientKey addr trusted = maybe False (matchesAny (webTrustedProxies (webConf s))) . hostAddressOf Reconfigure reconf signal -> do let newConf = reconf (webConf s) when (newConf /= webConf s) $ log Notice "Reconfiguring web server." if webSocket newConf /= webSocket (webConf s) then do terminateThread Nothing (listenerTid s) (killThread $ listenerTid s) closeSocket . webSocket $ webConf s newListener <- forkListener chan sem (webSocket newConf) signal loop s { webConf = newConf, listenerTid = newListener , deadListeners = S.insert (listenerTid s) (deadListeners s) } else signal >> loop s { webConf = newConf } Terminate reason -> do log Info "Terminating web server." terminateThread Nothing (listenerTid s) (killThread $ listenerTid s) if M.null (handlers s) then do pending <- drainMsgChan chan sequence_ [closeSocket c | NewClient c _ <- pending] exit reason -- Wait for the handlers' exit signals. They may already be -- queued behind this message, so don't drain the channel: that -- would lose them and leave us waiting forever. Clients queued -- meanwhile are closed as their messages arrive. else loop s { terminateReason = Just reason } Exit t reason | t == listenerTid s -> if isNothing (terminateReason s) then do log Warn "The web listener thread exited unexpectedly: " (show reason) "; restarting." newListener <- forkListener chan sem (webSocket $ webConf s) loop s { listenerTid = newListener } else loop s | t `S.member` deadListeners s -> loop s { deadListeners = S.delete t (deadListeners s) } | Just key <- M.lookup t (handlers s) -> do let remaining = M.delete t (handlers s) perClient' = M.update (\n -> if n <= 1 then Nothing else Just (n - 1)) key (perClient s) case terminateReason s of Just r | M.null remaining -> exit r _ -> loop s { handlers = remaining, perClient = perClient' } | isAbnormal reason -> exit reason | otherwise -> loop s return $ WebServer (writeMsgChan chan) tid where maxHandlers = 64 maxPerClient = 8 handlerTimeout = 10 * 10^(6 :: Int) -- | Who a client is, for limiting connections per client: its IP address. data ClientKey = Client4 !HostAddress | Client6 !HostAddress6 | OtherClient deriving (Eq, Ord) clientKey :: SockAddr -> ClientKey clientKey (SockAddrInet _ a) = Client4 a clientKey (SockAddrInet6 _ _ (0, 0, 0xffff, a) _) = Client4 (htonl a) clientKey (SockAddrInet6 _ _ a _) = Client6 a clientKey _ = OtherClient -- | Fork the thread accepting connections on the listening socket. forkListener :: MsgChan WebMessage -> QSem -> Socket -> IO ThreadId forkListener chan sem sock = forkLinkIO $ E.mask $ \restore -> forever $ do waitQSem sem (client,addr) <- restore (accept sock) `E.onException` signalQSem sem writeMsgChan chan $ NewClient client addr -- | Reconfigure the web server synchronously with the given function. If the -- server exits abnormally before reconfiguring itself, throw its exit signal -- in the calling thread. reconfigureWebServer :: (WebConfig -> WebConfig) -> WebServer -> IO () reconfigureWebServer reconf (WebServer send tid) = sendSyncMessage (send . Reconfigure reconf) tid -- | Terminate the web server gracefully. The optional parameter specifies the -- amount of time in microseconds to wait for the thread to terminate. If the -- thread hasn't terminated by the timeout, an uncatchable exit signal will be -- sent. terminateWebServer :: Maybe Int -> WebServer -> IO () terminateWebServer mbWait (WebServer send tid) = terminateThread mbWait tid (send $ Terminate NormalExit) -- | Read a request from a client, answer it, and close the connection. The -- request head must arrive within 'headTimeout'. serveClient :: WebConfig -> Socket -> SockAddr -> IO () serveClient conf client clientAddr = do raw <- fmap join . timeout headTimeout $ readRequestHead client response <- case raw >>= parseRequest of Nothing -> return $ errorResponse 400 "Bad Request" "malformed request" Just req | reqPath req == B.pack "/metrics" -> metricsResponse conf clientAddr req | otherwise -> do localAddr <- getSocketName client now <- getPOSIXTime ns <- readNetworkState return $ handleRequest conf now ns clientAddr localAddr req sendAll client $ renderResponse response -- | Answer a request for @\/metrics@: Prometheus metrics, for the clients in -- 'webMetricsAllowFrom' (judged by 'clientAddress', so a trusted reverse -- proxy's clients are judged by their own address), and \"404 Not Found\" -- for anyone else, as if there were no such thing. metricsResponse :: WebConfig -> SockAddr -> Request -> IO Response metricsResponse conf peer req | reqMethod req `notElem` [B.pack "GET", B.pack "HEAD"] = return (errorResponse 405 "Method Not Allowed" "only GET and HEAD are supported") { respHeaders = [ (B.pack "Allow", B.pack "GET, HEAD") , contentType "application/json" ] } | maybe False (matchesAny (webMetricsAllowFrom conf)) . hostAddressOf $ clientAddress (webTrustedProxies conf) peer req = do body <- webMetrics conf return $ Response 200 (B.pack "OK") [ contentType "text/plain; version=0.0.4; charset=utf-8" , (B.pack "Cache-Control", B.pack "no-store") ] body (reqMethod req == B.pack "HEAD") | otherwise = return $ errorResponse 404 "Not Found" "no such resource" -- | How long, in microseconds, a client may take to send its request. headTimeout :: Int headTimeout = 3 * 10^(6 :: Int) -- | Read the request line and headers, up to a limit. readRequestHead :: Socket -> IO (Maybe ByteString) readRequestHead sock = go B.empty where go acc | B.length acc > maxHeadLen = return Nothing | (front,rest) <- B.breakSubstring (B.pack "\r\n\r\n") acc , not (B.null rest) = return (Just front) | otherwise = do chunk <- recv sock 4096 if B.null chunk then return Nothing else go (acc `B.append` chunk) maxHeadLen = 8192 -------------------------------------------------------------------------------- -- Requests and responses -- | An HTTP request. data Request = Request { reqMethod :: !ByteString -- ^ The method, e.g. @GET@. , reqPath :: !ByteString -- ^ The decoded path. , reqQuery :: ![(ByteString, ByteString)] -- ^ Decoded query parameters. -- | Header fields, names in lower case, in order. , reqHeaders :: ![(ByteString, ByteString)] } deriving (Eq, Show) -- | An HTTP response. data Response = Response { respStatus :: !Int , respReason :: !ByteString , respHeaders :: ![(ByteString, ByteString)] , respBody :: !ByteString , respHead :: !Bool -- ^ Omit the body (a response to @HEAD@). } deriving (Eq, Show) -- | Parse the head of an HTTP request: the request line and the header -- fields. Header lines without a colon are ignored. parseRequest :: ByteString -> Maybe Request parseRequest raw = case B.words requestLine of [method, target, version] | B.pack "HTTP/1." `B.isPrefixOf` version , B.pack "/" `B.isPrefixOf` target -> do let (path,query) = B.break (== '?') target path' <- urlDecode False path params <- mapM param . filter (not . B.null) . B.split '&' $ B.drop 1 query return $ Request method path' params headers _ -> Nothing where requestLine : headerLines = map (B.takeWhile (/= '\r')) (B.lines raw) ++ [B.empty | B.null raw] headers = [ (B.map toLower name, trim (B.drop 1 value)) | line <- headerLines , let (name, value) = B.break (== ':') line , not (B.null value), not (B.null name) ] trim = B.dropWhile isSpaceC . fst . B.spanEnd isSpaceC isSpaceC c = c == ' ' || c == '\t' param p = do let (k,v) = B.break (== '=') p k' <- urlDecode True k v' <- urlDecode True (B.drop 1 v) return (k', v') -- | Decode percent-encoded octets; with the flag set, also decode @+@ as a -- space (as in query strings). urlDecode :: Bool -> ByteString -> Maybe ByteString urlDecode plusIsSpace = fmap B.pack . go . B.unpack where go ('%':a:b:rest) | isHexDigit a && isHexDigit b = (chr (digitToInt a * 16 + digitToInt b) :) `fmap` go rest go ('%':_) = Nothing go ('+':rest) | plusIsSpace = (' ' :) `fmap` go rest go (c:rest) = (c :) `fmap` go rest go [] = Just [] -- | Serialise a response, closing the connection afterwards. renderResponse :: Response -> ByteString renderResponse r = B.concat $ [ B.pack "HTTP/1.1 ", B.pack (show $ respStatus r), B.pack " " , respReason r, crlf ] ++ concat [ [k, B.pack ": ", v, crlf] | (k,v) <- headers ] ++ [ crlf ] ++ [ respBody r | not (respHead r) ] where crlf = B.pack "\r\n" headers = respHeaders r ++ [ (B.pack "Content-Length", B.pack . show . B.length $ respBody r) , (B.pack "Connection", B.pack "close") , (B.pack "Server", B.pack "TorDNSEL") ] -- | A minimal JSON value. data JSON = JString ByteString | JNumber Integer | JBool Bool | JNull | JArray [JSON] | JObject [(ByteString, JSON)] deriving (Eq, Show) -- | Render a JSON value. renderJSON :: JSON -> ByteString renderJSON = B.concat . go where go (JString s) = [quote s] go (JNumber n) = [B.pack $ show n] go (JBool b) = [B.pack $ if b then "true" else "false"] go JNull = [B.pack "null"] go (JArray xs) = [B.pack "["] ++ commaSep (map go xs) ++ [B.pack "]"] go (JObject kvs) = [B.pack "{"] ++ commaSep [quote k : B.pack ":" : go v | (k,v) <- kvs] ++ [B.pack "}"] commaSep = concat . sepBy [B.pack ","] sepBy _ [] = [] sepBy _ [x] = [x] sepBy s (x:xs) = x : s : sepBy s xs quote s = B.concat [B.pack "\"", B.concatMap escapeChar s, B.pack "\""] escapeChar c | c == '"' = B.pack "\\\"" | c == '\\' = B.pack "\\\\" | c < ' ' || c == '\DEL' = B.pack $ "\\u00" ++ [hexDigit (fromEnum c `div` 16), hexDigit (fromEnum c `mod` 16)] | otherwise = B.singleton c hexDigit n = "0123456789abcdef" !! n -- | Answer a request given the current time and network state, the address -- of the client and the local address of the connection. handleRequest :: WebConfig -> POSIXTime -> NetworkState -> SockAddr -> SockAddr -> Request -> Response handleRequest conf now ns peerAddr localAddr req | method `notElem` [B.pack "GET", B.pack "HEAD"] = (errorResponse 405 "Method Not Allowed" "only GET and HEAD are supported") { respHeaders = [ (B.pack "Allow", B.pack "GET, HEAD") , contentType "application/json" ] } | otherwise = (route $ B.unpack path) { respHead = method == B.pack "HEAD" } where method = reqMethod req path = reqPath req clientAddr = clientAddress (webTrustedProxies conf) peerAddr req params = reqQuery req lists = webLists conf route "/" = textResponse 200 cacheLong helpText route "/api/v1/ip-port" = either badRequest id $ do qAddr <- addrParam "ip" dAddr <- addrParam "dest" port <- portParam "port" return . jsonResponse cacheLong $ JObject [ (B.pack "query", JString $ B.pack "ip-port") , (B.pack "ip", showAddr qAddr) , (B.pack "dest", showAddr dAddr) , (B.pack "port", JNumber $ toInteger port) , (B.pack "listed", JBool $ listed qAddr (DestAddrPort dAddr port)) ] route "/api/v1/list" = either badRequest id $ do qAddr <- addrParam "ip" name <- B.map toLower `fmap` textParam "list" case M.lookup name lists of Nothing -> Left (404, B.pack "Not Found", B.pack "no such list") Just pats -> return . jsonResponse cacheLong $ JObject [ (B.pack "query", JString $ B.pack "list") , (B.pack "ip", showAddr qAddr) , (B.pack "list", JString name) , (B.pack "listed", JBool $ listed qAddr (DestAnyOf pats)) ] route "/api/v1/lists" = jsonResponse cacheLong $ JObject [ (name, JArray [JString . B.pack $ showAddrPortPattern p | p <- pats]) | (name,pats) <- M.toAscList lists ] route "/api/v1/me" = either badRequest id $ do qAddr <- addrParam "ip" port <- portParam "port" let isListed = maybe False (\a -> listed qAddr (DestAddrPort a port)) (ipv4Of clientAddr) return . jsonResponse noCache $ JObject [ (B.pack "query", JString $ B.pack "me") , (B.pack "ip", showAddr qAddr) , (B.pack "dest", maybe JNull showAddr (ipv4Of clientAddr)) , (B.pack "port", JNumber $ toInteger port) , (B.pack "listed", JBool isListed) ] route "/api/v1/exit" = either badRequest id $ do qAddr <- addrParam "ip" let fps = exitFingerprints now ns qAddr anyDestination return . jsonResponse cacheLong $ JObject [ (B.pack "query", JString $ B.pack "exit") , (B.pack "ip", showAddr qAddr) , (B.pack "listed", JBool $ qAddr == 0x7f000002 || not (null fps)) , (B.pack "fingerprints", JArray [JString . B.map toUpper $ encodeBase16RouterID fp | fp <- fps]) ] route "/api/ip" = let isTor = case (ipv4Of clientAddr, publicAddr) of (Just c, Just (a,p)) -> listed' c (DestAddrPort a p) _ -> False in jsonResponse noCache $ JObject [ (B.pack "IsTor", JBool isTor) , (B.pack "IP", JString . B.pack $ showSockAddrHost clientAddr) ] route "/torbulkexitlist" = either badRequest id $ do dest <- case lookup (B.pack "ip") params of Nothing -> return anyDestination Just _ -> do dAddr <- addrParam "ip" port <- case lookup (B.pack "port") params of Nothing -> return 80 Just _ -> portParam "port" return $ DestAddrPort dAddr port return . textResponse 200 cacheLong . B.unlines . map (B.pack . inet_htoa) $ exitAddressesTo now ns dest route "/exit-addresses" = textResponse 200 cacheLong . B.concat . map renderExitAddress . mapMaybe mkExitAddress . M.toList $ nsRouters ns route _ = errorResponse 404 "Not Found" "no such resource" listed a dest = a == 0x7f000002 || listed' a dest listed' a = isExitTo now ns a publicAddr = case webPublicAddress conf of Just ap -> Just ap Nothing -> case localAddr of SockAddrInet p a -> Just (ntohl a, fromIntegral p) _ -> Nothing textParam k = case lookup (B.pack k) params of Just v | not (B.null v) -> Right v _ -> Left (400, B.pack "Bad Request", B.pack $ "missing parameter \"" ++ k ++ "\"") addrParam k = do v <- textParam k either (const $ Left (400, B.pack "Bad Request", B.pack $ "parameter \"" ++ k ++ "\" must be an \ \IPv4 address")) Right (inet_atoh v) portParam k = do v <- textParam k unless (B.all isDigit v && B.length v <= 5) $ portError k either (const $ portError k) Right (parsePort v) portError k = Left (400, B.pack "Bad Request", B.pack $ "parameter \"" ++ k ++ "\" must be a port") badRequest (code,reason,msg) = errorResponse code (B.unpack reason) (B.unpack msg) showAddr = JString . B.pack . inet_htoa cacheLong = B.pack "public, max-age=1800" noCache = B.pack "no-store" helpText = B.unlines $ map B.pack [ "TorDNSEL: a Tor DNS-based exit list." , "" , "This server answers, over DNS and HTTP, the question \"which Tor exit" , "nodes will connect to me?\" (see doc/torel-design.md)." , "" , " GET /api/v1/ip-port?ip=IP1&port=PORT&dest=IP2" , " Is IP1 a Tor exit permitting connections to IP2:PORT?" , " GET /api/v1/list?ip=IP&list=NAME" , " Is IP a Tor exit permitting connections to a member of list NAME?" , " GET /api/v1/lists" , " The configured lists." , " GET /api/v1/me?ip=IP&port=PORT" , " Is IP a Tor exit permitting connections to PORT on your host?" , " GET /api/v1/exit?ip=IP" , " Is IP a Tor exit, and which relays exit from it?" , " GET /api/ip" , " Are you connecting from a Tor exit?" , " GET /torbulkexitlist[?ip=IP[&port=PORT]]" , " All Tor exit addresses (permitting connections to IP:PORT)." , " GET /exit-addresses" , " Results of active exit tests." ] -- | The address of the client a request is from. That's the address of the -- connection, unless it comes from a reverse proxy we trust: then it's the -- last address in X-Forwarded-For that isn't one of those proxies (each proxy -- appends the address it got the request from, and only the ones we trust -- can be believed). If the header is missing or malformed, it's the proxy. clientAddress :: [AddressPattern] -> SockAddr -> Request -> SockAddr clientAddress trusted peer req | Just peerHost <- hostAddressOf peer, matchesAny trusted peerHost , not (null forwarded) = case mapM parseHost (reverse forwarded) of Nothing -> peer Just hosts -> case dropWhile (matchesAny trusted) hosts of h : _ -> toSockAddr h [] -> toSockAddr (last hosts) | otherwise = peer where forwarded = [ entry | (name, value) <- reqHeaders req , name == B.pack "x-forwarded-for" , entry <- map trim (B.split ',' value) , not (B.null entry) ] trim = B.dropWhile (== ' ') . fst . B.spanEnd (== ' ') parseHost e | Right a <- inet_atoh e = Just (Host4 a) | Right a <- inet_atoh6 (unbracket e) = Just (Host6 a) | otherwise = Nothing unbracket e | B.pack "[" `B.isPrefixOf` e = B.takeWhile (/= ']') (B.drop 1 e) | otherwise = e toSockAddr (Host4 a) = SockAddrInet 0 (htonl a) toSockAddr (Host6 a) = SockAddrInet6 0 0 a 0 -- | The IPv4 address of a socket address, if it has one. ipv4Of :: SockAddr -> Maybe HostAddress ipv4Of (SockAddrInet _ a) = Just (ntohl a) ipv4Of (SockAddrInet6 _ _ (0, 0, 0xffff, a) _) = Just a ipv4Of _ = Nothing -- | The host part of a socket address as text. showSockAddrHost :: SockAddr -> String showSockAddrHost addr = case ipv4Of addr of Just a -> inet_htoa a Nothing -> case show addr of '[':rest -> takeWhile (/= ']') rest other -> other -- | A response with a content type, a cache policy and a body. contentType :: String -> (ByteString, ByteString) contentType t = (B.pack "Content-Type", B.pack t) textResponse :: Int -> ByteString -> ByteString -> Response textResponse code cache body = Response code (B.pack "OK") [ contentType "text/plain; charset=utf-8" , (B.pack "Cache-Control", cache) ] body False jsonResponse :: ByteString -> JSON -> Response jsonResponse cache json = Response 200 (B.pack "OK") [ contentType "application/json" , (B.pack "Cache-Control", cache) , (B.pack "Access-Control-Allow-Origin", B.pack "*") ] (renderJSON json `B.append` B.pack "\n") False errorResponse :: Int -> String -> String -> Response errorResponse code reason msg = Response code (B.pack reason) [ contentType "application/json" , (B.pack "Cache-Control", B.pack "no-store") ] (renderJSON (JObject [(B.pack "error", JString $ B.pack msg)]) `B.append` B.pack "\n") False mhatta-tordnsel-1d9141b/tests/000077500000000000000000000000001527317632400163235ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/000077500000000000000000000000001527317632400176555ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/Config/000077500000000000000000000000001527317632400210625ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/Config/Tests.hs000066400000000000000000000216571527317632400225330ustar00rootroot00000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Config.Tests -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : portable -- -- Config tests. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.Config.Tests (tests) where import Control.Arrow ((***)) import Data.Char (toLower) import qualified Data.ByteString.Char8 as B import qualified Data.Map as M import Network.Socket (SockAddr(..)) import Test.HUnit (Test(..), (@=?)) import TorDNSEL.Config.Internals import TorDNSEL.Main (supplementaryGroups) import TorDNSEL.Util (hush) tests = TestList . map TestCase $ [ Just config @=? hush (parseConfigFile configFile) , Just config' @=? hush (parseConfigArgs configArgs) -- dropping privileges keeps the user's groups, and only those , [107, 113] @=? supplementaryGroups "tordnsel" 107 [(0, ["root"]), (113, ["tordnsel", "other"]), (107, ["tordnsel"]) , (27, ["other"])] , [107] @=? supplementaryGroups "tordnsel" 107 [(0, ["root"])] -- Tor's control and SOCKS ports may be Unix sockets (as with Debian's -- tor) or IPv6; we listen on IP addresses only , Just (SockAddrUnix "/run/tor/control", SockAddrUnix "/run/tor/socks") @=? fmap (\c -> (cfTorControlAddress c, cfTorSocksAddress c)) (hush . makeConfig $ M.union (toConfig [ "TorControlAddress" ~> "unix:/run/tor/control" , "TorSocksAddress" ~> "unix:/run/tor/socks" ]) config) , Just (SockAddrInet6 9051 0 (0, 0, 0, 1) 0) @=? fmap cfTorControlAddress (hush . makeConfig $ M.insert "torcontroladdress" "[::1]:9051" config) , Nothing @=? fmap cfTorControlAddress (hush . makeConfig $ M.insert "torcontroladdress" "unix:run/tor/control" config) , Nothing @=? fmap cfDNSListenAddress (hush . makeConfig $ M.insert "dnslistenaddress" "unix:/run/dns" config) , Nothing @=? fmap cfHTTPListenAddress (hush . makeConfig $ M.insert "httplistenaddress" "unix:/run/http" config) ] config' = toConfig [ "User" ~> "nobody" , "ConfigFile" ~> "/srv/tordnsel/tordnsel.conf" ] configArgs = ["--User", "nobody", "-f", "/srv/tordnsel/tordnsel.conf"] config = toConfig [ "ZoneOfAuthority" ~> "exitlist.example.com." , "DomainName" ~> "exitlist-ns.example.com." , "SOARName" ~> "hostmaster.example.com." , "StateDirectory" ~> "/state/" , "RuntimeDirectory" ~> "/srv/tordnsel/run/" , "DNSListenAddress" ~> "127.0.0.1:53" , "Address" ~> "10.0.0.1" , "TorControlAddress" ~> "127.0.0.1:9051" , "TorControlPassword" ~> "password" , "Log" ~> "notice file /srv/tordnsel/log/" , "RunAsDaemon" ~> "True" , "User" ~> "tordnsel" , "Group" ~> "tordnsel" , "ChangeRootDirectory" ~> "/srv/tordnsel/" , "PIDFile" ~> "/srv/tordnsel/run/tordnsel.pid" , "EnableActiveTesting" ~> "True" , "TorSocksAddress" ~> "127.0.0.1:9050" , "TestListenAddress" ~> "10.0.0.1:80,443,110,53,22,5190,6667,9030" , "TestDestinationAddress" ~> "10.0.0.1:80,443,110,53,22,5190,6667,9030" ] configFile = "## torndsel.conf.sample\n\ \## Sample configuration file for TorDNSEL.\n\ \\n\ \################ Required options #########################################\n\ \##\n\ \## These options have no default values. They must be uncommented and\n\ \## changed for your system.\n\ \\n\ \## Answer queries authoritatively for this DNS zone. For example, if this\n\ \## is set to \"exitlist.example.com.\", your server would accept queries of\n\ \## the form \"1.0.0.10.80.4.3.2.1.ip-port.exitlist.example.com.\".\n\ \ZoneOfAuthority exitlist.example.com.\n\ \\n\ \## This name server's own domain name, for use in NS and SOA records.\n\ \DomainName exitlist-ns.example.com.\n\ \\n\ \## Use this email address in the RNAME field of SOA records. Usually, this\n\ \## should be something like \"hostmaster@example.com\" in the form of a\n\ \## fully-qualified domain name. This option is required.\n\ \SOARName hostmaster.example.com.\n\ \\n\ \## Store exit test results in this directory. This should be an absolute\n\ \## path accessible inside the chroot (if one is configured).\n\ \#StateDirectory /srv/tordnsel/state/\n\ \## This line is equivalent to the previous line if you've specified\n\ \## ChangeRootDirectory as /srv/tordnsel/.\n\ \StateDirectory /state/\n\ \\n\ \## Place the statistics and reconfigure sockets in this directory before\n\ \## chrooting or dropping privileges.\n\ \RuntimeDirectory /srv/tordnsel/run/\n\ \\n\ \################ Optional options #########################################\n\ \##\n\ \## These options either have sensible default values or can be left\n\ \## unspecifed. You will probably need to uncomment and change some of\n\ \## these.\n\ \\n\ \## Bind the name server to this IP address and UDP port. If you want to\n\ \## bind to all interfaces, you might set the address to \"0.0.0.0\". This\n\ \## port is bound before dropping privileges. Leave it commented to use the\n\ \## default.\n\ \DNSListenAddress 127.0.0.1:53\n\ \\n\ \## The IP address that will be returned in response to requests for the A\n\ \## record matching our zone of authority. If you don't specify this option,\n\ \## no A record will be returned for the zone of authority.\n\ \Address 10.0.0.1\n\ \\n\ \## Make Tor controller connections to this IP address and TCP port. You'll\n\ \## need to set this as your ControlListenAddress or ControlPort in Tor's\n\ \## torrc. Leave it commented to use the default.\n\ \TorControlAddress 127.0.0.1:9051\n\ \\n\ \## The password you used to generate the HashedControlPassword in Tor's\n\ \## torrc. This is only required when you have a HashedControlPassword.\n\ \TorControlPassword password\n\ \\n\ \## Send log messages of at least a minimum severity to a specified stream,\n\ \## to the system logger, or to a file. Valid severity levels are debug,\n\ \## info, notice, warn, and error. If you specify a log file, it should\n\ \## be accessible from inside the chroot (if one is configured), and\n\ \## writable after dropping privileges. This may only be specified once. The\n\ \## default is \"notice stdout\".\n\ \#Log notice stdout\n\ \#Log info stderr\n\ \#Log warn syslog\n\ \Log notice file /srv/tordnsel/log/\n\ \\n\ \## Detach from the controlling terminal and run in the background as a\n\ \## daemon. The default is \"False\".\n\ \RunAsDaemon True\n\ \\n\ \## The user name to which you want to drop privileges. This option requires\n\ \## root privileges.\n\ \User tordnsel\n\ \\n\ \## The group name to which you want to drop privileges. This option also\n\ \## requires root privileges.\n\ \Group tordnsel\n\ \\n\ \## Call chroot(2) to change our root directory. This option also requires\n\ \## root privileges.\n\ \ChangeRootDirectory /srv/tordnsel/\n\ \\n\ \## Write our PID to the specified file before chrooting or dropping\n\ \## privileges. This file won't be removed on exit.\n\ \PIDFile /srv/tordnsel/run/tordnsel.pid\n\ \\n\ \################ Active testing options ###################################\n\ \##\n\ \## These options are only necessary if you want to enable active testing\n\ \## through exit nodes for a more accurate exit list.\n\ \\n\ \## Enable active test connections through exit nodes to determine their\n\ \## exit IP addresses. Enabling this will result in a more accurate view\n\ \## exit nodes' IP addresses, at the expense of putting a much greater load\n\ \## on your local Tor process and the Tor network itself. The default is\n\ \## \"False\".\n\ \EnableActiveTesting True\n\ \\n\ \## Make exit test connections through Tor's SocksPort on this IP address\n\ \## and TCP port. Leave it commented to use the default.\n\ \TorSocksAddress 127.0.0.1:9050\n\ \\n\ \## Bind the exit test listeners to this IP address and these TCP ports.\n\ \## These ports are bound before dropping privileges. Don't use the loopback\n\ \## interface for TestListenAddress if you're redirecting connections with\n\ \## iptables because your redirected packets will be dropped as martians.\n\ \## This option is only required when EnableActiveTesting is set to True.\n\ \TestListenAddress 10.0.0.1:80,443,110,53,22,5190,6667,9030\n\ \\n\ \## Make exit test connections to this IP address and these TCP ports. These\n\ \## should be publicly accessible from Tor exit nodes. This option is only\n\ \## required when EnableActiveTesting is set to True.\n\ \TestDestinationAddress 10.0.0.1:80,443,110,53,22,5190,6667,9030\n" toConfig = M.fromList . map ((B.pack . map toLower) *** B.pack) (~>) = (,) mhatta-tordnsel-1d9141b/tests/TorDNSEL/DNS/000077500000000000000000000000001527317632400203015ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/DNS/Server/000077500000000000000000000000001527317632400215475ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/DNS/Server/Tests.hs000066400000000000000000000461641527317632400232200ustar00rootroot00000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.DNS.Server.Tests -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : portable -- -- DNS server tests: parsing of the three exit list query types and the -- responses generated for them. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.DNS.Server.Tests (tests) where import Control.Concurrent (forkIO, threadDelay, killThread) import qualified Control.Exception as E import qualified Data.ByteString.Char8 as B import qualified Data.Map as M import qualified Data.List as L import Data.Time.Clock.POSIX (POSIXTime) import Network.Socket ( Socket, socket, Family(AF_INET), SocketType(Datagram, Stream), SockAddr(..) , bind, listen, accept, connect, getSocketName, close ) import qualified Network.Socket.ByteString as NSB import System.Timeout (timeout) import Test.HUnit (Test(..), (@=?), (@?), assertFailure) import TorDNSEL.DNS import TorDNSEL.DNS.Internals (Packet(..), encodeMessage, decodeMessage, tcpFrame, renderEDNSOptions) import TorDNSEL.DNS.Server.Internals import TorDNSEL.ExitList import TorDNSEL.Fixtures import TorDNSEL.Util tests :: Test tests = TestList [ TestList . map TestCase $ [ dropAuthZone authZone queryName @=? Just query , parseExitListQuery lists query @=? FullQuery query' ] , TestLabel "query parsing" parsing , TestLabel "responses" responses , TestLabel "truncation" truncation , TestLabel "rate limiting" rateLimiting , TestLabel "TCP" tcp ] where query = toLabels ["ip-port","1","2","3","4","80","10","0","0","1"] queryName = toName [ "1","0","0","10","80","4","3","2","1" , "ip-port","torhosts","example","com" ] query' = IPPort { queryAddr = ip "10.0.0.1", destAddr = ip "1.2.3.4" , destPort = 80 } parsing :: Test parsing = TestList . map TestCase $ [ FullQuery (IPList (ip "1.2.3.4") "examplenet") @=? parse ["list","examplenet","1","2","3","4"] , FullQuery (IPList (ip "1.2.3.4") "examplenet") @=? parse ["LIST","ExampleNet","1","2","3","4"] , FullQuery (IPMe (ip "1.2.3.4") 6667) @=? parse ["me","6667","1","2","3","4"] -- prefixes of valid names are empty non-terminals (QNAME minimisation) , PartialQuery @=? parse ["ip-port"] , PartialQuery @=? parse ["ip-port","1","2","3","4","80","10"] , PartialQuery @=? parse ["list","examplenet"] , PartialQuery @=? parse ["me","80","1"] -- and everything else doesn't exist , NoSuchName @=? parse ["ip-port","1","2","3","4","80","10","0","0","1","5"] , NoSuchName @=? parse ["ip-port","256"] , NoSuchName @=? parse ["ip-port","1","2","3","4","65536"] , NoSuchName @=? parse ["list","nosuchlist"] , NoSuchName @=? parse ["me","x"] , NoSuchName @=? parse ["www"] -- {IP}.{zone}, the form of the Tor Project's service , FullQuery (IPExit (ip "1.2.3.4")) @=? parse ["1","2","3","4"] , PartialQuery @=? parse ["1","2"] , NoSuchName @=? parse ["1","2","3","4","5"] , NoSuchName @=? parse ["1","2","300"] , NoSuchName @=? parseExitListQuery M.empty (toLabels ["list"]) ] where parse = parseExitListQuery lists . toLabels responses :: Test responses = TestCase $ do sock <- socket AF_INET Datagram 0 let conf = dnsConf sock ask src qt labels = dnsResponse conf src (query (toName $ labels ++ ["torhosts","example","com"]) qt) now networkState fromV4 a = SockAddrInet 40000 (htonl $ ip a) -- query type 1 let (t1,r1) = ask client TA ["11","0","0","10","80","4","3","2","1","ip-port"] typ "t1" Positive t1 NoError @=? msgRCode r1 [A (rrNameOf r1) ttl 0x7f000002] @=? msgAnswers r1 let (t2,r2) = ask client TA ["11","0","0","10","25","4","3","2","1","ip-port"] typ "t2" Negative t2 NXDomain @=? msgRCode r2 -- an exit whose exit address was found by active testing let (t3,_) = ask client TA ["99","0","0","10","80","4","3","2","1","ip-port"] typ "t3" Positive t3 -- the RFC 5782 test address is always listed let (t4,_) = ask client TA ["2","0","0","127","80","4","3","2","1","ip-port"] typ "t4" Positive t4 -- TXT records explain the listing let (_,r5) = ask client TTXT ["11","0","0","10","80","4","3","2","1","ip-port"] case msgAnswers r5 of [TXT _ _ [txt]] -> "10.0.0.11 is a Tor exit" `B.isPrefixOf` txt @? "TXT" other -> assertFailure $ "unexpected TXT answer " ++ show other -- other record types: NOERROR without data (RFC 2308) let (_,r6) = ask client (UnsupportedType 28) ["11","0","0","10","80","4","3","2","1","ip-port"] (NoError, []) @=? (msgRCode r6, msgAnswers r6) -- empty non-terminal let (_,r7) = ask client TA ["4","3","ip-port"] (NoError, []) @=? (msgRCode r7, msgAnswers r7) -- "exit" queries: TXT records give the fingerprints, like the Tor -- Project's service let (te1,re1) = ask client TA ["99","0","0","10"] typ "te1" Positive te1 [A (rrNameOf re1) ttl 0x7f000002] @=? msgAnswers re1 let (_,re2) = ask client TTXT ["99","0","0","10"] [TXT (rrNameOf re2) ttl ["6161616161616161616161616161616161616161"]] @=? msgAnswers re2 -- 10.0.0.13 only permits 198.51.100.0/24, but that's an exit all the same; -- 10.0.0.12's last descriptor is too old let (te3,_) = ask client TA ["13","0","0","10"] typ "te3" Positive te3 let (te4,_) = ask client TA ["12","0","0","10"] typ "te4" Negative te4 -- query type 2 let (t8,_) = ask client TA ["11","0","0","10","examplenet","list"] typ "t8" Positive t8 let (t9,_) = ask client TA ["13","0","0","10","examplenet","list"] typ "t9" Negative t9 let (_,r10) = ask client TA ["11","0","0","10","othernet","list"] NXDomain @=? msgRCode r10 -- query type 3: the destination is whoever asks, and nothing is cached let (t11,r11) = ask (fromV4 "192.0.2.80") TA ["11","0","0","10","443","me"] typ "t11" Positive t11 [0] @=? map rrTTL (msgAnswers r11) let (t12,r12) = ask (fromV4 "192.0.2.80") TA ["13","0","0","10","443","me"] typ "t12" Negative t12 [(0,0)] @=? [(t,m) | SOA _ t _ _ _ _ _ _ m <- msgAuthority r12] let (t13,_) = ask (fromV4 "198.51.100.1") TA ["13","0","0","10","443","me"] typ "t13" Positive t13 -- an IPv6 client can't be reached by an IPv4 exit address let (t14,_) = ask (SockAddrInet6 40000 0 (0x20010db8,0,0,1) 0) TA ["11","0","0","10","443","me"] typ "t14" Negative t14 -- a router whose descriptor is older than 48 hours is no longer listed let (t15,_) = ask client TA ["12","0","0","10","80","4","3","2","1","ip-port"] typ "t15" Negative t15 -- EDNS(0): echo an OPT record; reject unknown versions with BADVERS let edns v = query (toName ["torhosts","example","com"]) TSOA `withAdditional` [UnsupportedResourceRecord (DomainName []) (v * 0x10000 + 0x8000) TOPT (UnsupportedClass 4096) B.empty] withAdditional m rrs = m { msgAdditional = rrs } (_,r16) = dnsResponse conf client (edns 0) now networkState (_,r17) = dnsResponse conf client (edns 1) now networkState Just (EDNS 1232 0 0 True (Just [])) @=? findEDNS r16 (NoError, Just (EDNS 1232 1 0 True (Just []))) @=? (msgRCode r17, findEDNS r17) -- EDNS client subnet (RFC 7871): "me" queries are about the client -- subnet the resolver gives; the answer's scope says it depends on it let withSubnet bytes m = m { msgAdditional = [UnsupportedResourceRecord (DomainName []) 0 TOPT (UnsupportedClass 1232) (renderEDNSOptions [(8, B.pack bytes)])] } v4subnet = "\0\1\24\0\198\51\100" -- 198.51.100.0/24 meName = toName ["13","0","0","10","443","me","torhosts","example","com"] askMe cfg bytes = dnsResponse cfg client (withSubnet bytes (query meName TA)) now networkState -- the source and scope prefixes of the reply's client subnet option, -- which must otherwise be what we sent (a valid option once its scope -- is set back to 0, as in a query) scopeOf m = do e <- findEDNS m opts <- ednsOptions e bs <- lookup 8 opts _ <- parseClientSubnet (B.take 3 bs `B.append` "\0" `B.append` B.drop 4 bs) return (fromEnum (B.index bs 2), fromEnum (B.index bs 3)) -- the resolver (192.0.2.1) isn't in 198.51.100.0/24, but its client is let (tc1,rc1) = askMe conf v4subnet typ "tc1" Positive tc1 Just (24, 24) @=? scopeOf rc1 -- without the option, the query is about the resolver let (tc2,_) = dnsResponse conf client (query meName TA) now networkState typ "tc2" Negative tc2 -- answers to other queries don't depend on the subnet: scope 0 let (_,rc3) = dnsResponse conf client (withSubnet v4subnet (query (toName ["11","0","0","10","80","4" ,"3","2","1","ip-port","torhosts","example","com"]) TA)) now networkState Just (24, 0) @=? scopeOf rc3 -- turned off: the option is ignored let (tc4,rc4) = askMe conf { dnsClientSubnet = False } v4subnet typ "tc4" Negative tc4 Just (24, 0) @=? scopeOf rc4 -- an IPv6 client can't be reached by an IPv4 exit let (tc5,rc5) = askMe conf "\0\2\56\0\32\1\13\184\0\0\1" typ "tc5" Negative tc5 Just (56, 56) @=? scopeOf rc5 -- malformed: a prefix longer than the address, bits beyond the prefix, a -- scope in a query, an unknown family, a short address mapM_ (\bytes -> FormatError @=? msgRCode (snd $ askMe conf bytes)) [ "\0\1\33\0\1\2\3\4\5", "\0\1\23\0\198\51\101" , "\0\1\24\24\198\51\100", "\0\3\0\0", "\0\1\24\0\198\51" ] -- queries outside our zone are refused let (_,r18) = dnsResponse conf client (query (toName ["example","org"]) TA) now networkState Refused @=? msgRCode r18 -- QCLASS * is answered like IN; other classes have no data let withClass qc m = m { msgQuestion = (msgQuestion m) { qClass = qc } } name19 = toName ["11","0","0","10","80","4","3","2","1","ip-port" ,"torhosts","example","com"] (t19,r19) = dnsResponse conf client (withClass AnyClass (query name19 TA)) now networkState (_,r20) = dnsResponse conf client (withClass (UnsupportedClass 3) (query name19 TA)) now networkState typ "t19" Positive t19 [A name19 ttl 0x7f000002] @=? msgAnswers r19 (NXDomain, []) @=? (msgRCode r20, msgAnswers r20) -- RFC 8482: ANY gets one RRset, the A record for a listed name and the -- SOA at the apex, so that it can't be used to amplify a flood let (t21,r21) = dnsResponse conf client (query name19 TAny) now networkState (_,r22) = dnsResponse conf client (query (toName ["torhosts","example","com"]) TAny) now networkState typ "t21" Positive t21 [A name19 ttl 0x7f000002] @=? msgAnswers r21 [dnsSOA conf] @=? msgAnswers r22 where client = SockAddrInet 40000 (htonl $ ip "192.0.2.1") typ label a b = (label, show' a) @=? (label, show' b) show' Positive = "Positive" :: String show' Negative = "Negative" show' Other = "Other" show' Limited = "Limited" rrNameOf m = qName (msgQuestion m) -- | Responses too big for UDP are truncated, so that clients retry over TCP. truncation :: Test truncation = TestCase $ do let name = toName ["torhosts","example","com"] big = (query name TTXT) { msgQR = True , msgAnswers = replicate 4 (TXT name ttl [B.replicate 200 'x']) } withEDNS size m = m { msgAdditional = [UnsupportedResourceRecord (DomainName []) 0 TOPT (UnsupportedClass size) B.empty] } 512 @=? udpPayloadLimit (query name TA) 1232 @=? udpPayloadLimit (withEDNS 4096 $ query name TA) 512 @=? udpPayloadLimit (withEDNS 100 $ query name TA) case decodeMessage . Packet =<< encodeResponse 512 big of Just m -> (True, [], [], []) @=? (msgTC m, msgAnswers m, msgAuthority m, msgAdditional m) Nothing -> assertFailure "no truncated response" -- the OPT record survives truncation case decodeMessage . Packet =<< encodeResponse 512 (withEDNS 1232 big) of Just m -> (True, 1) @=? (msgTC m, length (msgAdditional m)) Nothing -> assertFailure "no truncated response with EDNS" -- it fits in 1232 bytes, and certainly over TCP fmap (msgTC) (decodeMessage . Packet =<< encodeResponse 1232 big) @=? Just False -- queries are never truncated Nothing @=? encodeResponse 20 (query name TA) -- | Token buckets per client network. rateLimiting :: Test rateLimiting = TestCase $ do let run :: POSIXTime -> SockAddr -> RateLimiter -> [RateDecision] -> IO RateLimiter run _ _ rl [] = return rl run t a rl (expected:rest) = do let (d, rl') = rateLimit 2 t a rl expected @=? d run t a rl' rest v4 x = SockAddrInet 40000 (htonl $ ip x) rl1 <- run 100 (v4 "192.0.2.1") emptyRateLimiter [Allow, Allow, Slip, Drop, Slip, Drop] -- the same /24 shares the bucket; another network doesn't rl2 <- run 100 (v4 "192.0.2.200") rl1 [Slip] rl3 <- run 100 (v4 "192.0.3.1") rl2 [Allow, Allow, Slip] -- half a second later, there's one token again; a second later, two rl4 <- run 100.5 (v4 "192.0.2.1") rl3 [Allow, Drop] _ <- run 102 (v4 "192.0.2.1") rl4 [Allow, Allow, Slip] -- IPv6 clients are grouped by /56 let v6 b = SockAddrInet6 40000 0 (0x20010db8, b, 0, 1) 0 rl5 <- run 100 (v6 0x00000100) emptyRateLimiter [Allow, Allow, Slip] _ <- run 100 (v6 0x000001ff) rl5 [Drop] _ <- run 100 (v6 0x00000200) rl5 [Allow] -- networks whose buckets have filled up again are forgotten let (_, rl6) = rateLimit 2 103 (v4 "198.51.100.1") rl3 M.keys (rlBuckets rl6) @=? [rateKey (v4 "198.51.100.1")] -- at most so many networks are tracked; others are treated as limited let step (ds, rl) a = let (d, rl') = rateLimitWith 2 5 100 (v4 a) rl in (d : ds, rl') (ds7, rl7) = L.foldl' step ([], emptyRateLimiter) ["192.0.2.1", "192.0.3.1", "192.0.4.1", "192.0.5.1" , "192.0.2.2"] [Allow, Allow, Slip, Drop, Allow] @=? reverse ds7 2 @=? M.size (rlBuckets rl7) -- loopback can't be spoofed from outside: not limited (True, True, True, False, False) @=? ( isLoopback (v4 "127.0.0.1"), isLoopback (v4 "127.1.2.3") , isLoopback (SockAddrInet6 53 0 (0, 0, 0, 1) 0) , isLoopback (v4 "128.0.0.1"), isLoopback (v6 0) ) -- | DNS over TCP on a real connection: pipelined queries are answered in -- order, and idle or broken connections are closed. tcp :: Test tcp = TestCase $ do listener <- socket AF_INET Stream 0 bind listener (SockAddrInet 0 (htonl $ ip "127.0.0.1")) listen listener 5 addr <- getSocketName listener let name = toName ["torhosts","example","com"] handler _ q = return . Just $ q { msgQR = True, msgAnswers = [A name ttl (fromIntegral (msgID q))] } -- accept the next connection, in the background, closing it after 4 -- queries or 300 ms of idleness serve = serveWith 300000 serveWith idle = do _ <- forkIO $ do (s, a) <- accept listener serveTCPConnection s a (return idle) 4 (\_ _ -> return ()) handler `E.finally` close s return () connectTo = do c <- socket AF_INET Stream 0 connect c addr return c frame i = tcpFrame . unPacket . encodeMessage $ (query name TA) { msgID = i } readResponse c = do mbLen <- recvN c 2 case mbLen of Just l | [h, lo] <- B.unpack l -> do body <- recvN c (fromEnum h * 256 + fromEnum lo) return $ decodeMessage . Packet =<< body _ -> return Nothing -- two queries in one segment, one split over two serve c <- connectTo NSB.sendAll c (frame 1 `B.append` frame 2) let f3 = frame 3 NSB.sendAll c (B.take 5 f3) >> threadDelay 50000 >> NSB.sendAll c (B.drop 5 f3) rs <- mapM (const $ readResponse c) [1 :: Int, 2, 3] map (fmap msgID) rs @=? map Just [1, 2, 3] map (fmap (map aAddr . msgAnswers)) rs @=? map (Just . (:[])) [1, 2, 3] -- then it's closed after being idle closed <- timeout 2000000 (NSB.recv c 1) Just B.empty @=? closed close c -- something that isn't a DNS message ends the connection serve c' <- connectTo NSB.sendAll c' (B.pack "\0\3abc") closed' <- timeout 2000000 (NSB.recv c' 1) Just B.empty @=? closed' close c' -- after 4 queries (the limit given above) the connection is closed, long -- before the 5 s idle timeout serveWith 5000000 c'' <- connectTo NSB.sendAll c'' (B.concat $ map frame [1 .. 4]) rs' <- mapM (const $ readResponse c'') [1 :: Int .. 4] map (fmap msgID) rs' @=? map Just [1, 2, 3, 4] closed'' <- timeout 1000000 (NSB.recv c'' 1) Just B.empty @=? closed'' close c'' >> close listener -- one client network gets at most maxTCPConnectionsPerNetwork connections tcpListener <- socket AF_INET Stream 0 bind tcpListener (SockAddrInet 0 (htonl $ ip "127.0.0.1")) listen tcpListener 32 tcpAddr <- getSocketName tcpListener udp <- socket AF_INET Datagram 0 server <- forkIO $ runTCPServer id (dnsConf udp) { dnsTCPSocket = tcpListener } let open1 = do c3 <- socket AF_INET Stream 0 connect c3 tcpAddr return c3 conns <- mapM (const open1) [0 .. maxTCPConnectionsPerNetwork] threadDelay 200000 -- the last one was closed at once; the others are still open let isOpen c3 = do r <- E.try (timeout 100000 (NSB.recv c3 1)) return $ case r of Right Nothing -> True Right (Just _) -> False Left (_ :: E.IOException) -> False opens <- mapM isOpen conns (replicate maxTCPConnectionsPerNetwork True ++ [False]) @=? opens mapM_ close conns killThread server >> close tcpListener >> close udp where recvN c n = go n [] where go 0 acc = return . Just . B.concat $ reverse acc go k acc = do bs <- NSB.recv c k if B.null bs then return Nothing else go (k - B.length bs) (bs:acc) -- | A DNS query. query :: DomainName -> Type -> Message query name qt = Message 0x1234 False StandardQuery False False True False False False NoError (Question name qt IN) [] [] [] dnsConf :: Socket -> DNSConfig dnsConf sock = DNSConfig { dnsSocket = sock , dnsTCPSocket = sock , dnsAuthZone = authZone , dnsMyName = toName ["ns","example","com"] , dnsSOA = SOA zone ttl (toName ["ns","example","com"]) (toName ["hostmaster","example","com"]) 0 ttl ttl ttl ttl , dnsNS = NS zone ttl (toName ["ns","example","com"]) , dnsA = Nothing , dnsLists = lists , dnsRateLimit = 0 , dnsClientSubnet = True , dnsByteStats = \_ _ -> return () , dnsRespStats = const $ return () } where zone = toName ["torhosts","example","com"] lists :: NamedLists lists = M.fromList [("examplenet", [AddrPortPattern (ip "1.2.3.4") 0xffffffff 6667 6667])] authZone :: DomainName authZone = DomainName $ map Label ["com","example","torhosts"] toLabels :: [B.ByteString] -> [Label] toLabels = map Label toName :: [B.ByteString] -> DomainName toName = DomainName . toLabels mhatta-tordnsel-1d9141b/tests/TorDNSEL/DNS/Tests.hs000066400000000000000000000115621527317632400217440ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.DNS.Tests -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (imprecise exceptions) -- -- DNS tests. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.DNS.Tests (tests) where import Control.Monad (replicateM) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B (c2w) import qualified Data.ByteString.Lazy as L import Test.HUnit (Test(..), (@=?)) import Data.Binary.Get (runGet, skip) import TorDNSEL.DNS.Internals tests = TestList . map TestCase $ [ Just q @=? decodeMessage query , Just r @=? decodeMessage aResponse , Just r' @=? decodeMessage soaResponse , Just nsr @=? decodeMessage nsResponse , Nothing @=? decodeMessage cyclicPtrs , Nothing @=? decodeMessage cyclicPtrs' , query @=? encodeMessage q , aResponse @=? encodeMessage r , Just soaResponse @=? fmap encodeMessage (decodeMessage soaResponse) , Just nsResponse @=? fmap encodeMessage (decodeMessage nsResponse) , Just (Question name TA AnyClass) @=? fmap msgQuestion (decodeMessage anyClassQuery) , compNames' @=? compNames , decompNames' @=? decompNames ] q = Message 0x8eba False StandardQuery False False True False False False NoError (Question name TA IN) [] [] [] r = Message 0x8eba True StandardQuery False False True True False False NoError (Question name TA IN) [ A name 223 0xd86d7087 , A name 223 0x425eea0d ] [] [] r' = Message 0x8eba True StandardQuery False False True True False False NXDomain (Question name' TA IN) [] [ SOA (toName ["dnsbl","sorbs","net"]) 829 (toName ["rbldns0","sorbs","net"]) (toName ["dns","isux","com"]) 1180727520 7200 7200 604800 3600 ] [] nsr = Message 0x8eba True StandardQuery True False False False False False NoError (Question exitlist TA IN) [A exitlist 1800 0x7f000001] [NS exitlist 1800 exitlistNS] [] where exitlist = toName ["exitlist","torproject","org"] exitlistNS = toName ["exitlist-ns","torproject","org"] name = toName ["yahoo","com"] name' = toName ["1","0","0","127","dnsbl","sorbs","net"] decompNames = runGet (skip 12 >> replicateM 4 (getPacket (Packet compNames))) (L.fromChunks [compNames]) decompNames' = [name1, name2, name3, name4] compNames = B.replicate 12 0 `B.append` B.concat [b1,b2,b3,b4] where len = sum . map B.length (b1,t1) = compressName 12 name1 emptyTargetMap (b2,t2) = compressName (B.length b1) name2 t1 (b3,t3) = compressName (len [b1,b2]) name3 t2 (b4,_) = compressName (len [b1,b2,b3]) name4 t3 compNames' = B.pack . map B.c2w $ "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ \\x03\x77\x77\x77\x05\x79\x61\x68\x6f\x6f\x03\x63\x6f\x6d\ \\x00\x04\x6d\x61\x69\x6c\xc0\x10\x04\x6d\x61\x69\x6c\x06\ \\x67\x6f\x6f\x67\x6c\x65\xc0\x16\xc0\x0c" name1 = toName ["www","yahoo","com"] name2 = toName ["mail","yahoo","com"] name3 = toName ["mail","google","com"] name4 = toName ["www","yahoo","com"] toName = DomainName . map (Label . B.pack . map B.c2w) query = toPacket $ "\x8e\xba\x01\x00\x00\x01\x00\x00\x00\x00\x00\x00\x05\x79\ \\x61\x68\x6f\x6f\x03\x63\x6f\x6d\x00\x00\x01\x00\x01" aResponse = toPacket $ "\x8e\xba\x81\x80\x00\x01\x00\x02\x00\x00\x00\x00\x05\x79\ \\x61\x68\x6f\x6f\x03\x63\x6f\x6d\x00\x00\x01\x00\x01\xc0\ \\x0c\x00\x01\x00\x01\x00\x00\x00\xdf\x00\x04\xd8\x6d\x70\ \\x87\xc0\x0c\x00\x01\x00\x01\x00\x00\x00\xdf\x00\x04\x42\ \\x5e\xea\x0d" soaResponse = toPacket $ "\x8e\xba\x81\x83\x00\x01\x00\x00\x00\x01\x00\x00\x01\x31\ \\x01\x30\x01\x30\x03\x31\x32\x37\x05\x64\x6e\x73\x62\x6c\ \\x05\x73\x6f\x72\x62\x73\x03\x6e\x65\x74\x00\x00\x01\x00\ \\x01\xc0\x16\x00\x06\x00\x01\x00\x00\x03\x3d\x00\x2c\x07\ \\x72\x62\x6c\x64\x6e\x73\x30\xc0\x1c\x03\x64\x6e\x73\x04\ \\x69\x73\x75\x78\x03\x63\x6f\x6d\x00\x46\x60\x78\xe0\x00\ \\x00\x1c\x20\x00\x00\x1c\x20\x00\x09\x3a\x80\x00\x00\x0e\ \\x10" nsResponse = toPacket $ "\x8e\xba\x84\x00\x00\x01\x00\x01\x00\x01\x00\x00\x08\x65\ \\x78\x69\x74\x6c\x69\x73\x74\x0a\x74\x6f\x72\x70\x72\x6f\ \\x6a\x65\x63\x74\x03\x6f\x72\x67\x00\x00\x01\x00\x01\xc0\ \\x0c\x00\x01\x00\x01\x00\x00\x07\x08\x00\x04\x7f\x00\x00\ \\x01\xc0\x0c\x00\x02\x00\x01\x00\x00\x07\x08\x00\x0e\x0b\ \\x65\x78\x69\x74\x6c\x69\x73\x74\x2d\x6e\x73\xc0\x15" cyclicPtrs = toPacket $ "\x8e\xba\x01\x00\x00\x02\x00\x00\x00\x00\x00\x00\xc0\x12\ \\x00\x01\x00\x01\xc0\x0c\x00\x01\x00\x01" cyclicPtrs' = toPacket $ "\x8e\xba\x01\x00\x00\x02\x00\x00\x00\x00\x00\x00\x01\x61\ \\xc0\x0c" toPacket = Packet . B.pack . map B.c2w -- | 'query' with QCLASS * (255) instead of IN. anyClassQuery :: Packet anyClassQuery = Packet $ B.init (unPacket query) `B.snoc` 255 mhatta-tordnsel-1d9141b/tests/TorDNSEL/Directory/000077500000000000000000000000001527317632400216215ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/Directory/Tests.hs000066400000000000000000000227211527317632400232630ustar00rootroot00000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Directory.Tests -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : non-portable (GHC primitives) -- -- Directory tests. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.Directory.Tests (tests) where import qualified Data.ByteString.Char8 as B import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Network.Socket (HostAddress) import Test.HUnit (Test(..), (@=?), (@?)) import TorDNSEL.Directory.Internals import TorDNSEL.Document import TorDNSEL.Util tests = TestList [ TestCase descriptorParses, fingerprint, TestCase exitPolicy , TestCase modernDescriptor, TestCase modernStatuses , TestCase statusLines, TestCase modernPolicies ] -- | A router descriptor published by Tor 0.4.9.6 (from a chutney network). modernDescriptor = do doc <- B.readFile "tests/data/descriptor-0.4.9.txt" case parseDescriptors . parseDocument $ B.lines doc of [Right d] -> do "9739eeeaf0b4809dfc2d92bfa4647b41d364382b" @=? encodeBase16RouterID (descRouterID d) ip "127.0.0.13" @=? descListenAddr d "2026-10-20 02:38:39 UTC" @=? show (posixSecondsToUTCTime $ descPublished d) [ Rule Accept (ip "127.0.0.0") 0xff000000 6667 6667 , Rule Accept 0 0 443 443 , Rule Reject 0 0 0 65535 ] @=? descExitPolicy d other -> fail $ "unexpected parse: " ++ show (map (either (Left . ($ "")) Right) other) -- | The output of GETINFO ns/all from Tor 0.4.9.6: the publication time is a -- fixed placeholder since 0.4.8, but the entries are otherwise as before. modernStatuses = do doc <- B.readFile "tests/data/ns-all-0.4.9.txt" let rss = parseRouterStatuses . parseDocument $ B.lines doc 7 @=? length [() | Right _ <- rss] all (either (const False) rsIsRunning) rss @? "all running" -- | Both "r" line formats parse to the same thing. statusLines = do let full = [ "r test004ea yzXMxftj3wtBSF0uc9oHwccEcMw jmCdf8iX+yHkp/wC4Eik+MP8d7M \ \2038-01-01 00:00:00 10.200.0.11 5004 0", "s Exit Running Valid" ] micro = [ "r test004ea yzXMxftj3wtBSF0uc9oHwccEcMw \ \2038-01-01 00:00:00 10.200.0.11 5004 0", "s Exit Valid" ] parse = either (Left . ($ "")) (Right . (\r -> (rsRouterID r, rsIsRunning r))) . parseRouterStatus . parseDocument rid = either (error . ($ "")) id (decodeBase16RouterID "cb35ccc5fb63df0b41485d2e73da07c1c70470cc") Right (rid, True) @=? parse full Right (rid, False) @=? parse micro -- | Policy syntax that Tor can emit and that we must not choke on. modernPolicies = do let parse = either (error . ($ "")) id . parseExitPolicy . parseDocument parse ["reject private:*", "accept *:*"] @=? [Rule Reject a m 0 65535 | (a,m) <- privateNetworks] ++ [Rule Accept 0 0 0 65535] -- IPv6 patterns can't match IPv4 destinations and are dropped parse ["reject [2001:db8::]/32:*", "reject *6:25", "reject *4:80", "accept *:*"] @=? [Rule Reject 0 0 80 80, Rule Accept 0 0 0 65535] False @=? exitPolicyAccepts (ip "10.1.2.3") 80 (parse ["reject private:*", "accept *:*"]) True @=? exitPolicyAccepts (ip "172.32.0.1") 80 (parse ["reject private:*", "accept *:*"]) ip :: B.ByteString -> HostAddress ip = either (error . ($ "")) id . inet_atoh exitPolicy = do let Right [ip1,ip2,ip3] = mapM inet_atoh ips Right policy = parseExitPolicy $ parseDocument doc False @=? exitPolicyAccepts ip1 80 policy False @=? exitPolicyAccepts ip2 80 policy True @=? exitPolicyAccepts ip3 81 policy where ips = ["192.169.64.11","192.168.64.11","18.244.0.188"] doc = ["reject *:80","accept 18.244.0.18:*"] fingerprint = TestList . map TestCase $ [ Just rid @=? hush (decodeBase16RouterID base16) , Just rid @=? hush (decodeBase64RouterID base64) , base16 @=? encodeBase16RouterID rid ] where base16 = "ffcb46db1339da84674c70d7cb586434c4370441" base64 = "/8tG2xM52oRnTHDXy1hkNMQ3BEE" rid = RtrId "\255\203\70\219\19\57\218\132\103\76\112\ \\215\203\88\100\52\196\55\4\65" descriptorParses = "[Right " ++ parsed ++ ",Right " ++ parsed ++ "]" @=? parse descriptor where parse = show . parseDescriptors . parseDocument . concat . replicate 2 parsed = "41f0476c9cf03f2e233218bdff8ac1ae981533e0 128.2.141.33 2007-03-31 \ \21:34:31 UTC\n\ \Reject 0.0.0.0/0.0.0.0:22-22\n\ \Reject 0.0.0.0/0.0.0.0:1433-1433\n\ \Reject 0.0.0.0/255.0.0.0:0-65535\n\ \Reject 169.254.0.0/255.255.0.0:0-65535\n\ \Reject 127.0.0.0/255.0.0.0:0-65535\n\ \Reject 192.168.0.0/255.255.0.0:0-65535\n\ \Reject 10.0.0.0/255.0.0.0:0-65535\n\ \Reject 172.16.0.0/255.240.0.0:0-65535\n\ \Reject 0.0.0.0/0.0.0.0:25-25\n\ \Reject 0.0.0.0/0.0.0.0:119-119\n\ \Reject 0.0.0.0/0.0.0.0:135-139\n\ \Reject 0.0.0.0/0.0.0.0:445-445\n\ \Reject 0.0.0.0/0.0.0.0:465-465\n\ \Reject 0.0.0.0/0.0.0.0:587-587\n\ \Reject 0.0.0.0/0.0.0.0:1214-1214\n\ \Reject 0.0.0.0/0.0.0.0:4661-4666\n\ \Reject 0.0.0.0/0.0.0.0:6346-6429\n\ \Reject 0.0.0.0/0.0.0.0:6699-6699\n\ \Reject 0.0.0.0/0.0.0.0:6881-6999\n\ \Reject 18.244.0.188/255.255.255.255:0-65535\n\ \Reject 18.244.0.0/255.255.0.0:0-65535\n\ \Reject 2.0.0.0/2.2.2.2:80-80\n\ \Reject 192.168.0.0/255.255.0.0:22-25\n\ \Accept 0.0.0.0/0.0.0.0:0-65535\n" descriptor = B.lines $ "router err 128.2.141.33 9001 0 9030\n\ \platform Tor 0.1.0.17 on FreeBSD i386\n\ \published 2007-03-31 21:34:31\n\ \opt fingerprint 41F0 476C 9CF0 3F2E 2332 18BD FF8A C1AE 9815 33E0\n\ \uptime 17107892\n\ \bandwidth 655360 5242880 1058812\n\ \onion-key\n\ \-----BEGIN RSA PUBLIC KEY-----\n\ \MIGJAoGBAKNBq+8CxyPIDsGGonsp9OBMNmC94eQUTTPlVGMDxRV0qFfzYtovz57X\n\ \7npYyzWlsU3weEKUqk3+UYmyS+U06EI9+Etz7vhVXe356zd5k3fkYPjGUXU45bj8\n\ \+OcYhApzvX/j6fRwapsQk7S8RZqfO77NaKQ85D/7qeRE9hCsvMRhAgMBAAE=\n\ \-----END RSA PUBLIC KEY-----\n\ \signing-key\n\ \-----BEGIN RSA PUBLIC KEY-----\n\ \MIGJAoGBAKxqBfUbMpMJlVKtYD1QAM7UPF2Hw1MicwC9zjw26aZy/UUDmao8k19y\n\ \OqWCU6XXSb7tCOoYDZFSWFIppicheEsmfECedmVaLEUbErk91TDvRRb7+kiEKct5\n\ \ytGnGdfhMCYtYKXzsLfSIugEvMFD2NnBruXkElcMUEh14SiXcKcDAgMBAAE=\n\ \-----END RSA PUBLIC KEY-----\n\ \opt write-history 2007-03-31 21:22:58 (900 s) 578066987,587622813,584835445,\ \585201742,583211095,586682433,583562316,584206429,582016504,587287646,\ \582824061,580548866,590060637,585749427,583572871,583131506,575793840,\ \584378396,584858249,586256553,585316361,582975382,585566000,581052747,\ \588428807,588500251,585015083,582672236,589143715,583398130,585325958,\ \581557976,587611801,586869163,577796929,580764308,576024953,575814158,\ \581489264,577220925,580617597,580494023,577898711,581044860,582480308,\ \586770246,585741144,585112466,578520932,589939305,585118500,581594211,\ \584314299,586802619,585424813,588355421,581204276,586667140,580343006,\ \574772982,578801170,572328358,577198014,581826945,584808492,579516723,\ \582360193,579688773,588133393,586554075,583320577,580513818,585804666,\ \587476584,584928993,587470441,581390632,587168041,580638174,577111850,\ \556641250,566782715,567894740,582289206,587447049,585628823,585015986,\ \583607829,582999559,588123116,582090786,585689862,584317240,585496760,\ \586431179,584636699\n\ \opt read-history 2007-03-31 21:22:58 (900 s) 588538109,583787270,584790398,\ \585815935,582849016,586020989,584538527,584364009,585132020,584593814,\ \583913463,579796976,588724452,585225708,584576947,583925760,584581120,\ \584581120,583927107,583470806,584929234,586013155,582995684,585994885,\ \583863376,586918848,586141820,584504579,585777315,572326730,588758861,\ \584584423,583042876,584650910,588014788,583925624,584590996,584568943,\ \583928826,583923603,583924851,584587209,583933139,583913069,584580343,\ \584635188,583801885,585864769,584677998,585274294,582737669,587055654,\ \584940084,586157113,581114030,583691821,574164042,588116573,584041691,\ \583932984,583917816,584584538,570829358,587858639,583923787,584178524,\ \583659303,583927832,583493567,586299024,585259417,583930733,584487500,\ \585325127,583831156,585099111,581674496,585904120,585755796,583916625,\ \583926055,584588480,583257441,583929009,581410903,586798516,582247162,\ \587301864,584134617,585798361,585028528,584081569,585513948,583263200,\ \584122227,587115385\n\ \contact Serge Egelman \n\ \reject *:22\n\ \reject *:1433\n\ \reject 0.0.0.0/255.0.0.0:*\n\ \reject 169.254.0.0/255.255.0.0:*\n\ \reject 127.0.0.0/255.0.0.0:*\n\ \reject 192.168.0.0/255.255.0.0:*\n\ \reject 10.0.0.0/255.0.0.0:*\n\ \reject 172.16.0.0/255.240.0.0:*\n\ \reject *:25\n\ \reject *:119\n\ \reject *:135-139\n\ \reject *:445\n\ \reject *:465\n\ \reject *:587\n\ \reject *:1214\n\ \reject *:4661-4666\n\ \reject *:6346-6429\n\ \reject *:6699\n\ \reject *:6881-6999\n\ \reject 18.244.0.188:*\n\ \reject 18.244.0.188/16:*\n\ \reject 18.244.0.188/2.2.2.2:80\n\ \reject 192.168.0.1/255.255.00.0:22-25\n\ \accept *:*\n\ \router-signature\n\ \-----BEGIN SIGNATURE-----\n\ \ZU5RMHBifs+wm0DAouBbp/5u6eI3z+WeI3VGSxc7XMC0mInYY+GUPSl0GYqxQEOs\n\ \4qonLxMM7g98hWs3jDyV81iSLbzlx22COYag5mDNLSdjRNfaE+b3Z8nYYzQsqDJm\n\ \A7sL/7x8hhU9xnDCfFyjzkL1XfZHxBIiASfksNyuoiU=\n\ \-----END SIGNATURE-----" mhatta-tordnsel-1d9141b/tests/TorDNSEL/ExitList/000077500000000000000000000000001527317632400214225ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/ExitList/Tests.hs000066400000000000000000000102011527317632400230520ustar00rootroot00000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.ExitList.Tests -- License : Public domain (see LICENSE) -- -- Tests for destination patterns, named lists and exit policy evaluation -- over sets of destinations. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.ExitList.Tests (tests) where import qualified Data.ByteString.Char8 as B import Data.Either (isLeft) import Network.Socket (HostAddress) import Test.HUnit (Test(..), (@=?), (@?)) import TorDNSEL.Directory.Internals import TorDNSEL.Document import TorDNSEL.ExitList import TorDNSEL.Util tests :: Test tests = TestList [patterns, namedLists, someAccepted] patterns :: Test patterns = TestList . map TestCase $ [ Just [AddrPortPattern (ip "192.0.2.10") 0xffffffff 6667 6667] @=? hush (parseAddrPortPattern "192.0.2.10:6667") , Just [ AddrPortPattern (ip "198.51.100.0") 0xffffff00 6660 6669 , AddrPortPattern (ip "198.51.100.0") 0xffffff00 7000 7000 ] @=? hush (parseAddrPortPattern "198.51.100.7/24:6660-6669,7000") , isErr (parseAddrPortPattern "10.0.0.0/7:80") @? "masks wider than /8" , isErr (parseAddrPortPattern "10.0.0.1:90-80") @? "reversed port range" , isErr (parseAddrPortPattern "10.0.0.1") @? "missing port" , isErr (parseAddrPortPattern "10.0.0.256:80") @? "bad address" , "198.51.100.0/24:6660-6669" @=? showAddrPortPattern (AddrPortPattern (ip "198.51.100.0") 0xffffff00 6660 6669) ] namedLists :: Test namedLists = TestList . map TestCase $ [ Just ("examplenet", [ AddrPortPattern (ip "192.0.2.10") 0xffffffff 6667 6667 , AddrPortPattern (ip "192.0.2.11") 0xffffffff 6697 6697 ]) @=? hush (parseNamedList "ExampleNet 192.0.2.10:6667 192.0.2.11:6697") , isErr (parseNamedList "examplenet") @? "list without patterns" , isErr (parseNamedList "example.net 192.0.2.10:6667") @? "dots in names" , isErr (parseNamedList "-bad 192.0.2.10:6667") @? "leading hyphen" ] someAccepted :: Test someAccepted = TestList . map TestCase $ -- an IRC network: two servers on 6667 [ True @=? accepts irc "accept *:*" , False @=? accepts irc "reject *:6667\naccept *:*" , True @=? accepts irc "reject 192.0.2.10:*\naccept *:*" , False @=? accepts irc "reject 192.0.2.10:*\nreject 192.0.2.11:*\naccept *:*" , True @=? accepts irc "reject 192.0.2.0/24:1-6666\naccept *:*" , False @=? accepts irc "accept *:80\naccept *:443\nreject *:*" -- Tor's default "no matching rule" behaviour is to accept , True @=? accepts irc "reject 10.0.0.0/8:*" -- a range: accepted only if some address/port in it is , True @=? accepts range "reject 198.51.100.0/25:*\naccept *:*" , False @=? accepts range "reject 198.51.100.0/24:6660-6669\naccept *:*" , True @=? accepts range "reject 198.51.100.0/24:6660-6668\naccept *:*" , True @=? accepts range "reject 198.51.100.0/24:6661-6669\naccept 198.51.100.200:6660" , False @=? accepts range "reject 198.51.100.0/24:6661-6669\nreject *:6660\naccept *:*" -- agrees with exitPolicyAccepts on single destinations , and [ policyAcceptsSome [AddrPortPattern a 0xffffffff p p] (policy pol) == exitPolicyAccepts a p (policy pol) | a <- map ip ["192.0.2.10", "198.51.100.200", "10.1.2.3"] , p <- [22, 25, 80, 443, 6667] , pol <- [ "reject *:25\naccept *:*" , "accept 10.0.0.0/8:22-80\nreject *:*" , "reject 198.51.100.0/24:*\naccept *:443\nreject *:*" ] ] @? "single destinations" ] where irc = [ AddrPortPattern (ip "192.0.2.10") 0xffffffff 6667 6667 , AddrPortPattern (ip "192.0.2.11") 0xffffffff 6667 6667 ] range = [AddrPortPattern (ip "198.51.100.0") 0xffffff00 6660 6669] accepts pats = policyAcceptsSome pats . policy policy :: B.ByteString -> ExitPolicy policy = either (error . ($ "")) id . parseExitPolicy . parseDocument . B.lines isErr :: Either ShowS a -> Bool isErr = isLeft ip :: B.ByteString -> HostAddress ip = either (error . ($ "")) id . inet_atoh mhatta-tordnsel-1d9141b/tests/TorDNSEL/Fixtures.hs000066400000000000000000000042711527317632400220260ustar00rootroot00000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Fixtures -- License : Public domain (see LICENSE) -- -- A small synthetic view of the Tor network shared by several tests. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.Fixtures (networkState, now, ip, ridA, ridB, ridC) where import qualified Data.ByteString.Char8 as B import qualified Data.Map as M import qualified Data.Set as S import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) import Network.Socket (HostAddress) import TorDNSEL.Directory.Internals import TorDNSEL.NetworkState.Types import TorDNSEL.Util -- | A small network: 10.0.0.11 exits anywhere except port 25 and was also -- seen exiting from 10.0.0.99; 10.0.0.12 published its last descriptor three -- days ago; 10.0.0.13 only permits connections to 198.51.100.0/24. networkState :: NetworkState networkState = NetworkState { nsAddrs = M.fromList [ (ip "10.0.0.11", S.singleton ridA) , (ip "10.0.0.99", S.singleton ridA) , (ip "10.0.0.12", S.singleton ridB) , (ip "10.0.0.13", S.singleton ridC) ] , nsRouters = M.fromList [ (ridA, (router $ Desc (ip "10.0.0.11") (now - 3600) ridA policyA) { rtrTestResults = Just $ TestResults (utc $ now - 3600) (M.singleton (ip "10.0.0.99") (utc $ now - 600)) }) , (ridB, router $ Desc (ip "10.0.0.12") (now - 3 * 86400) ridB policyA) , (ridC, router $ Desc (ip "10.0.0.13") (now - 3600) ridC policyC) ] } where router d = Router (Just d) Nothing True (utc now) utc = posixSecondsToUTCTime policyA = [ Rule Reject 0 0 25 25, Rule Accept 0 0 0 65535 ] policyC = [ Rule Accept (ip "198.51.100.0") 0xffffff00 0 65535 , Rule Reject 0 0 0 65535 ] -- | Three router identities. ridA, ridB, ridC :: RouterID ridA = RtrId (B.replicate 20 'a') ridB = RtrId (B.replicate 20 'b') ridC = RtrId (B.replicate 20 'c') -- | The current time in the fixture. now :: POSIXTime now = 1800000000 -- | Parse a dotted-quad address. ip :: B.ByteString -> HostAddress ip = either (error . ($ "")) id . inet_atoh mhatta-tordnsel-1d9141b/tests/TorDNSEL/Properties.hs000066400000000000000000000303221527317632400223450ustar00rootroot00000000000000{-# OPTIONS_GHC -Wno-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Properties -- License : Public domain (see LICENSE) -- -- QuickCheck properties of the parts of TorDNSEL that read untrusted input: -- the DNS decoder (fed by anyone who can send us a packet), the SOCKS and -- control port parsers, and the UDP rate limiter. -- -- Each property runs as one HUnit test case, so that the test suite keeps a -- single runner. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.Properties (tests) where import qualified Control.Exception as E import Control.Monad (replicateM) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.List as L import qualified Data.Bits as Bits import Data.Word (Word8) import Network.Socket (SockAddr(..)) import Test.HUnit (Test(..), assertFailure) import Test.QuickCheck import TorDNSEL.DNS.Internals import TorDNSEL.DNS.Server.Internals (RateDecision(..), rateLimit, emptyRateLimiter) import TorDNSEL.Socks.Internals (Response(..), Result(..), decodeResponse) import TorDNSEL.TorControl.Internals (parseAuthChallenge) import TorDNSEL.ExitTest.Request (getRequest) import TorDNSEL.Web.Internals (parseRequest) import Network.Socket (socketPair, Family(AF_UNIX), SocketType(Stream), socketToHandle) import System.IO (IOMode(ReadWriteMode), hClose) import TorDNSEL.Util (Port(..), htonl) tests :: Test tests = TestList [ prop "decoding arbitrary bytes doesn't crash" decodeTotal , prop "decoding damaged messages doesn't crash" decodeDamaged , prop "decode . encode == id" roundTrip , prop "re-encoding a decoded message loses nothing" reencode , prop "EDNS options: round trip, and total" ednsOptionsProp , prop "client subnet option: round trip, and total" clientSubnetProp , prop "SOCKS responses: round trip, and total" socks , prop "AUTHCHALLENGE replies: parsing is total" authChallenge , prop "HTTP requests: parsing is total" httpRequests , prop "exit test requests: reading them doesn't crash" exitTestRequests , prop "the rate limiter allows at most rate*(1+t) queries" rateBound ] -- | Turn a property into a test case. prop :: Testable p => String -> p -> Test prop name p = TestLabel name . TestCase $ do r <- quickCheckWithResult stdArgs { maxSuccess = 500, chatty = False } p case r of Success {} -> return () _ -> assertFailure (name ++ ":\n" ++ output r) -- | Evaluate a value to WHNF, failing the property if that throws. noException :: a -> Property noException x = ioProperty $ do r <- E.try (E.evaluate x) return $ case r of Left (e :: E.SomeException) -> counterexample (show e) False Right _ -> property True -------------------------------------------------------------------------------- -- DNS decodeTotal :: Property decodeTotal = forAll bytes $ \bs -> noException (decodeMessage (Packet bs)) where -- Mostly short strings, with headers that claim records. bytes = oneof [ B.pack <$> arbitrary , B.append header . B.pack <$> arbitrary ] header = B.pack [0,1, 0,0, 0,1, 0,2, 0,1, 0,1] -- | Valid messages with bytes changed, inserted or cut off: the decoder may -- reject them, but must not crash. decodeDamaged :: Property decodeDamaged = forAll damagedMessage $ \bs -> noException (decodeMessage (Packet bs)) -- | An encoded message, damaged. damagedMessage :: Gen B.ByteString damagedMessage = do msg <- arbitrary damage (unPacket $ encodeMessage msg) where damage bs = oneof [ do i <- choose (0, B.length bs - 1) w <- arbitrary return $ B.concat [B.take i bs, B.singleton w, B.drop (i + 1) bs] , do i <- choose (0, B.length bs) return (B.take i bs) , do i <- choose (0, B.length bs) ws <- listOf1 arbitrary return $ B.concat [B.take i bs, B.pack ws, B.drop i bs] -- a compression pointer somewhere , do i <- choose (12, max 12 (B.length bs - 2)) p <- choose (0, 0x3fff :: Int) let ptr = B.pack [0xc0 + fromIntegral (p `div` 256), fromIntegral p] return $ B.concat [B.take i bs, ptr, B.drop (i + 2) bs] ] roundTrip :: Message -> Property roundTrip msg = let pkt = encodeMessage msg in counterexample (show pkt) $ decodeMessage pkt === Just msg -- | Whatever the decoder accepts, it can read back from our encoding of it: -- nothing it produces is something we can't send. reencode :: Property reencode = forAll damagedMessage $ \bs -> case decodeMessage (Packet bs) of Nothing -> property True Just msg -> decodeMessage (encodeMessage msg) === Just msg instance Arbitrary Message where arbitrary = do q <- arbitrary Message <$> arbitrary <*> arbitrary <*> opCode <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> rCode <*> pure q <*> records q <*> records q <*> records q where opCode = elements [StandardQuery, InverseQuery, ServerStatusRequest] `orElse` (UnknownOpCode <$> choose (3, 15)) rCode = elements [NoError, FormatError, ServerFailure, NXDomain , NotImplemented, Refused] `orElse` (UnknownRCode <$> choose (6, 15)) -- Records are often about the question's name, so that name -- compression has something to do. records q = do n <- choose (0, 3) replicateM n $ do rr <- arbitrary sameName <- arbitrary return $ if sameName then rr { rrName = qName q } else rr instance Arbitrary Question where arbitrary = Question <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary ResourceRecord where arbitrary = oneof [ A <$> arbitrary <*> arbitrary <*> arbitrary , NS <$> arbitrary <*> arbitrary <*> arbitrary , SOA <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary , TXT <$> arbitrary <*> arbitrary <*> strings , do (t, c) <- ((,) <$> arbitrary <*> arbitrary) `suchThat` unsupported UnsupportedResourceRecord <$> arbitrary <*> arbitrary <*> pure t <*> pure c <*> (B.pack <$> resize 64 (listOf arbitrary)) ] where -- A few character strings of up to 255 bytes, the most there can be. strings = do n <- choose (0, 3) replicateM n $ B.pack <$> (vector =<< choose (0, 255)) -- Records we decode as A, NS, SOA or TXT can't be unsupported. unsupported (t, c) = not (c == IN && t `elem` [TA, TNS, TSOA, TTXT]) instance Arbitrary DomainName where arbitrary = do n <- choose (0, 5) DomainName <$> replicateM n arbitrary instance Arbitrary Label where -- Labels from a small alphabet, so that names share suffixes and get -- compressed. At most 49 bytes, so that five of them fit in a name. arbitrary = do len <- frequency [(9, choose (1, 8)), (1, choose (1, 49))] Label . BC.pack <$> replicateM len (elements "abc-0") instance Arbitrary Type where arbitrary = elements [TA, TNS, TSOA, TTXT, TOPT, TAny] `orElse` (UnsupportedType <$> arbitrary `suchThat` (`notElem` [1, 2, 6, 16, 41, 255])) instance Arbitrary Class where arbitrary = elements [IN, AnyClass] `orElse` (UnsupportedClass <$> arbitrary `suchThat` (`notElem` [1, 255])) orElse :: Gen a -> Gen a -> Gen a orElse a b = frequency [(3, a), (1, b)] ednsOptionsProp :: Property ednsOptionsProp = valid .&&. total where valid = forAll (listOf ((,) <$> arbitrary <*> (B.pack <$> resize 40 (listOf arbitrary)))) $ \opts -> parseEDNSOptions (renderEDNSOptions opts) === Just opts total = forAll (B.pack <$> arbitrary) $ \bs -> noException (maybe () (const ()) (parseEDNSOptions bs)) clientSubnetProp :: Property clientSubnetProp = valid .&&. total where -- a valid IPv4 or IPv6 subnet: the right number of address bytes, and -- no bits beyond the prefix valid = forAll genSubnet $ \cs -> parseClientSubnet (renderClientSubnet cs) === Just cs genSubnet = do (family, maxBits) <- elements [(1, 32), (2, 128 :: Int)] source <- choose (0, maxBits) bytes <- vector ((source + 7) `div` 8) let bytes' | source `mod` 8 == 0 || null bytes = bytes | otherwise = init bytes ++ [last bytes Bits..&. (0xff `Bits.shiftL` (8 - source `mod` 8))] return $ ClientSubnet family (fromIntegral source) 0 (B.pack bytes') total = forAll (B.pack <$> arbitrary) $ \bs -> noException (maybe () (const ()) (parseClientSubnet bs)) -------------------------------------------------------------------------------- -- SOCKS and the control port socks :: Property socks = valid .&&. total where valid = forAll ((,,) <$> choose (90, 93) <*> arbitrary <*> arbitrary) $ \(code, addr, port) -> let bs = B.pack ([0, code] ++ be16 port ++ be32 addr) in fmap summary (decodeResponse bs) === Just (code, addr, port) total = forAll (B.pack <$> arbitrary) $ noException . decodeResponse summary (Response res addr (Port port)) = (resultCode res, addr, port) resultCode Granted = 90 resultCode Failed = 91 resultCode IdentdUnreachable = 92 resultCode IdentdMismatch = 93 :: Word8 be16 x = map fromIntegral [x `div` 256, x `mod` 256] be32 x = map (\s -> fromIntegral (x `div` (2 ^ (s :: Int)) `mod` 256)) [24, 16, 8, 0] authChallenge :: Property authChallenge = forAll text $ \t -> noException (either (const ()) (const ()) (parseAuthChallenge t)) where text = BC.pack <$> oneof [ arbitrary , (\a b -> "AUTHCHALLENGE SERVERHASH=" ++ a ++ " SERVERNONCE=" ++ b) <$> hex <*> hex ] hex = listOf (elements "0123456789abcdefABCDEFxyz") -- | Lines that look a bit like HTTP: a request line, header-ish lines (with -- and without colons) and some body. httpish :: Gen B.ByteString httpish = do reqLine <- elements [ "POST / HTTP/1.0", "POST / HTTP/1.1", "GET / HTTP/1.1" , "GET /api/v1/ip-port?ip=1.2.3.4&port=80&dest=5.6.7.8 HTTP/1.1" , "GET /%zz HTTP/1.0", "" ] hs <- listOf $ oneof [ elements [ "Content-Type: application/octet-stream", "Content-Length: 32" , "Content-Length", "content-type", "Content-Length: x", ":" , "Host: example.com" ] , BC.unpack . B.pack <$> listOf arbitrary ] body <- B.pack <$> resize 64 (listOf arbitrary) let crlf = "\r\n" return $ B.concat [ BC.pack (reqLine ++ crlf ++ concatMap (++ crlf) hs ++ crlf) , body ] httpRequests :: Property httpRequests = forAll (oneof [httpish, B.pack <$> arbitrary]) $ \bs -> noException (maybe () (const ()) (parseRequest bs)) -- | 'getRequest' reads from anyone who connects to an exit test listener. exitTestRequests :: Property exitTestRequests = forAll httpish $ \bs -> ioProperty $ do (a, b) <- socketPair AF_UNIX Stream 0 ha <- socketToHandle a ReadWriteMode hb <- socketToHandle b ReadWriteMode B.hPut hb bs >> hClose hb r <- E.try (getRequest ha >>= E.evaluate) hClose ha return $ case r of Left (e :: E.SomeException) | Just (_ :: E.IOException) <- E.fromException e -> property True | otherwise -> counterexample (show e) False Right _ -> property True -------------------------------------------------------------------------------- -- Rate limiting -- | Whatever the timing of the queries from one network, no more than -- @rate@ (the burst) plus @rate@ per elapsed second are allowed. rateBound :: Property rateBound = forAll (choose (1, 20)) $ \rate -> forAll (listOf (choose (0, 300 :: Int))) $ \gaps -> let times = scanl1 (+) (map (\ms -> fromIntegral ms / 1000) gaps) src = SockAddrInet 4000 (htonl 0xc0000201) step (rl, allowed) t = let (d, rl') = rateLimit rate (1000 + t) src rl in (rl', if d == Allow then allowed + 1 else allowed) (_, n) = L.foldl' step (emptyRateLimiter, 0 :: Int) times elapsed = if null times then 0 else last times - head times bound = fromIntegral rate * (1 + realToFrac elapsed) :: Double in counterexample (show (n, bound)) $ fromIntegral n <= bound + 1e-9 mhatta-tordnsel-1d9141b/tests/TorDNSEL/TorControl/000077500000000000000000000000001527317632400217625ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/TorControl/Tests.hs000066400000000000000000000401601527317632400234210ustar00rootroot00000000000000{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.TorControl.Tests -- License : Public domain (see LICENSE) -- -- Tests for talking to a current Tor (0.4.9) over the control protocol, and -- for how the network state manager uses what it learns. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.TorControl.Tests (tests) where import Control.Concurrent (forkIO) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import qualified Control.Exception as E import qualified Data.ByteString.Char8 as B import Data.Conduit (runConduit, (.|)) import qualified Data.Conduit.List as CL import Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S import Data.Time (hoursToTimeZone) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Network.Socket ( socketPair, Family(AF_UNIX, AF_INET), SocketType(Stream), socketToHandle , socket, bind, listen, connect, close, getSocketName, SockAddr(..) , defaultProtocol ) import qualified Network.Socket.ByteString as NSB import Control.Concurrent (threadDelay) import System.Directory (getTemporaryDirectory, removeFile) import System.IO (IOMode(ReadWriteMode), hClose, hFlush, openBinaryTempFile, hSetBuffering, BufferMode(LineBuffering)) import System.Posix.Files ( createNamedPipe, createSymbolicLink, getSymbolicLinkStatus, isRegularFile , fileMode ) import System.Timeout (timeout) import Test.HUnit (Test(..), (@=?), (@?), assertFailure) import TorDNSEL.Files (readSmallRegularFile, createFileExclusively, isGroupOrWorldWritable) import TorDNSEL.Directory.Internals import TorDNSEL.ExitTest.Request (Cookie(..), createRequest) import TorDNSEL.ExitTest.Server.Internals ( startExitTestServer, terminateExitTestServer, ExitTestServerConfig(..) , maxTestClientsPerAddress ) import TorDNSEL.Fixtures import TorDNSEL.NetworkState.Internals ( newConsensus, exitMappingName, takeCookie, acceptTestedAddress , maxTestedAddresses, mergeExitAddrsWithNetState ) import TorDNSEL.NetworkState.Storage.Internals ( ExitAddress(..), renderExitAddress, readExitAddresses, replaceExitAddresses , storePath ) import System.Directory (createDirectory, removeDirectoryRecursive) import TorDNSEL.NetworkState.Types import TorDNSEL.TorControl.Internals import TorDNSEL.Util (encodeBase16, htonl, Port(..)) tests :: Test tests = TestList [ protocolInfo', safeCookie, authChallenge, cookieFiles , fakeTor, exitTestCookies, exitTestListener, addressMap , replies, consensusEvent, consensus, mapping ] -- | The PROTOCOLINFO reply of Tor 0.4.9.6 with cookie authentication. protocolInfo' :: Test protocolInfo' = TestCase $ do let rs = [ Reply ('2','5','0') "PROTOCOLINFO 1" [] , Reply ('2','5','0') "AUTH METHODS=COOKIE,SAFECOOKIE \ \COOKIEFILE=\"/var/run/tor/control.authcookie\"" [] , Reply ('2','5','0') "VERSION Tor=\"0.4.9.6\"" [] , Reply ('2','5','0') "OK" [] ] case parseProtocolInfo rs of Left e -> fail (e "") Right pi' -> do TorVersion 0 4 9 6 "" @=? torVersion pi' Just "/var/run/tor/control.authcookie" @=? cookieAuth (authMethods pi') False @=? nullAuth (authMethods pi') True @=? safeCookieAuth (authMethods pi') -- | SAFECOOKIE hashes, checked against Python's hmac module: -- -- > hmac.new(key, bytes(range(32)) + b'\xaa' * 32 + b'\x55' * 32, -- > hashlib.sha256).hexdigest() safeCookie :: Test safeCookie = TestCase $ do let cookie = B.pack (map toEnum [0..31]) (server, client) = safeCookieHashes cookie (B.replicate 32 '\xaa') (B.replicate 32 '\x55') "5f7cb5569957c99373e329258545940f029af175da225f4a3125eebf30c24bba" @=? encodeBase16 server "9f99f2c4b75c91123ca5c6c6e3f76a9ef7fbd9471053cbe34454a4269cc39f7c" @=? encodeBase16 client -- | Cookie files are read with a length limit, and only if they're regular -- files: no FIFOs (which would block) or devices (which could be endless). cookieFiles :: Test cookieFiles = TestCase $ do tmp <- getTemporaryDirectory (path, h) <- openBinaryTempFile tmp "cookie" B.hPut h (B.replicate 100 'x') >> hClose h r1 <- readSmallRegularFile 33 path 33 @=? B.length r1 removeFile path r2 <- E.try (readSmallRegularFile 33 "/dev/zero") isLeft' r2 @? "/dev/zero accepted" let fifo = path ++ ".fifo" createNamedPipe fifo 0o600 r3 <- timeout 2000000 (E.try (readSmallRegularFile 33 fifo)) removeFile fifo case r3 of Nothing -> assertFailure "reading a FIFO blocked" Just r -> isLeft' r @? "FIFO accepted" -- createFileExclusively replaces a symbolic link rather than writing -- through it, and sets the mode despite the umask (victim, hv) <- openBinaryTempFile tmp "victim" B.hPut hv (B.pack "victim") >> hClose hv let pidFile = victim ++ ".pid" createSymbolicLink victim pidFile hp <- createFileExclusively pidFile 0o644 B.hPut hp (B.pack "1234\n") >> hClose hp B.readFile victim >>= (B.pack "victim" @=?) st <- getSymbolicLinkStatus pidFile (True, 0o644) @=? (isRegularFile st, fileMode st `mod` 0o1000) mapM_ removeFile [victim, pidFile] (True, False) @=? (isGroupOrWorldWritable 0o1777, isGroupOrWorldWritable 0o755) where isLeft' :: Either E.IOException a -> Bool isLeft' = either (const True) (const False) -- | A fake Tor on the control port: whatever it claims, we never send it a -- cookie file's contents. fakeTor :: Test fakeTor = TestCase $ do tmp <- getTemporaryDirectory (secret, h) <- openBinaryTempFile tmp "secret" B.hPut h (B.pack "32 bytes of a secret file.......") >> hClose h (short, h') <- openBinaryTempFile tmp "short" B.hPut h' (B.pack "too short") >> hClose h' let cookieOnly = "AUTH METHODS=COOKIE COOKIEFILE=\"" ++ secret ++ "\"" wrongLength = "AUTH METHODS=COOKIE,SAFECOOKIE COOKIEFILE=\"" ++ short ++ "\"" -- COOKIE only: refuse without sending anything after PROTOCOLINFO (ok1, sent1) <- talkTo True cookieOnly (False, ["PROTOCOLINFO 1"]) @=? (ok1, map (B.map toUpperC) sent1) -- SAFECOOKIE, but the "cookie" isn't 32 bytes: same (ok2, sent2) <- talkTo True wrongLength (False, ["PROTOCOLINFO 1"]) @=? (ok2, map (B.map toUpperC) sent2) -- a fake that never answers QUIT doesn't hang us (the QUIT wait is 5 s) r3 <- timeout 15000000 (talkTo False cookieOnly) fmap fst r3 @=? Just False mapM_ removeFile [secret, short] where toUpperC c = if c >= 'a' && c <= 'z' then toEnum (fromEnum c - 32) else c -- Run openConnection against a fake Tor sending the given AUTH line, and -- answering QUIT or not. -- Return whether opening succeeded and the lines the fake Tor received. talkTo answerQuit authLine = do (ours, theirs) <- socketPair AF_UNIX Stream 0 ourH <- socketToHandle ours ReadWriteMode theirH <- socketToHandle theirs ReadWriteMode hSetBuffering theirH LineBuffering done <- newEmptyMVar _ <- forkIO $ do l1 <- B.hGetLine theirH B.hPut theirH . B.pack $ concat [ "250-PROTOCOLINFO 1\r\n250-", authLine, "\r\n" , "250-VERSION Tor=\"0.4.9.6\"\r\n250 OK\r\n" ] hFlush theirH -- anything else we receive, until we're closed rest <- collect answerQuit theirH putMVar done (l1 : rest) r <- E.try (openConnection ourH Nothing (\n -> return (B.replicate n 'n'))) ok <- case r of Left (_ :: E.SomeException) -> hClose ourH >> return False Right conn -> closeConnection conn >> return True sent <- takeMVar done return (ok, map (B.takeWhile (/= '\r')) . filter (not . isQuit) $ sent) collect answerQuit hd = do r <- E.try (B.hGetLine hd) case r of Left (_ :: E.IOException) -> return [] Right l | B.null l -> return [] | isQuit l, answerQuit -> do B.hPut hd (B.pack "250 closing connection\r\n") hFlush hd >> hClose hd return [l] | otherwise -> (l :) `fmap` collect answerQuit hd isQuit l = B.map toUpperC (B.take 4 l) == B.pack "QUIT" -- | Exit test cookies work once, and a router gets at most -- 'maxTestedAddresses' tested exit addresses. exitTestCookies :: Test exitTestCookies = TestCase $ do let c = Cookie (B.replicate 32 'c') m = M.fromList [(c, 'x')] (first', m') = takeCookie c m (second', _) = takeCookie c m' (Just 'x', Nothing) @=? (first', second') let t = posixSecondsToUTCTime 0 router n = Router Nothing (Just $ TestResults t (M.fromList [(fromIntegral a, t) | a <- [1 .. n]])) True t acceptTestedAddress (Router Nothing Nothing True t) 7 @? "first address refused" acceptTestedAddress (router (maxTestedAddresses - 1)) 1000 @? "room refused" not (acceptTestedAddress (router maxTestedAddresses) 1000) @? "over the cap" acceptTestedAddress (router maxTestedAddresses) 1 @? "known address refused" -- stored results with more addresses than that (written before the limit, -- say) are cut down to the most recent when loaded let rid = ridA stored = ExitAddress rid t t (M.fromList [ (fromIntegral a, posixSecondsToUTCTime (fromIntegral a)) | a <- [1 .. 3 * maxTestedAddresses] ]) loaded = mergeExitAddrsWithNetState [stored] emptyNetworkState kept = maybe [] (M.keys . tstAddresses) $ rtrTestResults =<< M.lookup rid (nsRouters loaded) [fromIntegral a | a <- [2 * maxTestedAddresses + 1 .. 3 * maxTestedAddresses]] @=? kept kept @=? M.keys (nsAddrs loaded) -- the store is written to disk and read back, even out of order tmp <- getTemporaryDirectory (dirFile, hd) <- openBinaryTempFile tmp "state" hClose hd >> removeFile dirFile >> createDirectory dirFile _ <- replaceExitAddresses dirFile (nsRouters loaded) [ea] <- readExitAddresses dirFile (eaRouterID ea, M.keys (eaAddresses ea)) @=? (rid, kept) let one r a = ExitAddress r t t (M.singleton a t) B.writeFile (dirFile ++ storePath) . B.concat . map renderExitAddress $ [one ridC 3, one ridA 1, one ridB 2] back <- readExitAddresses dirFile L.sort [ridA, ridB, ridC] @=? map eaRouterID back removeDirectoryRecursive dirFile -- | One host can't take all the exit test listener's handlers: past the -- limit, its connections are closed at once, and other hosts (exits) are -- still served. exitTestListener :: Test exitTestListener = TestCase $ do listener <- socket AF_INET Stream defaultProtocol bind listener (SockAddrInet 0 (htonl 0x7f000001)) listen listener 64 addr <- getSocketName listener got <- newEmptyMVar server <- startExitTestServer [(addr, Just listener)] ExitTestServerConfig { etscfNotifyNewExitAddress = \_ cookie a -> putMVar got (cookie, a) , etscfConcClientLimit = 100 , etscfListenAddrs = S.singleton addr } let from src = do c <- socket AF_INET Stream defaultProtocol bind c (SockAddrInet 0 (htonl src)) connect c addr return c silent <- mapM (const $ from 0x7f000001) [1 .. maxTestClientsPerAddress] threadDelay 100000 extra <- from 0x7f000001 closed <- timeout 1000000 (E.try (NSB.recv extra 1)) case closed of Just (Right "") -> return () Just (Left (_ :: E.IOException)) -> return () _ -> assertFailure "connection over the limit kept open" -- another address is still served let cookie = Cookie (B.replicate 32 'k') other <- from 0x7f000002 NSB.sendAll other (createRequest "127.0.0.1" (Port 80) cookie) r <- timeout 2000000 (takeMVar got) Just (cookie, 0x7f000002) @=? r mapM_ close (extra : other : silent) terminateExitTestServer Nothing server -- | Parsing Tor's reply to AUTHCHALLENGE. authChallenge :: Test authChallenge = TestCase $ do let hash = B.replicate 64 'A' nonce = B.replicate 64 '0' ok = B.concat ["AUTHCHALLENGE SERVERHASH=", hash, " SERVERNONCE=", nonce] Right (B.replicate 32 '\xaa', B.replicate 32 '\0') @=? either (Left . ($ "")) Right (parseAuthChallenge ok) mapM_ (\t -> isLeft' (parseAuthChallenge t) @? ("accepted " ++ B.unpack t)) [ "AUTHCHALLENGE SERVERHASH=" `B.append` hash , B.concat ["AUTHCHALLENGE SERVERHASH=", B.take 62 hash, " SERVERNONCE=", nonce] , B.concat ["AUTHCHALLENGE SERVERHASH=", B.take 63 hash, "x SERVERNONCE=", nonce] , B.concat ["SOMETHING SERVERHASH=", hash, " SERVERNONCE=", nonce] ] where isLeft' :: Either ShowS a -> Bool isLeft' = either (const True) (const False) -- | ADDRMAP events: the UTC EXPIRES field wins over the local time. addressMap :: Test addressMap = TestCase $ do let tz = hoursToTimeZone 9 parse = either (Left . ($ "")) (Right . expiry) . parseAddressMap tz expiry (AddrMap _ _ e) = show e Right "2026-10-24 12:00:00" @=? parse "example.com 192.0.2.1 \"2026-10-24 21:00:00\" \ \EXPIRES=\"2026-10-24 12:00:00\" CACHED=\"NO\"" -- without EXPIRES (Tor before 0.2.0.x) the local time zone is used Right "2026-10-24 12:00:00" @=? parse "example.com 192.0.2.1 \"2026-10-24 21:00:00\"" Right "Never" @=? parse "example.com 192.0.2.1 NEVER" -- | Raw control port output, including an asynchronous NEWCONSENSUS event -- interleaved with command replies. replies :: Test replies = TestCase $ do rs <- runConduit $ CL.sourceList chunks .| c_replies .| CL.consume map (map repCode) rs @=? [ [('2','5','0')] , [('6','5','0'), ('6','5','0')] , [('2','5','0'), ('2','5','0')] ] case rs of [_, Reply _ "NEWCONSENSUS" doc : _, _] -> 2 @=? length (filter ("r " `B.isPrefixOf`) doc) _ -> fail "unexpected replies" where chunks = [ "250 OK\r\n650+NEWCONSENSUS\r\n" , B.unlines (map (`B.append` "\r") nsLines) , ".\r\n650 OK\r\n" , "250-tdeadbeef.tordnsel-test.invalid=10.0.0.1.A4C3850084D6BF" , "6C605C8C259A089F5FDF017621.exit\r\n250 OK\r\n" ] consensusEvent :: Test consensusEvent = TestCase $ do ref <- newIORef (-1, []) let EventHandler code handler = newConsensusEvent $ \errs rss -> writeIORef ref (length errs, map rsRouterID rss) "NEWCONSENSUS" @=? code handler [ Reply ('6','5','0') "NEWCONSENSUS" nsLines , Reply ('6','5','0') "OK" [] ] (n,rids) <- readIORef ref 0 @=? n [ "A4C3850084D6BF6C605C8C259A089F5FDF017621" , "CB35CCC5FB63DF0B41485D2E73DA07C1C70470CC" ] @=? map encodeBase16RouterIDUpper rids where encodeBase16RouterIDUpper = B.map toUpperC . encodeBase16RouterID toUpperC c = if c >= 'a' && c <= 'f' then toEnum (fromEnum c - 32) else c -- | A new consensus is a complete list: routers missing from it are no -- longer considered running, listed ones are refreshed. consensus :: Test consensus = TestCase $ do let later = posixSecondsToUTCTime (now + 3600) rs rid = RS rid later True ns' = newConsensus later [rs ridA, rs ridC] networkState running rid = rtrIsRunning <$> M.lookup rid (nsRouters ns') lastStatus rid = rtrLastStatus <$> M.lookup rid (nsRouters ns') (Just True, Just False, Just True) @=? (running ridA, running ridB, running ridC) Just later @=? lastStatus ridA Just (posixSecondsToUTCTime now) @=? lastStatus ridB -- addresses are untouched nsAddrs networkState @=? nsAddrs ns' S.size (M.keysSet $ nsRouters ns') @=? 3 -- | Exit tests connect to a unique, controller-mapped hostname. mapping :: Test mapping = TestCase $ do let name = exitMappingName (Cookie $ B.pack ['\xde','\xad','\xbe','\xef'] `B.append` B.replicate 28 '\0') "tdeadbeef000000000000.tordnsel-test.invalid" @=? name B.all (\c -> c `elem` (['a'..'z'] ++ ['0'..'9'] ++ "-.")) name @? "a valid destination for MAPADDRESS" nsLines :: [B.ByteString] nsLines = [ "r test005eb pMOFAITWv2xgXIwlmgifX98BdiE /sfG4X/TZbkh9wwokg8g9hf89BU \ \2038-01-01 00:00:00 10.200.0.12 5005 0" , "s Exit Fast Guard HSDir Running V2Dir Valid" , "w Bandwidth=56" , "p accept 1-65535" , "r test004ea yzXMxftj3wtBSF0uc9oHwccEcMw jmCdf8iX+yHkp/wC4Eik+MP8d7M \ \2038-01-01 00:00:00 10.200.0.11 5004 0" , "s Exit Fast Guard HSDir Running V2Dir Valid" , "w Bandwidth=214" , "p accept 1-65535" ] mhatta-tordnsel-1d9141b/tests/TorDNSEL/Web/000077500000000000000000000000001527317632400203725ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/TorDNSEL/Web/Tests.hs000066400000000000000000000263471527317632400220440ustar00rootroot00000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.Web.Tests -- License : Public domain (see LICENSE) -- -- Web interface tests. -- ----------------------------------------------------------------------------- -- #hide module TorDNSEL.Web.Tests (tests) where import Control.Concurrent (threadDelay) import qualified Control.Exception as E import qualified Data.ByteString.Char8 as B import qualified Data.Map as M import Data.Time.Clock.POSIX (getPOSIXTime) import Network.Socket ( socket, Family(AF_INET), SocketType(Stream), SockAddr(..), bind, listen , connect, getSocketName, close ) import qualified Network.Socket.ByteString as NSB import System.Timeout (timeout) import Test.HUnit (Test(..), (@=?), (@?), (@?=)) import TorDNSEL.AddressPattern import TorDNSEL.ExitList import TorDNSEL.Fixtures import TorDNSEL.Util import TorDNSEL.Statistics.Internals (Stats(..), renderMetrics) import TorDNSEL.Web.Internals tests :: Test tests = TestList [ requests, json, TestCase endpoints, TestCase limits , TestCase terminateAfterRequest ] -- | One client can't take all the handlers, and must send its request -- promptly. limits :: IO () limits = do listener <- socket AF_INET Stream 0 bind listener (SockAddrInet 0 (htonl $ ip "127.0.0.1")) listen listener 32 addr <- getSocketName listener web <- startWebServer (WebConfig listener M.empty Nothing (return ()) [] [] (return "")) let open1 = do c <- socket AF_INET Stream 0 connect c addr return c -- closed (or answered with an error before being closed) in time closedWithin us c = do r <- E.try (timeout us (NSB.recv c 1)) return $ case r of Right (Just _) -> True Right Nothing -> False Left (_ :: E.IOException) -> True silent <- mapM (const open1) [1 .. 8 :: Int] threadDelay 100000 -- the ninth connection from this address is closed at once ninth <- open1 closedWithin 1000000 ninth >>= (@? "ninth connection kept open") -- the silent ones are closed after the 3 s request timeout t0 <- getPOSIXTime closed <- mapM (closedWithin 5000000) silent t1 <- getPOSIXTime and closed @? "silent connections kept open" (t1 - t0 < 4) @? "silent connections closed too late" -- and then requests are served again c <- open1 NSB.sendAll c "GET /api/v1/lists HTTP/1.0\r\n\r\n" r <- timeout 2000000 (NSB.recv c 100) fmap (B.isPrefixOf "HTTP/1.1 200") r @=? Just True mapM_ close (c : ninth : silent) terminateWebServer Nothing web -- | The server terminates even when told to while a handler is finishing: -- the handler's exit signal may arrive after the request to terminate. terminateAfterRequest :: IO () terminateAfterRequest = mapM_ (const once) [1 .. 50 :: Int] where once = do listener <- socket AF_INET Stream 0 bind listener (SockAddrInet 0 (htonl $ ip "127.0.0.1")) listen listener 8 addr <- getSocketName listener web <- startWebServer (WebConfig listener M.empty Nothing (return ()) [] [] (return "")) c <- socket AF_INET Stream 0 connect c addr NSB.sendAll c "GET /api/v1/lists HTTP/1.0\r\n\r\n" _ <- timeout 2000000 (NSB.recv c 100) close c done <- timeout 5000000 (terminateWebServer Nothing web) close listener done @?= Just () requests :: Test requests = TestList . map TestCase $ [ Just (Request "GET" "/api/v1/ip-port" [("ip","10.0.0.11"),("port","80"),("dest","1.2.3.4")] [("host","example.com")]) @=? parseRequest "GET /api/v1/ip-port?ip=10.0.0.11&port=80&dest=1.2.3.4 \ \HTTP/1.1\r\nHost: example.com" , Just (Request "HEAD" "/a b" [("x","1 2"),("y","")] []) @=? parseRequest "HEAD /a%20b?x=1+2&y= HTTP/1.0" -- header names are lower-cased and values trimmed; lines without a colon -- are ignored , Just [("x-forwarded-for","192.0.2.7, 10.0.0.1"),("a","b:c")] @=? fmap reqHeaders (parseRequest "GET / HTTP/1.1\r\n\ \X-Forwarded-For: 192.0.2.7, 10.0.0.1 \r\nbogus\r\nA: b:c") , Nothing @=? parseRequest "GET /a%2 HTTP/1.1" , Nothing @=? parseRequest "GET http://example.com/ HTTP/1.1" , Nothing @=? parseRequest "garbage" -- address patterns, as for HTTPTrustedProxy , Just [ Net4 (ip "127.0.0.1") 0xffffffff, Net4 (ip "10.1.0.0") 0xffff0000 , Addr6 (0, 0, 0, 1) ] @=? hush (parseAddressPatterns "127.0.0.1, 10.1.2.3/16 ::1") , Nothing @=? hush (parseAddressPatterns "10.0.0.0/33") , Nothing @=? hush (parseAddressPatterns "example.com") , Just "a+b c" @=? urlDecode False "a+b%20c" , Just "a b c" @=? urlDecode True "a+b%20c" ] json :: Test json = TestCase $ "{\"a\":\"q\\\"\\\\\\u000a\",\"b\":[1,true,null]}" @=? renderJSON (JObject [ ("a", JString "q\"\\\n") , ("b", JArray [JNumber 1, JBool True, JNull]) ]) endpoints :: IO () endpoints = do sock <- socket AF_INET Stream 0 let conf = WebConfig sock lists Nothing (return ()) [] [] (return "tordnsel_up 1\n") get' path client = handleRequest conf now networkState client local (maybe (error "bad request") id $ parseRequest $ B.concat ["GET ", path, " HTTP/1.1"]) local = SockAddrInet 80 (htonl $ ip "198.51.100.80") client = SockAddrInet 40000 (htonl $ ip "192.0.2.1") body = respBody status = respStatus -- query type 1 let r1 = get' "/api/v1/ip-port?ip=10.0.0.11&port=80&dest=1.2.3.4" client (200, "{\"query\":\"ip-port\",\"ip\":\"10.0.0.11\",\"dest\":\"1.2.3.4\",\ \\"port\":80,\"listed\":true}\n") @=? (status r1, body r1) "\"listed\":false" `B.isInfixOf` body (get' "/api/v1/ip-port?ip=10.0.0.11&port=25&dest=1.2.3.4" client) @? "port 25 is rejected" 400 @=? status (get' "/api/v1/ip-port?ip=10.0.0.11&dest=1.2.3.4" client) 400 @=? status (get' "/api/v1/ip-port?ip=x&port=80&dest=1.2.3.4" client) -- query type 2 "\"listed\":true" `B.isInfixOf` body (get' "/api/v1/list?ip=10.0.0.13&list=ExampleNet" client) @? "list query" 404 @=? status (get' "/api/v1/list?ip=10.0.0.13&list=nope" client) "{\"examplenet\":[\"198.51.100.0/24:6667\"]}\n" @=? body (get' "/api/v1/lists" client) -- "exit": is the address an exit at all, and which relays exit from it (200, "{\"query\":\"exit\",\"ip\":\"10.0.0.99\",\"listed\":true,\ \\"fingerprints\":[\"6161616161616161616161616161616161616161\"]}\n") @=? (\r -> (status r, body r)) (get' "/api/v1/exit?ip=10.0.0.99" client) "\"listed\":false" `B.isInfixOf` body (get' "/api/v1/exit?ip=10.0.0.12" client) @? "exit query, router not running" 400 @=? status (get' "/api/v1/exit?ip=10.0.0" client) -- query type 3: the destination is the HTTP client "\"listed\":false" `B.isInfixOf` body (get' "/api/v1/me?ip=10.0.0.13&port=443" client) @? "me query, client outside 198.51.100.0/24" "\"listed\":true" `B.isInfixOf` body (get' "/api/v1/me?ip=10.0.0.13&port=443" (SockAddrInet 40000 (htonl $ ip "198.51.100.9"))) @? "me query, client inside 198.51.100.0/24" -- check.torproject.org compatible API: is the client a Tor exit able to -- reach this server? "{\"IsTor\":true,\"IP\":\"10.0.0.99\"}\n" @=? body (get' "/api/ip" (SockAddrInet 1234 (htonl $ ip "10.0.0.99"))) "{\"IsTor\":false,\"IP\":\"192.0.2.1\"}\n" @=? body (get' "/api/ip" client) -- 10.0.0.13 only exits to 198.51.100.0/24, which includes our address "{\"IsTor\":true,\"IP\":\"10.0.0.13\"}\n" @=? body (get' "/api/ip" (SockAddrInet 1234 (htonl $ ip "10.0.0.13"))) -- bulk lists "10.0.0.11\n10.0.0.99\n" @=? body (get' "/torbulkexitlist?ip=192.0.2.1&port=80" client) "10.0.0.11\n10.0.0.13\n10.0.0.99\n" @=? body (get' "/torbulkexitlist" client) "10.0.0.11\n10.0.0.13\n10.0.0.99\n" @=? body (get' "/torbulkexitlist?ip=198.51.100.1" client) "ExitNode 6161616161616161616161616161616161616161\n\ \Published 2027-01-15 07:00:00\n\ \LastStatus 2027-01-15 08:00:00\n\ \ExitAddress 10.0.0.99 2027-01-15 07:50:00\n" @=? body (get' "/exit-addresses" client) -- misc 404 @=? status (get' "/nope" client) let post = handleRequest conf now networkState client local (Request "POST" "/api/ip" [] []) (405, Just "GET, HEAD") @=? (status post, lookup "Allow" (respHeaders post)) let headR = handleRequest conf now networkState client local (Request "HEAD" "/api/ip" [] []) True @=? respHead headR "HTTP/1.1 200 OK\r\n" `B.isPrefixOf` renderResponse headR @? "status line" "\r\n\r\n" `B.isSuffixOf` renderResponse headR @? "HEAD has no body" -- X-Forwarded-For is believed only from trusted proxies, read from the -- right, skipping trusted proxies let proxied = conf { webTrustedProxies = [Net4 (ip "10.1.0.0") 0xffff0000, Net4 (ip "127.0.0.1") 0xffffffff] } viaProxy xff peer = respBody $ handleRequest proxied now networkState peer local (Request "GET" "/api/ip" [] [("x-forwarded-for", xff)]) proxy = SockAddrInet 40000 (htonl $ ip "127.0.0.1") -- the value of "IP" in {"IsTor":...,"IP":"..."} ipOf' b = B.takeWhile (/= '"') . B.drop 6 . snd $ B.breakSubstring "\"IP\":\"" b "10.0.0.99" @=? ipOf' (viaProxy "1.1.1.1, 10.0.0.99, 10.1.2.3" proxy) "\"IsTor\":true" `B.isInfixOf` viaProxy "10.0.0.99" proxy @? "a Tor exit behind the proxy" -- from a client that isn't a trusted proxy, the header is ignored "192.0.2.1" @=? ipOf' (viaProxy "10.0.0.99" client) -- all trusted: the leftmost; malformed: the proxy itself "10.1.9.9" @=? ipOf' (viaProxy "10.1.9.9, 10.1.2.3" proxy) "127.0.0.1" @=? ipOf' (viaProxy "10.0.0.99, junk" proxy) "2001:db8::1" @=? ipOf' (viaProxy "[2001:db8::1]" proxy) -- /metrics: only for the configured clients; for others it doesn't exist let metricsReq = Request "GET" "/metrics" [] [] allowed = conf { webMetricsAllowFrom = [Net4 (ip "192.0.2.0") 0xffffff00] } m1 <- metricsResponse conf client metricsReq 404 @=? status m1 m2 <- metricsResponse allowed client metricsReq (200, "tordnsel_up 1\n") @=? (status m2, body m2) m3 <- metricsResponse allowed (SockAddrInet 40000 (htonl $ ip "198.51.100.9")) metricsReq 404 @=? status m3 -- rendered from the statistics and the network state let text = renderMetrics "9.9" (Stats 10 20 3 4 5 6 7 8) 1700000000 now networkState has l = (l `elem` B.lines text) @? ("missing: " ++ B.unpack l) mapM_ has [ "tordnsel_build_info{version=\"9.9\"} 1" , "tordnsel_start_time_seconds 1700000000" , "tordnsel_dns_received_bytes_total 10" , "tordnsel_dns_responses_total{result=\"positive\"} 4" , "tordnsel_dns_responses_total{result=\"rate_limited\"} 8" , "tordnsel_http_requests_total 7" -- ridB's descriptor is three days old , "tordnsel_relays{state=\"known\"} 3" , "tordnsel_relays{state=\"running\"} 2" , "tordnsel_running_exits 2" -- 10.0.0.11 and 10.0.0.99 (tested) for ridA, 10.0.0.13 for ridC , "tordnsel_exit_addresses 3" , "tordnsel_tested_exit_addresses 1" , "# TYPE tordnsel_dns_responses_total counter" ] where lists = M.fromList [("examplenet", [AddrPortPattern (ip "198.51.100.0") 0xffffff00 6667 6667])] mhatta-tordnsel-1d9141b/tests/data/000077500000000000000000000000001527317632400172345ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/data/descriptor-0.4.9.txt000066400000000000000000000043361527317632400226270ustar00rootroot00000000000000router test006ec 127.0.0.13 5006 0 0 identity-ed25519 -----BEGIN ED25519 CERT----- AQQAB5vDAarm1wYYz26vX+UOom1CU8zBACUzted6/vovdgdyAhCHAQAgBACr7O+n mu5Vwj/JnxeGunVSVevIT/CF9UPU68YWKCOYvQJUV/gs0SdIkiBsl5bpWFqqUbD/ 6XOfqmp5N1ynDmsTpzWFWwzRC9QbeFJ+rC3Uqz6rQvC/mC4GlkFuHo1/GwI= -----END ED25519 CERT----- master-key-ed25519 q+zvp5ruVcI/yZ8Xhrp1UlXryE/whfVD1OvGFigjmL0 platform Tor 0.4.9.6 on Linux proto Conflux=1 Cons=1-2 Desc=1-4 DirCache=2 FlowCtrl=1-2 HSDir=2 HSIntro=4-5 HSRend=1-2 Link=3-5 LinkAuth=3 Microdesc=1-3 Padding=2 Relay=2-6 published 2026-10-20 02:38:39 fingerprint 9739 EEEA F0B4 809D FC2D 92BF A464 7B41 D364 382B uptime 52 bandwidth 1073741824 1073741824 56579 extra-info-digest BFEDD59430FD1130209293FF30766EEFB7DC8223 MLQYzRJoDqxb71082F0xfeVP4gtYlJor+QP31w14Cno onion-key -----BEGIN RSA PUBLIC KEY----- MIGJAoGBAMQBI1kTRG1PY/ySjibI/9UTVAWpor78iRgYJgjZqnmINYYmJffGFutP BeJ45ZtGBvOVxiiu9dADINJcfCOiXUQYf02J+s0gJol9TtBcFmiZuG2kTTU4eoH8 kyrovJCn5bcFzxO0dWPmYz+6NGu1IJxgMjnbw8GyXEEU0om8spHxAgMBAAE= -----END RSA PUBLIC KEY----- signing-key -----BEGIN RSA PUBLIC KEY----- MIGJAoGBALLH1yGNw9O33T62Zr+A4OVxIT1PbXqHGHWIMy9ZMAOKwLbiOKwLU7tH t8O0HQgPmYbtrcaYOjJ1c1dhx9tLw58cbMtVkJncUTCbZqOo0aeHFy/cO9JKYcNy ZhpfOw+w8f7ZeQvcMnCjtdTyuNt4CK+Q3Tdk1b57A3SOQtTYmYOtAgMBAAE= -----END RSA PUBLIC KEY----- onion-key-crosscert -----BEGIN CROSSCERT----- n4/vGx94llydA3F7+pAsBVIwtdu7O2YuoP/1XFg3JGti+wLabDr10AlFTsbj+I+p pH8knfS2BKyWVmtcsTFm+yJhLQDnYxWvNvaXTaIQ78eVhC0BnKGG8rUg8TEpMLML OBE0ykINxufiTXRFMoypMwZ/iTwGZnqYloDn2sK1xq8= -----END CROSSCERT----- ntor-onion-key-crosscert 0 -----BEGIN ED25519 CERT----- AQoAB5uTAavs76ea7lXCP8mfF4a6dVJV68hP8IX1Q9TrxhYoI5i9AHu+H7t/wuAm jtT6wocdyecutVNV9eX4wPrUrTdJxyyuJR5FZEd5DP+bzpckMq/2kmN75AIlsN44 jU3ASpJ2+wc= -----END ED25519 CERT----- hidden-service-dir ntor-onion-key 9ceYSUUiBy0HV8b1Drmlw42VunkPCgtAFTjGaU0SQXU accept 127.0.0.0/8:6667 accept *:443 reject *:* tunnelled-dir-server router-sig-ed25519 In2caLoOSqvxnxM67XBSdhW8NF2UicoYjcuGoba15Jja+KPgME/mhStF1pbyt3Nj74nApN6DpJAijTzNTnkXCA router-signature -----BEGIN SIGNATURE----- oXjPWb67I0zz8Oj+dgsxW5hUmSrfKTSmKlJDZN1WOh6Bb0a6mOvJFi/tihLWi4c0 lhh0/aYz5MN2NgYc9RIeR7CThA4KHsKwpVYqJx0kspQk+pr361dg53MpUNRjiijG l1E/mYZHgLupkfsFnLlcneAld7jHEgaai4rF7LapQCw= -----END SIGNATURE----- mhatta-tordnsel-1d9141b/tests/data/ns-all-0.4.9.txt000066400000000000000000000025061527317632400216340ustar00rootroot00000000000000r test002a PwgbMn+L93Wbuqmbcc1vNtx4GFQ oPDDE5pPjx54hZJOwhhJaKcYPg0 2038-01-01 00:00:00 127.0.0.1 5002 7002 s Authority Exit Fast Guard HSDir Running Stable V2Dir Valid w Bandwidth=183 p reject 1-65535 r test001a VfPs7kGLaAQnBFh0h3Y6/KSI2Mo DphYvPnZVpBnqW6Sw1JCmk36u1E 2038-01-01 00:00:00 127.0.0.1 5001 7001 s Authority Exit Guard HSDir Running Stable V2Dir Valid w Bandwidth=17 p reject 1-65535 r test003a ielhXjSUf4r1Y7za5f2ilVbtedw ro8Q2rTVuCzG8hPYsA2LuOy/JOE 2038-01-01 00:00:00 127.0.0.1 5003 7003 s Authority Exit Fast Guard HSDir Running Stable V2Dir Valid w Bandwidth=248 p reject 1-65535 r test006ec lznu6vC0gJ38LZK/pGR7QdNkOCs iqYEHfBeCuUZoySJIemSK4RFUL8 2038-01-01 00:00:00 127.0.0.13 5006 0 s Exit Fast Guard HSDir Running V2Dir Valid w Bandwidth=56 p accept 443 r test005eb pMOFAITWv2xgXIwlmgifX98BdiE /sfG4X/TZbkh9wwokg8g9hf89BU 2038-01-01 00:00:00 127.0.0.12 5005 0 s Exit Fast Guard HSDir Running V2Dir Valid w Bandwidth=56 p accept 1-65535 r test000a xxnuD8w5HJLdIeS8caty+umDoKk eTI2jeVylnfF0ILd+02fdwo5t2o 2038-01-01 00:00:00 127.0.0.1 5000 7000 s Authority Exit Fast Guard HSDir Running Stable V2Dir Valid w Bandwidth=180 p reject 1-65535 r test004ea yzXMxftj3wtBSF0uc9oHwccEcMw jmCdf8iX+yHkp/wC4Eik+MP8d7M 2038-01-01 00:00:00 127.0.0.11 5004 0 s Exit Fast Guard HSDir Running V2Dir Valid w Bandwidth=214 p accept 1-65535 . 250 OK mhatta-tordnsel-1d9141b/tests/integration/000077500000000000000000000000001527317632400206465ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/integration/README.md000066400000000000000000000055071527317632400221340ustar00rootroot00000000000000# Integration test against a private Tor network `run.sh` builds a small Tor network with [chutney](https://gitlab.torproject.org/tpo/core/chutney) (four directory authorities, three exits with different exit policies and exit addresses, one client), runs TorDNSEL against the client with active exit testing, and checks the DNS and HTTP answers, including that an exit whose traffic leaves from an address other than the advertised one is found by active testing. ```sh git clone https://gitlab.torproject.org/tpo/core/chutney.git cabal build sudo tests/integration/run.sh chutney $(cabal list-bin tordnsel) ``` With a build made by `runhaskell Setup.hs build`, the binary is `dist/build/tordnsel/tordnsel`. ## Requirements - `tor` and `tor-gencert` (Tor 0.4.8 or newer) - `dig`, `curl` and `ip` (iproute2) - Python 3 with the modules chutney needs: - `asyncore` and `asynchat`, removed from the standard library in Python 3.12 and needed by every chutney version so far - in addition, for current chutney from GitLab: `tomli_w`, `typeguard`, `paramiko` and `rpyc` On Debian sid: ```sh sudo apt install tor bind9-dnsutils curl iproute2 \ python3-pyasyncore python3-standard-asynchat \ python3-tomli-w python3-typeguard python3-paramiko python3-rpyc ``` If the script runs under `sudo`, modules installed with `pip install --user` are not seen; install them with apt (or system-wide). Alternatively, run it as a normal user with `SUDO=sudo` and a virtual environment first on the `PATH` (chutney runs the first `python3` it finds), as the CI does: ```sh python3 -m venv ~/chutney-venv ~/chutney-venv/bin/pip install pyasyncore pyasynchat PATH=~/chutney-venv/bin:$PATH SUDO=sudo tests/integration/run.sh chutney dist/build/tordnsel/tordnsel ``` ## Notes - Root is needed to add 10.200.0.{1,11,12,13,99} to the loopback interface. Run as a normal user with `SUDO=sudo` to use sudo for just that step. - The script uses ports 5000-5007, 7000-7003, 8000-8007, 9000-9007, 15353 and 18080 on the loopback interface. - The working directory is created under `$TMPDIR` (default `/tmp`). Tor can't use a Unix socket whose path is longer than about 100 bytes, so keep `$TMPDIR` short; the script stops early if it is too long. - On failure the script shows the end of chutney's output (kept in `chutney.log` in the working directory) and, if the Tor nodes didn't start, what `tor --verify-config` says about the first node's torrc. - `KEEP=1` keeps the working directory (TorDNSEL's log, the Tor nodes' logs and data) instead of deleting it. - A run takes a few minutes, mostly waiting for the network to bootstrap and for the exit tests (which run every 20 seconds or so). - `chutney/` holds the network definition and torrc templates, copied over a fresh copy of chutney at each run; your chutney clone is not modified. mhatta-tordnsel-1d9141b/tests/integration/chutney/000077500000000000000000000000001527317632400223255ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/integration/chutney/networks/000077500000000000000000000000001527317632400242015ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/integration/chutney/networks/tordnsel000066400000000000000000000023561527317632400257640ustar00rootroot00000000000000# A small Tor test network for TorDNSEL's integration test. # # - 4 directory authorities on 127.0.0.1 (not exits) # - exit A advertises 10.200.0.11 and exits from 10.200.0.11 # - exit B advertises 10.200.0.12 but exits from 10.200.0.99, which only # active testing can discover # - exit C advertises 10.200.0.13, exits from it, and only permits # connections to 10.200.0.0/16:6667 and *:443 # - a client whose control and SOCKS ports TorDNSEL uses # # The 10.200.0.0/24 addresses must be configured on the loopback interface # (see ../run.sh): Tor never binds outgoing exit connections to a source # address when the destination is in 127.0.0.0/8. Authority = Node(tag="a", authority=1, relay=1, torrc="authority.tmpl") ExitA = Node(tag="ea", relay=1, exit=1, torrc="tordnsel-exit.tmpl", ip="10.200.0.11", exit_bind="10.200.0.11") ExitB = Node(tag="eb", relay=1, exit=1, torrc="tordnsel-exit.tmpl", ip="10.200.0.12", exit_bind="10.200.0.99") ExitC = Node(tag="ec", relay=1, exit=1, torrc="tordnsel-exit-restricted.tmpl", ip="10.200.0.13", exit_bind="10.200.0.13") Client = Node(tag="c", client=1, torrc="tordnsel-client.tmpl") NODES = Authority.getN(4) + [ExitA, ExitB, ExitC] + Client.getN(1) ConfigureNodes(NODES) mhatta-tordnsel-1d9141b/tests/integration/chutney/networks/tordnsel-nodeconfig000066400000000000000000000035571527317632400301010ustar00rootroot00000000000000# The same network as "tordnsel", for chutney versions whose Node() takes # NodeConfig fields (2025 and later): torrc templates can no longer be chosen # per node, so the per-node settings go in extra_raw_torrc instead. # # - 4 directory authorities on 127.0.0.1 (not exits) # - exit A advertises 10.200.0.11 and exits from 10.200.0.11 # - exit B advertises 10.200.0.12 but exits from 10.200.0.99 # - exit C advertises 10.200.0.13, exits from it, and only permits # connections to 10.200.0.0/16:6667 and *:443 # - a client whose control and SOCKS ports TorDNSEL uses # # Exit C is configured as a non-exit relay that turns ExitRelay back on, so # that its exit policy is ours alone and not appended to chutney's default # exit policy (which accepts everything). chutney then leaves it out of the # authorities' TestingDirAuthVoteExit list, so the authorities vote the Exit # flag for every relay, as older chutney did. Authority = Node(tag="a", authority=True, relay=True, extra_raw_torrc="TestingDirAuthVoteExit *\n") ExitA = Node(tag="ea", relay=True, exit=True, ip="10.200.0.11", extra_raw_torrc="OutboundBindAddressExit 10.200.0.11\n") ExitB = Node(tag="eb", relay=True, exit=True, ip="10.200.0.12", extra_raw_torrc="OutboundBindAddressExit 10.200.0.99\n") ExitC = Node(tag="ec", relay=True, ip="10.200.0.13", extra_raw_torrc="ExitRelay 1\n" "ExitPolicyRejectPrivate 0\n" "ExitPolicy accept 10.200.0.0/16:6667\n" "ExitPolicy accept *:443\n" "ExitPolicy reject *:*\n" "OutboundBindAddressExit 10.200.0.13\n") Client = Node(tag="c", client=True, extra_raw_torrc="FetchUselessDescriptors 1\n") NODES = Authority.getN(4) + [ExitA, ExitB, ExitC] + Client.getN(1) ConfigureNodes(NODES) mhatta-tordnsel-1d9141b/tests/integration/chutney/torrc_templates/000077500000000000000000000000001527317632400255345ustar00rootroot00000000000000mhatta-tordnsel-1d9141b/tests/integration/chutney/torrc_templates/tordnsel-client.tmpl000066400000000000000000000003351527317632400315410ustar00rootroot00000000000000${include:common.i} SocksPort $socksport # TorDNSEL turns on FetchUselessDescriptors itself while it is connected; # turning it on here as well makes the client fetch descriptors from the start. FetchUselessDescriptors 1 mhatta-tordnsel-1d9141b/tests/integration/chutney/torrc_templates/tordnsel-exit-restricted.tmpl000066400000000000000000000002731527317632400334030ustar00rootroot00000000000000${include:relay-non-exit.tmpl} ExitRelay 1 ExitPolicyRejectPrivate 0 ExitPolicy accept 10.200.0.0/16:6667 ExitPolicy accept *:443 ExitPolicy reject *:* OutboundBindAddressExit $exit_bind mhatta-tordnsel-1d9141b/tests/integration/chutney/torrc_templates/tordnsel-exit.tmpl000066400000000000000000000003551527317632400312360ustar00rootroot00000000000000${include:relay-non-exit.tmpl} ${include:exit-v4.i} # Make exit connections originate from a chosen address, which may differ # from the advertised one (this is what TorDNSEL's active testing detects). OutboundBindAddressExit $exit_bind mhatta-tordnsel-1d9141b/tests/integration/run.sh000077500000000000000000000276231527317632400220230ustar00rootroot00000000000000#!/usr/bin/env bash # End-to-end test of TorDNSEL against a private Tor network built with # chutney: start the network, run TorDNSEL with active exit testing, and check # the answers of the DNS and HTTP interfaces. # # usage: tests/integration/run.sh CHUTNEY_DIR TORDNSEL_BINARY # # Needs tor and tor-gencert, python3 with the modules chutney needs (see # tests/integration/README.md), dig, curl and iproute2. The addresses # 10.200.0.{1,11,12,13,99} are added to the loopback interface, which needs # root; set SUDO=sudo to run just that step with sudo. Set KEEP=1 to keep the # working directory (logs, Tor data) afterwards. # -E makes the ERR trap below fire for failures inside functions too. set -Eeuo pipefail if [ $# -ne 2 ]; then echo "usage: $0 CHUTNEY_DIR TORDNSEL_BINARY" >&2 exit 64 fi here=$(cd "$(dirname "$0")" && pwd) chutney_src=$(cd "$1" && pwd) tordnsel=$(cd "$(dirname "$2")" && pwd)/$(basename "$2") work=$(cd "$(mktemp -d "${TMPDIR:-/tmp}/tordnsel-it.XXXXXX")" && pwd -P) dns_port=${DNS_PORT:-15353} http_port=${HTTP_PORT:-18080} zone=exitlist.example.com td_pid= failures=0 log() { printf '%s\n' "$*" >&2; } cleanup() { [ -n "$td_pid" ] && kill "$td_pid" 2>/dev/null || true if [ -d "$work/chutney" ]; then (cd "$work/chutney" && chutney_cmd stop >/dev/null 2>&1) || true fi if [ "${KEEP:-0}" = 1 ]; then log "Kept $work" else rm -rf "$work" fi } trap cleanup EXIT trap 'log "Failed at line $LINENO: $BASH_COMMAND"' ERR # logged NAME COMMAND...: run COMMAND with its output appended to # $work/NAME.log; if it fails, show the end of that log. logged() { local name=$1 shift if ! "$@" >>"$work/$name.log" 2>&1; then log "\"$*\" failed; the end of $work/$name.log:" tail -n 30 "$work/$name.log" | sed 's/^/ /' >&2 return 1 fi } # Tor won't bind a Unix socket whose path doesn't fit in sun_path (108 bytes # on Linux, 104 on the BSDs, including the terminating NUL), and chutney puts # each node's control socket deep inside our working directory. When the path # is too long every tor fails to start with nothing but "exit 1" from chutney, # so check before starting. sock=$work/chutney/net/nodes.0000000000/000ea/control if [ "${#sock}" -gt 103 ]; then log "The working directory $work is too long for Tor's control sockets" log "(e.g. $sock is ${#sock} bytes; at most 103 work everywhere)." log "Set TMPDIR to a directory with a shorter path, e.g. TMPDIR=/tmp." exit 69 fi # wait_for DESCRIPTION SECONDS COMMAND... wait_for() { local what=$1 secs=$2 shift 2 for _ in $(seq "$secs"); do if "$@" >/dev/null 2>&1; then return 0; fi sleep 1 done log "Timed out waiting for $what." return 1 } # check DESCRIPTION EXPECTED ACTUAL check() { if [ "$2" = "$3" ]; then printf 'ok %s\n' "$1" else printf 'FAIL %s\n expected: %s\n got: %s\n' "$1" "$2" "$3" failures=$((failures + 1)) fi } dns() { # dns NAME [TYPE [DIG-OPTIONS...]] -> "STATUS answers..." local name=$1 type=${2:-A} shift; [ $# -gt 0 ] && shift dig +norec +time=2 +tries=2 "$@" -p "$dns_port" @127.0.0.1 "$name" "$type" | awk '/status:/ { s = $6; sub(",", "", s) } /^[^;].*IN[ \t]+(A|TXT)[ \t]/ { a = a " " $NF } END { print s a }' } http() { curl -s --noproxy '*' "http://127.0.0.1:$http_port$1"; } log "Preparing chutney in $work." cp -r "$chutney_src" "$work/chutney" cd "$work/chutney" # Add our network definition and torrc templates. In some versions of # chutney networks/ and torrc_templates/ are symbolic links to directories # elsewhere in the tree, so copy into wherever they really are (never into # the original chutney clone). for d in networks torrc_templates; do if [ -L "$d" ]; then target=$(readlink -f "$d") case "$target" in "$work"/*) ;; *) rm "$d"; cp -r "$target" "$d"; target=$PWD/$d ;; esac else target=$PWD/$d fi mkdir -p "$target" cp -r "$here/chutney/$d/." "$target/" done # Python 3.13 removed cgitb, which older chutney uses for nicer tracebacks. # (grep finds nothing in newer chutney; with pipefail that must not stop us.) for f in $(grep -rlx 'import cgitb' lib 2>/dev/null || true); do sed -i 's/^import cgitb$/try:\n import cgitb\nexcept ImportError:\n cgitb = None/; s/^cgitb.enable(format="plain")$/if cgitb: cgitb.enable(format="plain")/' "$f" done # Don't require IPv6 on the test host. for f in torrc_templates/relay-non-dir.tmpl torrc_templates/relay-non-exit.tmpl; do if [ -f "$f" ]; then sed -i 's/^OrPort \$orport$/OrPort $orport IPv4Only/; s/^DirPort \$dirport$/DirPort $dirport IPv4Only/' "$f" fi done # Older chutney needs the asyncore/asynchat modules removed in Python 3.12. if grep -rqE '^[[:space:]]*import (asyncore|asynchat)' lib 2>/dev/null && ! python3 -c 'import asyncore, asynchat' 2>/dev/null; then log "chutney needs asyncore and asynchat; on Debian: apt install python3-pyasyncore python3-standard-asynchat" exit 69 fi log "Adding test addresses to the loopback interface." for a in 1 11 12 13 99; do ip -4 addr show dev lo | grep -q "inet 10\.200\.0\.$a/" || ${SUDO:-} ip addr add "10.200.0.$a/32" dev lo done export CHUTNEY_TOR=${CHUTNEY_TOR:-$(command -v tor)} export CHUTNEY_TOR_GENCERT=${CHUTNEY_TOR_GENCERT:-$(command -v tor-gencert)} export CHUTNEY_DATA_DIR=$work/chutney/net # chutney's command line changed: older versions take the network file with # every command, newer ones load it once with "init" and take --data-dir. if ./chutney --help 2>/dev/null | grep -q -- '--data-dir'; then new_cli=1 chutney_cmd() { ./chutney --data-dir "$CHUTNEY_DATA_DIR" "$@"; } else new_cli=0 chutney_cmd() { ./chutney "$@" networks/tordnsel; } fi mkdir -p "$CHUTNEY_DATA_DIR" rm -rf "$CHUTNEY_DATA_DIR"/nodes* # Our relays listen on 10.200.0.0/24; newer chutney only binds non-loopback # addresses it is told to trust. Older chutney ignores these variables. export CHUTNEY_TRUSTED_NETWORKS=10.200.0.0/24 export CHUTNEY_DISABLE_IPV6=1 log "Starting the Tor network." if [ "$new_cli" = 1 ]; then logged chutney ./chutney --data-dir "$CHUTNEY_DATA_DIR" init \ --net-from-script-path networks/tordnsel-nodeconfig fi logged chutney chutney_cmd configure if ! logged chutney chutney_cmd start; then # chutney only reports that tor exited. Ask the first node's tor why. for n in "$CHUTNEY_DATA_DIR"/nodes/*/; do log "tor --verify-config for ${n%/}:" "$CHUTNEY_TOR" --verify-config -f "${n}torrc" 2>&1 | grep -E '\[(warn|err)\]' | tail -n 5 | sed 's/^/ /' >&2 || true break done exit 1 fi nodes=$(readlink -f "$CHUTNEY_DATA_DIR/nodes") # The client is the last node; its directory name ends in "c" (e.g. 007c). client=$(ls -d "$nodes"/*c | tail -1) control_port=$(awk 'tolower($1) == "controlport" { sub(/.*:/, "", $2); print $2; exit }' "$client/torrc") socks_port=$(awk 'tolower($1) == "socksport" { sub(/.*:/, "", $2); print $2; exit }' "$client/torrc") wait_for "the client to bootstrap" 300 grep -q "Bootstrapped 100%" "$client/notice.log" log "Starting TorDNSEL." mkdir -p "$work/state" "$work/run" cat > "$work/tordnsel.conf" < "$work/tordnsel.out" 2>&1 & td_pid=$! tested() { [ "$(grep -o 'Exit test through router [0-9a-f]*' "$work/tordnsel.log" 2>/dev/null | sort -u | wc -l)" -ge 3 ] } wait_for "exit tests through all three exits" 600 tested grep 'Exit test through router' "$work/tordnsel.log" | awk '!seen[$8]++ { print " " $0 }' >&2 z=$zone echo "DNS, query type 1 (ip-port)" check "exit A, port 80" "NOERROR 127.0.0.2" "$(dns 11.0.200.10.80.7.100.51.198.ip-port.$z)" check "exit B by its tested exit address" "NOERROR 127.0.0.2" "$(dns 99.0.200.10.80.7.100.51.198.ip-port.$z)" check "exit C, port 80 rejected" "NXDOMAIN" "$(dns 13.0.200.10.80.7.100.51.198.ip-port.$z)" check "exit C, port 443" "NOERROR 127.0.0.2" "$(dns 13.0.200.10.443.7.100.51.198.ip-port.$z)" check "exit C, 10.200.0.1:6667" "NOERROR 127.0.0.2" "$(dns 13.0.200.10.6667.1.0.200.10.ip-port.$z)" check "an authority (not an exit)" "NXDOMAIN" "$(dns 1.0.0.127.80.7.100.51.198.ip-port.$z)" check "the RFC 5782 test address" "NOERROR 127.0.0.2" "$(dns 2.0.0.127.80.7.100.51.198.ip-port.$z)" check "empty non-terminal" "NOERROR" "$(dns 7.100.51.198.ip-port.$z)" check "TXT explanation" \ 'NOERROR 198.51.100.7:80"' "$(dns 11.0.200.10.80.7.100.51.198.ip-port.$z TXT)" echo "DNS, \"exit\" ({IP}.zone, the Tor Project's form)" check "exit B by its tested exit address" "NOERROR 127.0.0.2" "$(dns 99.0.200.10.$z)" check "an authority" "NXDOMAIN" "$(dns 1.0.0.127.$z)" check "TXT is one fingerprint" "1" \ "$(dig +short -p "$dns_port" @127.0.0.1 11.0.200.10.$z TXT | tr -d '"' | grep -cE '^[0-9A-F]{40}$')" echo "DNS, query type 2 (list)" check "exit C, ircnet" "NOERROR 127.0.0.2" "$(dns 13.0.200.10.ircnet.list.$z)" check "exit C, web" "NOERROR 127.0.0.2" "$(dns 13.0.200.10.web.list.$z)" check "unknown list" "NXDOMAIN" "$(dns 13.0.200.10.nosuch.list.$z)" echo "DNS, query type 3 (me; the asker is 127.0.0.1)" check "exit A, port 6667" "NOERROR 127.0.0.2" "$(dns 11.0.200.10.6667.me.$z)" check "exit C, port 6667" "NXDOMAIN" "$(dns 13.0.200.10.6667.me.$z)" check "exit C, port 6667, client subnet 10.200.0.1/32" "NOERROR 127.0.0.2" \ "$(dns 13.0.200.10.6667.me.$z A +subnet=10.200.0.1/32)" check "TTL 0" "0" \ "$(dig +noall +answer -p "$dns_port" @127.0.0.1 11.0.200.10.6667.me.$z | awk '{print $2}')" echo "DNS, misc" check "outside our zone" "REFUSED" "$(dns example.org)" check "EDNS(0) is echoed" "udp: 1232" \ "$(dig +norec -p "$dns_port" @127.0.0.1 $z SOA | grep -o 'udp: [0-9]*')" echo "DNS over TCP" check "exit A, port 80" "NOERROR 127.0.0.2" "$(dns 11.0.200.10.80.7.100.51.198.ip-port.$z A +tcp)" check "exit C, port 80 rejected" "NXDOMAIN" "$(dns 13.0.200.10.80.7.100.51.198.ip-port.$z A +tcp)" check "three queries on one connection" "3" \ "$(dig +norec +tcp +keepopen -p "$dns_port" @127.0.0.1 \ 11.0.200.10.80.7.100.51.198.ip-port.$z A \ 13.0.200.10.ircnet.list.$z A \ 13.0.200.10.80.7.100.51.198.ip-port.$z A | grep -c 'status: [A-Z]*')" echo "HTTP" check "/api/v1/ip-port" \ '{"query":"ip-port","ip":"10.200.0.99","dest":"198.51.100.7","port":80,"listed":true}' \ "$(http '/api/v1/ip-port?ip=10.200.0.99&port=80&dest=198.51.100.7')" check "/api/v1/list" \ '{"query":"list","ip":"10.200.0.13","list":"ircnet","listed":true}' \ "$(http '/api/v1/list?ip=10.200.0.13&list=ircnet')" check "/torbulkexitlist" "10.200.0.11 10.200.0.12 10.200.0.99" \ "$(http '/torbulkexitlist?ip=198.51.100.7&port=80' | tr '\n' ' ' | sed 's/ $//')" check "/exit-addresses lists three exits" "3" \ "$(http /exit-addresses | grep -c '^ExitNode')" check "/api/v1/exit lists exit C" '"listed":true' \ "$(http '/api/v1/exit?ip=10.200.0.13' | grep -o '"listed":true')" check "/metrics: three running exits" "tordnsel_running_exits 3" \ "$(http /metrics | grep '^tordnsel_running_exits ')" check "/api/ip, direct" '{"IsTor":false,"IP":"127.0.0.1"}' "$(http /api/ip)" echo if [ "$failures" -eq 0 ]; then echo "All checks passed." else echo "$failures check(s) failed. Logs: $work (rerun with KEEP=1 to keep them)." exit 1 fi mhatta-tordnsel-1d9141b/tests/runtests.hs000066400000000000000000000027641527317632400205570ustar00rootroot00000000000000----------------------------------------------------------------------------- -- | -- Module : Main -- License : Public domain (see LICENSE) -- -- Maintainer : tup.tuple@googlemail.com -- Stability : alpha -- Portability : portable -- -- Unit tests. -- ----------------------------------------------------------------------------- -- #hide module Main (main) where import Control.Monad (when) import Data.IORef (newIORef, readIORef, writeIORef) import System.Exit (exitFailure) import Test.HUnit (runTestTT, Test(..), Counts(..)) import TorDNSEL.Control.Concurrent.Link (withLinksDo) import qualified TorDNSEL.Config.Tests as Config import qualified TorDNSEL.Directory.Tests as Directory import qualified TorDNSEL.DNS.Tests as DNS import qualified TorDNSEL.DNS.Server.Tests as DNS.Server import qualified TorDNSEL.ExitList.Tests as ExitList import qualified TorDNSEL.Properties as Properties import qualified TorDNSEL.TorControl.Tests as TorControl import qualified TorDNSEL.Web.Tests as Web -- Some tests start TorDNSEL's threads, which need withLinksDo; it may only be -- used once, in the main thread. main :: IO () main = do result <- newIORef Nothing withLinksDo $ writeIORef result . Just =<< runTests counts <- maybe exitFailure return =<< readIORef result when (errors counts + failures counts > 0) exitFailure where runTests = runTestTT . TestList $ [ Config.tests, Directory.tests, DNS.tests, DNS.Server.tests , ExitList.tests, TorControl.tests, Web.tests, Properties.tests ] mhatta-tordnsel-1d9141b/tordnsel.cabal000066400000000000000000000124421527317632400200020ustar00rootroot00000000000000cabal-version: 2.4 name: tordnsel version: 0.4.0 synopsis: provides a DNSBL-style interface for detecting Tor exit nodes description: TorDNSEL implements a design for a DNSBL-style interface for detecting connections exiting the Tor network. This design and its rationale is described in doc/torel-design.md. license: LicenseRef-PublicDomain license-file: LICENSE homepage: https://github.com/mhatta/tordnsel bug-reports: https://github.com/mhatta/tordnsel/issues author: tup maintainer: Masayuki Hatta copyright: Public domain category: Network build-type: Simple tested-with: GHC == 9.4.7, GHC == 9.10.3 extra-doc-files: README.md, ChangeLog, TODO.md, doc/torel-design.md extra-source-files: tests/data/*.txt data-files: config/tordnsel.conf.sample, contrib/cacti-input.pl, contrib/tordnsel-init.d-script.sample, doc/tordnsel.8 source-repository head type: git location: https://github.com/mhatta/tordnsel.git common shared default-language: Haskell2010 default-extensions: FlexibleContexts FlexibleInstances TypeSynonymInstances MultiParamTypeClasses PatternGuards BangPatterns ViewPatterns ScopedTypeVariables GeneralizedNewtypeDeriving RankNTypes StandaloneDeriving build-depends: base >= 4.17 && < 5, array >= 0.5 && < 0.6, binary >= 0.8 && < 0.9, bytestring >= 0.11 && < 0.13, conduit >= 1.3 && < 1.4, conduit-extra >= 1.3 && < 1.4, containers >= 0.6 && < 0.9, cryptohash-sha256 >= 0.11.101 && < 0.12, deepseq >= 1.4 && < 1.6, directory >= 1.3 && < 1.4, mtl >= 2.2 && < 2.4, network >= 3.1 && < 3.3, stm >= 2.5 && < 2.6, time >= 1.9 && < 1.15, transformers >= 0.5 && < 0.7, unix >= 2.7 && < 2.9 ghc-options: -Wall -Wno-unused-do-bind -Wno-name-shadowing -Wno-incomplete-uni-patterns -Wno-type-defaults -Wno-x-partial -Wno-unrecognised-warning-flags library import: shared hs-source-dirs: src ghc-options: -funbox-strict-fields cpp-options: -DVERSION="0.4.0" exposed-modules: TorDNSEL.AddressPattern TorDNSEL.Config TorDNSEL.Config.Internals TorDNSEL.Control.Concurrent.Future TorDNSEL.Control.Concurrent.Link TorDNSEL.Control.Concurrent.Link.Internals TorDNSEL.Control.Concurrent.Util TorDNSEL.Directory TorDNSEL.Directory.Internals TorDNSEL.DistinctQueue TorDNSEL.DNS TorDNSEL.DNS.Internals TorDNSEL.DNS.Server TorDNSEL.DNS.Server.Internals TorDNSEL.Document TorDNSEL.ExitList TorDNSEL.ExitTest.Initiator TorDNSEL.ExitTest.Initiator.Internals TorDNSEL.ExitTest.Request TorDNSEL.ExitTest.Server TorDNSEL.ExitTest.Server.Internals TorDNSEL.Files TorDNSEL.Log TorDNSEL.Log.Internals TorDNSEL.Main TorDNSEL.NetworkState TorDNSEL.NetworkState.Internals TorDNSEL.NetworkState.Storage TorDNSEL.NetworkState.Storage.Internals TorDNSEL.NetworkState.Types TorDNSEL.Random TorDNSEL.Socks TorDNSEL.Socks.Internals TorDNSEL.Statistics TorDNSEL.Statistics.Internals TorDNSEL.TorControl TorDNSEL.TorControl.Internals TorDNSEL.Util TorDNSEL.Web TorDNSEL.Web.Internals executable tordnsel import: shared main-is: tordnsel.hs hs-source-dirs: app build-depends: tordnsel ghc-options: -threaded -rtsopts test-suite runtests import: shared type: exitcode-stdio-1.0 main-is: runtests.hs hs-source-dirs: tests other-modules: TorDNSEL.Config.Tests TorDNSEL.Directory.Tests TorDNSEL.DNS.Tests TorDNSEL.DNS.Server.Tests TorDNSEL.ExitList.Tests TorDNSEL.Fixtures TorDNSEL.Properties TorDNSEL.TorControl.Tests TorDNSEL.Web.Tests build-depends: tordnsel, HUnit >= 1.6 && < 1.7, QuickCheck >= 2.14 && < 2.17 ghc-options: -threaded -Wno-missing-signatures