├── pkg ├── template │ ├── debian │ │ ├── compat │ │ ├── source │ │ │ ├── format │ │ │ └── lintian-overrides │ │ ├── README.logdir │ │ ├── rules │ │ ├── bowline.install │ │ ├── bowline.lintian-overrides │ │ ├── bowline.logrotate │ │ ├── control │ │ ├── changelog │ │ ├── copyright │ │ └── bowline.init │ └── Makefile └── proto-checks.sh ├── dnsext-do53 ├── CHANGELOG.md ├── test │ ├── Spec.hs │ ├── LookupSpec.hs │ └── IOSpec.hs ├── DNS │ └── Do53 │ │ ├── Id.hs │ │ ├── Imports.hs │ │ ├── System.hs │ │ ├── Internal.hs │ │ ├── Client.hs │ │ └── VC.hs ├── util │ └── cli.hs ├── LICENSE ├── cbits │ └── dns.c └── dnsext-do53.cabal ├── dnsext-dox ├── CHANGELOG.md ├── test │ └── Spec.hs ├── DNS │ └── DoX │ │ ├── Internal.hs │ │ ├── Imports.hs │ │ ├── HTTP3.hs │ │ └── SAN.hs ├── LICENSE └── dnsext-dox.cabal ├── dnsext-svcb ├── CHANGELOG.md ├── test │ └── Spec.hs ├── DNS │ ├── SVCB │ │ ├── Internal.hs │ │ ├── Imports.hs │ │ ├── Key.hs │ │ └── Params.hs │ └── SVCB.hs ├── LICENSE └── dnsext-svcb.cabal ├── dnsext-types ├── CHANGELOG.md ├── test │ └── Spec.hs ├── DNS │ ├── Wire.hs │ ├── Wire │ │ └── Types.hs │ └── Types │ │ ├── Opaque.hs │ │ ├── Imports.hs │ │ ├── Parser.hs │ │ ├── Seconds.hs │ │ ├── Time.hs │ │ ├── Internal.hs │ │ ├── Encode.hs │ │ └── ShortBuilder.hs ├── LICENSE └── dnsext-types.cabal ├── dnsext-utils ├── CHANGELOG.md ├── test │ ├── Spec.hs │ ├── cache.hs │ ├── ProtocolBufferSpec.hs │ ├── ArraySpec.hs │ ├── SchemaSpec.hs │ └── FastStreamSpec.hs ├── DNS │ ├── Parser.hs │ ├── RRCache.hs │ ├── Parser │ │ └── State.hs │ ├── ZoneFile.hs │ ├── ZoneFile │ │ ├── IO.hs │ │ ├── ParserBase.hs │ │ └── ParserDNSSEC.hs │ ├── Array.hs │ ├── TimeCache.hs │ ├── ThreadAsync.hs │ ├── ThreadStats.hs │ └── Utils │ │ └── AutoUpdate.hs ├── LICENSE └── dnsext-utils.cabal ├── .gitignore ├── dnsext-bowline ├── CHANGELOG.md ├── prometheus.yml.example ├── bowline │ ├── stub-example.conf │ ├── svcb-example.conf │ ├── local-example.conf │ ├── SockOpt.hsc │ ├── bowline.conf │ ├── Types.hs │ ├── DNSTAP.hs │ ├── SocketUtil.hs │ └── Prometheus.hs ├── include │ ├── HsSockOpt.h │ └── HsSockOptConfig.h.in ├── configure.ac ├── dump │ └── dump.hs ├── dug │ ├── Types.hs │ ├── SocketUtil.hs │ └── Iterative.hs ├── LICENSE └── test-dug.hs ├── dnsext-dnssec ├── CHANGELOG.md ├── test │ └── Spec.hs ├── DNS │ └── SEC │ │ ├── Verify.hs │ │ ├── Verify │ │ ├── N3SHA.hs │ │ ├── SHA.hs │ │ ├── EdDSA.hs │ │ └── ECDSA.hs │ │ ├── Internal.hs │ │ ├── Imports.hs │ │ ├── HashAlg.hs │ │ ├── Time.hs │ │ ├── Flags.hs │ │ ├── PubKey.hs │ │ ├── PubAlg.hs │ │ └── Opts.hs ├── LICENSE └── dnsext-dnssec.cabal ├── dnsext-iterative ├── CHANGELOG.md ├── test │ └── Spec.hs ├── Setup.hs ├── root.hints.test ├── DNS │ └── Iterative │ │ ├── stats.el │ │ ├── RootTrustAnchors.hs │ │ ├── Query.hs │ │ ├── Query │ │ ├── Local.hs │ │ ├── StubZone.hs │ │ ├── TestEnv.hs │ │ ├── ZoneMap.hs │ │ └── Norec.hs │ │ ├── Internal.hs │ │ ├── Server │ │ ├── HTTP3.hs │ │ ├── PrometheusHisto.hs │ │ ├── Bench.hs │ │ ├── UDP.hs │ │ ├── TCP.hs │ │ ├── Types.hs │ │ └── CtlRecv.hs │ │ ├── Imports.hs │ │ └── Server.hs └── LICENSE ├── docs ├── _config.yml ├── index.md ├── dnsext.md ├── ddrd.md ├── bowline.md └── _layouts │ └── default.html ├── README.md ├── format.sh ├── cabal.project ├── test.sh ├── root-data ├── root.key └── root.hints └── fourmolu.yaml /pkg/template/debian/compat: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /dnsext-do53/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.0.0 2 | -------------------------------------------------------------------------------- /dnsext-dox/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.0.0 2 | -------------------------------------------------------------------------------- /dnsext-svcb/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.0.0 2 | -------------------------------------------------------------------------------- /dnsext-types/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.0.0 2 | -------------------------------------------------------------------------------- /dnsext-utils/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.0.0 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | pkg/work 3 | -------------------------------------------------------------------------------- /dnsext-bowline/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.0.0 2 | -------------------------------------------------------------------------------- /dnsext-dnssec/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.0.0 2 | -------------------------------------------------------------------------------- /dnsext-iterative/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.0.0 2 | -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-minimal -------------------------------------------------------------------------------- /pkg/template/debian/source/format: -------------------------------------------------------------------------------- 1 | 3.0 (native) 2 | -------------------------------------------------------------------------------- /pkg/template/debian/README.logdir: -------------------------------------------------------------------------------- 1 | log directory for bowline. 2 | -------------------------------------------------------------------------------- /pkg/template/debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | %: 3 | dh $@ 4 | -------------------------------------------------------------------------------- /dnsext-do53/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /dnsext-dox/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /dnsext-svcb/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /dnsext-types/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /dnsext-utils/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /dnsext-dnssec/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /dnsext-iterative/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /pkg/template/debian/bowline.install: -------------------------------------------------------------------------------- 1 | debian/README.logdir opt/bowline/log 2 | -------------------------------------------------------------------------------- /pkg/template/debian/source/lintian-overrides: -------------------------------------------------------------------------------- 1 | bowline source: source-is-missing 2 | -------------------------------------------------------------------------------- /dnsext-iterative/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /pkg/template/debian/bowline.lintian-overrides: -------------------------------------------------------------------------------- 1 | bowline binary: dir-or-file-in-opt 2 | -------------------------------------------------------------------------------- /dnsext-utils/test/cache.hs: -------------------------------------------------------------------------------- 1 | import CacheProp (run) 2 | 3 | main :: IO () 4 | main = run 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![GitHub Actions status](https://github.com/iijlab/dnsext/workflows/Haskell%20CI/badge.svg) 2 | 3 | Home page: https://iijlab.github.io/dnsext/ 4 | -------------------------------------------------------------------------------- /format.sh: -------------------------------------------------------------------------------- 1 | for pkg in dnsext-types dnsext-dnssec dnsext-utils dnsext-do53 dnsext-svcb dnsext-dox dnsext-iterative dnsext-bowline 2 | do 3 | (cd $pkg; cabal format ${pkg}.cabal) 4 | done 5 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | dnsext-types 3 | dnsext-dnssec 4 | dnsext-svcb 5 | dnsext-utils 6 | dnsext-do53 7 | dnsext-dox 8 | dnsext-iterative 9 | dnsext-bowline 10 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/Parser.hs: -------------------------------------------------------------------------------- 1 | module DNS.Parser ( 2 | module DNS.Parser.Class, 3 | module DNS.Parser.State, 4 | ) where 5 | 6 | import DNS.Parser.Class 7 | import DNS.Parser.State 8 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/RRCache.hs: -------------------------------------------------------------------------------- 1 | module DNS.RRCache ( 2 | module DNS.RRCache.Managed, 3 | module DNS.RRCache.Types, 4 | ) where 5 | 6 | import DNS.RRCache.Managed 7 | import DNS.RRCache.Types 8 | -------------------------------------------------------------------------------- /dnsext-bowline/prometheus.yml.example: -------------------------------------------------------------------------------- 1 | scrape_configs: 2 | # put it under scrape_configs alongside other job_names 3 | - job_name: bowline 4 | static_configs: 5 | - targets: ['localhost:8080'] 6 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Verify.hs: -------------------------------------------------------------------------------- 1 | module DNS.SEC.Verify ( 2 | module DNS.SEC.Verify.Types, 3 | module DNS.SEC.Verify.Verify, 4 | ) 5 | where 6 | 7 | import DNS.SEC.Verify.Types 8 | import DNS.SEC.Verify.Verify 9 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/stub-example.conf: -------------------------------------------------------------------------------- 1 | ## stub-zone example config 2 | stub-zone: a.example. 3 | stub-addr: 192.0.2.2 4 | stub-host: ns.b.example 5 | 6 | stub-zone: b.example. 7 | stub-addr: 192.0.2.3@2053 # @ 8 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Wire.hs: -------------------------------------------------------------------------------- 1 | module DNS.Wire ( 2 | module DNS.Wire.Builder, 3 | module DNS.Wire.Parser, 4 | module DNS.Wire.Types, 5 | ) where 6 | 7 | import DNS.Wire.Builder 8 | import DNS.Wire.Parser 9 | import DNS.Wire.Types 10 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Wire/Types.hs: -------------------------------------------------------------------------------- 1 | module DNS.Wire.Types where 2 | 3 | import Data.Array (Array) 4 | import Data.ByteString.Short 5 | 6 | type Label = ShortByteString 7 | type Labels = [Label] 8 | type WireLabels = Array Int Label 9 | 10 | type Position = Int 11 | -------------------------------------------------------------------------------- /dnsext-iterative/root.hints.test: -------------------------------------------------------------------------------- 1 | ; 2 | ; OPERATED BY WIDE 3 | ; 4 | . 3600000 NS M.ROOT-SERVERS.NET. 5 | M.ROOT-SERVERS.NET. 3600000 A 202.12.27.33 6 | M.ROOT-SERVERS.NET. 3600000 AAAA 2001:dc3::35 7 | ; End of file 8 | -------------------------------------------------------------------------------- /dnsext-bowline/include/HsSockOpt.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef HSSOCKOPT_H 3 | #define HSSOCKOPT_H 4 | 5 | #include "HsSockOptConfig.h" 6 | 7 | #ifdef HAVE_NETINET_IN_H 8 | # include 9 | #endif 10 | #ifdef HAVE_NETINET_TCP_H 11 | # include 12 | #endif 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /pkg/template/Makefile: -------------------------------------------------------------------------------- 1 | 2 | prefix = $(DESTDIR)/opt/bowline 3 | 4 | all: 5 | 6 | install: 7 | mkdir -p $(prefix)/bin 8 | for n in ./bin/* ; do \ 9 | install -m 755 $$n $(prefix)/bin/ ; \ 10 | done 11 | mkdir -p $(prefix)/etc 12 | for n in ./etc/* ; do \ 13 | install -m 644 $$n $(prefix)/etc/ ; \ 14 | done 15 | 16 | clean: 17 | -------------------------------------------------------------------------------- /test.sh: -------------------------------------------------------------------------------- 1 | cab delete -r dnsext-types 2 | 3 | for pkg in dnsext-types dnsext-dnssec dnsext-svcb dnsext-utils dnsext-do53 dnsext-dox dnsext-iterative 4 | do 5 | (cd $pkg; cab install -d -t; cab clean; cab conf -t; cab build; cab test; cab doctest $pkg; cab install) 6 | done 7 | 8 | (cd dnsext-bowline; cab install -d -t; cab clean; cab conf -t; cab build; cab test) 9 | -------------------------------------------------------------------------------- /pkg/template/debian/bowline.logrotate: -------------------------------------------------------------------------------- 1 | 2 | /opt/bowline/log/bowline.log { 3 | missingok 4 | weekly 5 | rotate 106 6 | dateext 7 | create 0664 root adm 8 | minsize 1M 9 | compress 10 | postrotate 11 | /usr/bin/curl http://127.0.0.1:8080/reopen-log 12 | endscript 13 | } 14 | -------------------------------------------------------------------------------- /dnsext-svcb/DNS/SVCB/Internal.hs: -------------------------------------------------------------------------------- 1 | module DNS.SVCB.Internal ( 2 | get_svcb, 3 | get_https, 4 | SvcParamValue (..), 5 | SPV_Mandatory (..), 6 | SPV_Port (..), 7 | SPV_IPv4Hint (..), 8 | SPV_IPv6Hint (..), 9 | SPV_ALPN (..), 10 | SPV_Opaque (..), 11 | SPV_DoHPath (..), 12 | ) 13 | where 14 | 15 | import DNS.SVCB.SVCB 16 | import DNS.SVCB.Value 17 | -------------------------------------------------------------------------------- /dnsext-dox/DNS/DoX/Internal.hs: -------------------------------------------------------------------------------- 1 | module DNS.DoX.Internal ( 2 | http2Resolver, 3 | http2PersistentResolver, 4 | http2cResolver, 5 | http2cPersistentResolver, 6 | http3Resolver, 7 | http3PersistentResolver, 8 | tlsResolver, 9 | tlsPersistentResolver, 10 | quicResolver, 11 | quicPersistentResolver, 12 | ) 13 | where 14 | 15 | import DNS.DoX.HTTP2 16 | import DNS.DoX.HTTP3 17 | import DNS.DoX.QUIC 18 | import DNS.DoX.TLS 19 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/stats.el: -------------------------------------------------------------------------------- 1 | (defun fix-pattern-region (beg end) 2 | (interactive "r") 3 | (save-restriction 4 | (narrow-to-region beg end) 5 | (save-excursion 6 | (goto-char (point-min)) 7 | (let ((i 0)) 8 | (while (re-search-forward "^pattern [^=]+= StatsIx +\\([0-9]+\\)" nil t) 9 | (delete-region (match-beginning 1) (match-end 0)) 10 | (goto-char (match-beginning 1)) 11 | (insert (format "%d" i)) 12 | (setq i (+ i 1))))))) 13 | -------------------------------------------------------------------------------- /root-data/root.key: -------------------------------------------------------------------------------- 1 | . IN DS 20326 8 2 E06D44B80B8F1D39A95C0B0D7C65D08458E880409BBC683457104237C7F8EC8D 2 | . 172800 IN DNSKEY 257 3 8 AwEAAaz/tAm8yTn4Mfeh5eyI96WSVexTBAvkMgJzkKTOiW1vkIbzxeF3 +/4RgWOq7HrxRixHlFlExOLAJr5emLvN7SWXgnLh4+B5xQlNVz8Og8kv ArMtNROxVQuCaSnIDdD5LKyWbRd2n9WGe2R8PzgCmr3EgVLrjyBxWezF 0jLHwVN8efS3rCj/EWgvIWgb9tarpVUDK/b58Da+sqqls3eNbuv7pr+e oZG+SrDK6nWeL3c6H5Apxz7LjVc1uTIdsIXxuOLYA4/ilBmSVIzuDWfd RUfhHdY6+cn8HFRm+2hM8AnXGXws9555KrUB5qihylGa8subX2Nn6UwN R1AkUTV74bU= 3 | -------------------------------------------------------------------------------- /dnsext-bowline/configure.ac: -------------------------------------------------------------------------------- 1 | AC_INIT([Haskell bowline package], 2 | [0.0.0], 3 | [], 4 | [bowline]) 5 | 6 | AC_CONFIG_SRCDIR([include/HsSockOpt.h]) 7 | 8 | AC_CONFIG_HEADERS([include/HsSockOptConfig.h]) 9 | 10 | AC_CANONICAL_HOST 11 | 12 | AC_CHECK_HEADERS([netinet/in.h netinet/tcp.h]) 13 | 14 | AC_CHECK_DECLS([IPPROTO_TCP], [], [], 15 | [AC_INCLUDES_DEFAULT[ 16 | #ifdef HAVE_NETINET_IN_H 17 | # include 18 | #endif 19 | ]]) 20 | 21 | AC_OUTPUT 22 | -------------------------------------------------------------------------------- /pkg/template/debian/control: -------------------------------------------------------------------------------- 1 | Source: bowline 2 | Priority: extra 3 | Section: haskell 4 | Maintainer: Kei Hibino 5 | Build-Depends: 6 | dpkg-dev (>= 1.18.0), 7 | debhelper (>= 9), 8 | Standards-Version: 3.9.8 9 | 10 | Package: bowline 11 | Architecture: any 12 | Depends: curl, ${misc:Depends}, ${shlibs:Depends} 13 | Description: full service resolver Bowline, executables 14 | Full service resolver implementation Bowline, written in Haskell. 15 | . 16 | This package provides executable files and bootstrap scripts. 17 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/svcb-example.conf: -------------------------------------------------------------------------------- 1 | local-zone: example. static 2 | local-data: 'example. 3600 IN HTTPS 1 srv.example.' 3 | 4 | local-zone: _dns.resolver.arpa. static 5 | local-data: '_dns.resolver.arpa. 300 IN SVCB 1 c.example. alpn=h2,h3 port=443 ipv4hint=192.0.2.19 ipv6hint=2001:db8::13 dohpath="/dns-query{?dns}"' 6 | local-data: '_dns.resolver.arpa. 300 IN SVCB 2 c.example. alpn=dot port=853 ipv4hint=192.0.2.19 ipv6hint=2001:db8::13' 7 | local-data: '_dns.resolver.arpa. 300 IN SVCB 3 c.example. alpn=doq port=853 ipv4hint=192.0.2.19 ipv6hint=2001:db8::13' 8 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Types/Opaque.hs: -------------------------------------------------------------------------------- 1 | module DNS.Types.Opaque ( 2 | Opaque, 3 | null, 4 | singleton, 5 | concat, 6 | splitAt, 7 | uncons, 8 | length, 9 | foldr, 10 | toByteString, 11 | fromByteString, 12 | toShortByteString, 13 | fromShortByteString, 14 | toString, 15 | toBase16, 16 | fromBase16, 17 | toBase32Hex, 18 | fromBase32Hex, 19 | toBase64, 20 | fromBase64, 21 | ) where 22 | 23 | import Prelude hiding (concat, foldr, length, null, splitAt) 24 | 25 | import DNS.Types.Opaque.Internal 26 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/local-example.conf: -------------------------------------------------------------------------------- 1 | ## local-zone / local-data example 2 | ## 3 | ## Because the content must conform to zone file syntax -- which allows the use of double-quotes `"` --, 4 | ## it is recommended to enclose the string for `local-data:` in single-quotes `'`. 5 | 6 | local-zone: z.example. static 7 | local-data: 'a.z.example. 10800 A 192.0.2.9' 8 | local-data: 't1.z.example. 10800 IN TXT "foo bar baz"' 9 | local-data: 't2.z.example. 10800 IN TXT "foo bar" "baz"' 10 | 11 | local-zone: 'y.example.' redirect 12 | local-data: 'y.example. 10800 A 192.0.2.10' 13 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Verify/N3SHA.hs: -------------------------------------------------------------------------------- 1 | module DNS.SEC.Verify.N3SHA ( 2 | n3sha1, 3 | ) 4 | where 5 | 6 | -- memory 7 | 8 | -- cryptonite 9 | import Crypto.Hash (HashAlgorithm, hashWith) 10 | import Crypto.Hash.Algorithms (SHA1 (..)) 11 | import DNS.SEC.Verify.Types 12 | import qualified Data.ByteArray as BA 13 | 14 | n3sha1 :: NSEC3Impl 15 | n3sha1 = shaHelper SHA1 16 | 17 | shaHelper :: HashAlgorithm hash => hash -> NSEC3Impl 18 | shaHelper hash = 19 | NSEC3Impl 20 | { nsec3IGetHash = hashWith hash 21 | , nsec3IGetBytes = BA.convert 22 | } 23 | -------------------------------------------------------------------------------- /docs/index.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: dnsext 4 | rank: 1 5 | --- 6 | 7 | # DNS stack written in Haskell 8 | 9 | - [`bowline`](bowline.html): a full resolver server (cache server) 10 | - [`dug`](dug.html): a stub resolver command 11 | - [`ddrd`](ddrd.html): a stub resolver daemon for DDR (Discovery of Designated Resolvers) 12 | - [`dnsext-*`](dnsext.html): a new series of DNS libraries based on the experience of the [`dns`](https://github.com/kazu-yamamoto/dns) library in Haskell. 13 | 14 | Future readings: 15 | 16 | - Status report: [Developing a full resolver](https://www.iijlab.net/en/projects/Underpinning/dns.html) -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/RootTrustAnchors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module DNS.Iterative.RootTrustAnchors ( 4 | rootSepDS, 5 | ) where 6 | 7 | import DNS.SEC 8 | import qualified DNS.Types.Opaque as Opaque 9 | 10 | {- import trust-anchor DS RData from 11 | https://data.iana.org/root-anchors/root-anchors.xml -} 12 | rootSepDS :: RD_DS 13 | rootSepDS = RD_DS 20326 RSASHA256 SHA256 digest 14 | where 15 | digest = 16 | either (error . ("rootSepDS: bad configuration: " ++)) id $ 17 | Opaque.fromBase16 18 | "E06D44B80B8F1D39A95C0B0D7C65D08458E880409BBC683457104237C7F8EC8D" 19 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/SockOpt.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | module SockOpt where 3 | 4 | import Network.Socket (SocketOption (..)) 5 | 6 | #include 7 | 8 | -- | TCP_KEEPIDLE 9 | pattern TcpKeepIdle :: SocketOption 10 | #ifdef TCP_KEEPIDLE 11 | pattern TcpKeepIdle = SockOpt (#const IPPROTO_TCP) (#const TCP_KEEPIDLE) 12 | #else 13 | pattern TcpKeepIdle = SockOpt (-1) (-1) 14 | #endif 15 | 16 | -- | TCP_KEEPINTVL 17 | pattern TcpKeepInterval :: SocketOption 18 | #ifdef TCP_KEEPINTVL 19 | pattern TcpKeepInterval = SockOpt (#const IPPROTO_TCP) (#const TCP_KEEPINTVL) 20 | #else 21 | pattern TcpKeepInterval = SockOpt (-1) (-1) 22 | #endif 23 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Verify/SHA.hs: -------------------------------------------------------------------------------- 1 | module DNS.SEC.Verify.SHA ( 2 | sha1, 3 | sha256, 4 | sha384, 5 | ) 6 | where 7 | 8 | -- memory 9 | 10 | -- cryptonite 11 | import Crypto.Hash (HashAlgorithm, hashWith) 12 | import Crypto.Hash.Algorithms (SHA1 (..), SHA256 (..), SHA384 (..)) 13 | import DNS.SEC.Verify.Types 14 | import qualified Data.ByteArray as BA 15 | 16 | sha1, sha256, sha384 :: DSImpl 17 | sha1 = shaHelper SHA1 18 | sha256 = shaHelper SHA256 19 | sha384 = shaHelper SHA384 20 | 21 | shaHelper :: HashAlgorithm hash => hash -> DSImpl 22 | shaHelper hash = 23 | DSImpl 24 | { dsIGetDigest = hashWith hash 25 | , dsIVerify = verify 26 | } 27 | where 28 | verify digest bs = BA.convert digest == bs 29 | -------------------------------------------------------------------------------- /dnsext-do53/DNS/Do53/Id.hs: -------------------------------------------------------------------------------- 1 | module DNS.Do53.Id ( 2 | singleGenId, 3 | newConcurrentGenId, 4 | ) 5 | where 6 | 7 | import Control.Concurrent 8 | import Control.Monad 9 | import DNS.Types 10 | import Data.Array 11 | import System.Random.Stateful ( 12 | globalStdGen, 13 | initStdGen, 14 | newAtomicGenM, 15 | uniformWord16, 16 | ) 17 | 18 | singleGenId :: IO Identifier 19 | singleGenId = uniformWord16 globalStdGen 20 | 21 | newConcurrentGenId :: IO (IO Identifier) 22 | newConcurrentGenId = do 23 | n <- getNumCapabilities 24 | gs <- replicateM n (initStdGen >>= newAtomicGenM) 25 | let arr = listArray (0, n - 1) gs 26 | return $ do 27 | (i, _) <- myThreadId >>= threadCapability 28 | uniformWord16 (arr ! i) 29 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Query.hs: -------------------------------------------------------------------------------- 1 | module DNS.Iterative.Query ( 2 | -- * Env, Types 3 | module DNS.Iterative.Query.Env, 4 | module DNS.Iterative.Query.Types, 5 | 6 | -- * Iterative query 7 | resolveResponseIterative, 8 | foldResponseIterative, 9 | foldResponseIterative', 10 | 11 | -- * Cache 12 | foldResponseCached, 13 | ) where 14 | 15 | import DNS.Do53.Client 16 | import DNS.Iterative.Query.API 17 | import DNS.Iterative.Query.Env 18 | import DNS.Iterative.Query.Types (VResult (..)) 19 | import DNS.Types 20 | 21 | resolveResponseIterative :: Env -> Question -> QueryControls -> IO (Either String DNSMessage) 22 | resolveResponseIterative env q ictl = foldResponseIterative' Left (\_ -> Right) env 0 {- dummy id -} [q] q ictl 23 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Internal.hs: -------------------------------------------------------------------------------- 1 | module DNS.SEC.Internal ( 2 | get_rrsig, 3 | get_ds, 4 | get_nsec, 5 | get_dnskey, 6 | get_nsec3, 7 | get_nsec3param, 8 | get_cds, 9 | get_cdnskey, 10 | get_dau, 11 | get_dhu, 12 | get_n3u, 13 | putPubAlg, 14 | getPubAlg, 15 | putPubKey, 16 | getPubKey, 17 | putDigestAlg, 18 | getDigestAlg, 19 | putHashAlg, 20 | getHashAlg, 21 | putDNSKEYflags, 22 | getDNSKEYflags, 23 | putNSEC3flags, 24 | getNSEC3flags, 25 | putDNSTime, 26 | getDNSTime, 27 | toPubKey_RSA, 28 | ) 29 | where 30 | 31 | import DNS.SEC.Flags 32 | import DNS.SEC.HashAlg 33 | import DNS.SEC.Opts 34 | import DNS.SEC.PubAlg 35 | import DNS.SEC.PubKey 36 | import DNS.SEC.Time 37 | import DNS.SEC.Types 38 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Query/Local.hs: -------------------------------------------------------------------------------- 1 | module DNS.Iterative.Query.Local where 2 | 3 | -- dnsext packages 4 | import DNS.Types 5 | 6 | -- this package 7 | 8 | import DNS.Iterative.Query.Class 9 | import DNS.Iterative.Query.LocalZone (lookupApex, lookupName) 10 | 11 | {- FOURMOLU_DISABLE -} 12 | takeLocalResult :: Env -> Question -> a -> a -> (ResultRRS -> a) -> a 13 | takeLocalResult env q@Question{qname=dom,qclass=cls} denied nothing just 14 | | CH <- cls, (apexes, names) <- chaosZones_ env, Just apex <- lookupApex apexes dom = maybe denied just $ lookupName names apex q 15 | | IN <- cls, (apexes, names) <- localZones_ env, Just apex <- lookupApex apexes dom = maybe denied just $ lookupName names apex q 16 | | otherwise = nothing 17 | {- FOURMOLU_ENABLE -} 18 | -------------------------------------------------------------------------------- /dnsext-utils/test/ProtocolBufferSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ProtocolBufferSpec where 4 | 5 | import Data.ByteString () 6 | import Test.Hspec 7 | 8 | import DNS.TAP.ProtocolBuffer 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "encode & decode" $ do 13 | it "can encode then decode" $ do 14 | roundTrip empty 15 | roundTrip $ setVAR 1 10000 empty 16 | roundTrip $ setVAR 1 12345 empty 17 | roundTrip $ setI32 2 10000 empty 18 | roundTrip $ setI32 2 12345 empty 19 | roundTrip $ setI64 3 10000 empty 20 | roundTrip $ setI64 3 12345 empty 21 | roundTrip $ setS 4 "foo" empty 22 | roundTrip $ setS 5 "foobar" $ setVAR 6 12345678 empty 23 | 24 | roundTrip :: Object -> Expectation 25 | roundTrip obj = decode (encode obj) `shouldBe` obj 26 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Types/Imports.hs: -------------------------------------------------------------------------------- 1 | module DNS.Types.Imports ( 2 | ByteString, 3 | ShortByteString, 4 | NonEmpty (..), 5 | module Control.Applicative, 6 | module Control.Monad, 7 | module Data.Bits, 8 | module Data.Function, 9 | module Data.List, 10 | module Data.Maybe, 11 | module Data.Monoid, 12 | module Data.Ord, 13 | module Data.String, 14 | module Data.Typeable, 15 | module Data.Word, 16 | module Numeric, 17 | ) where 18 | 19 | import Control.Applicative 20 | import Control.Monad 21 | import Data.Bits 22 | import Data.ByteString (ByteString) 23 | import Data.ByteString.Short (ShortByteString) 24 | import Data.Function 25 | import Data.List 26 | import Data.List.NonEmpty (NonEmpty (..)) 27 | import Data.Maybe 28 | import Data.Monoid 29 | import Data.Ord 30 | import Data.String 31 | import Data.Typeable 32 | import Data.Word 33 | import Numeric 34 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Internal.hs: -------------------------------------------------------------------------------- 1 | module DNS.Iterative.Internal ( 2 | -- * types 3 | module DNS.Iterative.Query.Class, 4 | module DNS.Iterative.Query.Types, 5 | module DNS.Iterative.Query.Env, 6 | module DNS.Iterative.Query.API, 7 | 8 | -- * testing 9 | newTestCache, 10 | runResolve, 11 | runResolveExact, 12 | runResolveJust, 13 | runIterative, 14 | printResult, 15 | refreshRoot, 16 | rootPriming, 17 | rootHint, 18 | rrsetValid, 19 | -- 20 | rrWithRRSIG, 21 | sepDNSKEY, 22 | ) where 23 | 24 | import DNS.Iterative.Query.API 25 | import DNS.Iterative.Query.Class 26 | import DNS.Iterative.Query.Env 27 | import DNS.Iterative.Query.Helpers 28 | import DNS.Iterative.Query.Resolve 29 | import DNS.Iterative.Query.ResolveJust 30 | import DNS.Iterative.Query.TestEnv 31 | import DNS.Iterative.Query.Types 32 | import DNS.Iterative.Query.Utils 33 | import DNS.Iterative.Query.Verify 34 | -------------------------------------------------------------------------------- /dnsext-svcb/DNS/SVCB/Imports.hs: -------------------------------------------------------------------------------- 1 | module DNS.SVCB.Imports ( 2 | ByteString, 3 | ShortByteString, 4 | Int64, 5 | NonEmpty (..), 6 | module Control.Applicative, 7 | module Control.Monad, 8 | module Data.Bits, 9 | module Data.Function, 10 | module Data.List, 11 | module Data.Maybe, 12 | module Data.Monoid, 13 | module Data.Ord, 14 | module Data.String, 15 | module Data.Typeable, 16 | module Data.Word, 17 | module Numeric, 18 | ) 19 | where 20 | 21 | import Control.Applicative 22 | import Control.Monad 23 | import Data.Bits 24 | import Data.ByteString (ByteString) 25 | import Data.ByteString.Short (ShortByteString) 26 | import Data.Function 27 | import Data.Int (Int64) 28 | import Data.List 29 | import Data.List.NonEmpty (NonEmpty (..)) 30 | import Data.Maybe 31 | import Data.Monoid 32 | import Data.Ord 33 | import Data.String 34 | import Data.Typeable 35 | import Data.Word 36 | import Numeric 37 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Types/Parser.hs: -------------------------------------------------------------------------------- 1 | module DNS.Types.Parser ( 2 | Parser, 3 | Result (..), 4 | Builder, 5 | ToBuilder (..), 6 | parse, 7 | char, 8 | string, 9 | eof, 10 | option, 11 | match, 12 | skip, 13 | skipSome, 14 | satisfy, 15 | digit, 16 | anyChar, 17 | ) where 18 | 19 | import DNS.Types.Imports 20 | import DNS.Types.ShortBuilder 21 | import DNS.Types.ShortParser hiding (char, string) 22 | import qualified DNS.Types.ShortParser as P 23 | 24 | parse 25 | :: Parser Builder 26 | -> ShortByteString 27 | -> (Maybe ShortByteString, ShortByteString) 28 | parse p bs0 = case P.runParser p bs0 of 29 | (Unmatch, bs) -> (Nothing, bs) 30 | (Match b, bs) -> (Just (build b), bs) 31 | (Fail _, bs) -> (Nothing, bs) 32 | 33 | char :: Word8 -> Parser Builder 34 | char w = toBuilder <$> P.char w 35 | 36 | string :: ShortByteString -> Parser Builder 37 | string s = toBuilder <$> P.string s 38 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/Parser/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | module DNS.Parser.State where 6 | 7 | import Control.Monad.Trans.Class (lift) 8 | import Control.Monad.Trans.Except (Except, runExcept, throwE) 9 | import Control.Monad.Trans.State 10 | import Data.Maybe (fromMaybe) 11 | import Data.Monoid (Last (..)) 12 | 13 | import DNS.Parser.Class 14 | 15 | type Error = Last String 16 | type Parser s = StateT s (StateT (Int, Int) (Except Error)) 17 | 18 | runError :: Error -> String 19 | runError = fromMaybe "" . getLast 20 | 21 | runParser :: Parser s a -> s -> Either String (a, s) 22 | runParser p in_ = either (Left . runError) Right $ runExcept (evalStateT (runStateT p in_) (1, 0)) 23 | 24 | instance CaseCons t s => MonadParser t s (Parser s) where 25 | getInput = get 26 | putInput = put 27 | raiseParser = lift . lift . throwE . Last . Just 28 | getPos = lift get 29 | putPos = lift . put 30 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/ZoneFile.hs: -------------------------------------------------------------------------------- 1 | module DNS.ZoneFile ( 2 | LexParser, 3 | ZoneParser, 4 | runLexParser, 5 | runZoneParser, 6 | module DNS.ZoneFile.Types, 7 | module DNS.ZoneFile.Lexer, 8 | module DNS.ZoneFile.Parser, 9 | module DNS.ZoneFile.IO, 10 | ) where 11 | 12 | -- ghc packages 13 | import qualified Data.ByteString.Lazy as LB 14 | 15 | -- this package 16 | import DNS.Parser (runParser) 17 | import DNS.ZoneFile.IO 18 | import DNS.ZoneFile.Lexer hiding (Parser) 19 | import qualified DNS.ZoneFile.Lexer as L 20 | import DNS.ZoneFile.Parser hiding (Parser, parseFile, parseLineRR, runParser) 21 | import qualified DNS.ZoneFile.Parser as P 22 | import DNS.ZoneFile.Types 23 | 24 | type LexParser a = L.Parser a 25 | 26 | runLexParser :: LexParser a -> LB.ByteString -> Either String (a, LB.ByteString) 27 | runLexParser = runParser 28 | 29 | type ZoneParser a = P.Parser a 30 | 31 | runZoneParser :: ZoneParser a -> Context -> [Token] -> Either String ((a, Context), [Token]) 32 | runZoneParser = P.runParser 33 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Types/Seconds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module DNS.Types.Seconds where 4 | 5 | import DNS.Types.Imports 6 | import DNS.Wire 7 | 8 | newtype Seconds = Seconds Word32 9 | deriving (Eq, Ord, Enum, Num, Real, Integral, Bits) 10 | 11 | instance Show Seconds where 12 | show (Seconds n) = show n ++ "(" ++ unit n ++ ")" 13 | where 14 | mul u k = if k == 1 then u else u ++ "s" 15 | unit i 16 | | i >= 86400 = 17 | let j = i `div` 86400 18 | in show j ++ mul " day" j 19 | | i >= 3600 = 20 | let j = i `div` 3600 21 | in show j ++ mul " hour" j 22 | | i >= 60 = 23 | let j = i `div` 60 24 | in show j ++ mul " min" j 25 | | otherwise = mul "sec" i 26 | 27 | putSeconds :: Seconds -> Builder () 28 | putSeconds (Seconds n) wbuf _ = put32 wbuf n 29 | 30 | getSeconds :: Parser Seconds 31 | getSeconds rbuf _ = Seconds <$> get32 rbuf 32 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/ZoneFile/IO.hs: -------------------------------------------------------------------------------- 1 | module DNS.ZoneFile.IO where 2 | 3 | -- ghc packages 4 | import qualified Data.ByteString.Lazy as LB 5 | import qualified Data.ByteString.Lazy.Char8 as L8 6 | 7 | -- dnsext-* packages 8 | import DNS.Types (ResourceRecord) 9 | 10 | -- this package 11 | import DNS.ZoneFile.Lexer (lexLine) 12 | import DNS.ZoneFile.Parser (Context) 13 | import qualified DNS.ZoneFile.Parser as P 14 | import DNS.ZoneFile.Types as T 15 | 16 | parseLineRR :: L8.ByteString -> Context -> Either String (ResourceRecord, Context) 17 | parseLineRR s cxt = do 18 | ts <- lexLine s 19 | P.parseLineRR (T.normLine ts) cxt 20 | 21 | parseLine :: L8.ByteString -> Context -> Either String (Record, Context) 22 | parseLine s cxt = do 23 | ts <- lexLine s 24 | P.parseLineRecord (T.normLine ts) cxt 25 | 26 | parseFile :: FilePath -> IO [Record] 27 | parseFile fn = do 28 | bslines <- L8.lines <$> LB.readFile fn 29 | tklines <- either fail pure $ mapM lexLine bslines 30 | either fail (pure . fst) $ P.parseFile $ T.normTokens tklines 31 | -------------------------------------------------------------------------------- /dnsext-bowline/dump/dump.hs: -------------------------------------------------------------------------------- 1 | -- % sudo -u unbound dump 2 | module Main where 3 | 4 | import Control.Concurrent (forkIO) 5 | import Control.Monad (forever, void) 6 | import Network.Socket 7 | import System.Environment (getArgs) 8 | import Text.Pretty.Simple (pPrint) 9 | 10 | import DNS.SEC (addResourceDataForDNSSEC) 11 | import DNS.SVCB (addResourceDataForSVCB) 12 | import DNS.TAP.FastStream (Config (..), reader) 13 | import DNS.TAP.Schema (decodeDnstap) 14 | import DNS.Types (runInitIO) 15 | 16 | ---------------------------------------------------------------- 17 | 18 | main :: IO () 19 | main = do 20 | [path] <- getArgs 21 | runInitIO $ do 22 | addResourceDataForDNSSEC 23 | addResourceDataForSVCB 24 | lsock <- socket AF_UNIX Stream defaultProtocol 25 | bind lsock $ SockAddrUnix path 26 | listen lsock 10 27 | loop lsock 28 | where 29 | loop lsock = forever $ do 30 | (sock, _) <- accept lsock 31 | let conf = Config True True 32 | void $ forkIO $ reader sock conf (pPrint . decodeDnstap) 33 | -------------------------------------------------------------------------------- /docs/dnsext.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: dnsext-* 4 | rank: 5 5 | --- 6 | 7 | # `dnsext-*` 8 | 9 | This is a new series of DNS libraries based on the experience of the [dns](https://github.com/kazu-yamamoto/dns) library in Haskell. The dns library has two flaws: 10 | 11 | - Resource records are not extensible 12 | - Resource records are not friendly to caching 13 | 14 | Resource records are implemented as a sum type. The third party library cannot extend them. The only way to extend them is to send a pull request to the dns library. 15 | 16 | Some resource records use `ByteString` internally. So, if they are cached for a long time, fragmentation happens. 17 | 18 | This new library uses typeclasses to extend resource records and uses `ShortByteString` in them. 19 | 20 | * `dnsext-types`: basic types 21 | * `dnsext-dnssec`: DNSSEC 22 | * `dnsext-svcb`: SVCB 23 | * `dnsext-utils`: utility functions 24 | * `dnsext-do53`: DNS over UDP 53 and TCP 53 25 | * `dnsext-dox`: DNS over TLS, QUIC, H2 and H3 26 | * `dnsext-iterative`: iterative queries 27 | * `dnsext-bowline`: `bowline`, `dug` and `ddrd` 28 | -------------------------------------------------------------------------------- /docs/ddrd.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: ddrd 4 | rank: 4 5 | --- 6 | 7 | # `ddrd` 8 | 9 | `ddrd` is a daemon for DDR (Discovery of Designated Resolvers, RFC 9462). `ddrd` behaves as follows: 10 | 11 | - Read 127.0.0.1:53 to get a DNS query from the local stub resolver. 12 | - If an encrypted connection is not created yet, SVCB RR is obtained from the specified unencrypted DNS servers. Select one of encrypted DNS servers and create an encrypted connection. 13 | - Send the DNS query through the connection and get a response. 14 | - Send the response back to the local stub resolver. 15 | - Repeat. 16 | 17 | ## Installation 18 | 19 | * [Binaries are available](https://github.com/iijlab/dnsext/releases) 20 | 21 | * Execute `ddrd` with IP addresses of unencrypted DNS servers which provide SVCB RR. 22 | 23 | ``` 24 | % sudo ddrd 8.8.8.8 -d 25 | ``` 26 | 27 | This binds 127.0.0.1:53. If executed with the `-d` option, `ddrd` displays debug logs. ALPN (`dot`, `doq`, `h2`, `h3`) can be specified with the `-a` option to select your favorite encrypted connection. 28 | 29 | * Rewrite `/etc/resolv.conf` as follows: 30 | 31 | ``` 32 | nameserver 127.0.0.1 33 | ``` 34 | -------------------------------------------------------------------------------- /dnsext-utils/test/ArraySpec.hs: -------------------------------------------------------------------------------- 1 | module ArraySpec where 2 | 3 | import Control.Concurrent.Async 4 | import DNS.Array 5 | import Data.Array.IO 6 | import Test.Hspec 7 | 8 | arraySize :: Int 9 | arraySize = 10 10 | 11 | threadNumber :: Int 12 | threadNumber = 100 13 | 14 | repeatNumber :: Int 15 | repeatNumber = 10000 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "atomicModifyArray" $ do 20 | it "can update atomically" $ do 21 | launch `shouldReturn` (threadNumber * repeatNumber) 22 | 23 | launch :: IO Int 24 | launch = do 25 | arr <- newArray (0, arraySize - 1) 0 :: IO (IOUArray Int Int) 26 | foldr concurrently_ (return ()) $ replicate threadNumber (update arr) 27 | sumIt 0 arr 0 28 | where 29 | sumIt ix arr acc 30 | | ix == arraySize = return acc 31 | | otherwise = do 32 | n <- readArray arr ix 33 | sumIt (ix + 1) arr (acc + n) 34 | 35 | update :: IOUArray Int Int -> IO () 36 | update arr = loop 0 37 | where 38 | loop i 39 | | i == repeatNumber = return () 40 | | otherwise = do 41 | let ix = i `mod` arraySize 42 | _ <- atomicModifyIntArray arr ix (+ 1) 43 | loop (i + 1) 44 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/Array.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnboxedTuples #-} 4 | {-# LANGUAGE NoStrict #-} 5 | {-# LANGUAGE NoStrictData #-} 6 | 7 | module DNS.Array where 8 | 9 | import Data.Array.Base (STUArray (..)) 10 | import Data.Array.IO.Internals (IOUArray (..)) 11 | import Data.Array.MArray (Ix (..)) 12 | import GHC.Exts (Int (..), atomicReadIntArray#, casIntArray#, (==#)) 13 | import GHC.IO (IO (..)) 14 | 15 | atomicModifyIntArray :: Ix ix => IOUArray ix Int -> ix -> (Int -> Int) -> IO Int 16 | atomicModifyIntArray (IOUArray (STUArray l u _s mba)) ix f = 17 | atomicModify mba $ index (l, u) ix 18 | where 19 | -- stolen from "massiv" 20 | atomicModify mba# (I# i#) = 21 | let go s# o# = 22 | let !(I# n#) = f (I# o#) 23 | in case casIntArray# mba# i# o# n# s# of 24 | (# s'#, o'# #) -> 25 | case o# ==# o'# of 26 | 0# -> go s# o'# 27 | _ -> (# s'#, I# o# #) 28 | in IO $ \s# -> 29 | case atomicReadIntArray# mba# i# s# of 30 | (# s'#, o# #) -> go s'# o# 31 | {-# INLINE atomicModify #-} 32 | {-# INLINE atomicModifyIntArray #-} 33 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/ZoneFile/ParserBase.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module DNS.ZoneFile.ParserBase where 4 | 5 | import Control.Applicative 6 | import Control.Monad 7 | import qualified Data.ByteString.Short as Short 8 | 9 | -- this package 10 | import DNS.Parser 11 | import DNS.ZoneFile.Types 12 | 13 | -- | 14 | -- >>> runParser dot [Dot] 15 | -- Right (Dot,[]) 16 | dot :: MonadParser Token s m => m Token 17 | dot = this Dot 18 | 19 | -- | 20 | -- >>> runParser blank [Blank] 21 | -- Right (Blank,[]) 22 | blank :: MonadParser Token s m => m Token 23 | blank = this Blank 24 | 25 | {- FOURMOLU_DISABLE -} 26 | lstring :: MonadParser Token s m => m CS' 27 | lstring = do 28 | t <- token 29 | case t of 30 | CS cs -> pure cs 31 | _ -> raise $ "Parser.lstring: not CString token: " ++ show t 32 | 33 | cstring' :: MonadParser Token s m => m CS' 34 | cstring' = do 35 | cs <- lstring 36 | guard (Short.length (cs_cs cs) < 256) <|> raise ("Parser.cstring: too long: " ++ show cs) 37 | pure cs 38 | 39 | cstring :: MonadParser Token s m => m CString 40 | cstring = cs_cs <$> cstring' 41 | {- FOURMOLU_ENABLE -} 42 | 43 | readCString :: (Read a, MonadParser Token s m) => String -> m a 44 | readCString name = readable ("Zonefile." ++ name) . fromCString =<< cstring 45 | -------------------------------------------------------------------------------- /dnsext-dox/DNS/DoX/Imports.hs: -------------------------------------------------------------------------------- 1 | module DNS.DoX.Imports ( 2 | ByteString, 3 | ShortByteString, 4 | module Control.Applicative, 5 | module Control.Monad, 6 | module Data.Bits, 7 | module Data.Function, 8 | module Data.IP, 9 | module Data.List, 10 | module Data.Maybe, 11 | module Data.Monoid, 12 | module Data.Ord, 13 | module Data.String, 14 | module Data.Typeable, 15 | module Data.Word, 16 | module Numeric, 17 | toDNSError, 18 | ) 19 | where 20 | 21 | import Control.Applicative 22 | import Control.Monad 23 | import Data.Bits 24 | import Data.ByteString (ByteString) 25 | import Data.ByteString.Short (ShortByteString) 26 | import Data.Function 27 | import Data.IP 28 | import Data.List 29 | import Data.Maybe 30 | import Data.Monoid 31 | import Data.Ord 32 | import Data.String 33 | import Data.Typeable 34 | import Data.Word 35 | import Numeric 36 | 37 | import qualified Control.Exception as E 38 | 39 | import DNS.Types 40 | 41 | toDNSError :: String -> IO a -> IO a 42 | toDNSError tag action = action `E.catch` handler 43 | where 44 | -- SomeException: asynchronous exceptions are re-thrown 45 | handler se@(E.SomeException _) 46 | | Just (E.SomeAsyncException _) <- E.fromException se = E.throwIO se 47 | | otherwise = E.throwIO $ NetworkFailure se tag 48 | -------------------------------------------------------------------------------- /dnsext-do53/util/cli.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent 7 | import Control.Concurrent.Async 8 | import Control.Monad 9 | import DNS.Do53.Internal 10 | import DNS.Types 11 | import Data.IORef 12 | import Data.IP () 13 | import Data.List 14 | import System.Environment 15 | 16 | main :: IO () 17 | main = do 18 | args <- getArgs 19 | let (ats, doms') = partition ("@" `isPrefixOf`) args 20 | ips = read . drop 1 <$> ats 21 | doms = fromRepresentation <$> doms' 22 | domsN = length doms 23 | port = 53 24 | ris = (\ip -> defaultResolveInfo{rinfoIP = ip, rinfoPort = port}) <$> ips 25 | refs <- replicateM domsN (newIORef False) 26 | let targets = zip doms refs 27 | stdoutLock <- newMVar () 28 | foldr1 race_ $ map (withServer stdoutLock targets) ris 29 | where 30 | withServer stdoutLock targets ri = tcpPersistentResolver ri $ \resolv -> do 31 | foldr1 concurrently_ $ map (lookupAndPrint resolv stdoutLock) targets 32 | lookupAndPrint resolv stdoutLock (dom, ref) = do 33 | r <- resolv q mempty 34 | notyet <- atomicModifyIORef' ref (True,) 35 | unless notyet $ withMVar stdoutLock $ \() -> print r 36 | where 37 | q = Question dom A IN 38 | -------------------------------------------------------------------------------- /dnsext-utils/test/SchemaSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module SchemaSpec where 4 | 5 | import DNS.Types 6 | import Data.ByteString () 7 | import Test.Hspec 8 | 9 | import DNS.TAP.Schema 10 | 11 | gMSG :: Message 12 | gMSG = 13 | Message 14 | { messageType = CLIENT_QUERY 15 | , messageSocketFamily = Just IPv4 16 | , messageSocketProtocol = Just UDP 17 | , messageQueryAddress = Just "127.0.0.1" 18 | , messageResponseAddress = Just "127.0.0.1" 19 | , messageQueryPort = Just 5000 20 | , messageResponsePort = Just 53 21 | , messageQueryTimeSec = Just 1693364212 22 | , messageQueryTimeNsec = Just 267921000 23 | , messageQueryMessage = Just $ DnsMsg defaultQuery 24 | , messageQueryZone = Nothing 25 | , messageResponseTimeSec = Nothing 26 | , messageResponseTimeNsec = Nothing 27 | , messageResponseMessage = Nothing 28 | , messagePolicy = Nothing 29 | , messageHttpProtocol = Just HTTP_NONE 30 | } 31 | 32 | spec :: Spec 33 | spec = do 34 | describe "encode & decode" $ do 35 | it "can encode then decode" $ do 36 | roundTripMessage gMSG 37 | 38 | roundTripMessage :: Message -> Expectation 39 | roundTripMessage msg = decodeMessage (encodeMessage msg) `shouldBe` msg 40 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Types/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | 3 | module DNS.Types.Time ( 4 | EpochTime, 5 | EpochTimeUsec, 6 | getCurrentTime, 7 | getCurrentTimeUsec, 8 | runEpochTimeUsec, 9 | epochUsecToSeconds, 10 | diffUsec, 11 | getCurrentTimeNsec, 12 | ) where 13 | 14 | import Data.Int (Int32, Int64) 15 | import Data.UnixTime 16 | import Foreign.C.Types (CTime (..)) 17 | 18 | type EpochTime = Int64 19 | 20 | getCurrentTime :: IO EpochTime 21 | getCurrentTime = do 22 | UnixTime (CTime tim) _ <- getUnixTime 23 | return tim 24 | 25 | type EpochTimeUsec = UnixTime 26 | 27 | getCurrentTimeUsec :: IO EpochTimeUsec 28 | getCurrentTimeUsec = getUnixTime 29 | 30 | runEpochTimeUsec :: EpochTimeUsec -> (Int64 -> Int32 -> a) -> a 31 | runEpochTimeUsec (UnixTime (CTime sec) usec) f = f sec usec 32 | 33 | epochUsecToSeconds :: EpochTimeUsec -> EpochTime 34 | epochUsecToSeconds (UnixTime (CTime tim) _) = tim 35 | 36 | diffUsec :: EpochTimeUsec -> EpochTimeUsec -> Integer 37 | diffUsec x y = toMicro $ diffUnixTime x y 38 | where 39 | toMicro (UnixDiffTime (CTime sec) u) = fromIntegral sec * 1_000_000 + fromIntegral u 40 | 41 | getCurrentTimeNsec :: IO (EpochTime, Int64) 42 | getCurrentTimeNsec = do 43 | UnixTime (CTime tim) usec <- getUnixTime 44 | return (tim, fromIntegral usec * 1000) 45 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Types/Internal.hs: -------------------------------------------------------------------------------- 1 | module DNS.Types.Internal ( 2 | -- * Types 3 | TYPE (..), 4 | OptCode (..), 5 | RCODE (..), 6 | CanonicalFlag (..), 7 | CLASS (..), 8 | 9 | -- * Classes 10 | ResourceData (..), 11 | OptData (..), 12 | 13 | -- * Misc 14 | section, 15 | 16 | -- * Extension 17 | extendRR, 18 | extendOpt, 19 | 20 | -- * High level 21 | putDNSMessage, 22 | getDNSMessage, 23 | putDNSFlags, 24 | getDNSFlags, 25 | putQuestion, 26 | getQuestion, 27 | putResourceRecord, 28 | getResourceRecord, 29 | putRData, 30 | getRData, 31 | 32 | -- * Middle level 33 | putDomain, 34 | putDomainRFC1035, 35 | getDomain, 36 | getDomainRFC1035, 37 | putMailbox, 38 | putMailboxRFC1035, 39 | getMailbox, 40 | getMailboxRFC1035, 41 | putOpaque, 42 | putLenOpaque, 43 | getOpaque, 44 | getLenOpaque, 45 | putTYPE, 46 | getTYPE, 47 | putCLASS, 48 | getCLASS, 49 | putSeconds, 50 | getSeconds, 51 | 52 | -- * Low level 53 | module DNS.Wire, 54 | ) where 55 | 56 | import DNS.Types.Dict 57 | import DNS.Types.Domain 58 | import DNS.Types.EDNS 59 | import DNS.Types.Message 60 | import DNS.Types.Opaque.Internal 61 | import DNS.Types.RData 62 | import DNS.Types.Seconds 63 | import DNS.Types.Type 64 | import DNS.Wire 65 | -------------------------------------------------------------------------------- /dnsext-do53/DNS/Do53/Imports.hs: -------------------------------------------------------------------------------- 1 | module DNS.Do53.Imports ( 2 | module Control.Applicative, 3 | module Control.Monad, 4 | module Data.Bits, 5 | module Data.Function, 6 | module Data.IP, 7 | module Data.List, 8 | module Data.Maybe, 9 | module Data.Monoid, 10 | module Data.Ord, 11 | module Data.Typeable, 12 | module Data.Word, 13 | module Numeric, 14 | ByteString, 15 | EpochTime, 16 | NonEmpty, 17 | PortNumber, 18 | ShortByteString, 19 | Socket, 20 | fromString, 21 | getEpochTime, 22 | ) 23 | where 24 | 25 | import Control.Applicative 26 | import Control.Monad 27 | import DNS.Types.Time (EpochTime) 28 | import Data.Bits 29 | import Data.ByteString (ByteString) 30 | import Data.ByteString.Short (ShortByteString) 31 | import Data.Function 32 | import Data.IP 33 | import Data.List hiding (lookup) 34 | import Data.List.NonEmpty (NonEmpty) 35 | import Data.Maybe 36 | import Data.Monoid 37 | import Data.Ord 38 | import Data.String (fromString) 39 | import Data.Typeable 40 | import Data.UnixTime (UnixTime (..), getUnixTime) 41 | import Data.Word 42 | import Foreign.C.Types (CTime (..)) 43 | import Network.Socket (PortNumber, Socket) 44 | import Numeric 45 | 46 | -- | Getting the current epoch time. 47 | getEpochTime :: IO EpochTime 48 | getEpochTime = do 49 | UnixTime (CTime tim) _ <- getUnixTime 50 | return tim 51 | -------------------------------------------------------------------------------- /dnsext-do53/DNS/Do53/System.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module DNS.Do53.System ( 4 | getDefaultDnsServers, 5 | ) 6 | where 7 | 8 | import DNS.Do53.Imports 9 | 10 | #ifdef mingw32_HOST_OS 11 | import Foreign.C.String 12 | import Foreign.Marshal.Alloc (allocaBytes) 13 | 14 | foreign import ccall "getWindowsDefDnsServers" getWindowsDefDnsServers :: CString -> Int -> IO Word32 15 | 16 | getDefaultDnsServers :: FilePath -> IO [String] 17 | getDefaultDnsServers _ = do 18 | allocaBytes 256 $ \cString -> do 19 | res <- getWindowsDefDnsServers cString 256 20 | case res of 21 | 0 -> split ',' <$> peekCString cString 22 | _ -> return [] -- TODO: Do proper error handling here. 23 | where 24 | split :: Char -> String -> [String] 25 | split c cs = 26 | let (h, t) = dropWhile (== c) <$> break (== c) cs 27 | in if null t 28 | then if null h then [] else [h] 29 | else if null h 30 | then split c t 31 | else h : split c t 32 | 33 | #else 34 | 35 | import Data.Char (isSpace) 36 | 37 | getDefaultDnsServers :: FilePath -> IO [String] 38 | getDefaultDnsServers file = toAddresses <$> readFile file 39 | where 40 | toAddresses :: String -> [String] 41 | toAddresses cs = map extract (filter ("nameserver" `isPrefixOf`) (lines cs)) 42 | extract = takeWhile (not . isEnd) . dropWhile isSpace . drop 11 43 | isEnd = or . sequence [isSpace, (==) '#', (==) ';'] 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Query/StubZone.hs: -------------------------------------------------------------------------------- 1 | module DNS.Iterative.Query.StubZone where 2 | 3 | -- GHC packages 4 | import Data.Map.Strict (Map) 5 | import qualified Data.Map.Strict as Map 6 | 7 | -- other packages 8 | 9 | -- dnsext packages 10 | import DNS.Types 11 | import Data.IP (IP (..)) 12 | 13 | -- this package 14 | import DNS.Iterative.Imports 15 | import DNS.Iterative.Query.Class 16 | import DNS.Iterative.Query.ZoneMap 17 | 18 | {- FOURMOLU_DISABLE -} 19 | getStubDelegation :: (Domain, [Domain], [Address], MayFilledDS) -> Either String Delegation 20 | getStubDelegation (apex, names, addrs, dsState) = 21 | maybe (Left $ "stub-zone: zone has empty address or names: " ++ show apex) (pure . mkD) $ nonEmpty es 22 | where 23 | mkD ns = Delegation apex ns dsState [] FreshD 24 | es = [DEstubA4 ne | Just ne <- [nonEmpty [(i, p) | (IPv4 i, p) <- addrs]]] ++ 25 | [DEstubA6 ne | Just ne <- [nonEmpty [(i, p) | (IPv6 i, p) <- addrs]]] ++ 26 | [DEonlyNS n | n <- names] 27 | {- FOURMOLU_ENABLE -} 28 | 29 | stubDomain :: Delegation -> Domain 30 | stubDomain = delegationZone 31 | 32 | getStubMap :: [(Domain, [Domain], [Address], MayFilledDS)] -> Either String (Map Domain [Delegation]) 33 | getStubMap es = do 34 | delegations <- mapM getStubDelegation es 35 | let lats = subdomainSemilatticeOn stubDomain delegations 36 | pure $ Map.fromList lats 37 | 38 | lookupStub :: Map Domain [Delegation] -> Domain -> Maybe Delegation 39 | lookupStub = lookupApexOn stubDomain 40 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module DNS.SEC.Imports ( 4 | ByteString, 5 | ShortByteString, 6 | NonEmpty (..), 7 | module Control.Applicative, 8 | module Control.Monad, 9 | module Data.Bits, 10 | module Data.Function, 11 | module Data.List, 12 | module Data.Maybe, 13 | module Data.Monoid, 14 | module Data.Ord, 15 | module Data.Typeable, 16 | module Data.Word, 17 | module Numeric, 18 | EpochTime, 19 | unconsLabels, 20 | numLabels, 21 | ) 22 | where 23 | 24 | import Control.Applicative 25 | import Control.Monad 26 | import Data.Bits 27 | import Data.ByteString (ByteString) 28 | import Data.ByteString.Short (ShortByteString) 29 | import Data.Function 30 | import Data.List 31 | import Data.List.NonEmpty (NonEmpty (..)) 32 | import Data.Maybe 33 | import Data.Monoid 34 | import Data.Ord 35 | import Data.Typeable 36 | import Data.Word 37 | import Numeric 38 | 39 | import DNS.Types (Domain, labelsCount, unconsDomain) 40 | import DNS.Types.Internal (Label) 41 | import DNS.Types.Time (EpochTime) 42 | 43 | unconsLabels :: Domain -> a -> (Label -> Domain -> a) -> a 44 | unconsLabels d nothing just = case unconsDomain d of 45 | Nothing -> nothing 46 | Just (x, xs) -> just x xs 47 | 48 | {- FOURMOLU_DISABLE -} 49 | numLabels :: Domain -> Int 50 | numLabels d = unconsLabels d 0 nlabels 51 | where 52 | nlabels "*" _ = c - 1 53 | nlabels _ _ = c 54 | c = labelsCount d 55 | {- FOURMOLU_ENABLE -} 56 | -------------------------------------------------------------------------------- /dnsext-svcb/DNS/SVCB/Key.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | module DNS.SVCB.Key where 4 | 5 | import DNS.SVCB.Imports 6 | 7 | newtype SvcParamKey = SvcParamKey 8 | { fromSvcParamKey :: Word16 9 | } 10 | deriving (Eq, Ord) 11 | 12 | {- FOURMOLU_DISABLE -} 13 | instance Show SvcParamKey where 14 | show SPK_Mandatory = "mandatory" 15 | show SPK_ALPN = "alpn" 16 | show SPK_NoDefaultALPN = "no-default-alpn" 17 | show SPK_Port = "port" 18 | show SPK_IPv4Hint = "ipv4hint" 19 | show SPK_ECH = "ech" 20 | show SPK_IPv6Hint = "ipv6hint" 21 | show SPK_DoHPath = "dohpath" 22 | show (SvcParamKey n) = "SvcParamKey" ++ show n -- no space 23 | {- FOURMOLU_ENABLE -} 24 | 25 | toSvcParamKey :: Word16 -> SvcParamKey 26 | toSvcParamKey = SvcParamKey 27 | 28 | pattern SPK_Mandatory :: SvcParamKey 29 | pattern SPK_Mandatory = SvcParamKey 0 30 | 31 | pattern SPK_ALPN :: SvcParamKey 32 | pattern SPK_ALPN = SvcParamKey 1 33 | 34 | pattern SPK_NoDefaultALPN :: SvcParamKey 35 | pattern SPK_NoDefaultALPN = SvcParamKey 2 36 | 37 | pattern SPK_Port :: SvcParamKey 38 | pattern SPK_Port = SvcParamKey 3 39 | 40 | pattern SPK_IPv4Hint :: SvcParamKey 41 | pattern SPK_IPv4Hint = SvcParamKey 4 42 | 43 | pattern SPK_ECH :: SvcParamKey 44 | pattern SPK_ECH = SvcParamKey 5 45 | 46 | pattern SPK_IPv6Hint :: SvcParamKey 47 | pattern SPK_IPv6Hint = SvcParamKey 6 48 | 49 | pattern SPK_DoHPath :: SvcParamKey 50 | pattern SPK_DoHPath = SvcParamKey 7 51 | -------------------------------------------------------------------------------- /dnsext-do53/DNS/Do53/Internal.hs: -------------------------------------------------------------------------------- 1 | module DNS.Do53.Internal ( 2 | -- * TCP related 3 | openTCP, 4 | sendTCP, 5 | recvTCP, 6 | 7 | -- * Virtual circuit 8 | sendVC, 9 | recvVC, 10 | encodeVCLength, 11 | decodeVCLength, 12 | BS, 13 | 14 | -- * Resolver 15 | Resolver, 16 | Reply (..), 17 | 18 | -- * Pipeline resolver 19 | PersistentResolver, 20 | PipelineResolver, 21 | tcpPersistentResolver, 22 | vcPersistentResolver, 23 | 24 | -- * One-shot resolver 25 | OneshotResolver, 26 | udpTcpResolver, 27 | udpResolver, 28 | tcpResolver, 29 | vcResolver, 30 | 31 | -- * Resolver information 32 | ResolveInfo (..), 33 | defaultResolveInfo, 34 | UDPRetry, 35 | VCLimit (..), 36 | ResolveActions (..), 37 | defaultResolveActions, 38 | 39 | -- * One shot resolve function 40 | resolve, 41 | ResolveEnv (..), 42 | 43 | -- * Query 44 | encodeQuery, 45 | modifyQuery, 46 | queryControls, 47 | 48 | -- * Generating identifier 49 | singleGenId, 50 | newConcurrentGenId, 51 | 52 | -- * Misc 53 | LookupEnv (..), 54 | checkRespM, 55 | withLookupConfAndResolver, 56 | NameTag (..), 57 | nameTag, 58 | fromNameTag, 59 | toNameTag, 60 | queryTag, 61 | raceAny, 62 | ) 63 | where 64 | 65 | import DNS.Do53.Do53 66 | import DNS.Do53.IO 67 | import DNS.Do53.Id 68 | import DNS.Do53.Lookup 69 | import DNS.Do53.Query 70 | import DNS.Do53.Resolve 71 | import DNS.Do53.Types 72 | import DNS.Do53.VC 73 | -------------------------------------------------------------------------------- /dnsext-bowline/dug/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Types where 4 | 5 | import qualified DNS.Log as Log 6 | import Data.ByteString.Short (ShortByteString) 7 | 8 | import Output (OutputFlag (..)) 9 | 10 | data Options = Options 11 | { optHelp :: Bool 12 | , optIterative :: Bool 13 | , optDisableV6NS :: Bool 14 | , optPort :: Maybe String 15 | , optDoX :: ShortByteString 16 | , optFormat :: OutputFlag 17 | , optVerboseLevel :: Int 18 | , optKeyLogFile :: Maybe FilePath 19 | , optResumptionFile :: Maybe FilePath 20 | , opt0RTT :: Bool 21 | , optValidate :: Bool 22 | } 23 | deriving (Show) 24 | 25 | defaultOptions :: Options 26 | defaultOptions = 27 | Options 28 | { optHelp = False 29 | , optIterative = False 30 | , optDisableV6NS = False 31 | , optPort = Nothing 32 | , optDoX = "do53" 33 | , optFormat = Singleline 34 | , optVerboseLevel = 0 35 | , optKeyLogFile = Nothing 36 | , optResumptionFile = Nothing 37 | , opt0RTT = False 38 | , optValidate = False 39 | } 40 | 41 | shortLog :: Options -> Bool 42 | shortLog opt = optVerboseLevel opt == 1 43 | 44 | {- FOURMOLU_DISABLE -} 45 | logLevel :: Options -> Log.Level 46 | logLevel opt 47 | | verbose <= 0 = Log.WARN 48 | | verbose == 1 = Log.DEMO {- for short-log mode with DEMO log-level -} 49 | | verbose == 2 = Log.DEMO 50 | | otherwise = Log.DEBUG 51 | where 52 | verbose = optVerboseLevel opt 53 | {- FOURMOLU_ENABLE -} 54 | -------------------------------------------------------------------------------- /dnsext-utils/test/FastStreamSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module FastStreamSpec where 4 | 5 | import Control.Concurrent 6 | import qualified Control.Exception as E 7 | import Data.ByteString () 8 | import Data.IORef 9 | import Network.Run.TCP 10 | import Test.Hspec 11 | 12 | import DNS.TAP.FastStream 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "reader & writer" $ do 17 | it "can send stream correctly in uni-directional" $ do 18 | let conf = Config False False 19 | readWrite conf 20 | it "can send stream correctly in bi-directional" $ do 21 | let conf = Config True False 22 | readWrite conf 23 | 24 | readWrite :: Config -> IO () 25 | readWrite conf = do 26 | mvar <- newEmptyMVar 27 | E.bracket (forkIO $ server mvar) killThread $ \_ -> client mvar 28 | where 29 | n = 10 :: Int 30 | client mvar = do 31 | threadDelay 10000 32 | runTCPClient "127.0.0.1" "50002" $ \sock -> do 33 | ref <- newIORef 0 34 | writer sock conf $ do 35 | i <- readIORef ref 36 | if i < n 37 | then do 38 | let i' = i + 1 39 | writeIORef ref i' 40 | return "foo!" 41 | else return "" 42 | takeMVar mvar `shouldReturn` () 43 | server mvar = runTCPServer (Just "127.0.0.1") "50002" $ \sock -> do 44 | ref <- newIORef 0 45 | reader sock conf $ \_ -> modifyIORef' ref (+ 1) 46 | readIORef ref `shouldReturn` n 47 | putMVar mvar () 48 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Server/HTTP3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module DNS.Iterative.Server.HTTP3 ( 5 | http3Servers, 6 | ) where 7 | 8 | -- GHC packages 9 | import Control.Monad (when) 10 | import Data.Functor 11 | 12 | -- other packages 13 | import qualified Network.HTTP3.Server as H3 14 | import qualified Network.QUIC.Server as QUIC 15 | import qualified System.TimeManager as T 16 | 17 | -- this package 18 | import DNS.Iterative.Internal (Env (..)) 19 | import DNS.Iterative.Server.HTTP2 20 | import DNS.Iterative.Server.QUIC 21 | import DNS.Iterative.Server.Types 22 | import DNS.Iterative.Server.UDP 23 | import DNS.Iterative.Stats (incStatsDoH3, sessionStatsDoH3) 24 | 25 | ---------------------------------------------------------------- 26 | http3Servers :: VcServerConfig -> ServerActions 27 | http3Servers VcServerConfig{..} env toCacher ss = do 28 | -- fixme: withLocationIOE naming 29 | when vc_interface_automatic $ mapM_ setPktInfo ss 30 | name <- mapM socketName ss <&> \xs -> show xs ++ "/h3" 31 | let http3server = T.withManager (vc_idle_timeout * 1000000) $ \mgr -> 32 | withLocationIOE name $ QUIC.runWithSockets ss sconf $ \conn -> 33 | H3.runIO conn (conf mgr) $ doHTTP name sbracket incQuery env toCacher H3 34 | return [http3server] 35 | where 36 | sbracket = sessionStatsDoH3 (stats_ env) 37 | incQuery inet6 = incStatsDoH3 inet6 (stats_ env) 38 | sconf = getServerConfig vc_credentials vc_session_manager "h3" (vc_idle_timeout * 1000) env 39 | conf mgr = H3.defaultConfig{H3.confTimeoutManager = mgr} 40 | -------------------------------------------------------------------------------- /dnsext-dnssec/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /dnsext-do53/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /dnsext-dox/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /dnsext-svcb/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /dnsext-types/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /dnsext-utils/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /dnsext-bowline/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /dnsext-iterative/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 4 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: 132 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: diff-friendly 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: false 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: false 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: single-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: inline 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: right-align 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: never 39 | 40 | # Output Unicode syntax (choices: detect, always, or never) 41 | unicode: never 42 | 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # Fixity information for operators 47 | fixities: [] 48 | 49 | -------------------------------------------------------------------------------- /pkg/template/debian/changelog: -------------------------------------------------------------------------------- 1 | bowline (0.0.0.20250521) unstable; urgency=medium 2 | 3 | * fix along with lintian checks. 4 | 5 | -- Kei Hibino Wed, 21 May 2025 22:52:40 +0900 6 | 7 | bowline (0.0.0.20250519) unstable; urgency=medium 8 | 9 | * New upstream release. 10 | * fix init.d script. add '--make-pidfile'. 11 | 12 | -- IIJLab bowline Mon, 19 May 2025 14:30:47 +0900 13 | 14 | bowline (0.0.0.20250501) unstable; urgency=medium 15 | 16 | * feature-quic-keylog 17 | 18 | -- Kei Hibino Thu, 01 May 2025 18:33:10 +0900 19 | 20 | bowline (0.0.0.20250428) unstable; urgency=medium 21 | 22 | * fix-server-recv 23 | 24 | -- Kei Hibino Mon, 28 Apr 2025 12:45:29 +0900 25 | 26 | bowline (0.0.0.20250424) unstable; urgency=medium 27 | 28 | * support BOWLINE_SSLKEYLOGFILE. 29 | 30 | -- Kei Hibino Thu, 24 Apr 2025 17:21:45 +0900 31 | 32 | bowline (0.0.0.20250422) unstable; urgency=medium 33 | 34 | * New upstream release. 35 | 36 | -- Kei Hibino Thu, 24 Apr 2025 11:28:10 +0900 37 | 38 | bowline (0.0.0.20250317) unstable; urgency=medium 39 | 40 | * Set root privilege for reopen log. 41 | 42 | -- Kei Hibino Mon, 17 Mar 2025 02:54:56 +0900 43 | 44 | bowline (0.0.0.20250225) unstable; urgency=medium 45 | 46 | * Not to exit on reloading with parsing config. 47 | 48 | -- Kei Hibino Tue, 25 Feb 2025 15:12:18 +0900 49 | 50 | bowline (0.0.0.20250218) unstable; urgency=medium 51 | 52 | * Initial release. 53 | 54 | -- Kei Hibino Tue, 18 Feb 2025 15:11:56 +0900 55 | -------------------------------------------------------------------------------- /dnsext-bowline/dug/SocketUtil.hs: -------------------------------------------------------------------------------- 1 | module SocketUtil (checkDisableV6) where 2 | 3 | import Control.Exception (bracket) 4 | import Data.IP (IP (..), IPv6) 5 | import qualified Data.List.NonEmpty as NE 6 | import Network.Socket (AddrInfo (..), AddrInfoFlag (..), SocketType (..)) 7 | import qualified Network.Socket as S 8 | import System.IO.Error (tryIOError) 9 | 10 | checkDisableV6 :: [IP] -> IO Bool 11 | checkDisableV6 addrs 12 | | v6 : _ <- v6s = either disabled pure =<< tryIOError (checkV6 v6) 13 | | otherwise = pure False 14 | where 15 | v6s = [v6 | IPv6 v6 <- addrs] 16 | disabled e = do 17 | putStrLn ("disabling IPv6: " ++ show e) 18 | return True 19 | 20 | checkV6 :: IPv6 -> IO Bool 21 | checkV6 dst = do 22 | ai@AddrInfo{addrAddress = peer} <- 23 | NE.head <$> S.getAddrInfo (Just hint) (Just addr) (Just port) 24 | bracket (S.openSocket ai) S.close $ \s -> S.connect s peer 25 | return False 26 | where 27 | addr = show dst 28 | port = "53" -- "0" causes an error on BSD variants 29 | -- Check whether IPv6 is available by specifying `AI_ADDRCONFIG` 30 | -- to `addrFlags` of hints passed to `getAddrInfo`. If `Nothing` 31 | -- is passed to `hints`, the default value of `addrFlags` is 32 | -- implementation-dependent. 33 | -- 34 | -- \* Glibc: `[AI_ADDRCONFIG,AI_V4MAPPED]`. 35 | -- * https://man7.org/linux/man-pages/man3/getaddrinfo.3.html#DESCRIPTION 36 | -- \* POSIX, BSD: `[]`. 37 | -- * https://man.freebsd.org/cgi/man.cgi?query=getaddrinfo&sektion=3 38 | -- 39 | -- So, specifying `AI_ADDRCONFIG` explicitly. 40 | hint = 41 | S.defaultHints 42 | { addrFlags = [AI_ADDRCONFIG] 43 | , addrSocketType = Datagram 44 | } 45 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/TimeCache.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module DNS.TimeCache ( 5 | TimeCache (..), 6 | newTimeCache, 7 | noneTimeCache, 8 | ) where 9 | 10 | -- GHC packages 11 | import qualified Data.ByteString.Char8 as C8 12 | import Foreign.C.Types (CTime (..)) 13 | 14 | -- other packages 15 | import Data.UnixTime (UnixTime (..), formatUnixTime, getUnixTime) 16 | 17 | -- dnsext-* packages 18 | import DNS.Types.Time (EpochTime) 19 | 20 | -- this package 21 | import DNS.Utils.AutoUpdate (mkClosableAutoUpdate) 22 | 23 | {- FOURMOLU_DISABLE -} 24 | data TimeCache = TimeCache 25 | { getTime :: IO EpochTime 26 | , getTimeStr :: IO ShowS 27 | , closeTimeCache :: IO () 28 | } 29 | {- FOURMOLU_ENABLE -} 30 | 31 | {- FOURMOLU_DISABLE -} 32 | newTimeCache :: IO TimeCache 33 | newTimeCache = do 34 | let interval = 1_000_000 35 | (onceGetString, close) <- mkClosableAutoUpdate interval (getTimeShowS =<< getUnixTime) 36 | {- Due to the efficient time retrieval enabled by the vdso(7) mechanism, caching is not required. 37 | Only the formatting of time strings is subject to caching. 38 | https://man7.org/linux/man-pages/man7/vdso.7.html -} 39 | return $ TimeCache (unixToEpoch <$> getUnixTime) onceGetString close 40 | {- FOURMOLU_ENABLE -} 41 | 42 | noneTimeCache :: TimeCache 43 | noneTimeCache = 44 | TimeCache 45 | { getTime = unixToEpoch <$> getUnixTime 46 | , getTimeStr = getTimeShowS =<< getUnixTime 47 | , closeTimeCache = pure () 48 | } 49 | 50 | --- 51 | 52 | getTimeShowS :: UnixTime -> IO ShowS 53 | getTimeShowS ts = (++) . C8.unpack <$> formatUnixTime "%Y-%m-%dT%H:%M:%S%z" ts 54 | 55 | unixToEpoch :: UnixTime -> EpochTime 56 | unixToEpoch (UnixTime (CTime tim) _) = tim 57 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/HashAlg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | module DNS.SEC.HashAlg where 4 | 5 | import DNS.SEC.Imports 6 | import DNS.Types.Internal 7 | 8 | -- https://www.iana.org/assignments/ds-rr-types/ds-rr-types.xhtml 9 | 10 | newtype DigestAlg = DigestAlg 11 | { fromDigestAlg :: Word8 12 | } 13 | deriving (Eq, Ord) 14 | 15 | toDigestAlg :: Word8 -> DigestAlg 16 | toDigestAlg = DigestAlg 17 | 18 | pattern SHA1 :: DigestAlg 19 | pattern SHA1 = DigestAlg 1 20 | 21 | pattern SHA256 :: DigestAlg 22 | pattern SHA256 = DigestAlg 2 23 | 24 | pattern GOST :: DigestAlg 25 | pattern GOST = DigestAlg 3 26 | 27 | pattern SHA384 :: DigestAlg 28 | pattern SHA384 = DigestAlg 4 29 | 30 | {- FOURMOLU_DISABLE -} 31 | instance Show DigestAlg where 32 | show SHA1 = "SHA1" 33 | show SHA256 = "SHA256" 34 | show GOST = "GOST" 35 | show SHA384 = "SHA384" 36 | show (DigestAlg n) = "DigestAlg " ++ show n 37 | {- FOURMOLU_ENABLE -} 38 | 39 | putDigestAlg :: DigestAlg -> Builder () 40 | putDigestAlg d wbuf _ = put8 wbuf $ fromDigestAlg d 41 | 42 | getDigestAlg :: Parser DigestAlg 43 | getDigestAlg rbuf _ = toDigestAlg <$> get8 rbuf 44 | 45 | -- https://www.iana.org/assignments/dnssec-nsec3-parameters/dnssec-nsec3-parameters.xhtml 46 | 47 | newtype HashAlg = HashAlg 48 | { fromHashAlg :: Word8 49 | } 50 | deriving (Eq, Ord) 51 | 52 | toHashAlg :: Word8 -> HashAlg 53 | toHashAlg = HashAlg 54 | 55 | pattern Hash_SHA1 :: HashAlg 56 | pattern Hash_SHA1 = HashAlg 1 57 | 58 | instance Show HashAlg where 59 | show Hash_SHA1 = "SHA1" 60 | show (HashAlg n) = "HashAlg " ++ show n 61 | 62 | putHashAlg :: HashAlg -> Builder () 63 | putHashAlg h wbuf _ = put8 wbuf $ fromHashAlg h 64 | 65 | getHashAlg :: Parser HashAlg 66 | getHashAlg rbuf _ = toHashAlg <$> get8 rbuf 67 | -------------------------------------------------------------------------------- /dnsext-do53/DNS/Do53/Client.hs: -------------------------------------------------------------------------------- 1 | module DNS.Do53.Client ( 2 | -- * Lookups returning each type 3 | lookupA, 4 | lookupAAAA, 5 | lookupMX, 6 | lookupAviaMX, 7 | lookupAAAAviaMX, 8 | lookupNS, 9 | lookupNSAuth, 10 | lookupTXT, 11 | lookupSOA, 12 | lookupPTR, 13 | lookupRDNS, 14 | lookupSRV, 15 | 16 | -- * Lookups returning requested RData 17 | lookup, 18 | lookupAuth, 19 | 20 | -- * Lookups returning requested resource data 21 | lookupX, 22 | lookupAuthX, 23 | 24 | -- * Lookups returning DNS Messages 25 | lookupRaw, 26 | 27 | -- * Lookup configuration for sub resolvers 28 | LookupConf, 29 | defaultLookupConf, 30 | withLookupConf, 31 | UDPRetry, 32 | LookupEnv, 33 | 34 | -- ** Accessors 35 | lconfSeeds, 36 | lconfUDPRetry, 37 | lconfVCLimit, 38 | lconfConcurrent, 39 | lconfCacheConf, 40 | lconfQueryControls, 41 | lconfActions, 42 | 43 | -- ** Specifying full resolvers 44 | Seeds (..), 45 | 46 | -- ** Configuring cache 47 | CacheConf, 48 | defaultCacheConf, 49 | maximumTTL, 50 | pruningDelay, 51 | 52 | -- ** Actions 53 | ResolveActions, 54 | defaultResolveActions, 55 | ractionTimeoutTime, 56 | ractionGenId, 57 | ractionGetTime, 58 | ractionLog, 59 | ractionShortLog, 60 | Reply, 61 | 62 | -- ** Query control 63 | QueryControls (..), 64 | HeaderControls (..), 65 | EdnsControls (..), 66 | FlagOp (..), 67 | rdFlag, 68 | adFlag, 69 | cdFlag, 70 | doFlag, 71 | ednsEnabled, 72 | ednsSetVersion, 73 | ednsSetUdpSize, 74 | ednsSetOptions, 75 | ODataOp (..), 76 | ) 77 | where 78 | 79 | import DNS.Do53.Lookup 80 | import DNS.Do53.LookupX 81 | import DNS.Do53.Query 82 | import DNS.Do53.Types 83 | import Prelude hiding (lookup) 84 | -------------------------------------------------------------------------------- /dnsext-svcb/DNS/SVCB.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides Service Binding (SVCB) RR and HTTPS RR. 2 | module DNS.SVCB ( 3 | -- * Extension 4 | addResourceDataForSVCB, 5 | 6 | -- ** DNS types 7 | TYPE ( 8 | SVCB, 9 | HTTPS 10 | ), 11 | 12 | -- ** Resource data 13 | 14 | -- *** SVCB RR 15 | RD_SVCB, 16 | svcb_priority, 17 | svcb_target, 18 | svcb_params, 19 | rd_svcb, 20 | 21 | -- *** HTTPS RR 22 | RD_HTTPS, 23 | https_priority, 24 | https_target, 25 | https_params, 26 | rd_https, 27 | 28 | -- * Service parameters 29 | SvcParams, 30 | lookupSvcParam, 31 | extractSvcParam, 32 | toSvcParams, 33 | 34 | -- ** Service parameter keys 35 | SvcParamKey ( 36 | SPK_Mandatory, 37 | SPK_ALPN, 38 | SPK_NoDefaultALPN, 39 | SPK_Port, 40 | SPK_IPv4Hint, 41 | SPK_ECH, 42 | SPK_IPv6Hint, 43 | SPK_DoHPath 44 | ), 45 | fromSvcParamKey, 46 | toSvcParamKey, 47 | 48 | -- ** Service parameter values 49 | SvcParamValue, 50 | SPV (..), 51 | --- *** Mandatory 52 | SPV_Mandatory, 53 | mandatory_keys, 54 | spv_mandatory, 55 | --- *** ALPN 56 | SPV_ALPN, 57 | alpn_names, 58 | spv_alpn, 59 | ALPN, 60 | --- *** Port 61 | SPV_Port, 62 | port_number, 63 | spv_port, 64 | --- *** IPv4Hint 65 | SPV_IPv4Hint, 66 | hint_ipv4s, 67 | spv_ipv4hint, 68 | --- *** IPv6Hint 69 | SPV_IPv6Hint, 70 | hint_ipv6s, 71 | spv_ipv6hint, 72 | --- *** DoHPath 73 | SPV_DoHPath, 74 | dohpath, 75 | spv_dohpath, 76 | --- *** Others 77 | SPV_Opaque, 78 | opaque_value, 79 | spv_opaque, 80 | ) 81 | where 82 | 83 | import DNS.SVCB.Key 84 | import DNS.SVCB.Params 85 | import DNS.SVCB.SVCB 86 | import DNS.SVCB.Value 87 | import DNS.Types 88 | -------------------------------------------------------------------------------- /docs/bowline.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: bowline 4 | rank: 2 5 | --- 6 | 7 | # `bowline` 8 | 9 | `bowline` is a DNS full resolver (cache server) which supports: 10 | 11 | * Basic feature of DNS full resolvers (RFC 1123) 12 | * DNS over UDP 53 and TCP 53 13 | * DNS over TLS (RFC7858), QUIC (RFC 9250), H2 and H3 (RFC 8484) for communication with stub resolvers 14 | * DNSSEC for communication with authoritative servers (RFC 9364) 15 | * Negative Trust Anchor 16 | * stub-zone, local-zone, local-data 17 | * DNSTAP for logging 18 | * Web API (for reloading etc) 19 | * Monitor console 20 | * Prometheus 21 | 22 | ## Releases 23 | 24 | * [Binaries are available](https://github.com/iijlab/dnsext/releases) 25 | 26 | ## Installation 27 | 28 | We have a debian package hosted on public repository; follow the instruction below to install. 29 | 30 | ``` 31 | curl -1sLf \ 32 | 'https://dl.cloudsmith.io/public/iijlab/bowline/setup.deb.sh' \ 33 | | sudo -E bash 34 | sudo apt-get update 35 | sudo apt-get install bowline 36 | ``` 37 | 38 | ## Configuration 39 | 40 | * [`bowline.conf`](https://github.com/iijlab/dnsext/blob/main/dnsext-bowline/bowline/bowline.conf) 41 | * [`local-example.conf`](https://github.com/iijlab/dnsext/blob/main/dnsext-bowline/bowline/local-example.conf) 42 | * [`stub-example.conf`](https://github.com/iijlab/dnsext/blob/main/dnsext-bowline/bowline/stub-example.conf) 43 | 44 | ## Executing 45 | 46 | ``` 47 | % sudo bowline bowline.conf 48 | ``` 49 | 50 | If `bowline` runs well, a monitor console is provided via stdin/stdout. Type `help` to know its commands. 51 | 52 | ## Web API 53 | 54 | Send `GET` to the following path: 55 | 56 | * `/metrics`: get stats 57 | * `/stats`: get stats 58 | * `/wstats`: get workers' stats 59 | * `/reopen-log`: reopen a log file 60 | * `/reload`: reload 61 | * `/keep-cache`: Reloading with the cache kept 62 | * `/quit`: quit 63 | * `/help`: display help 64 | * `/`: display help 65 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module DNS.SEC.Time where 4 | 5 | import DNS.SEC.Imports 6 | import DNS.Types.Internal 7 | 8 | import qualified Data.ByteString.Char8 as C8 9 | import Data.Int (Int64) 10 | import Data.String (IsString, fromString) 11 | import Data.UnixTime 12 | import Foreign.C.Types (CTime (..)) 13 | 14 | newtype DNSTime = DNSTime {fromDNSTime :: Int64} deriving (Eq, Ord, Num) 15 | 16 | toDNSTime :: Int64 -> DNSTime 17 | toDNSTime = DNSTime 18 | 19 | instance Show DNSTime where 20 | show (DNSTime i32) = C8.unpack $ formatUnixTimeGMT webDateFormat $ UnixTime (CTime i32) 0 21 | 22 | {- read DNSTime from dig command output string -} 23 | readDigDNSTime :: String -> DNSTime 24 | readDigDNSTime s = DNSTime i 25 | where 26 | UnixTime (CTime i) _ = parseUnixTimeGMT (fromString "%Y%m%d%H%M%S") $ C8.pack s 27 | 28 | instance IsString DNSTime where 29 | fromString = readDigDNSTime 30 | 31 | -- | Given a 32-bit circle-arithmetic DNS time, and the current absolute epoch 32 | -- time, return the epoch time corresponding to the DNS timestamp. 33 | dnsTime 34 | :: Word32 35 | -- ^ DNS circle-arithmetic timestamp 36 | -> EpochTime 37 | -- ^ current epoch time 38 | -> DNSTime 39 | -- ^ absolute DNS timestamp 40 | dnsTime tdns tnow = 41 | let delta = tdns - fromIntegral tnow 42 | in if delta > 0x7FFFFFFF -- tdns is in the past? 43 | then DNSTime (tnow - (0x100000000 - fromIntegral delta)) 44 | else DNSTime (tnow + fromIntegral delta) 45 | 46 | -- | Helper to find position of RData end, that is, the offset of the first 47 | -- byte /after/ the current RData. 48 | getDNSTime :: Parser DNSTime 49 | getDNSTime rbuf ref = do 50 | tnow <- getAtTime ref 51 | tdns <- get32 rbuf 52 | return $ dnsTime tdns tnow 53 | 54 | putDNSTime :: DNSTime -> Builder () 55 | putDNSTime (DNSTime i32) wbuf _ = put32 wbuf $ fromIntegral i32 56 | -------------------------------------------------------------------------------- /dnsext-svcb/DNS/SVCB/Params.hs: -------------------------------------------------------------------------------- 1 | module DNS.SVCB.Params where 2 | 3 | import DNS.SVCB.Key 4 | import DNS.SVCB.Value 5 | import Data.IntMap.Strict (IntMap) 6 | import qualified Data.IntMap.Strict as M 7 | 8 | newtype SvcParams = SvcParams (IntMap SvcParamValue) deriving (Eq, Ord) 9 | 10 | instance Show SvcParams where 11 | show (SvcParams m) = unwords $ M.foldrWithKey f [] m 12 | where 13 | showkv k v = 14 | show (toSvcParamKey $ fromIntegral k) 15 | ++ "=" 16 | ++ showValue (toSvcParamKey $ fromIntegral k) v 17 | f k v xs = showkv k v : xs 18 | 19 | showValue :: SvcParamKey -> SvcParamValue -> String 20 | showValue SPK_Port v = case fromSvcParamValue v of 21 | Nothing -> "" 22 | Just x@(SPV_Port _) -> show x 23 | showValue SPK_IPv4Hint v = case fromSvcParamValue v of 24 | Nothing -> "" 25 | Just x@(SPV_IPv4Hint _) -> show x 26 | showValue SPK_IPv6Hint v = case fromSvcParamValue v of 27 | Nothing -> "" 28 | Just x@(SPV_IPv6Hint _) -> show x 29 | showValue SPK_ALPN v = case fromSvcParamValue v of 30 | Nothing -> "" 31 | Just x@(SPV_ALPN _) -> show x 32 | showValue SPK_DoHPath v = case fromSvcParamValue v of 33 | Nothing -> "" 34 | Just x@(SPV_DoHPath _) -> show x 35 | showValue SPK_ECH v = case fromSvcParamValue v of 36 | Nothing -> "" 37 | Just x@(SPV_ECH _) -> show x 38 | showValue _ v = show v 39 | 40 | lookupSvcParam :: SvcParamKey -> SvcParams -> Maybe SvcParamValue 41 | lookupSvcParam key (SvcParams m) = M.lookup k m 42 | where 43 | k = fromIntegral $ fromSvcParamKey key 44 | 45 | newSvcParams :: [(Int, SvcParamValue)] -> SvcParams 46 | newSvcParams kvs = SvcParams $ foldr ins M.empty kvs 47 | where 48 | ins (k, v) = M.insert k v 49 | 50 | toSvcParams :: [(SvcParamKey, SvcParamValue)] -> SvcParams 51 | toSvcParams kvs = SvcParams $ foldr ins M.empty kvs 52 | where 53 | ins (SvcParamKey k, v) = M.insert (fromIntegral k) v 54 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Query/TestEnv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module DNS.Iterative.Query.TestEnv where 4 | 5 | -- GHC packages 6 | import Data.IORef (newIORef, readIORef, writeIORef) 7 | 8 | -- dnsext-* packages 9 | import qualified DNS.RRCache as Cache 10 | import DNS.Types 11 | import DNS.Types.Time 12 | 13 | -- this package 14 | import DNS.Iterative.Imports hiding (insert) 15 | import DNS.Iterative.Query.Class (Address) 16 | import DNS.Iterative.Query.Env (Env (..), newEmptyEnv) 17 | import DNS.Iterative.Query.Norec (norec) 18 | 19 | newTestEnvNoCache :: ([String] -> IO ()) -> Bool -> IO Env 20 | newTestEnvNoCache putLines disableV6NS = (\env -> env{logLines_ = \_ _ -> putLines, disableV6NS_ = disableV6NS}) <$> newEmptyEnv 21 | 22 | newTestCache :: IO EpochTime -> Int -> IO (IO Cache.Cache, Question -> Seconds -> Cache.Hit -> Cache.Ranking -> IO ()) 23 | newTestCache getSec cacheSize = do 24 | cacheRef <- newIORef $ Cache.empty cacheSize 25 | let insert k ttl crs rank = do 26 | {- do not applying insertWithExpiresRRCache, because of the detached write thread in `Managed`. 27 | Want to check the result of writing immediately afterwards, so implement sequential logic. -} 28 | t <- getSec 29 | let withExpire = Cache.insertWithExpires t k ttl crs rank 30 | cache <- readIORef cacheRef 31 | maybe (pure ()) (writeIORef cacheRef) $ withExpire cache 32 | return (readIORef cacheRef, insert) 33 | 34 | newTestEnv :: ([String] -> IO ()) -> Bool -> Int -> IO Env 35 | newTestEnv putLines disableV6NS cacheSize = do 36 | env0@Env{..} <- newEmptyEnv 37 | (getCache, insert) <- newTestCache currentSeconds_ cacheSize 38 | pure $ env0{logLines_ = \_ _ -> putLines, disableV6NS_ = disableV6NS, insert_ = insert, getCache_ = getCache} 39 | 40 | testNorec :: MonadIO m => Env -> Bool -> NonEmpty Address -> Domain -> TYPE -> m (Either DNSError DNSMessage) 41 | testNorec = norec 42 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Flags.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BinaryLiterals #-} 2 | 3 | module DNS.SEC.Flags where 4 | 5 | import DNS.SEC.Imports 6 | import DNS.Types.Internal 7 | 8 | data DNSKEY_Flag = ZONE | REVOKE | SecureEntryPoint deriving (Eq, Ord, Show) 9 | 10 | toDNSKEYflags :: Word16 -> [DNSKEY_Flag] 11 | toDNSKEYflags w = catMaybes flags 12 | where 13 | jst c v = if c then Just v else Nothing 14 | flags = 15 | [ jst (w `testBit` 8) ZONE 16 | , jst (w `testBit` 7) REVOKE 17 | , jst (w `testBit` 0) SecureEntryPoint 18 | ] 19 | 20 | fromDNSKEYflags :: [DNSKEY_Flag] -> Word16 21 | fromDNSKEYflags flags = foldl' (.|.) 0 $ map toW flags 22 | where 23 | toW ZONE = 0b0000000100000000 24 | toW REVOKE = 0b0000000010000000 25 | toW SecureEntryPoint = 0b0000000000000001 26 | 27 | putDNSKEYflags :: [DNSKEY_Flag] -> Builder () 28 | putDNSKEYflags fs wbuf _ = put16 wbuf $ fromDNSKEYflags fs 29 | 30 | getDNSKEYflags :: Parser [DNSKEY_Flag] 31 | getDNSKEYflags rbuf _ = toDNSKEYflags <$> get16 rbuf 32 | 33 | data NSEC3_Flag = OptOut | NSEC3_Flag_Unknown Word8 deriving (Eq, Ord, Show) 34 | 35 | toNSEC3flags :: Word8 -> [NSEC3_Flag] 36 | toNSEC3flags w 37 | {- https://datatracker.ietf.org/doc/html/rfc5155#section-8.2 38 | "A validator MUST ignore NSEC3 RRs with a Flag fields value other than zero or one." -} 39 | | w `elem` [0, 1] = catMaybes flags 40 | | otherwise = [NSEC3_Flag_Unknown w] 41 | where 42 | jst c v = if c then Just v else Nothing 43 | flags = 44 | [ jst (w `testBit` 0) OptOut 45 | ] 46 | 47 | fromNSEC3flags :: [NSEC3_Flag] -> Word8 48 | fromNSEC3flags flags = foldl' (.|.) 0 $ map toW flags 49 | where 50 | toW OptOut = 0b00000001 51 | toW (NSEC3_Flag_Unknown w) = w 52 | 53 | putNSEC3flags :: [NSEC3_Flag] -> Builder () 54 | putNSEC3flags ns wbuf _ = put8 wbuf $ fromNSEC3flags ns 55 | 56 | getNSEC3flags :: Parser [NSEC3_Flag] 57 | getNSEC3flags rbuf _ = toNSEC3flags <$> get8 rbuf 58 | -------------------------------------------------------------------------------- /dnsext-do53/test/LookupSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LookupSpec where 4 | 5 | import DNS.Do53.Client as DNS 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "lookup" $ do 10 | it "lookupA" $ do 11 | withLookupConf defaultLookupConf $ \resolver -> do 12 | addrs <- DNS.lookupA resolver "mew.org" 13 | -- mew.org has one or more IPv6 addresses 14 | fmap null addrs `shouldBe` Right False 15 | 16 | it "lookupAAAA" $ do 17 | withLookupConf defaultLookupConf $ \resolver -> do 18 | -- google.com has one or more IPv6 addresses 19 | addrs <- DNS.lookupAAAA resolver "google.com" 20 | fmap null addrs `shouldBe` Right False 21 | 22 | it "lookupAAAA with empty result" $ do 23 | withLookupConf defaultLookupConf $ \resolver -> do 24 | addrs <- DNS.lookupAAAA resolver "ipv4.tlund.se" 25 | fmap null addrs `shouldBe` Right True 26 | 27 | it "lookupMX" $ do 28 | withLookupConf defaultLookupConf $ \resolver -> do 29 | addrs <- DNS.lookupMX resolver "mew.org" 30 | -- mew.org has one or more MX records. 31 | fmap null addrs `shouldBe` Right False 32 | 33 | it "lookupTXT" $ do 34 | withLookupConf defaultLookupConf $ \resolver -> do 35 | addrs <- DNS.lookupTXT resolver "mew.org" 36 | -- mew.org has one or more TXT records. 37 | fmap null addrs `shouldBe` Right False 38 | 39 | it "lookupSOA" $ do 40 | withLookupConf defaultLookupConf $ \resolver -> do 41 | addrs <- DNS.lookupTXT resolver "mew.org" 42 | -- mew.org has a SOA record. 43 | fmap null addrs `shouldBe` Right False 44 | 45 | it "lookupNS" $ do 46 | withLookupConf defaultLookupConf $ \resolver -> do 47 | addrs <- DNS.lookupNS resolver "mew.org" 48 | -- mew.org has one or more NS records. 49 | fmap null addrs `shouldBe` Right False 50 | -------------------------------------------------------------------------------- /dnsext-dox/DNS/DoX/HTTP3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module DNS.DoX.HTTP3 where 5 | 6 | import qualified Control.Exception as E 7 | import DNS.Do53.Client 8 | import DNS.Do53.Internal 9 | import qualified Network.HTTP3.Client as H3 10 | import qualified Network.QUIC.Client as QUIC 11 | 12 | import DNS.DoX.HTTP2 13 | import DNS.DoX.Imports 14 | import DNS.DoX.QUIC 15 | import DNS.DoX.TLS 16 | 17 | http3PersistentResolver :: PersistentResolver 18 | http3PersistentResolver ri@ResolveInfo{..} body = do 19 | cc <- getQUICParams ri tag "h3" -- TLS SNI 20 | toDNSError "http3PersistentResolver" $ QUIC.run cc $ \conn -> 21 | E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf -> do 22 | ident <- ractionGenId rinfoActions 23 | H3.run conn cliconf conf $ 24 | doHTTP tag ident ri body 25 | saveResumptionInfo conn ri tag 26 | where 27 | tag = nameTag ri "H3" 28 | auth = fromMaybe (show rinfoIP) rinfoServerName 29 | cliconf = 30 | H3.defaultClientConfig 31 | { H3.scheme = "https" 32 | , H3.authority = auth -- HTTP :authority 33 | } 34 | 35 | http3Resolver :: OneshotResolver 36 | http3Resolver ri@ResolveInfo{..} q qctl = do 37 | cc <- getQUICParams ri tag "h3" -- TLS SNI 38 | toDNSError "http3Resolver" $ QUIC.run cc $ \conn -> 39 | E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf -> do 40 | ident <- ractionGenId rinfoActions 41 | withTimeout ri $ do 42 | res <- 43 | H3.run conn cliconf conf $ 44 | doHTTPOneshot tag ident ri q qctl 45 | saveResumptionInfo conn ri tag 46 | return res 47 | where 48 | tag = nameTag ri "H3" 49 | auth = fromMaybe (show rinfoIP) rinfoServerName 50 | cliconf = 51 | H3.defaultClientConfig 52 | { H3.scheme = "https" 53 | , H3.authority = auth -- HTTP :authority 54 | } 55 | -------------------------------------------------------------------------------- /pkg/template/debian/copyright: -------------------------------------------------------------------------------- 1 | Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ 2 | Upstream-Name: bowline 3 | Upstream-Contact: Kei Hibino 4 | Source: https://github.com/kazu-yamamoto/dnsext/ 5 | 6 | Files: * 7 | License: BSD-3-clause 8 | Copyright: 2022-2025 Internet Initiative Japan Inc. 9 | 10 | Files: debian/* 11 | Copyright: held by the contributors mentioned in debian/changelog 12 | License: BSD-3-clause 13 | 14 | License: BSD-3-clause 15 | Redistribution and use in source and binary forms, with or without modification, 16 | are permitted provided that the following conditions are met: 17 | . 18 | 1. Redistributions of source code must retain the above copyright notice, 19 | this list of conditions and the following disclaimer. 20 | . 21 | 2. Redistributions in binary form must reproduce the above copyright 22 | notice, this list of conditions and the following disclaimer in the 23 | documentation and/or other materials provided with the distribution. 24 | . 25 | 3. Neither the name of copyright holder(s) nor the names of its contributors may be used 26 | to endorse or promote products derived from this software without 27 | specific prior written permission. 28 | . 29 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 30 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 31 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 32 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 33 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 34 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 35 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 36 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 37 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 38 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 39 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Server/PrometheusHisto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | 3 | -- emulate prometheus histogram 4 | module DNS.Iterative.Server.PrometheusHisto where 5 | 6 | import Data.ByteString.Builder (Builder) 7 | 8 | import DNS.Iterative.Imports 9 | import DNS.Iterative.Stats (Stats, bucketUpperBounds, readHistogram, readQueryTimeSumUsec) 10 | 11 | getHistogramBucktes :: Stats -> Builder -> IO Builder 12 | getHistogramBucktes stats_ prefix = formatBuckets prefix <$> readHistogram stats_ <*> readQueryTimeSumUsec stats_ 13 | 14 | {- FOURMOLU_DISABLE -} 15 | formatBuckets :: Builder -> [Int] -> Int -> Builder 16 | formatBuckets prefix hvs sumVal = mconcat $ zipWith bformat bucketUpperBounds pbackets ++ [inf_, sum_, count_] 17 | where 18 | pbackets = drop 1 $ scanl (+) 0 hvs 19 | countVal 20 | | null pbackets = 0 21 | | otherwise = last pbackets 22 | bformat ub bv = prefix <> fromString ("response_time_seconds_bucket" ++ "{" ++ bucketKey ub ++ "}" ++ " " ++ show bv ++ "\n") 23 | inf_ = prefix <> fromString ("response_time_seconds_bucket" ++ "{le=\"+Inf\"}" ++ " " ++ show countVal ++ "\n") 24 | sum_ = prefix <> fromString ("response_time_seconds_sum" ++ " " ++ show sec ++ '.' : replicate (6 - length uss) '0' ++ uss ++ "\n") 25 | where 26 | uss = show usec 27 | (sec, usec) = sumVal `quotRem `1_000_000 28 | count_ = prefix <> fromString ("response_time_seconds_count" ++ " " ++ show countVal ++ "\n") 29 | {- FOURMOLU_ENABLE -} 30 | 31 | bucketKey :: (Int64, Int64) -> String 32 | bucketKey upper = "le=" ++ ['"'] ++ bucketKey' upper ++ ['"'] 33 | 34 | {- FOURMOLU_DISABLE -} 35 | bucketKey' :: (Int64, Int64) -> String 36 | bucketKey' (s, u) 37 | | s == 0 && u <= 8 = show u ++ "e-06" 38 | | s == 0 && u <= 64 = show n1 ++ "." ++ show n2 ++ "e-05" 39 | | s == 0 = "0." ++ u6 40 | | otherwise = show s 41 | where 42 | ~(n1, n2) = u `quotRem` 10 43 | ~u6 = replicate (6 - length su) '0' ++ su 44 | where su = show u 45 | {- FOURMOLU_ENABLE -} 46 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Types/Encode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module DNS.Types.Encode ( 4 | -- * Main encoder 5 | encode, 6 | 7 | -- * Encoders for parts 8 | encodeDNSFlags, 9 | encodeQuestion, 10 | encodeResourceRecord, 11 | encodeRData, 12 | encodeDomain, 13 | encodeMailbox, 14 | ) where 15 | 16 | import DNS.Types.Domain 17 | import DNS.Types.EDNS 18 | import DNS.Types.Imports 19 | import DNS.Types.Message 20 | import DNS.Types.RData 21 | import DNS.Wire 22 | 23 | -- | Encode DNS message. 24 | encode :: DNSMessage -> ByteString 25 | encode msg@DNSMessage{..} = runBuilder siz $ putDNSMessage msg 26 | where 27 | siz = 28 | 16 29 | + mapEDNS ednsHeader ednsSize 0 30 | + sum (map qsiz question) 31 | + sum (map resourceRecordSize answer) 32 | + sum (map resourceRecordSize authority) 33 | + sum (map resourceRecordSize additional) 34 | ednsSize eh = 11 + sum (map (\o -> 4 + odataSize o) $ ednsOptions eh) 35 | 36 | -- | Encode DNS flags. 37 | encodeDNSFlags :: (DNSFlags, OPCODE, RCODE) -> ByteString 38 | encodeDNSFlags = runBuilder 2 . putDNSFlags 39 | 40 | -- | Encode a question. 41 | encodeQuestion :: Question -> ByteString 42 | encodeQuestion q = runBuilder (qsiz q) $ putQuestion Original q 43 | 44 | qsiz :: Question -> Int 45 | qsiz Question{..} = domainSize qname + 4 46 | 47 | -- | Encode a resource record. 48 | encodeResourceRecord :: ResourceRecord -> ByteString 49 | encodeResourceRecord rr = runBuilder (resourceRecordSize rr) $ putResourceRecord Original rr 50 | 51 | -- | Encode a resource data. 52 | encodeRData :: RData -> ByteString 53 | encodeRData rd = runBuilder (rdataSize rd) $ putRData Original rd 54 | 55 | -- | Encode a domain with name compression. 56 | encodeDomain :: Domain -> ByteString 57 | encodeDomain d = runBuilder (domainSize d) $ putDomainRFC1035 Original d 58 | 59 | -- | Encode a mailbox name with name compression. 60 | encodeMailbox :: Mailbox -> ByteString 61 | encodeMailbox m = runBuilder (mailboxSize m) $ putMailboxRFC1035 Original m 62 | -------------------------------------------------------------------------------- /dnsext-svcb/dnsext-svcb.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: dnsext-svcb 3 | version: 0.0.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | maintainer: Kazu Yamamoto 7 | author: Kazu Yamamoto 8 | tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==9.0.2 ghc ==9.2.4 9 | synopsis: SVCB for Extensible DNS libraries 10 | description: 11 | SVCB and HTTPS RR for Extensible DNS libraries which are written 12 | purely in Haskell 13 | 14 | category: Network 15 | build-type: Simple 16 | extra-source-files: CHANGELOG.md 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/kazu-yamamoto/dnsext 21 | 22 | library 23 | exposed-modules: 24 | DNS.SVCB 25 | DNS.SVCB.Internal 26 | 27 | other-modules: 28 | DNS.SVCB.Imports 29 | DNS.SVCB.Key 30 | DNS.SVCB.Params 31 | DNS.SVCB.SVCB 32 | DNS.SVCB.Value 33 | 34 | default-language: Haskell2010 35 | ghc-options: -Wall 36 | build-depends: 37 | -- GHC bundled 38 | base >=4 && <5, 39 | bytestring, 40 | containers, 41 | -- dnsext packages 42 | dnsext-types, 43 | -- other packages 44 | ech-config >= 0.0.1, 45 | iproute, 46 | network >= 3.2.2 && < 3.3 47 | 48 | if impl(ghc >=8) 49 | default-extensions: Strict StrictData 50 | 51 | test-suite spec 52 | type: exitcode-stdio-1.0 53 | main-is: Spec.hs 54 | build-tool-depends: hspec-discover:hspec-discover 55 | hs-source-dirs: test 56 | other-modules: RoundTripSpec 57 | default-language: Haskell2010 58 | ghc-options: -Wall 59 | build-depends: 60 | -- GHC bundled 61 | base, 62 | bytestring, 63 | -- this package 64 | dnsext-svcb, 65 | -- dnsext packages 66 | dnsext-types, 67 | -- other packages 68 | QuickCheck >=2.9, 69 | hspec 70 | -------------------------------------------------------------------------------- /dnsext-bowline/include/HsSockOptConfig.h.in: -------------------------------------------------------------------------------- 1 | /* include/HsSockOptConfig.h.in. Generated from configure.ac by autoheader. */ 2 | 3 | /* Define to 1 if you have the declaration of 'IPPROTO_TCP', and to 0 if you 4 | don't. */ 5 | #undef HAVE_DECL_IPPROTO_TCP 6 | 7 | /* Define to 1 if you have the header file. */ 8 | #undef HAVE_INTTYPES_H 9 | 10 | /* Define to 1 if you have the header file. */ 11 | #undef HAVE_NETINET_IN_H 12 | 13 | /* Define to 1 if you have the header file. */ 14 | #undef HAVE_NETINET_TCP_H 15 | 16 | /* Define to 1 if you have the header file. */ 17 | #undef HAVE_STDINT_H 18 | 19 | /* Define to 1 if you have the header file. */ 20 | #undef HAVE_STDIO_H 21 | 22 | /* Define to 1 if you have the header file. */ 23 | #undef HAVE_STDLIB_H 24 | 25 | /* Define to 1 if you have the header file. */ 26 | #undef HAVE_STRINGS_H 27 | 28 | /* Define to 1 if you have the header file. */ 29 | #undef HAVE_STRING_H 30 | 31 | /* Define to 1 if you have the header file. */ 32 | #undef HAVE_SYS_STAT_H 33 | 34 | /* Define to 1 if you have the header file. */ 35 | #undef HAVE_SYS_TYPES_H 36 | 37 | /* Define to 1 if you have the header file. */ 38 | #undef HAVE_UNISTD_H 39 | 40 | /* Define to the address where bug reports for this package should be sent. */ 41 | #undef PACKAGE_BUGREPORT 42 | 43 | /* Define to the full name of this package. */ 44 | #undef PACKAGE_NAME 45 | 46 | /* Define to the full name and version of this package. */ 47 | #undef PACKAGE_STRING 48 | 49 | /* Define to the one symbol short name of this package. */ 50 | #undef PACKAGE_TARNAME 51 | 52 | /* Define to the home page for this package. */ 53 | #undef PACKAGE_URL 54 | 55 | /* Define to the version of this package. */ 56 | #undef PACKAGE_VERSION 57 | 58 | /* Define to 1 if all of the C89 standard headers exist (not just the ones 59 | required in a freestanding environment). This macro is provided for 60 | backward compatibility; new code need not use it. */ 61 | #undef STDC_HEADERS 62 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/ZoneFile/ParserDNSSEC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module DNS.ZoneFile.ParserDNSSEC where 4 | 5 | -- GHC packages 6 | import Control.Applicative 7 | import Data.ByteString.Short (fromShort) 8 | import Data.Word 9 | 10 | -- dnsext-* packages 11 | import DNS.SEC 12 | import DNS.Types (Opaque, RData) 13 | import qualified DNS.Types.Opaque as Opaque 14 | 15 | -- this package 16 | import DNS.Parser 17 | import DNS.ZoneFile.ParserBase 18 | import DNS.ZoneFile.Types 19 | 20 | {- FOURMOLU_DISABLE -} 21 | rdatasDNSSEC :: MonadParser Token s m => [(TYPE, m RData)] 22 | rdatasDNSSEC = 23 | [ (DS , rdataDS) 24 | , (DNSKEY , rdataDNSKEY) 25 | ] 26 | {- FOURMOLU_ENABLE -} 27 | 28 | ----- 29 | 30 | {- FOURMOLU_DISABLE -} 31 | rdataDS :: MonadParser Token s m => m RData 32 | rdataDS = 33 | rd_ds 34 | <$> keytag <*> (blank *> pubalg) <*> (blank *> digestalg) 35 | <*> (blank *> digest) 36 | {- FOURMOLU_ENABLE -} 37 | 38 | {- FOURMOLU_DISABLE -} 39 | rdataDNSKEY :: MonadParser Token s m => m RData 40 | rdataDNSKEY = do 41 | mkRD <- rd_dnskey <$> keyflags <*> (blank *> proto) 42 | alg <- blank *> pubalg 43 | pkey <- blank *> (toPubKey alg <$> keyB64) 44 | pure $ mkRD alg pkey 45 | where 46 | keyflags = toDNSKEYflags <$> readCString "dnskey.flags" 47 | proto = readCString "dnskey.proto" 48 | handleB64 = either (raise . ("Parser.rdataDNSKEY: fromBase64: " ++)) pure 49 | part = fromShort . cs_cs <$> lstring 50 | parts = (mconcat <$>) $ (:) <$> part <*> many (blank *> part) 51 | keyB64 = handleB64 . Opaque.fromBase64 =<< parts 52 | {- FOURMOLU_ENABLE -} 53 | 54 | ----- 55 | 56 | keytag :: MonadParser Token s m => m Word16 57 | keytag = readCString "keytag" 58 | 59 | pubalg :: MonadParser Token s m => m PubAlg 60 | pubalg = toPubAlg <$> readCString "pubalg" 61 | 62 | digestalg :: MonadParser Token s m => m DigestAlg 63 | digestalg = toDigestAlg <$> readCString "digestalg" 64 | 65 | digest :: MonadParser Token s m => m Opaque 66 | digest = handleB16 . Opaque.fromBase16 . fromShort =<< cstring 67 | where 68 | handleB16 = either (raise . ("Parser.digest: fromBase16: " ++)) pure 69 | -------------------------------------------------------------------------------- /pkg/proto-checks.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | set_ports() { 4 | mode="$1" 5 | case $mode in 6 | root) 7 | udp_port=53 8 | tcp_port=53 9 | tls_port=853 10 | h2c_port=80 11 | h2_port=443 12 | h3_port=443 13 | quic_port=853 14 | ;; 15 | *) 16 | udp_port=1053 17 | tcp_port=1053 18 | tls_port=1853 19 | h2c_port=1080 20 | h2_port=1443 21 | h3_port=1443 22 | quic_port=1853 23 | ;; 24 | esac 25 | } 26 | 27 | check() { 28 | local proto="$1" 29 | local addr="$2" 30 | 31 | case "$proto" in 32 | udp) 33 | set -x 34 | dug @${addr} $domain $type -p $udp_port -d udp 35 | ;; 36 | 37 | tcp) 38 | set -x 39 | dug @${addr} $domain $type -p $tcp_port -d tcp 40 | ;; 41 | 42 | tls|dot) 43 | set -x 44 | dug @${addr} $domain $type -p $tls_port -d dot 45 | ;; 46 | 47 | h2c|doh2c) 48 | set -x 49 | dug @${addr} $domain $type -p $h2c_port -d h2c 50 | ;; 51 | 52 | h2|doh2) 53 | set -x 54 | dug @${addr} $domain $type -p $h2_port -d h2 55 | ;; 56 | 57 | h3|doh3) 58 | set -x 59 | dug @${addr} $domain $type -p $h3_port -d h3 60 | ;; 61 | 62 | quic|doq) 63 | set -x 64 | dug @${addr} $domain $type -p $quic_port -d doq 65 | ;; 66 | 67 | all) 68 | for p in udp tcp h2c h2 h3 tls quic ; do 69 | check $p $addr 70 | done 71 | ;; 72 | 73 | *) 74 | cat <>> :seti -XOverloadedStrings 15 | 16 | {- FOURMOLU_DISABLE -} 17 | -- | 18 | -- >>> subdomainSemilatticeOn id [] 19 | -- [] 20 | -- >>> subdomainSemilatticeOn id ["example.", "b.example.", "a.example."] 21 | -- [("example.",["b.example.","a.example.","example."])] 22 | -- >>> subdomainSemilatticeOn id ["example.", "b.example.", "a.example.", "a.example.com.", "example.com."] 23 | -- [("example.com.",["a.example.com.","example.com."]),("example.",["b.example.","a.example.","example."])] 24 | subdomainSemilatticeOn :: (a -> Domain) -> [a] -> [(Domain, [a])] 25 | subdomainSemilatticeOn f = unfoldr subdoms . sortOn f 26 | where 27 | subdoms [] = Nothing 28 | subdoms (x:xs) = Just ((fx, reverse hd), tl) {- check target between smallest and largest in sub-domain lattice -} 29 | where 30 | fx = f x 31 | (hd, tl) = span ((`isSubDomainOf` fx) . f) $ x : xs 32 | {- FOURMOLU_ENABLE -} 33 | 34 | -- | 35 | -- >>> semilattice xs = Map.fromList $ subdomainSemilatticeOn id xs 36 | -- >>> lookupApexOn id (semilattice ["example.", "s.example", "example.com."]) "xexample." 37 | -- Nothing 38 | -- >>> lookupApexOn id (semilattice ["example.", "s.example", "example.com."]) "example." 39 | -- Just "example." 40 | -- >>> lookupApexOn id (semilattice ["example.", "s.example", "example.com."]) "x.a.example." 41 | -- Just "example." 42 | -- >>> lookupApexOn id (semilattice ["example.", "s.example", "example.com."]) "a.s.example." 43 | -- Just "s.example." 44 | -- >>> lookupApexOn id (semilattice ["example.", "s.example", "example.com."]) "a.t.example." 45 | -- Just "example." 46 | -- >>> lookupApexOn id (semilattice ["example.", "s.example", "example.com."]) "a.example.com." 47 | -- Just "example.com." 48 | lookupApexOn :: (a -> Domain) -> Map Domain [a] -> Domain -> Maybe a 49 | lookupApexOn f aMap dom = do 50 | (_super, subs) <- Map.lookupLE dom aMap 51 | find ((dom `isSubDomainOf`) . f) subs 52 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/ThreadAsync.hs: -------------------------------------------------------------------------------- 1 | module DNS.ThreadAsync where 2 | 3 | -- GHC internal 4 | import GHC.Conc.Sync (labelThread) 5 | 6 | -- base 7 | import Control.Monad 8 | 9 | -- async 10 | import Control.Concurrent.Async (Async, asyncThreadId) 11 | import qualified Control.Concurrent.Async as Async 12 | 13 | {- FOURMOLU_DISABLE -} 14 | async :: String -> IO a -> IO (Async a) 15 | withAsync :: String -> IO a -> (Async a -> IO b) -> IO b 16 | withAsyncs :: [(String, IO a)] -> ([Async a] -> IO b) -> IO b 17 | concurrently :: String -> IO a -> String -> IO b -> IO (a, b) 18 | concurrently_ :: String -> IO a -> String -> IO b -> IO () 19 | race :: String -> IO a -> String -> IO b -> IO (Either a b) 20 | race_ :: String -> IO a -> String -> IO b -> IO () 21 | concurrentlyList :: [(String, IO a)] -> IO [a] 22 | concurrentlyList_ :: [(String, IO a)] -> IO () 23 | raceList :: [(String, IO a)] -> IO (Async a, a) 24 | raceList_ :: [(String, IO a)] -> IO () 25 | {- FOURMOLU_ENABLE -} 26 | 27 | async name io = do 28 | a <- Async.async io 29 | labelThread (asyncThreadId a) name 30 | pure a 31 | 32 | withAsync name io h0 = 33 | Async.withAsync io h 34 | where 35 | h a = do 36 | labelThread (asyncThreadId a) name 37 | h0 a 38 | 39 | withAsyncs ps h = foldr op (\f -> h (f [])) ps id 40 | where 41 | op (n, io) action = \s -> withAsync n io $ \a -> action (s . (a :)) 42 | 43 | {- FOURMOLU_DISABLE -} 44 | concurrently nleft left nright right = 45 | withAsync nleft left $ \a -> 46 | withAsync nright right $ \b -> 47 | Async.waitBoth a b 48 | {- FOURMOLU_ENABLE -} 49 | 50 | concurrently_ nleft left nright right = void $ concurrently nleft left nright right 51 | 52 | {- FOURMOLU_DISABLE -} 53 | race nleft left nright right = 54 | withAsync nleft left $ \a -> 55 | withAsync nright right $ \b -> 56 | Async.waitEither a b 57 | {- FOURMOLU_ENABLE -} 58 | 59 | race_ nleft left nright right = void $ race nleft left nright right 60 | 61 | -- | 62 | -- >>> concurrentlyList $ zip [[c] | c <- ['a'..]] [pure x | x <- [1::Int .. 5]] 63 | -- [1,2,3,4,5] 64 | concurrentlyList ps = withAsyncs ps $ mapM Async.wait 65 | 66 | concurrentlyList_ = void . concurrentlyList 67 | 68 | raceList ps = withAsyncs ps Async.waitAny 69 | 70 | raceList_ = void . raceList 71 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Server/Bench.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | 3 | module DNS.Iterative.Server.Bench ( 4 | benchServer, 5 | Request, 6 | ) where 7 | 8 | -- GHC packages 9 | import Control.Concurrent 10 | import Control.Monad (forever) 11 | import Data.ByteString (ByteString) 12 | import qualified Data.List.NonEmpty as NE 13 | 14 | -- other packages 15 | import Network.Socket 16 | 17 | -- this package 18 | import DNS.Iterative.Internal 19 | import DNS.Iterative.Server.Pipeline 20 | import DNS.Iterative.Server.Types 21 | 22 | ---------------------------------------------------------------- 23 | ---------------------------------------------------------------- 24 | -- Benchmark 25 | 26 | type Request a = (ByteString, a) 27 | type Response a = (ByteString, a) 28 | 29 | benchServer 30 | :: Int 31 | -> Env 32 | -> Bool 33 | -> IO ([IO ()], Request () -> IO (), IO (Response ())) 34 | benchServer bench_pipelines _ True = do 35 | reqQ <- newChan 36 | resQ <- newChan 37 | let pipelines_per_socket = bench_pipelines 38 | let pipelines = replicate pipelines_per_socket [forever $ writeChan resQ =<< readChan reqQ] 39 | return (concat pipelines, writeChan reqQ, readChan resQ) 40 | benchServer bench_pipelines env _ = do 41 | myDummy <- getSockAddr "127.1.1.1" "53" 42 | clntDummy <- getSockAddr "127.2.1.1" "53" 43 | usecDummy <- currentTimeUsec_ env 44 | 45 | let pipelines_per_socket = bench_pipelines 46 | workers_per_pipeline = 8 {- only used initial setup, benchmark runs on cached state -} 47 | cacherStats <- getWorkerStats pipelines_per_socket 48 | workerStats <- getWorkerStats workers_per_pipeline 49 | (cachers, workers, toCacher) <- mkPipeline env cacherStats workerStats 50 | 51 | resQ <- newChan 52 | 53 | let toSender = writeChan resQ 54 | 55 | enqueueReq (bs, ()) = toCacher (mkInput myDummy toSender UDP bs (PeerInfoUDP clntDummy []) noPendingOp usecDummy) 56 | dequeueRes = (\(Output bs _ _) -> (bs, ())) <$> readChan resQ 57 | return (cachers ++ workers, enqueueReq, dequeueRes) 58 | where 59 | getSockAddr host port = 60 | addrAddress . NE.head 61 | <$> getAddrInfo (Just $ defaultHints{addrSocketType = Datagram, addrFlags = [AI_ADDRCONFIG]}) (Just host) (Just port) 62 | -------------------------------------------------------------------------------- /pkg/template/debian/bowline.init: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | ### BEGIN INIT INFO 4 | # Provides: bowline 5 | # Required-Start: $remote_fs $network 6 | # Required-Stop: $remote_fs $network 7 | # Should-Start: $syslog 8 | # Should-Stop: $syslog 9 | # Default-Start: 2 3 4 5 10 | # Default-Stop: 0 1 6 11 | # Short-Description: Bowline DNS full-service-resolver 12 | ### END INIT INFO 13 | 14 | NAME=bowline 15 | DESC="DNS server" 16 | DAEMON=/opt/bowline/bin/bowline 17 | PIDFILE=/run/bowline.pid 18 | 19 | test -x $DAEMON || exit 0 20 | 21 | export PATH=/bin:/usr/bin:/sbin:/usr/sbin 22 | 23 | . /lib/lsb/init-functions 24 | 25 | if [ -f /etc/default/bowline ]; then 26 | . /etc/default/bowline 27 | fi 28 | 29 | case "$1" in 30 | start) 31 | log_daemon_msg "Starting $DESC" "$NAME" 32 | if start-stop-daemon --start --chdir /opt/bowline --background --make-pidfile --pidfile $PIDFILE --name $NAME \ 33 | --exec $DAEMON -- /opt/bowline/etc/bowline.conf $DAEMON_OPTS; then 34 | log_end_msg 0 35 | else 36 | log_end_msg 1 37 | fi 38 | ;; 39 | 40 | stop) 41 | log_daemon_msg "Stopping $DESC" "$NAME" 42 | rv=$(/usr/bin/curl --silent http://127.0.0.1:8080/quit) 43 | echo -e "\n$rv" 44 | log_end_msg 0 45 | ;; 46 | 47 | reload) 48 | log_daemon_msg "Reloading with keeping cache $DESC" "$NAME" 49 | rv=$(/usr/bin/curl --silent http://127.0.0.1:8080/keep-cache) 50 | echo -e "\n$rv" 51 | if [ x"$rv" = xOK ]; then 52 | log_end_msg 0 53 | else 54 | log_end_msg 1 55 | fi 56 | ;; 57 | 58 | force-reload) 59 | log_daemon_msg "Reloading $DESC" "$NAME" 60 | rv=$(/usr/bin/curl --silent http://127.0.0.1:8080/reload) 61 | echo -e "\n$rv" 62 | if [ x"$rv" = xOK ]; then 63 | log_end_msg 0 64 | else 65 | log_end_msg 1 66 | fi 67 | ;; 68 | 69 | restart) 70 | $0 stop 71 | sleep 1 72 | $0 start 73 | ;; 74 | 75 | status) 76 | /usr/bin/curl http://127.0.0.1:8080/stats 77 | ;; 78 | 79 | *) 80 | echo "Usage: /etc/init.d/$NAME {start|stop|restart|status|reload|force-reload}" >&2 81 | exit 1 82 | ;; 83 | esac 84 | -------------------------------------------------------------------------------- /dnsext-bowline/dug/Iterative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Iterative (iterativeQuery, getRootV6) where 4 | 5 | -- 6 | import Data.Functor 7 | import Data.List.NonEmpty (NonEmpty (..)) 8 | import System.Timeout (timeout) 9 | 10 | -- 11 | 12 | import DNS.Do53.Client (QueryControls) 13 | import DNS.Iterative.Internal (Delegation (..), delegationEntry) 14 | import DNS.Iterative.Query (Env (..), newEmptyEnv, resolveResponseIterative, setRRCacheOps, setTimeCache) 15 | import qualified DNS.Log as Log 16 | import qualified DNS.RRCache as Cache 17 | import DNS.TimeCache (getTime, newTimeCache) 18 | import Data.IP (IP (IPv6)) 19 | import Network.Socket (PortNumber) 20 | 21 | import DNS.Types 22 | 23 | import Types (Options (..), shortLog) 24 | 25 | {- FOURMOLU_DISABLE -} 26 | getRootV6 :: IO [(IP, PortNumber)] 27 | getRootV6 = do 28 | Env{rootHint_=Delegation{delegationNS=d:|ds}} <- newEmptyEnv 29 | pure $ foldr takeV6 [] $ d:ds 30 | where 31 | nlist (x:|xs) = x:xs 32 | ax _ _ n6 xs = [(IPv6 a, 53) | a <- nlist n6] ++ xs 33 | a6 _ n6 xs = [(IPv6 a, 53) | a <- nlist n6] ++ xs 34 | takeV6 = delegationEntry ax (\_ _ xs -> xs) a6 (\_ xs -> xs) (\_ xs -> xs) (\_ xs -> xs) 35 | {- FOURMOLU_ENABLE -} 36 | 37 | iterativeQuery 38 | :: (DNSMessage -> IO ()) 39 | -> Log.PutLines IO 40 | -> (Question, QueryControls) 41 | -> Options 42 | -> IO () 43 | iterativeQuery putLn putLines qq opts = do 44 | env <- setup putLines opts 45 | er <- resolve env qq 46 | case er of 47 | Left e -> print e 48 | Right msg -> putLn msg 49 | 50 | setup :: Log.PutLines IO -> Options -> IO Env 51 | setup putLines opt@Options{..} = do 52 | tcache <- newTimeCache 53 | let cacheConf = Cache.getDefaultStubConf (4 * 1024) 600 $ getTime tcache 54 | cacheOps <- Cache.newRRCacheOps cacheConf 55 | let tmout = timeout 3000000 56 | setOps = setRRCacheOps cacheOps . setTimeCache tcache 57 | newEmptyEnv <&> \env0 -> 58 | (setOps env0) 59 | { shortLog_ = shortLog opt 60 | , logLines_ = putLines 61 | , disableV6NS_ = optDisableV6NS 62 | , timeout_ = tmout 63 | } 64 | 65 | resolve 66 | :: Env -> (Question, QueryControls) -> IO (Either String DNSMessage) 67 | resolve env (q, ctl) = resolveResponseIterative env q ctl 68 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-dodgy-imports #-} 3 | 4 | module DNS.Iterative.Imports ( 5 | ByteString, 6 | module Control.Applicative, 7 | module Control.Arrow, 8 | module Control.Monad, 9 | module Control.Monad.IO.Class, 10 | module Control.Monad.Trans.Class, 11 | module Control.Monad.Trans.Except, 12 | module Control.Monad.Trans.Reader, 13 | module Data.Bits, 14 | module Data.Bool, 15 | module Data.Function, 16 | module Data.Functor, 17 | module Data.Int, 18 | module Data.List, 19 | module Data.List.NonEmpty, 20 | module Data.Maybe, 21 | module Data.Monoid, 22 | module Data.Ord, 23 | module Data.String, 24 | module Data.Typeable, 25 | module Data.Word, 26 | module Numeric, 27 | module DNS.Types.Time, 28 | unzipNE, 29 | ednsHeaderCases, 30 | ) 31 | where 32 | 33 | -- GHC packages 34 | import Control.Applicative 35 | import Control.Arrow (first, second, (&&&), (***), (<<<), (>>>)) 36 | import Control.Monad 37 | import Control.Monad.IO.Class 38 | import Control.Monad.Trans.Class 39 | import Control.Monad.Trans.Except hiding (liftCallCC) 40 | import Control.Monad.Trans.Reader 41 | import Data.Bits 42 | import Data.Bool (bool) 43 | import Data.ByteString (ByteString) 44 | import Data.Function 45 | import Data.Functor hiding (unzip) 46 | import Data.Int 47 | import Data.List 48 | import Data.List.NonEmpty (NonEmpty (..), nonEmpty) 49 | import Data.Maybe 50 | import Data.Monoid 51 | import Data.Ord 52 | import Data.String 53 | import Data.Typeable 54 | import Data.Word 55 | import Numeric 56 | 57 | -- dns packages 58 | import DNS.Types (EDNS (..), EDNSheader (..)) 59 | import DNS.Types.Time (EpochTime, EpochTimeUsec) 60 | 61 | #if __GLASGOW_HASKELL__ >= 910 62 | import qualified Data.Functor as F 63 | 64 | unzipNE :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) 65 | unzipNE = F.unzip 66 | #else 67 | import qualified Data.List.NonEmpty as NE 68 | 69 | unzipNE :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) 70 | unzipNE = NE.unzip 71 | #endif 72 | 73 | {- FOURMOLU_DISABLE -} 74 | -- fold EDNS 75 | ednsHeaderCases :: (EDNS -> a) -> a -> a -> EDNSheader -> a 76 | ednsHeaderCases heh noh inv eh = case eh of 77 | EDNSheader edns -> heh edns 78 | NoEDNS -> noh 79 | InvalidEDNS -> inv 80 | {- FOURMOLU_ENABLE -} 81 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Verify/EdDSA.hs: -------------------------------------------------------------------------------- 1 | module DNS.SEC.Verify.EdDSA ( 2 | ed25519, 3 | ed448, 4 | ) 5 | where 6 | 7 | import Crypto.Error (CryptoFailable, onCryptoFailure) 8 | import qualified Crypto.PubKey.Ed25519 as Ed25519 9 | import qualified Crypto.PubKey.Ed448 as Ed448 10 | import DNS.SEC.PubKey 11 | import DNS.SEC.Verify.Types 12 | import DNS.Types 13 | import qualified DNS.Types.Opaque as Opaque 14 | import Data.ByteString (ByteString) 15 | 16 | {- Verify RRSIG with DNSKEY using Edwards-Curve Digital Security Algorithm (EdDSA) 17 | -- https://datatracker.ietf.org/doc/html/rfc6605 18 | -} 19 | 20 | ed25519 :: RRSIGImpl 21 | ed25519 = eddsaHelper "Ed25519" Ed25519.publicKey Ed25519.signature Ed25519.verify 22 | 23 | ed448 :: RRSIGImpl 24 | ed448 = eddsaHelper "Ed448" Ed448.publicKey Ed448.signature Ed448.verify 25 | 26 | eddsaHelper 27 | :: String 28 | -> (ByteString -> CryptoFailable pubkey) 29 | -> (ByteString -> CryptoFailable sig) 30 | -> (pubkey -> ByteString -> sig -> Bool) 31 | -> RRSIGImpl 32 | eddsaHelper algName consPublicKey consSignature verifyImpl = 33 | RRSIGImpl 34 | { rrsigIGetKey = eddsaDecodePubKey algName consPublicKey 35 | , rrsigIGetSig = eddsaDecodeSignature algName consSignature 36 | , rrsigIVerify = eddsaVerify verifyImpl 37 | } 38 | 39 | eddsaDecodePubKey 40 | :: String 41 | -> (ByteString -> CryptoFailable pubkey) 42 | -> PubKey 43 | -> Either String pubkey 44 | eddsaDecodePubKey algName consPublicKey (PubKey_Opaque ks) = 45 | eitherCryptoFailable (algName ++ ".publicKey") . consPublicKey $ 46 | Opaque.toByteString ks 47 | eddsaDecodePubKey _ _ _ = do 48 | Left "eddsaDecodePubKey: not EdDSA pubkey format" 49 | 50 | eddsaDecodeSignature 51 | :: String -> (ByteString -> CryptoFailable sig) -> Opaque -> Either String sig 52 | eddsaDecodeSignature algName consSignature = 53 | eitherCryptoFailable (algName ++ ".signature") 54 | . consSignature 55 | . Opaque.toByteString 56 | 57 | eddsaVerify 58 | :: (pubkey -> ByteString -> sig -> Bool) 59 | -> pubkey 60 | -> sig 61 | -> ByteString 62 | -> Either String Bool 63 | eddsaVerify verifyImpl pubkey sig msg = Right $ verifyImpl pubkey msg sig 64 | 65 | eitherCryptoFailable :: String -> CryptoFailable a -> Either String a 66 | eitherCryptoFailable prefix = onCryptoFailure (Left . ((prefix ++ ": ") ++) . show) Right 67 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Server/UDP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module DNS.Iterative.Server.UDP ( 4 | udpServers, 5 | UdpServerConfig (..), 6 | setPktInfo, 7 | ) 8 | where 9 | 10 | -- GHC packages 11 | import Control.Concurrent.STM 12 | import Control.Monad (void, when) 13 | 14 | -- dnsext-* packages 15 | import qualified DNS.ThreadAsync as TAsync 16 | 17 | -- other packages 18 | import Network.Socket ( 19 | SocketOption (..), 20 | getSocketName, 21 | setSocketOption, 22 | ) 23 | import qualified Network.Socket.ByteString as NSB 24 | 25 | -- this package 26 | import DNS.Iterative.Internal (Env (..)) 27 | import DNS.Iterative.Server.Pipeline 28 | import DNS.Iterative.Server.Types 29 | import DNS.Iterative.Stats (incStatsUDP53) 30 | 31 | ---------------------------------------------------------------- 32 | 33 | newtype UdpServerConfig = UdpServerConfig 34 | { udp_interface_automatic :: Bool 35 | } 36 | 37 | ---------------------------------------------------------------- 38 | 39 | udpServers :: UdpServerConfig -> ServerActions 40 | udpServers _conf env toCacher ss = 41 | concat <$> mapM (udpServer _conf env toCacher) ss 42 | 43 | udpServer :: UdpServerConfig -> Env -> (ToCacher -> IO ()) -> Socket -> IO [IO ()] 44 | udpServer UdpServerConfig{..} env toCacher s = do 45 | mysa <- getSocketName s 46 | when udp_interface_automatic $ setPktInfo s 47 | {- limit waiting area on server to constant size -} 48 | let queueBound = 64 49 | qs <- newTBQueueIO queueBound 50 | let toSender = atomically . writeTBQueue qs 51 | fromX = atomically $ readTBQueue qs 52 | recv = do 53 | (peersa, bs, cmsgs, _) <- NSB.recvMsg s 2048 2048 0 54 | incStatsUDP53 peersa (stats_ env) 55 | return (bs, PeerInfoUDP peersa cmsgs) 56 | send bs (PeerInfoUDP peersa cmsgs) = 57 | void $ NSB.sendMsg s peersa [bs] cmsgs 0 58 | send _ _ = return () 59 | receiver = receiverLogic env mysa recv toCacher toSender UDP 60 | sender = senderLogic env send fromX 61 | return [TAsync.concurrently_ "bw.udp-send" sender "bw.udp-recv" receiver] 62 | 63 | setPktInfo :: Socket -> IO () 64 | setPktInfo s = do 65 | sa <- getSocketName s 66 | setSocketOption s (decideOption sa) 1 67 | 68 | decideOption :: SockAddr -> SocketOption 69 | decideOption SockAddrInet{} = RecvIPv4PktInfo 70 | decideOption SockAddrInet6{} = RecvIPv6PktInfo 71 | decideOption _ = error "decideOption" 72 | -------------------------------------------------------------------------------- /dnsext-do53/test/IOSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module IOSpec where 5 | 6 | import Control.Exception 7 | import DNS.Do53.Internal 8 | import DNS.Types 9 | import Data.List.NonEmpty (NonEmpty (..)) 10 | import Test.Hspec 11 | 12 | q :: Question 13 | q = Question "www.mew.org" A IN 14 | 15 | google :: ResolveInfo 16 | google = 17 | defaultResolveInfo 18 | { rinfoIP = "8.8.8.8" 19 | , rinfoUDPRetry = 1 20 | , rinfoVCLimit = 8 * 1024 21 | } 22 | 23 | cloudflare :: ResolveInfo 24 | cloudflare = 25 | defaultResolveInfo 26 | { rinfoIP = "1.1.1.1" 27 | , rinfoUDPRetry = 1 28 | , rinfoVCLimit = 8 * 1024 29 | } 30 | 31 | bad0 :: ResolveInfo 32 | bad0 = 33 | defaultResolveInfo 34 | { rinfoIP = "192.0.2.1" 35 | , rinfoActions = defaultResolveActions{ractionTimeoutTime = 100000} 36 | , rinfoUDPRetry = 1 37 | , rinfoVCLimit = 8 * 1024 38 | } 39 | 40 | bad1 :: ResolveInfo 41 | bad1 = 42 | defaultResolveInfo 43 | { rinfoIP = "192.0.2.2" 44 | , rinfoActions = defaultResolveActions{ractionTimeoutTime = 100000} 45 | , rinfoUDPRetry = 1 46 | , rinfoVCLimit = 8 * 1024 47 | } 48 | 49 | spec :: Spec 50 | spec = describe "solvers" $ do 51 | it "resolves well with UDP" $ do 52 | r <- udpResolver google q mempty 53 | checkNoErr r 54 | 55 | it "resolves well with TCP" $ do 56 | r <- tcpResolver google q mempty 57 | checkNoErr r 58 | 59 | it "resolves well concurrently (0)" $ do 60 | let resolver = udpResolver 61 | renv = ResolveEnv resolver True $ google :| [cloudflare] 62 | r <- resolve renv q mempty 63 | checkNoErr r 64 | 65 | it "resolves well concurrently (1)" $ do 66 | let resolver = udpResolver 67 | renv = ResolveEnv resolver True $ cloudflare :| [bad0] 68 | r <- resolve renv q mempty 69 | checkNoErr r 70 | 71 | it "resolves well concurrently (2)" $ do 72 | let resolver = udpResolver 73 | renv = ResolveEnv resolver True $ bad0 :| [bad1] 74 | r <- resolve renv q mempty 75 | either (Left . fst . unwrapDNSErrorInfo) Right r `shouldBe` Left RetryLimitExceeded 76 | 77 | dnsException :: Selector DNSError 78 | dnsException = const True 79 | 80 | checkNoErr :: Either DNSError Reply -> Expectation 81 | checkNoErr (Left e) = throwIO e 82 | checkNoErr (Right Reply{..}) = rcode replyDNSMessage `shouldBe` NoErr 83 | -------------------------------------------------------------------------------- /dnsext-dnssec/dnsext-dnssec.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: dnsext-dnssec 3 | version: 0.0.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | maintainer: Kazu Yamamoto 7 | author: Kazu Yamamoto 8 | tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==9.0.2 ghc ==9.2.4 9 | synopsis: DNSSEC library 10 | description: DNSSEC library for dnsext 11 | category: Network 12 | build-type: Simple 13 | extra-source-files: CHANGELOG.md 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/kazu-yamamoto/dnsext 18 | 19 | library 20 | exposed-modules: 21 | DNS.SEC 22 | DNS.SEC.Internal 23 | DNS.SEC.Verify 24 | DNS.SEC.Verify.Types 25 | 26 | other-modules: 27 | DNS.SEC.Flags 28 | DNS.SEC.HashAlg 29 | DNS.SEC.Imports 30 | DNS.SEC.Opts 31 | DNS.SEC.PubAlg 32 | DNS.SEC.PubKey 33 | DNS.SEC.Time 34 | DNS.SEC.Types 35 | DNS.SEC.Verify.SHA 36 | DNS.SEC.Verify.ECDSA 37 | DNS.SEC.Verify.EdDSA 38 | DNS.SEC.Verify.RSA 39 | DNS.SEC.Verify.N3SHA 40 | DNS.SEC.Verify.NSEC 41 | DNS.SEC.Verify.NSEC3 42 | DNS.SEC.Verify.NSECxRange 43 | DNS.SEC.Verify.Verify 44 | 45 | default-language: Haskell2010 46 | ghc-options: -Wall 47 | build-depends: 48 | -- GHC bundled 49 | array, 50 | base >=4 && <5, 51 | bytestring, 52 | containers, 53 | mtl, 54 | -- dnsext-packages 55 | dnsext-types, 56 | -- other pacakges 57 | memory, 58 | crypton, 59 | iproute >=1.3.2, 60 | word8, 61 | unix-time 62 | 63 | if impl(ghc >=8) 64 | default-extensions: Strict StrictData 65 | 66 | test-suite spec 67 | type: exitcode-stdio-1.0 68 | main-is: Spec.hs 69 | build-tool-depends: hspec-discover:hspec-discover 70 | hs-source-dirs: test 71 | other-modules: 72 | RoundTripSpec 73 | VerifySpec 74 | 75 | default-language: Haskell2010 76 | ghc-options: -Wall 77 | build-depends: 78 | -- GHC bundled 79 | base, 80 | bytestring, 81 | -- this package 82 | dnsext-dnssec, 83 | -- dnsext packages 84 | dnsext-types, 85 | -- other packages 86 | QuickCheck >=2.9, 87 | hspec, 88 | iproute >=1.3.2, 89 | word8 90 | -------------------------------------------------------------------------------- /dnsext-dox/dnsext-dox.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: dnsext-dox 3 | version: 0.0.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | maintainer: Kazu Yamamoto 7 | author: Kazu Yamamoto 8 | tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==9.0.2 ghc ==9.2.4 9 | synopsis: DNS over X based on dnsext 10 | description: 11 | A thread-safe DNS library for both clients and servers written 12 | purely in Haskell. 13 | 14 | category: Network 15 | build-type: Simple 16 | extra-source-files: CHANGELOG.md 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/kazu-yamamoto/dnsext 21 | 22 | library 23 | exposed-modules: 24 | DNS.DoX.Client 25 | DNS.DoX.Internal 26 | 27 | other-modules: 28 | DNS.DoX.HTTP2 29 | DNS.DoX.HTTP3 30 | DNS.DoX.Imports 31 | DNS.DoX.QUIC 32 | DNS.DoX.SAN 33 | DNS.DoX.TLS 34 | 35 | default-language: Haskell2010 36 | ghc-options: -Wall 37 | build-depends: 38 | -- GHC bundled 39 | base >=4 && <5, 40 | bytestring, 41 | -- dnsext packages 42 | dnsext-do53, 43 | dnsext-svcb, 44 | dnsext-types, 45 | dnsext-utils, 46 | -- other packages 47 | crypton-x509 >=1.7 && <1.8, 48 | crypton-x509-validation >=1.6 && <1.7, 49 | http-types, 50 | http2 >= 5.4 && < 5.5, 51 | http2-tls >= 0.5 && < 0.6, 52 | http3 >= 0.1.2 && < 0.2, 53 | iproute, 54 | network >= 3.2.8 && < 3.3, 55 | quic >= 0.2.21 && < 0.3, 56 | serialise, 57 | tls >= 2.1.10 58 | 59 | if impl(ghc >=8) 60 | default-extensions: Strict StrictData 61 | 62 | test-suite spec 63 | type: exitcode-stdio-1.0 64 | main-is: Spec.hs 65 | build-tool-depends: hspec-discover:hspec-discover 66 | hs-source-dirs: test 67 | other-modules: ResolverSpec 68 | default-language: Haskell2010 69 | ghc-options: -Wall -threaded 70 | build-depends: 71 | -- GHC bundled 72 | base, 73 | bytestring, 74 | -- this package 75 | dnsext-dox, 76 | -- dnsext packages 77 | dnsext-do53, 78 | dnsext-types, 79 | -- other packages 80 | hspec 81 | 82 | if (os(windows) && impl(ghc >=9.0)) 83 | ghc-options: -with-rtsopts=--io-manager=native 84 | 85 | if impl(ghc >=8) 86 | default-extensions: Strict StrictData 87 | -------------------------------------------------------------------------------- /dnsext-do53/cbits/dns.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #define MALLOC(x) HeapAlloc(GetProcessHeap(), 0, (x)) 8 | #define FREE(x) HeapFree(GetProcessHeap(), 0, (x)) 9 | 10 | // Fills `dnsAddresses` with the DNS addresses found, up to `bufferLen`. 11 | // Returns NO_ERROR (0x0) in case the operation succeeds, otherwise a non-zero 12 | // error code. See: https://msdn.microsoft.com/en-us/library/windows/desktop/ms681382(v=vs.85).aspx 13 | DWORD getWindowsDefDnsServers(char* dnsAddresses, size_t bufferLen) { 14 | FIXED_INFO *pFixedInfo; 15 | ULONG ulOutBufLen; 16 | DWORD dwRetVal; 17 | 18 | if (bufferLen <= 0) return ERROR_NOT_ENOUGH_MEMORY; 19 | 20 | pFixedInfo = (FIXED_INFO *) MALLOC(sizeof (FIXED_INFO)); 21 | if (pFixedInfo == NULL) 22 | return ERROR_NOT_ENOUGH_MEMORY; 23 | ulOutBufLen = sizeof (FIXED_INFO); 24 | 25 | // Make an initial call to GetAdaptersInfo to get the necessary size into the 26 | // ulOutBufLen variable 27 | if (GetNetworkParams(pFixedInfo, &ulOutBufLen) == ERROR_BUFFER_OVERFLOW) { 28 | FREE(pFixedInfo); 29 | pFixedInfo = (FIXED_INFO *) MALLOC(ulOutBufLen); 30 | if (pFixedInfo == NULL) 31 | return ERROR_NOT_ENOUGH_MEMORY; 32 | } 33 | 34 | dwRetVal = GetNetworkParams(pFixedInfo, &ulOutBufLen); 35 | 36 | if (dwRetVal == NO_ERROR) { 37 | int offset = 0; 38 | int spaceAvailable = bufferLen; 39 | IP_ADDR_STRING* head = &pFixedInfo->DnsServerList; 40 | int count = 0; 41 | 42 | while (head != NULL) { 43 | int ipLen = strlen(head->IpAddress.String); 44 | int copySize = ipLen + 1; 45 | 46 | spaceAvailable -= copySize; 47 | if (spaceAvailable >= 0) { 48 | // Write the separator. 49 | // The string is already terminated due to the call to 50 | // strcpy_s, which copies the null terminator. 51 | if (count != 0) dnsAddresses[offset - 1] = ','; 52 | // Copy the IP address, including the null terminator. 53 | strcpy_s(dnsAddresses + offset, copySize, head->IpAddress.String); 54 | if (spaceAvailable == 0) break; 55 | } else 56 | break; 57 | 58 | offset += copySize; 59 | count++; 60 | head = head->Next; 61 | } 62 | 63 | } 64 | 65 | if (pFixedInfo) FREE(pFixedInfo); 66 | return dwRetVal; 67 | } 68 | 69 | /* 70 | 71 | // Test with 'gcc -o dnsServer -Wall -Werror -pedantic -liphlpapi -Iinclude dns.c' on a 72 | // Windows machine. 73 | 74 | int main(){ 75 | printf(getWindowsDefDnsServers()->dnsAddresses); 76 | return 0; 77 | }*/ 78 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/bowline.conf: -------------------------------------------------------------------------------- 1 | user: nobody 2 | group: nobody 3 | log: yes 4 | #log-file: /opt/bowline/log/bowline.log # specifying logfile example 5 | log-level: WARNING 6 | #log-timestamp: no # prepend timestamp string to log text, when yes 7 | cache-size: 33554432 8 | cert-file: fullchain.pem 9 | key-file: privkey.pem 10 | #trust-anchor-file: root.key # filename with zonefile format 11 | #root-hints: root.hints # filename with zonefile format, DS and DNSKEY 12 | disable-v6-ns: no 13 | #hide-identity: no # when 'yes', refuse id.server 14 | #identity: foo # specified string 15 | #identity-option: refuse # refuse id.server 16 | #identity-option: hash # prefix of hash hex, default behavior 17 | #identity-option: host # plain-text hostname 18 | #identity-option: string "foo" # specified id string 19 | #hide-version: no # when 'yes', refuse version.server 20 | #version: x.y # specified version string 21 | #version-option: refuse # refuse version.server 22 | #version-option: blank # not show version string, default behavior 23 | #version-option: show # show version string 24 | #version-option: string "x.y" # specified version string 25 | #nsid: ascii_foo 26 | #nsid: 666f6f 27 | #domain-insecure: fail.dnssec.jp 28 | dns-addrs: 127.0.0.1,::1 29 | resolve-timeout: 5000000 30 | cachers: 4 31 | workers: 128 32 | udp: yes 33 | udp-port: 53 34 | vc-query-max-size: 2048 35 | vc-idle-timeout: 30 36 | vc-slowloris-size: 50 37 | tcp: yes 38 | tcp-port: 53 39 | tls: yes 40 | tls-port: 853 41 | tls-session-ticket-lifetime: 7200 42 | quic: yes 43 | quic-port: 853 44 | h2c: yes 45 | h2c-port: 80 46 | h2: yes 47 | h2-port: 443 48 | h3: yes 49 | h3-port: 443 50 | early-data-size: 4096 51 | monitor-port: 10023 52 | monitor-addrs: 127.0.0.1,::1 53 | #monitor-keep-interval: 300 # interval seconds of packets to keep alive monitor connections 54 | monitor-stdio: yes 55 | threads-dumper: no 56 | dnstap: yes 57 | dnstap-socket-path: /tmp/bowline.sock 58 | dnstap-reconnect-interval: 10 59 | webapi: yes 60 | webapi-addr: 127.0.0.1 61 | webapi-port: 8080 62 | #cache-max-negative-ttl: 3600 # maximum ttl for negative cache 63 | #cache-failure-rcode-ttl: 180 # ttl for failure RCODE like SERVFAIL 64 | #max-global-quota: 64 # maximum query count for one request 65 | #udp-limit-size: 1200 # UDP payload size limit for downstream 66 | #include: "stub-example.conf" # stub-zone example # include example 67 | #include: "local-example.conf" # local-zone / local-data example 68 | #include: "svcb-example.conf" # SVCB record example 69 | interface-automatic: no 70 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | -- | The server side of full resolver. 4 | module DNS.Iterative.Server ( 5 | -- * Types 6 | module DNS.Iterative.Query.Env, 7 | module DNS.Iterative.Server.Types, 8 | module DNS.RRCache, 9 | module DNS.TimeCache, 10 | 11 | -- * Pipeline 12 | mkPipeline, 13 | getWorkerStats, 14 | 15 | -- * UDP 16 | UdpServerConfig (..), 17 | udpServers, 18 | 19 | -- * Virtual circuit 20 | VcServerConfig (..), 21 | http2Servers, 22 | http2cServers, 23 | http3Servers, 24 | quicServers, 25 | tcpServers, 26 | tlsServers, 27 | 28 | -- * WorkerStat 29 | WorkerStat (..), 30 | WorkerStatOP (..), 31 | pprWorkerStats, 32 | pprWorkerStat, 33 | 34 | -- * Stats 35 | getStats, 36 | 37 | -- * Tests 38 | VcTimer (..), 39 | VcSession (..), 40 | VcFinished (..), 41 | VcPendings, 42 | withVcTimer, 43 | initVcSession, 44 | mkInput, 45 | noPendingOp, 46 | checkReceived, 47 | receiverVC, 48 | getSendVC, 49 | senderVC, 50 | controlledRecvVC, 51 | mkConnector, 52 | waitVcInput, 53 | waitVcOutput, 54 | enableVcEof, 55 | enableVcTimeout, 56 | addVcPending, 57 | delVcPending, 58 | module DNS.Iterative.Server.CtlRecv, 59 | ) where 60 | 61 | import DNS.Iterative.Imports 62 | import DNS.Iterative.Query.Env 63 | import DNS.Iterative.Server.CtlRecv 64 | import DNS.Iterative.Server.HTTP2 65 | import DNS.Iterative.Server.HTTP3 66 | import DNS.Iterative.Server.Pipeline 67 | import DNS.Iterative.Server.PrometheusHisto (getHistogramBucktes) 68 | import DNS.Iterative.Server.QUIC 69 | import DNS.Iterative.Server.TCP 70 | import DNS.Iterative.Server.TLS 71 | import DNS.Iterative.Server.Types 72 | import DNS.Iterative.Server.UDP 73 | import DNS.Iterative.Server.WorkerStats 74 | import DNS.Iterative.Stats 75 | import DNS.RRCache (RRCache, RRCacheConf (..), RRCacheOps (..), newRRCache, newRRCacheOps) 76 | import qualified DNS.RRCache as RRCache 77 | import DNS.TimeCache 78 | 79 | import Data.ByteString.Builder 80 | 81 | getStats :: Env -> Builder -> IO Builder 82 | getStats Env{..} prefix = 83 | mconcat <$> sequence [readStats stats_ prefix, getHistogramBucktes stats_ prefix, getCC, pure info, getRI] 84 | where 85 | getCC = getCache_ <&> \c -> prefix <> fromString ("rrset_cache_count " <> show (RRCache.size c) <> "\n") 86 | info = prefix <> fromString ("info{" ++ intercalate ", " [k ++ "=\"" ++ v ++ "\"" | (k, v) <- statsInfo_] ++ "} 1\n") 87 | getRI = mconcat <$> sequence [getV <&> \v -> prefix <> fromString (k <> " " <> show v <> "\n") | (k, getV) <- reloadInfo_] 88 | -------------------------------------------------------------------------------- /dnsext-dox/DNS/DoX/SAN.hs: -------------------------------------------------------------------------------- 1 | module DNS.DoX.SAN (makeOnServerCertificate) where 2 | 3 | import qualified Data.ByteString as BS 4 | import Data.IP (IP (..)) 5 | import qualified Data.IP as IP 6 | import Data.Maybe (mapMaybe) 7 | import Data.X509 ( 8 | AltName (..), 9 | Certificate (..), 10 | ExtSubjectAltName (..), 11 | certExtensions, 12 | extensionGet, 13 | getCertificate, 14 | ) 15 | import Data.X509.Validation (FailedReason (..), validateDefault) 16 | import Network.TLS (CertificateChain (..), OnServerCertificate) 17 | 18 | makeOnServerCertificate :: (String -> IO ()) -> Maybe IP -> OnServerCertificate 19 | makeOnServerCertificate _ Nothing = validateDefault 20 | makeOnServerCertificate logLn (Just ip) = f 21 | where 22 | f caStore validCache sid cc 23 | | any (isTrusted ip) defaultTrusted = logLn (show ip ++ ": validation skipped (rfc9462 opportunistic discovery)") >> return [] 24 | | ip `elem` ips = validateDefault caStore validCache sid cc 25 | | otherwise = return [InvalidName $ show ip ++ " is not included in " ++ show ips] 26 | where 27 | ips = getSAN cc 28 | 29 | getSAN :: CertificateChain -> [IP] 30 | getSAN (CertificateChain []) = [] 31 | getSAN (CertificateChain (cert : _)) = getNames $ getCertificate cert 32 | 33 | getNames :: Certificate -> [IP] 34 | getNames cert = maybe [] toAltName $ extensionGet $ certExtensions cert 35 | where 36 | toAltName (ExtSubjectAltName names) = mapMaybe unAltName names 37 | unAltName (AltNameIP s) = toIP s 38 | unAltName _ = Nothing 39 | 40 | toIP :: BS.ByteString -> Maybe IP 41 | toIP bs 42 | | len == 4 = Just $ IPv4 $ IP.toIPv4 is 43 | | len == 16 = Just $ IPv6 $ IP.toIPv6b is 44 | | otherwise = Nothing 45 | where 46 | ws = BS.unpack bs 47 | len = length ws 48 | is = map fromIntegral ws 49 | 50 | -- RFC9462 4.3. Opportunistic Discovery 51 | -- private IP addresses [RFC1918], Unique Local Addresses (ULAs) [RFC4193], 52 | -- and Link-Local addresses [RFC3927] [RFC4291] cannot be safely confirmed 53 | -- using TLS certificates under most conditions. 54 | defaultTrusted :: [IP.IPRange] 55 | defaultTrusted = 56 | map 57 | read 58 | [ "127.0.0.0/8" 59 | , "10.0.0.0/8" 60 | , "169.254.0.0/16" 61 | , "172.16.0.0/12" 62 | , "192.168.0.0/16" 63 | , "::1/128" 64 | , "fc00::/7" 65 | , "fe80::/10" 66 | ] 67 | 68 | isTrusted :: IP -> IP.IPRange -> Bool 69 | isTrusted (IPv4 ip) (IP.IPv4Range r) = ip `IP.isMatchedTo` r 70 | isTrusted (IPv6 ip) (IP.IPv6Range r) = ip `IP.isMatchedTo` r 71 | isTrusted (IPv4 ip) (IP.IPv6Range r) = IP.ipv4ToIPv6 ip `IP.isMatchedTo` r 72 | isTrusted _ _ = False 73 | -------------------------------------------------------------------------------- /dnsext-types/dnsext-types.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: dnsext-types 3 | version: 0.0.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | maintainer: Kazu Yamamoto 7 | author: Kazu Yamamoto 8 | tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==9.0.2 ghc ==9.2.4 9 | synopsis: Types for Extensible DNS libraries 10 | description: 11 | Types for Extensible DNS libraries which are written 12 | purely in Haskell 13 | 14 | category: Network 15 | build-type: Simple 16 | extra-source-files: CHANGELOG.md 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/kazu-yamamoto/dnsext 21 | 22 | library 23 | exposed-modules: 24 | DNS.Types 25 | DNS.Types.Decode 26 | DNS.Types.Encode 27 | DNS.Types.Internal 28 | DNS.Types.Opaque 29 | DNS.Types.Time 30 | 31 | other-modules: 32 | DNS.Types.Base32Hex 33 | DNS.Types.Dict 34 | DNS.Types.Domain 35 | DNS.Types.EDNS 36 | DNS.Types.Error 37 | DNS.Types.Imports 38 | DNS.Types.Message 39 | DNS.Types.Opaque.Internal 40 | DNS.Types.Parser 41 | DNS.Types.RData 42 | DNS.Types.Seconds 43 | DNS.Types.ShortBuilder 44 | DNS.Types.ShortParser 45 | DNS.Types.Type 46 | DNS.Wire 47 | DNS.Wire.Builder 48 | DNS.Wire.Parser 49 | DNS.Wire.Types 50 | 51 | default-language: Haskell2010 52 | ghc-options: -Wall 53 | build-depends: 54 | -- GHC bundled 55 | array, 56 | base >=4 && <5, 57 | bytestring, 58 | containers, 59 | mtl, 60 | -- other packages 61 | base16-bytestring, 62 | base64-bytestring, 63 | iproute >=1.3.2, 64 | network-byte-order, 65 | unix-time, 66 | word8 67 | 68 | if impl(ghc >=8) 69 | default-extensions: Strict StrictData 70 | 71 | test-suite spec 72 | type: exitcode-stdio-1.0 73 | main-is: Spec.hs 74 | build-tool-depends: hspec-discover:hspec-discover 75 | hs-source-dirs: test 76 | other-modules: 77 | EncodeSpec 78 | DecodeSpec 79 | RoundTripSpec 80 | 81 | default-language: Haskell2010 82 | ghc-options: -Wall 83 | build-depends: 84 | -- GHC bundled 85 | base, 86 | bytestring, 87 | -- this package 88 | dnsext-types, 89 | -- others packages 90 | QuickCheck >=2.9, 91 | hspec, 92 | iproute >=1.3.2, 93 | word8 94 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/PubKey.hs: -------------------------------------------------------------------------------- 1 | module DNS.SEC.PubKey where 2 | 3 | import DNS.SEC.Imports 4 | import DNS.SEC.PubAlg 5 | import DNS.Types 6 | import DNS.Types.Internal 7 | import qualified DNS.Types.Opaque as Opaque 8 | 9 | data PubKey 10 | = PubKey_RSA {rsa_size :: Int, rsa_e :: Opaque, rsa_n :: Opaque} 11 | | PubKey_ECDSA {ecdsa_x :: Opaque, ecdsa_y :: Opaque} 12 | | PubKey_Opaque {pubkey_opaque :: Opaque} 13 | deriving (Eq, Ord, Show) 14 | 15 | toPubKey :: PubAlg -> Opaque -> PubKey 16 | toPubKey RSAMD5 = toPubKey_RSA 17 | toPubKey RSASHA1 = toPubKey_RSA 18 | toPubKey RSASHA1_NSEC3_SHA1 = toPubKey_RSA {- https://datatracker.ietf.org/doc/html/rfc5155#section-2 -} 19 | toPubKey RSASHA256 = toPubKey_RSA 20 | toPubKey RSASHA512 = toPubKey_RSA 21 | toPubKey ECDSAP256SHA256 = toPubKey_ECDSA 32 22 | toPubKey ECDSAP384SHA384 = toPubKey_ECDSA 48 23 | toPubKey _ = PubKey_Opaque 24 | 25 | toPubKey_RSA :: Opaque -> PubKey 26 | toPubKey_RSA o = PubKey_RSA len e n 27 | where 28 | (len, e, n) = case Opaque.uncons o of 29 | Just (0, r0) -> fromJust $ do 30 | (x, r1) <- Opaque.uncons r0 31 | (y, r2) <- Opaque.uncons r1 32 | let elen = 256 * fromIntegral x + fromIntegral y 33 | return $ divide elen r2 34 | Just (l, r0) -> divide (fromIntegral l) r0 35 | _ -> error "toPubKey_RSA" 36 | 37 | divide elen o' = 38 | let (e', n') = Opaque.splitAt elen o' 39 | in ( Opaque.length n' * 8 40 | , e' 41 | , n' 42 | ) 43 | 44 | toPubKey_ECDSA :: Int -> Opaque -> PubKey 45 | toPubKey_ECDSA len o 46 | | len * 2 == blen = 47 | let (x, y) = Opaque.splitAt len o 48 | in PubKey_ECDSA x y 49 | | otherwise = error "toPubKey_ECDSA" 50 | where 51 | blen = Opaque.length o 52 | 53 | fromPubKey :: PubKey -> Opaque 54 | fromPubKey (PubKey_RSA _len e n) 55 | | elen >= 256 = 56 | let (x, y) = elen `divMod` 256 57 | in Opaque.concat 58 | [ Opaque.singleton 0 59 | , Opaque.singleton $ fromIntegral x 60 | , Opaque.singleton $ fromIntegral y 61 | , e 62 | , n 63 | ] 64 | | otherwise = 65 | Opaque.concat 66 | [ Opaque.singleton $ fromIntegral elen 67 | , e 68 | , n 69 | ] 70 | where 71 | elen = Opaque.length e 72 | fromPubKey (PubKey_ECDSA x y) = x <> y 73 | fromPubKey (PubKey_Opaque o) = o 74 | 75 | putPubKey :: PubKey -> Builder () 76 | putPubKey pub = putOpaque $ fromPubKey pub 77 | 78 | getPubKey :: PubAlg -> Int -> Parser PubKey 79 | getPubKey alg len rbuf ref = toPubKey alg <$> getOpaque len rbuf ref 80 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/PubAlg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | module DNS.SEC.PubAlg where 4 | 5 | import DNS.SEC.Imports 6 | import DNS.Types.Internal 7 | 8 | -- https://www.iana.org/assignments/dns-sec-alg-numbers/dns-sec-alg-numbers.xhtml 9 | newtype PubAlg = PubAlg 10 | { fromPubAlg :: Word8 11 | } 12 | deriving (Eq, Ord) 13 | 14 | toPubAlg :: Word8 -> PubAlg 15 | toPubAlg = PubAlg 16 | 17 | pattern DELETE :: PubAlg 18 | pattern DELETE = PubAlg 0 19 | 20 | pattern RSAMD5 :: PubAlg 21 | pattern RSAMD5 = PubAlg 1 22 | 23 | pattern DH :: PubAlg 24 | pattern DH = PubAlg 2 25 | 26 | pattern DSA :: PubAlg 27 | pattern DSA = PubAlg 3 28 | 29 | pattern RSASHA1 :: PubAlg 30 | pattern RSASHA1 = PubAlg 5 31 | 32 | pattern DSA_NSEC3_SHA1 :: PubAlg 33 | pattern DSA_NSEC3_SHA1 = PubAlg 6 34 | 35 | pattern RSASHA1_NSEC3_SHA1 :: PubAlg 36 | pattern RSASHA1_NSEC3_SHA1 = PubAlg 7 37 | 38 | pattern RSASHA256 :: PubAlg 39 | pattern RSASHA256 = PubAlg 8 40 | 41 | pattern RSASHA512 :: PubAlg 42 | pattern RSASHA512 = PubAlg 10 43 | 44 | pattern ECC_GOST :: PubAlg 45 | pattern ECC_GOST = PubAlg 12 46 | 47 | pattern ECDSAP256SHA256 :: PubAlg 48 | pattern ECDSAP256SHA256 = PubAlg 13 49 | 50 | pattern ECDSAP384SHA384 :: PubAlg 51 | pattern ECDSAP384SHA384 = PubAlg 14 52 | 53 | pattern ED25519 :: PubAlg 54 | pattern ED25519 = PubAlg 15 55 | 56 | pattern ED448 :: PubAlg 57 | pattern ED448 = PubAlg 16 58 | 59 | pattern INDIRECT :: PubAlg 60 | pattern INDIRECT = PubAlg 252 61 | 62 | pattern PRIVATEDNS :: PubAlg 63 | pattern PRIVATEDNS = PubAlg 253 64 | 65 | pattern PRIVATEOID :: PubAlg 66 | pattern PRIVATEOID = PubAlg 254 67 | 68 | {- FOURMOLU_DISABLE -} 69 | instance Show PubAlg where 70 | show DELETE = "DELETE" 71 | show RSAMD5 = "RSAMD5" 72 | show DH = "DH" 73 | show DSA = "DSA" 74 | show RSASHA1 = "RSASHA1" 75 | show DSA_NSEC3_SHA1 = "DSA_NSEC3_SHA1" 76 | show RSASHA1_NSEC3_SHA1 = "RSASHA1_NSEC3_SHA1" 77 | show RSASHA256 = "RSASHA256" 78 | show RSASHA512 = "RSASHA512" 79 | show ECC_GOST = "ECC_GOST" 80 | show ECDSAP256SHA256 = "ECDSAP256SHA256" 81 | show ECDSAP384SHA384 = "ECDSAP384SHA384" 82 | show ED25519 = "ED25519" 83 | show ED448 = "ED448" 84 | show INDIRECT = "INDIRECT" 85 | show PRIVATEDNS = "PRIVATEDNS" 86 | show PRIVATEOID = "PRIVATEOID" 87 | show (PubAlg n) = "PubAlg " ++ show n 88 | {- FOURMOLU_ENABLE -} 89 | 90 | putPubAlg :: PubAlg -> Builder () 91 | putPubAlg a wbuf _ = put8 wbuf $ fromPubAlg a 92 | 93 | getPubAlg :: Parser PubAlg 94 | getPubAlg rbuf _ = toPubAlg <$> get8 rbuf 95 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Server/TCP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module DNS.Iterative.Server.TCP ( 6 | tcpServers, 7 | ) 8 | where 9 | 10 | -- GHC packages 11 | import Control.Concurrent.STM (atomically) 12 | import Data.Functor 13 | 14 | -- dnsext-* packages 15 | import qualified DNS.Do53.Internal as DNS 16 | import qualified DNS.Log as Log 17 | import qualified DNS.ThreadAsync as TAsync 18 | 19 | -- other packages 20 | import Network.Run.TCP 21 | import Network.Socket (getPeerName, getSocketName, waitReadSocketSTM) 22 | import qualified Network.Socket.ByteString as Network 23 | 24 | -- this package 25 | import DNS.Iterative.Internal (Env (..)) 26 | import DNS.Iterative.Server.Pipeline 27 | import DNS.Iterative.Server.Types 28 | import DNS.Iterative.Stats (incStatsTCP53, sessionStatsTCP53) 29 | 30 | ---------------------------------------------------------------- 31 | 32 | tcpServers :: VcServerConfig -> ServerActions 33 | tcpServers conf env toCacher ss = 34 | concat <$> mapM (tcpServer conf env toCacher) ss 35 | 36 | tcpServer :: VcServerConfig -> Env -> (ToCacher -> IO ()) -> Socket -> IO [IO ()] 37 | tcpServer VcServerConfig{..} env toCacher s = do 38 | name <- socketName s <&> (++ "/tcp") 39 | let tcpserver = 40 | withLocationIOE name $ 41 | runTCPServerWithSocket s go 42 | return [tcpserver] 43 | where 44 | maxSize = fromIntegral vc_query_max_size 45 | tmicro = vc_idle_timeout * 1_000_000 46 | go sock = sessionStatsTCP53 (stats_ env) $ do 47 | mysa <- getSocketName sock 48 | peersa <- getPeerName sock 49 | logLn env Log.DEBUG $ "tcp-srv: accept: " ++ show peersa 50 | let peerInfo = PeerInfoVC peersa 51 | -- "cancel" action is not used. 52 | -- However, "closeFd" is eventually called. 53 | -- It deletes the entry relating to the socket from the table 54 | -- of IOManager. 55 | (vcSess, toSender, fromX) <- initVcSession (waitReadSocketSTM sock) 56 | withVcTimer tmicro (atomically $ enableVcTimeout $ vcTimeout_ vcSess) $ \vcTimer -> do 57 | let recv = Network.recv sock 58 | let onRecv bs = do 59 | checkReceived vc_slowloris_size vcTimer bs 60 | incStatsTCP53 peersa (stats_ env) 61 | let send = getSendVC vcTimer $ \bs _ -> DNS.sendVC (DNS.sendTCP sock) bs 62 | receiver = receiverVCnonBlocking "tcp-recv" env maxSize vcSess peerInfo recv onRecv toCacher $ mkInput mysa toSender TCP 63 | sender = senderVC "tcp-send" env vcSess send fromX 64 | TAsync.concurrently_ "bw.tcp-send" sender "bw.tcp-recv" receiver 65 | logLn env Log.DEBUG $ "tcp-srv: close: " ++ show peersa 66 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Types where 4 | 5 | import Control.Concurrent.STM 6 | import Control.Monad 7 | import Data.ByteString.Builder 8 | import Data.Functor 9 | import Data.IORef 10 | import System.IO.Error (tryIOError) 11 | 12 | -- 13 | 14 | import DNS.Log (PutLines) 15 | import DNS.RRCache (RRCacheOps) 16 | import DNS.Types 17 | 18 | import Config (Config) 19 | 20 | {- FOURMOLU_DISABLE -} 21 | data CacheControl = CacheControl 22 | { ccRemove :: Domain -> IO () 23 | , ccRemoveType :: Domain -> TYPE -> IO () 24 | , ccRemoveBogus :: IO () 25 | , ccRemoveNegative :: IO () 26 | , ccClear :: IO () 27 | } 28 | 29 | data GlobalCache = GlobalCache 30 | { gcacheRRCacheOps :: RRCacheOps 31 | , gcacheControl :: CacheControl 32 | , gcacheSetLogLn :: PutLines IO -> IO () 33 | } 34 | {- FOURMOLU_ENABLE -} 35 | 36 | emptyCacheControl :: CacheControl 37 | emptyCacheControl = CacheControl (\_ -> pure ()) (\_ _ -> pure ()) (pure ()) (pure ()) (pure ()) 38 | 39 | data ReloadCmd = Reload | KeepCache deriving (Show) 40 | 41 | data QuitCmd = Quit | Reload1 Config | KeepCache1 Config deriving (Show) 42 | 43 | data Control = Control 44 | { getStats :: IO Builder 45 | , getWStats :: IO Builder 46 | , reopenLog :: IO () 47 | , getConfig :: IO (Either IOError Config) 48 | , quitServer :: IO () 49 | , waitQuit :: STM () 50 | , reloadSuccess :: ReloadCmd -> IO () 51 | , reloadFailure :: ReloadCmd -> IO () 52 | , getCommandAndClear :: IO QuitCmd 53 | , setCommand :: QuitCmd -> IO () 54 | } 55 | 56 | newControl :: IO Config -> IO Control 57 | newControl readConfig = do 58 | qRef <- newTVarIO False 59 | ref <- newIORef Quit 60 | return 61 | Control 62 | { getStats = return mempty 63 | , getWStats = return mempty 64 | , reopenLog = return () 65 | , getConfig = tryIOError readConfig 66 | , quitServer = atomically $ writeTVar qRef True 67 | , waitQuit = readTVar qRef >>= guard 68 | , reloadSuccess = \_ -> pure () 69 | , reloadFailure = \_ -> pure () 70 | , getCommandAndClear = atomicModifyIORef' ref (\x -> (Quit, x)) 71 | , setCommand = atomicWriteIORef ref 72 | } 73 | 74 | quitCmd :: Control -> QuitCmd -> IO () 75 | quitCmd Control{..} cmd = setCommand cmd >> quitServer 76 | 77 | reloadCmd :: Control -> ReloadCmd -> a -> a -> IO a 78 | reloadCmd ctl@Control{..} rcmd lv rv = do 79 | either left right =<< getConfig 80 | where 81 | left e = putStrLn ("reload failed: " ++ show e) *> reloadFailure rcmd $> lv 82 | right conf = quitCmd ctl (cmd1 rcmd conf) *> reloadSuccess rcmd $> rv 83 | cmd1 Reload = Reload1 84 | cmd1 KeepCache = KeepCache1 85 | -------------------------------------------------------------------------------- /dnsext-types/DNS/Types/ShortBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE UnboxedTuples #-} 4 | 5 | module DNS.Types.ShortBuilder ( 6 | ToBuilder (..), 7 | Builder, 8 | build, 9 | ) where 10 | 11 | import qualified Data.ByteString.Short as Short 12 | import Data.ByteString.Short.Internal (ShortByteString (..)) 13 | import GHC.Exts ( 14 | ByteArray#, 15 | Int (..), 16 | MutableByteArray#, 17 | copyByteArray#, 18 | newByteArray#, 19 | unsafeFreezeByteArray#, 20 | writeWord8Array#, 21 | ) 22 | import GHC.ST (ST (ST), runST) 23 | import GHC.Word 24 | 25 | import DNS.Types.Imports 26 | 27 | data Piece = PWord8 Word8 | PShort ShortByteString 28 | 29 | class ToBuilder a where 30 | toBuilder :: a -> Builder 31 | 32 | instance ToBuilder Word8 where 33 | toBuilder w8 = Builder 1 ([PWord8 w8] ++) 34 | 35 | instance ToBuilder ShortByteString where 36 | toBuilder sbs = Builder (Short.length sbs) ([PShort sbs] ++) 37 | 38 | instance Semigroup Builder where 39 | Builder l0 b0 <> Builder l1 b1 = Builder (l0 + l1) (b0 . b1) 40 | 41 | instance Monoid Builder where 42 | mempty = Builder 0 id 43 | 44 | data Builder = Builder !Int ([Piece] -> [Piece]) 45 | 46 | build :: Builder -> ShortByteString 47 | build (Builder len b) = create len $ \mba -> go mba 0 xs 48 | where 49 | xs = b [] 50 | go _ _ [] = return () 51 | go mba i (PWord8 w8 : cs) = do 52 | writeWord8Array mba i w8 53 | go mba (i + 1) cs 54 | go mba i (PShort src : cs) = do 55 | let l = Short.length src 56 | copyByteArray (asBA src) 0 mba i l 57 | go mba (i + l) cs 58 | 59 | -- Stolen from Data.ByteString.Short.Internal, sigh. 60 | 61 | data BA = BA# ByteArray# 62 | data MBA s = MBA# (MutableByteArray# s) 63 | 64 | create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString 65 | create len fill = 66 | runST 67 | ( do 68 | mba <- newByteArray len 69 | fill mba 70 | BA# ba# <- unsafeFreezeByteArray mba 71 | return (SBS ba#) 72 | ) 73 | 74 | newByteArray :: Int -> ST s (MBA s) 75 | newByteArray (I# len#) = 76 | ST $ \s0 -> case newByteArray# len# s0 of 77 | (# s, mba# #) -> (# s, MBA# mba# #) 78 | 79 | unsafeFreezeByteArray :: MBA s -> ST s BA 80 | unsafeFreezeByteArray (MBA# mba#) = 81 | ST $ \s0 -> case unsafeFreezeByteArray# mba# s0 of 82 | (# s, ba# #) -> (# s, BA# ba# #) 83 | 84 | writeWord8Array :: MBA s -> Int -> Word8 -> ST s () 85 | writeWord8Array (MBA# mba#) (I# i#) (W8# w#) = 86 | ST $ \s0 -> case writeWord8Array# mba# i# w# s0 of 87 | s -> (# s, () #) 88 | 89 | copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s () 90 | copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = 91 | ST $ \s0 -> case copyByteArray# src# src_off# dst# dst_off# len# s0 of 92 | s -> (# s, () #) 93 | 94 | asBA :: ShortByteString -> BA 95 | asBA (SBS ba#) = BA# ba# 96 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Query/Norec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MonadComprehensions #-} 2 | {-# LANGUAGE NumericUnderscores #-} 3 | 4 | module DNS.Iterative.Query.Norec where 5 | 6 | -- GHC packages 7 | 8 | -- other packages 9 | 10 | -- dnsext packages 11 | import DNS.Do53.Client ( 12 | FlagOp (..), 13 | ResolveActions (..), 14 | defaultResolveActions, 15 | ) 16 | import qualified DNS.Do53.Client as DNS 17 | import DNS.Do53.Internal ( 18 | ResolveEnv (..), 19 | ResolveInfo (..), 20 | defaultResolveInfo, 21 | udpTcpResolver, 22 | ) 23 | import qualified DNS.Do53.Internal as DNS 24 | import DNS.Types 25 | 26 | -- this package 27 | import DNS.Iterative.Imports 28 | import DNS.Iterative.Query.Class 29 | import DNS.Iterative.Query.SteppedWait (steppedWait) 30 | 31 | {- FOURMOLU_DISABLE -} 32 | norec :: MonadIO m => Env -> Bool -> NonEmpty Address -> Domain -> TYPE -> m (Either DNSError DNSMessage) 33 | norec cxt dnssecOK aservers name typ = 34 | liftIO $ steppedWait TimeoutExpired RetryLimitExceeded 250_000 actions 35 | where 36 | actions = [(tag ++ ".q1", action), (tag ++ ".q2", action)] 37 | tag = let (a:|as) = aservers in show (a:as) 38 | action = norec_ 500_000 cxt dnssecOK aservers name typ 39 | {- FOURMOLU_ENABLE -} 40 | 41 | {- FOURMOLU_DISABLE -} 42 | {- Get the answer DNSMessage from the authoritative server. 43 | Note about flags in request to an authoritative server. 44 | * RD (Recursion Desired) must be 0 for request to authoritative server 45 | * EDNS must be enable for DNSSEC OK request -} 46 | norec_ :: Int -> Env -> Bool -> NonEmpty Address -> Domain -> TYPE -> IO (Either DNSError DNSMessage) 47 | norec_ utimeout cxt dnssecOK aservers name typ = do 48 | let riActions = 49 | defaultResolveActions 50 | { ractionGenId = idGen_ cxt 51 | , ractionGetTime = currentSeconds_ cxt 52 | , ractionLog = logLines_ cxt 53 | , ractionShortLog = shortLog_ cxt 54 | , ractionTimeoutTime = utimeout 55 | } 56 | ris = 57 | [ defaultResolveInfo 58 | { rinfoIP = aserver 59 | , rinfoPort = port 60 | , rinfoActions = riActions 61 | , rinfoUDPRetry = 1 62 | , rinfoVCLimit = 8 * 1024 63 | } 64 | | (aserver, port) <- aservers 65 | ] 66 | renv = 67 | ResolveEnv 68 | { renvResolver = udpTcpResolver 69 | , renvConcurrent = True -- should set True if multiple RIs are provided 70 | , renvResolveInfos = ris 71 | } 72 | q = Question name typ IN 73 | doFlagSet 74 | | dnssecOK = FlagSet 75 | | otherwise = FlagClear 76 | qctl = DNS.rdFlag FlagClear <> DNS.doFlag doFlagSet 77 | fmap DNS.replyDNSMessage <$> DNS.resolve renv q qctl 78 | {- FOURMOLU_ENABLE -} 79 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/ThreadStats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module DNS.ThreadStats where 4 | 5 | #if __GLASGOW_HASKELL__ >= 906 6 | 7 | -- GHC internal 8 | import GHC.Conc.Sync (threadStatus) 9 | import qualified GHC.Conc.Sync as GHC 10 | 11 | #else 12 | 13 | -- (imports for case, GHC 9.4.x, GHC 9.2.x) 14 | 15 | #endif 16 | 17 | -- GHC internal 18 | import GHC.Conc.Sync (labelThread) 19 | 20 | -- base 21 | import Control.Concurrent (ThreadId, myThreadId, threadDelay) 22 | import qualified Control.Concurrent as Concurrent 23 | import Control.Monad 24 | import Data.List 25 | import Data.Maybe 26 | import Debug.Trace (traceEventIO) 27 | 28 | showTid :: ThreadId -> String 29 | showTid tid = stripTh $ show tid 30 | where 31 | stripTh x = fromMaybe x $ stripPrefix "ThreadId " x 32 | 33 | --- 34 | 35 | eventLog :: String -> IO () 36 | eventLog s = do 37 | tid <- showTid <$> myThreadId 38 | traceEventIO ("uevent: thread " ++ tid ++ " (" ++ s ++ ")") 39 | 40 | -- naming not named 41 | setThreadLabel :: String -> IO () 42 | setThreadLabel name = do 43 | tid <- myThreadId 44 | maybe (labelThread tid name) (const $ pure ()) =<< threadLabel tid 45 | 46 | --- 47 | 48 | getThreadLabel :: IO String 49 | dumpThreads :: IO [String] 50 | dumper :: ([String] -> IO ()) -> IO () 51 | 52 | #if __GLASGOW_HASKELL__ >= 906 53 | 54 | getThreadLabel = withName (pure "") $ \tid n -> pure $ n ++ ": " ++ showTid tid 55 | where 56 | withName nothing just = do 57 | tid <- myThreadId 58 | maybe nothing (just tid) =<< GHC.threadLabel tid 59 | 60 | dumpThreads = do 61 | ts <- mapM getName =<< GHC.listThreads 62 | vs <- sequence [ dump tid n | (tid, Just n) <- ts ] 63 | pure . map (uncurry (++)) $ sort vs 64 | where 65 | getName tid = (,) tid <$> GHC.threadLabel tid 66 | dump tid name = do 67 | st <- show <$> threadStatus tid 68 | let stid = showTid tid 69 | pad = replicate (width - length name - length stid) ' ' 70 | val = pad ++ ": " ++ stid ++ ": " ++ st 71 | pure (name, val) 72 | width = 24 73 | 74 | dumper putLines = forever $ do 75 | putLines . (++ ["----------------------------------------"]) =<< dumpThreads 76 | threadDelay interval 77 | where 78 | interval = 3 * 1000 * 1000 79 | 80 | #else 81 | 82 | getThreadLabel = pure "" 83 | dumpThreads = pure [""] 84 | dumper _ = forever $ threadDelay interval 85 | where 86 | interval = 3 * 1000 * 1000 87 | 88 | #endif 89 | 90 | --- 91 | 92 | listThreads :: IO [ThreadId] 93 | threadLabel :: ThreadId -> IO (Maybe String) 94 | 95 | #if __GLASGOW_HASKELL__ >= 906 96 | 97 | listThreads = GHC.listThreads 98 | threadLabel = GHC.threadLabel 99 | 100 | #else 101 | 102 | listThreads = pure [] 103 | threadLabel _ = pure Nothing 104 | 105 | #endif 106 | 107 | --- 108 | 109 | forkIO :: String -> IO () -> IO ThreadId 110 | forkIO name action = do 111 | tid <- Concurrent.forkIO action 112 | labelThread tid name 113 | pure tid 114 | -------------------------------------------------------------------------------- /dnsext-bowline/test-dug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Main where 4 | 5 | import Data.List 6 | import System.Exit 7 | import System.Process 8 | 9 | dug :: String 10 | dug = "dist/build/dug/dug" 11 | 12 | domains :: [String] 13 | domains = ["www.mew.org", "www.jprs.jp"] 14 | 15 | input :: String 16 | input = "" 17 | 18 | main :: IO () 19 | main = mapM_ testCompany profiles 20 | 21 | data Profile = Profile 22 | { company :: String 23 | , serverName :: String 24 | , transports :: [String] 25 | , ipAddr :: String 26 | , transportsIP :: [String] 27 | , ipInCert :: Bool 28 | } 29 | 30 | profiles :: [Profile] 31 | profiles = 32 | [ Profile 33 | { company = "Google" 34 | , serverName = "dns.google" 35 | , transports = ["udp", "tcp", "dot", "h2", "h3", "auto"] 36 | , ipAddr = "8.8.8.8" 37 | , transportsIP = ["udp", "tcp", "dot", "h2", "h3", "auto"] 38 | , ipInCert = True 39 | } 40 | , Profile 41 | { company = "Cloudfare" 42 | , serverName = "one.one.one.one" 43 | , transports = ["udp", "tcp", "dot", "h2", "h3", "auto"] 44 | , ipAddr = "1.1.1.1" 45 | , transportsIP = ["udp", "tcp", "dot", "h2", "h3", "auto"] 46 | , ipInCert = True 47 | } 48 | , Profile 49 | { company = "AdGuard" 50 | , serverName = "unfiltered.adguard-dns.com" 51 | , transports = ["udp", "tcp", "dot", "doq", "h2", "h3", "auto"] 52 | , ipAddr = "94.140.14.140" 53 | , transportsIP = ["udp", "tcp", "dot", "doq", "h2", "h3", "auto"] 54 | , ipInCert = True 55 | } 56 | , Profile 57 | { company = "IIJ" 58 | , serverName = "public.dns.iij.jp" 59 | , transports = ["dot", "h2"] 60 | , ipAddr = "103.2.57.5" 61 | , transportsIP = ["dot", "h2"] 62 | , ipInCert = False -- No IP addresses in certificate 63 | } 64 | ] 65 | 66 | testCompany :: Profile -> IO () 67 | testCompany Profile{..} = do 68 | putStrLn $ company ++ "..." 69 | mapM_ (runTest serverName True) transports 70 | mapM_ (runTest ipAddr ipInCert) transportsIP 71 | putStrLn $ company ++ "...done" 72 | 73 | runTest :: String -> Bool -> String -> IO () 74 | runTest host certCheck transport = do 75 | -- AdGuard is using certificates signed by ZeroSSL. 76 | -- This means that IPv6 addresses are not contained in SAN, sign. 77 | let workaround 78 | | host == "unfiltered.adguard-dns.com" = ["-4"] 79 | | otherwise = [] 80 | options 81 | | certCheck = "-e" : workaround 82 | | otherwise = [] 83 | let args = ['@' : host] ++ options ++ ["-d", transport] ++ domains 84 | (ec, out, err) <- readProcessWithExitCode dug args input 85 | case ec of 86 | ExitSuccess -> return () 87 | ExitFailure _ -> do 88 | putStrLn "FAILED FAILED FAILED FAILED FAILED FAILED" 89 | putStrLn $ " " ++ dug ++ " " ++ unwords args 90 | putStrLn "stdout:" 91 | putStrLn out 92 | putStrLn "stderr:" 93 | putStrLn err 94 | exitFailure 95 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/DNSTAP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module DNSTAP ( 4 | DnstapQ, 5 | new, 6 | Message, 7 | ) where 8 | 9 | import Control.Concurrent 10 | import Control.Concurrent.STM 11 | import qualified Control.Exception as E 12 | import Control.Monad (when) 13 | import qualified DNS.Log as Log 14 | import qualified DNS.TAP.FastStream as FSTRM 15 | import DNS.TAP.Schema 16 | import qualified DNS.ThreadStats as TStat 17 | import Data.IORef 18 | import Network.Socket 19 | 20 | import Config 21 | 22 | new :: Config -> Log.PutLines IO -> IO (IO (Maybe ThreadId), Message -> IO ()) 23 | new conf@Config{..} logP 24 | | cnf_dnstap = do 25 | (writer, put) <- newDnstapWriter conf logP 26 | return (Just <$> TStat.forkIO "bw.dnstap-writer" writer, put) 27 | | otherwise = do 28 | let put ~_ = return () 29 | return (return Nothing, put) 30 | 31 | newtype DnstapQ = DnstapQ (TBQueue Message) 32 | 33 | newDnstapQ :: IO DnstapQ 34 | newDnstapQ = DnstapQ <$> newTBQueueIO queueBound 35 | where 36 | {- limit waiting area on server to constant size -} 37 | {- transactions per 1 millisecond. When under load, assume GC runs about every 1 millisecond and the thread switches -} 38 | queueBound = 64 39 | 40 | writeDnstapQ :: DnstapQ -> Message -> IO () 41 | writeDnstapQ (DnstapQ q) ~msg = atomically $ writeTBQueue q msg 42 | 43 | readDnsTapQ :: DnstapQ -> IO Message 44 | readDnsTapQ (DnstapQ q) = atomically $ readTBQueue q 45 | 46 | newDnstapWriter :: Config -> Log.PutLines IO -> IO (IO (), Message -> IO ()) 47 | newDnstapWriter conf logP = do 48 | q <- newDnstapQ 49 | ref <- newIORef False 50 | let logger = control conf $ exec conf q ref logP 51 | put ~x = do 52 | ready <- readIORef ref 53 | when ready $ writeDnstapQ q x 54 | return (logger, put) 55 | 56 | exec :: Config -> DnstapQ -> IORef Bool -> Log.PutLines IO -> IO () 57 | exec Config{..} q ref logP = E.bracket setup teardown $ \sock -> do 58 | let fconf = FSTRM.Config True False 59 | FSTRM.writer sock fconf $ do 60 | msg <- readDnsTapQ q 61 | let d = defaultDNSTAP{dnstapMessage = Just msg} 62 | return $ encodeDnstap d 63 | where 64 | logLn level = logP level Nothing . (: []) 65 | setup = do 66 | s <- E.bracketOnError open close conn 67 | writeIORef ref True 68 | return s 69 | where 70 | open = socket AF_UNIX Stream defaultProtocol 71 | conn sock = do 72 | connect sock $ SockAddrUnix cnf_dnstap_socket_path 73 | logLn Log.INFO ("DNSTAP connected: " ++ cnf_dnstap_socket_path) 74 | return sock 75 | teardown s = do 76 | writeIORef ref False 77 | logLn Log.INFO ("DNSTAP disconnected: " ++ cnf_dnstap_socket_path) 78 | close s 79 | 80 | control :: Config -> IO () -> IO () 81 | control Config{..} body = loop 82 | where 83 | loop = do 84 | ex <- E.try body 85 | case ex of 86 | Right () -> return () 87 | Left (E.SomeException _e) -> do 88 | threadDelay (cnf_dnstap_reconnect_interval * 1000000) 89 | loop 90 | -------------------------------------------------------------------------------- /dnsext-do53/dnsext-do53.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: dnsext-do53 3 | version: 0.0.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | maintainer: Kazu Yamamoto 7 | author: Kazu Yamamoto 8 | tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==9.0.2 ghc ==9.2.4 9 | synopsis: DNS over 53 port based on dnsext 10 | description: 11 | A thread-safe DNS library for both clients and servers written 12 | purely in Haskell. 13 | 14 | category: Network 15 | build-type: Simple 16 | extra-source-files: 17 | CHANGELOG.md 18 | cbits/dns.c 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/kazu-yamamoto/dnsext 23 | 24 | flag devel 25 | description: Development commands 26 | default: False 27 | 28 | library 29 | exposed-modules: 30 | DNS.Do53.Client 31 | DNS.Do53.Internal 32 | 33 | other-modules: 34 | DNS.Do53.Do53 35 | DNS.Do53.IO 36 | DNS.Do53.Id 37 | DNS.Do53.Imports 38 | DNS.Do53.Lookup 39 | DNS.Do53.LookupX 40 | DNS.Do53.Query 41 | DNS.Do53.Resolve 42 | DNS.Do53.System 43 | DNS.Do53.Types 44 | DNS.Do53.VC 45 | 46 | default-language: Haskell2010 47 | ghc-options: -Wall 48 | build-depends: 49 | array, 50 | async, 51 | base >=4 && <5, 52 | bytestring, 53 | containers, 54 | dnsext-types, 55 | dnsext-utils, 56 | iproute >=1.3.2, 57 | mtl, 58 | network >= 3.2.3 && < 3.3, 59 | random >=1.2, 60 | recv, 61 | stm, 62 | unix-time 63 | 64 | if os(windows) 65 | c-sources: cbits/dns.c 66 | extra-libraries: iphlpapi 67 | 68 | if impl(ghc >=8) 69 | default-extensions: Strict StrictData 70 | 71 | test-suite spec 72 | type: exitcode-stdio-1.0 73 | main-is: Spec.hs 74 | build-tool-depends: hspec-discover:hspec-discover 75 | hs-source-dirs: test 76 | other-modules: 77 | LookupSpec 78 | IOSpec 79 | 80 | default-language: Haskell2010 81 | ghc-options: -Wall -threaded 82 | build-depends: 83 | dnsext-do53, 84 | dnsext-types, 85 | base, 86 | hspec, 87 | network 88 | 89 | if (os(windows) && impl(ghc >=9.0)) 90 | ghc-options: -with-rtsopts=--io-manager=native 91 | 92 | if impl(ghc >=8) 93 | default-extensions: Strict StrictData 94 | 95 | executable cli 96 | main-is: cli.hs 97 | hs-source-dirs: util 98 | 99 | default-language: Haskell2010 100 | default-extensions: Strict StrictData 101 | ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N4 -qn1 -T -A32m -kc2k" 102 | build-depends: 103 | base >=4.9 && <5, 104 | async, 105 | dnsext-do53, 106 | dnsext-types, 107 | iproute 108 | 109 | if flag(devel) 110 | 111 | else 112 | buildable: False 113 | -------------------------------------------------------------------------------- /dnsext-utils/DNS/Utils/AutoUpdate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module DNS.Utils.AutoUpdate ( 4 | -- * interfaces 5 | mkAutoUpdate, 6 | mkClosableAutoUpdate, 7 | 8 | -- * dubugging 9 | mkClosableAutoUpdate', 10 | UpdateState, 11 | ) 12 | where 13 | 14 | -- GHC packages 15 | 16 | import Control.Concurrent.STM 17 | import Control.Monad 18 | import Data.IORef 19 | import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) 20 | 21 | mkAutoUpdate :: Int -> IO a -> IO (IO a) 22 | mkAutoUpdate micro uaction = fst <$> mkClosableAutoUpdate micro uaction 23 | 24 | -- $setup 25 | -- >>> :set -XNumericUnderscores 26 | -- >>> import Control.Concurrent 27 | 28 | -- | 29 | -- >>> iref <- newIORef (0 :: Int) 30 | -- >>> action = modifyIORef iref (+ 1) >> readIORef iref 31 | -- >>> (getValue, closeState) <- mkClosableAutoUpdate 200_000 action 32 | -- >>> getValue 33 | -- 1 34 | -- >>> threadDelay 100_000 >> getValue 35 | -- 1 36 | -- >>> threadDelay 200_000 >> getValue 37 | -- 2 38 | -- >>> closeState 39 | mkClosableAutoUpdate :: Int -> IO a -> IO (IO a, IO ()) 40 | mkClosableAutoUpdate = mkAutoUpdateThings $ \g c _ -> (g, c) 41 | 42 | -- | provide `UpdateState` for debugging 43 | mkClosableAutoUpdate' :: Int -> IO a -> IO (IO a, IO (), UpdateState a) 44 | mkClosableAutoUpdate' = mkAutoUpdateThings (,,) 45 | 46 | mkAutoUpdateThings :: (IO a -> IO () -> UpdateState a -> b) -> Int -> IO a -> IO b 47 | mkAutoUpdateThings mk micro uaction = do 48 | us <- openUpdateState micro uaction 49 | pure $ mk (getUpdateResult us) (closeUpdateState us) us 50 | 51 | -------------------------------------------------------------------------------- 52 | 53 | {- FOURMOLU_DISABLE -} 54 | data UpdateState a = 55 | UpdateState 56 | { usUpdateAction_ :: IO a 57 | , usLastResult_ :: IORef a 58 | , usIntervalMicro_ :: Int 59 | , usTimeHasCome_ :: TVar Bool 60 | , usDeleteTimeout_ :: IORef (IO ()) 61 | } 62 | {- FOURMOLU_ENABLE -} 63 | 64 | mkDeleteTimeout :: TVar Bool -> Int -> IO (IO ()) 65 | mkDeleteTimeout thc micro = do 66 | mgr <- getSystemTimerManager 67 | key <- registerTimeout mgr micro (atomically $ writeTVar thc True) 68 | pure $ unregisterTimeout mgr key 69 | 70 | openUpdateState :: Int -> IO a -> IO (UpdateState a) 71 | openUpdateState micro uaction = do 72 | thc <- newTVarIO False 73 | UpdateState uaction <$> (newIORef =<< uaction) <*> pure micro <*> pure thc <*> (newIORef =<< mkDeleteTimeout thc micro) 74 | 75 | closeUpdateState :: UpdateState a -> IO () 76 | closeUpdateState UpdateState{..} = do 77 | delete <- readIORef usDeleteTimeout_ 78 | delete 79 | 80 | onceOnTimeHasCome :: UpdateState a -> IO () -> IO () 81 | onceOnTimeHasCome UpdateState{..} action = do 82 | action' <- atomically $ do 83 | timeHasCome <- readTVar usTimeHasCome_ 84 | when timeHasCome $ writeTVar usTimeHasCome_ False 85 | pure $ when timeHasCome action 86 | action' 87 | 88 | getUpdateResult :: UpdateState a -> IO a 89 | getUpdateResult us@UpdateState{..} = do 90 | onceOnTimeHasCome us $ do 91 | writeIORef usLastResult_ =<< usUpdateAction_ 92 | writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_ 93 | readIORef usLastResult_ 94 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Verify/ECDSA.hs: -------------------------------------------------------------------------------- 1 | module DNS.SEC.Verify.ECDSA ( 2 | ecdsaP256SHA, 3 | ecdsaP384SHA, 4 | ) 5 | where 6 | 7 | import Control.Monad (unless) 8 | import Crypto.Hash (HashAlgorithm) 9 | import Crypto.Hash.Algorithms (SHA256 (..), SHA384 (..)) 10 | import Crypto.Number.Serialize (os2ip) 11 | import Crypto.PubKey.ECC.ECDSA (PublicKey, Signature) 12 | import qualified Crypto.PubKey.ECC.ECDSA as ECDSA 13 | import qualified Crypto.PubKey.ECC.Prim as ECC 14 | import Crypto.PubKey.ECC.Types (Curve, CurveName) 15 | import qualified Crypto.PubKey.ECC.Types as ECC 16 | import DNS.SEC.PubKey 17 | import DNS.SEC.Verify.Types 18 | import DNS.Types 19 | import qualified DNS.Types.Opaque as Opaque 20 | import Data.ByteString (ByteString) 21 | import qualified Data.ByteString as BS 22 | 23 | {- Verify RRSIG with DNSKEY using Elliptic Curve Digital Signature Algorithm (ECDSA) 24 | -- https://datatracker.ietf.org/doc/html/rfc6605 25 | -} 26 | 27 | ecdsaP256SHA :: RRSIGImpl 28 | ecdsaP256SHA = ecdsaHelper ECC.SEC_p256r1 SHA256 29 | 30 | ecdsaP384SHA :: RRSIGImpl 31 | ecdsaP384SHA = ecdsaHelper ECC.SEC_p384r1 SHA384 32 | 33 | ecdsaHelper :: HashAlgorithm hash => CurveName -> hash -> RRSIGImpl 34 | ecdsaHelper cn hash = 35 | RRSIGImpl 36 | { rrsigIGetKey = ecdsaDecodePubKey cn curve 37 | , rrsigIGetSig = ecdsaDecodeSignature curve 38 | , rrsigIVerify = ecdsaVerify hash 39 | } 40 | where 41 | curve = ECC.getCurveByName cn 42 | 43 | curveSizeBytes :: Curve -> Int 44 | curveSizeBytes curve = (ECC.curveSizeBits curve + 7) `div` 8 45 | 46 | ecdsaDecodePubKey :: CurveName -> Curve -> PubKey -> Either String PublicKey 47 | ecdsaDecodePubKey cn curve (PubKey_ECDSA xs ys) = do 48 | unless (xlen == size && ylen == size) $ 49 | Left $ 50 | "ecdsaDecodePubKey: invalid length of pubkey bytes: " 51 | ++ "expect " 52 | ++ show (size, size) 53 | ++ " =/= " 54 | ++ "actual " 55 | ++ show (xlen, ylen) 56 | unless (ECC.isPointValid curve point) $ 57 | Left $ 58 | "ecdsaDecodePubKey: not valid point on curve " ++ show cn 59 | return $ ECDSA.PublicKey curve point 60 | where 61 | size = curveSizeBytes curve 62 | xlen = Opaque.length xs 63 | ylen = Opaque.length ys 64 | point = ECC.Point (os2ip $ Opaque.toByteString xs) (os2ip $ Opaque.toByteString ys) 65 | ecdsaDecodePubKey _ _ _ = 66 | Left "ecdsaDecodePubKey: not ECDSA pubkey format" 67 | 68 | ecdsaDecodeSignature :: Curve -> Opaque -> Either String Signature 69 | ecdsaDecodeSignature curve ss = do 70 | unless (slen == size * 2) $ 71 | Left $ 72 | "ecdsaDecodeSignature: invalid length of signature bytes: " 73 | ++ "expect " 74 | ++ show (size * 2) 75 | ++ ", " 76 | ++ "actual " 77 | ++ show slen 78 | return $ ECDSA.Signature (os2ip rb) (os2ip sb) 79 | where 80 | size = curveSizeBytes curve 81 | slen = Opaque.length ss 82 | (rb, sb) = BS.splitAt size $ Opaque.toByteString ss 83 | 84 | ecdsaVerify 85 | :: HashAlgorithm hash 86 | => hash 87 | -> PublicKey 88 | -> Signature 89 | -> ByteString 90 | -> Either String Bool 91 | ecdsaVerify hash pubkey sig = Right . ECDSA.verify hash pubkey sig 92 | -------------------------------------------------------------------------------- /docs/_layouts/default.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | {% seo %} 9 | 10 | 13 | 14 | 15 |
16 |
17 |

{{ site.title | default: site.github.repository_name }}

18 | 19 | {% if site.logo %} 20 | Logo 21 | {% endif %} 22 | 23 |

{{ site.description | default: site.github.project_tagline }}

24 | 25 | {% if site.github.is_project_page %} 26 |

View the Project on GitHub {{ site.github.repository_nwo }}

27 | {% endif %} 28 | 29 | {% if site.github.is_user_page %} 30 |

View My GitHub Profile

31 | {% endif %} 32 | 33 | {% if site.show_downloads %} 34 | 39 | {% endif %} 40 | {% assign sorted = site.html_pages | sort:"rank" %} 41 | {% for item in sorted %} 42 | {% if item.path != "index.md" and item.title and item.rank %} 43 |
  • 44 | {{ item.title }} 45 | 46 |
    • 47 | {% endif %} 48 | {% endfor %} 49 |
    50 |
    51 | 52 | {{ content }} 53 | 54 |
    55 | 61 |
    62 | 63 | {% if site.google_analytics %} 64 | 72 | {% endif %} 73 | 74 | 75 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/SocketUtil.hs: -------------------------------------------------------------------------------- 1 | module SocketUtil ( 2 | ainfosSkipError, 3 | foldAddrInfo, 4 | ) where 5 | 6 | -- GHC packages 7 | import Data.Functor 8 | import Data.List 9 | import Data.Maybe 10 | import System.IO.Error (tryIOError) 11 | import Text.Read (readMaybe) 12 | 13 | -- dns packages 14 | import Data.IP (IP) 15 | import Network.Socket ( 16 | AddrInfo (..), 17 | AddrInfoFlag (..), 18 | HostName, 19 | PortNumber, 20 | SocketType (..), 21 | defaultHints, 22 | ) 23 | import qualified Network.Socket as S 24 | 25 | {- FOURMOLU_DISABLE -} 26 | -- expected behavior examples in a typical environments 27 | -- 28 | -- 53 [] --> 0.0.0.0:53, [::]:53 29 | -- 53 ["0.0.0.0", "::"] --> 0.0.0.0:53, [::]:53 30 | -- 53 ["localhost"] --> 127.0.0.1:53, [::1]:53 31 | -- 53 ["127.0.0.1", "::1"] --> 127.0.0.1:53, [::1]:53 32 | ainfosSkipError :: (String -> IO ()) -> SocketType -> PortNumber -> [HostName] -> IO [AddrInfo] 33 | ainfosSkipError logLn sty p hs = case hs of 34 | [] -> foldAddrInfo' sty Nothing p 35 | _:_ -> concat <$> sequence [ainfoSkip h p | h <- hs] 36 | where 37 | ainfoSkip host port = case (readMaybe host :: Maybe IP) of 38 | Nothing -> foldAddrInfo' sty (Just host) port 39 | Just {} -> take 1 <$> foldAddrInfo' sty (Just host) port {- assume the first is the best -} 40 | foldAddrInfo' = foldAddrInfo left pure 41 | left e = logLn (estring $ show e) $> [] 42 | estring s = "skipping : " ++ fromMaybe s (stripPrefix "Network.Socket." s) 43 | {- FOURMOLU_ENABLE -} 44 | 45 | {- FOURMOLU_DISABLE -} 46 | _checks :: IO () 47 | _checks = 48 | mapM_ check 49 | [[], ["0.0.0.0", "::"], ["localhost"], ["127.0.0.1", "::1"]] 50 | where 51 | check ns = do 52 | putStrLn $ show ns ++ ":" 53 | as <- ainfosSkipError putStrLn S.Datagram 53 ns 54 | putStr $ unlines $ map ((" " ++) . show) as 55 | {- FOURMOLU_ENABLE -} 56 | 57 | {- FOURMOLU_DISABLE -} 58 | -- | 59 | -- Check whether IPv6 is available by specifying `AI_ADDRCONFIG` to `addrFlags` of hints passed to `getAddrInfo`. 60 | -- If `Nothing` is passed to `hints`, the default value of `addrFlags` is implementation-dependent. 61 | -- * Glibc: `[AI_ADDRCONFIG, AI_V4MAPPED]`. 62 | -- * https://man7.org/linux/man-pages/man3/getaddrinfo.3.html#DESCRIPTION 63 | -- * POSIX, BSD: `[]`. 64 | -- * https://man.freebsd.org/cgi/man.cgi?query=getaddrinfo&sektion=3 65 | -- So, specifying `AI_ADDRCONFIG` explicitly. 66 | -- 67 | -- >>> getAI = S.getAddrInfo (Just defaultHints{addrFlags = [AI_ADDRCONFIG]}) (Just "::") (Just "0") :: IO [AddrInfo] 68 | -- >>> v6unsupported <- either (\_ -> True) (\_ -> False) <$> tryIOError getAI 69 | -- >>> (== v6unsupported) <$> foldAddrInfo (\_ -> pure True) (\_ -> pure False) Datagram (Just "::1") 53 70 | -- True 71 | foldAddrInfo :: (IOError -> IO a) -> ([AddrInfo] -> IO a) -> SocketType -> Maybe HostName -> PortNumber -> IO a 72 | foldAddrInfo left right socktype mhost port = 73 | either left right1 =<< tryIOError (S.getAddrInfo (Just hints) mhost (Just $ show port)) 74 | where 75 | hints = defaultHints { 76 | addrFlags = [AI_ADDRCONFIG, AI_PASSIVE] 77 | , addrSocketType = socktype 78 | } 79 | right1 as = right [ai | ai <- as, addrSocketType ai == socktype] 80 | {- FOURMOLU_ENABLE -} 81 | -------------------------------------------------------------------------------- /dnsext-utils/dnsext-utils.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: dnsext-utils 3 | version: 0.0.0 4 | license-file: LICENSE 5 | maintainer: ex8k.hibino@gmail.com, kazu@iij.ad.jp 6 | author: Kei Hibino and Kazu Yamamoto 7 | build-type: Simple 8 | extra-source-files: CHANGELOG.md 9 | 10 | library 11 | exposed-modules: 12 | DNS.Array 13 | DNS.Log 14 | DNS.Parser 15 | DNS.TAP.FastStream 16 | DNS.TAP.ProtocolBuffer 17 | DNS.TAP.Schema 18 | DNS.ThreadAsync 19 | DNS.ThreadStats 20 | DNS.TimeCache 21 | DNS.RRCache 22 | DNS.ZoneFile 23 | 24 | other-modules: 25 | DNS.Utils.AutoUpdate 26 | DNS.RRCache.Managed 27 | DNS.RRCache.ReaperReduced 28 | DNS.RRCache.Types 29 | DNS.Parser.Class 30 | DNS.Parser.State 31 | DNS.ZoneFile.Types 32 | DNS.ZoneFile.Lexer 33 | DNS.ZoneFile.ParserBase 34 | DNS.ZoneFile.ParserDNSSEC 35 | DNS.ZoneFile.ParserSVCB 36 | DNS.ZoneFile.Parser 37 | DNS.ZoneFile.IO 38 | 39 | default-language: Haskell2010 40 | ghc-options: -Wall 41 | build-depends: 42 | -- GHC bundled 43 | array, 44 | async, 45 | base >=4 && <5, 46 | bytestring, 47 | containers, 48 | deepseq, 49 | stm, 50 | transformers, 51 | -- dnsext packages 52 | dnsext-dnssec, 53 | dnsext-svcb, 54 | dnsext-types, 55 | -- other packages 56 | ansi-terminal, 57 | iproute, 58 | network >= 3.2.2 && < 3.3, 59 | network-byte-order, 60 | psqueues, 61 | recv, 62 | unix-time, 63 | word8 64 | 65 | if impl(ghc >=8) 66 | default-extensions: Strict StrictData 67 | 68 | test-suite spec 69 | type: exitcode-stdio-1.0 70 | main-is: Spec.hs 71 | build-tool-depends: hspec-discover:hspec-discover 72 | hs-source-dirs: test 73 | other-modules: 74 | ArraySpec 75 | FastStreamSpec 76 | ProtocolBufferSpec 77 | SchemaSpec 78 | 79 | default-language: Haskell2010 80 | ghc-options: -Wall -threaded -with-rtsopts=-N 81 | build-depends: 82 | -- GHC bundled 83 | array, 84 | async, 85 | base, 86 | bytestring, 87 | -- this package 88 | dnsext-utils, 89 | -- dnsext packages 90 | dnsext-types, 91 | -- other packages 92 | hspec, 93 | network-run 94 | 95 | if impl(ghc >=8) 96 | default-extensions: Strict StrictData 97 | 98 | test-suite cache-test 99 | type: exitcode-stdio-1.0 100 | main-is: cache.hs 101 | hs-source-dirs: test 102 | other-modules: CacheProp 103 | default-language: Haskell2010 104 | ghc-options: -Wall 105 | build-depends: 106 | -- GHC bundled 107 | base, 108 | bytestring, 109 | -- this package 110 | dnsext-utils, 111 | -- dnsext packages 112 | dnsext-types, 113 | -- other packages 114 | QuickCheck, 115 | unix-time 116 | 117 | if impl(ghc >=8) 118 | default-extensions: Strict StrictData 119 | -------------------------------------------------------------------------------- /dnsext-dnssec/DNS/SEC/Opts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | module DNS.SEC.Opts ( 4 | OptCode ( 5 | DAU, 6 | DHU, 7 | N3U 8 | ), 9 | OD_DAU (..), 10 | OD_DHU (..), 11 | OD_N3U (..), 12 | od_dau, 13 | od_dhu, 14 | od_n3u, 15 | get_dau, 16 | get_dhu, 17 | get_n3u, 18 | ) 19 | where 20 | 21 | import DNS.SEC.HashAlg 22 | import DNS.SEC.Imports 23 | import DNS.SEC.PubAlg 24 | import DNS.Types 25 | import DNS.Types.Internal 26 | 27 | -- | DNSSEC algorithm support (RFC6975, section 3) 28 | pattern DAU :: OptCode 29 | pattern DAU = OptCode 5 30 | 31 | pattern DHU :: OptCode 32 | pattern DHU = OptCode 6 33 | 34 | pattern N3U :: OptCode 35 | pattern N3U = OptCode 7 36 | 37 | --------------------------------------------------------------- 38 | 39 | -- | DNSSEC Algorithm Understood (RFC6975). Client to server. 40 | -- (array of 8-bit numbers). Lists supported DNSKEY algorithms. 41 | newtype OD_DAU = OD_DAU [PubAlg] deriving (Eq) 42 | 43 | instance Show OD_DAU where 44 | show (OD_DAU as) = _showAlgList "DAU" as 45 | 46 | instance OptData OD_DAU where 47 | optDataCode _ = DAU 48 | optDataSize (OD_DAU as) = 4 + length as 49 | putOptData (OD_DAU as) = putODWords (fromOptCode DAU) $ map fromPubAlg as 50 | 51 | get_dau :: Int -> Parser OD_DAU 52 | get_dau len rbuf _ = OD_DAU . map toPubAlg <$> getNOctets rbuf len 53 | 54 | od_dau :: [PubAlg] -> OData 55 | od_dau a = toOData $ OD_DAU a 56 | 57 | --------------------------------------------------------------- 58 | 59 | -- | DS Hash Understood (RFC6975). Client to server. 60 | -- (array of 8-bit numbers). Lists supported DS hash algorithms. 61 | newtype OD_DHU = OD_DHU [HashAlg] deriving (Eq) 62 | 63 | instance Show OD_DHU where 64 | show (OD_DHU hs) = _showAlgList "DHU" hs 65 | 66 | instance OptData OD_DHU where 67 | optDataCode _ = DHU 68 | optDataSize (OD_DHU hs) = 4 + length hs 69 | putOptData (OD_DHU hs) = putODWords (fromOptCode DHU) $ map fromHashAlg hs 70 | 71 | get_dhu :: Int -> Parser OD_DHU 72 | get_dhu len rbuf _ = OD_DHU . map toHashAlg <$> getNOctets rbuf len 73 | 74 | od_dhu :: [HashAlg] -> OData 75 | od_dhu a = toOData $ OD_DHU a 76 | 77 | --------------------------------------------------------------- 78 | 79 | -- | NSEC3 Hash Understood (RFC6975). Client to server. 80 | -- (array of 8-bit numbers). Lists supported NSEC3 hash algorithms. 81 | newtype OD_N3U = OD_N3U [HashAlg] deriving (Eq) 82 | 83 | instance Show OD_N3U where 84 | show (OD_N3U hs) = _showAlgList "N3U" hs 85 | 86 | instance OptData OD_N3U where 87 | optDataCode _ = N3U 88 | optDataSize (OD_N3U hs) = 4 + length hs 89 | putOptData (OD_N3U hs) = putODWords (fromOptCode N3U) $ map fromHashAlg hs 90 | 91 | get_n3u :: Int -> Parser OD_N3U 92 | get_n3u len rbuf _ = OD_N3U . map toHashAlg <$> getNOctets rbuf len 93 | 94 | od_n3u :: [HashAlg] -> OData 95 | od_n3u a = toOData $ OD_N3U a 96 | 97 | --------------------------------------------------------------- 98 | 99 | _showAlgList :: Show a => String -> [a] -> String 100 | _showAlgList nm ws = nm ++ " " ++ intercalate "," (map show ws) 101 | 102 | -- | Encode EDNS OPTION consisting of a list of octets. 103 | putODWords :: Word16 -> [Word8] -> Builder () 104 | putODWords code ws wbuf _ = do 105 | put16 wbuf code 106 | putInt16 wbuf $ length ws 107 | mapM_ (put8 wbuf) ws 108 | -------------------------------------------------------------------------------- /dnsext-do53/DNS/Do53/VC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module DNS.Do53.VC ( 4 | vcPersistentResolver, 5 | tcpPersistentResolver, 6 | ) where 7 | 8 | import Control.Concurrent 9 | import Control.Concurrent.STM 10 | import qualified Control.Exception as E 11 | import qualified Data.ByteString as BS 12 | import Data.IORef 13 | import Data.IntMap.Strict (IntMap) 14 | import qualified Data.IntMap.Strict as IM 15 | import Data.Tuple (swap) 16 | import Network.Socket 17 | import System.Timeout (timeout) 18 | 19 | -- import System.IO.Error (annotateIOError) 20 | -- import qualified DNS.Log as Log 21 | 22 | import DNS.Do53.Do53 hiding (vcResolver) 23 | import DNS.Do53.IO 24 | import DNS.Do53.Imports 25 | import DNS.Do53.Query 26 | import DNS.Do53.Types 27 | import qualified DNS.ThreadAsync as TAsync 28 | import DNS.Types 29 | import DNS.Types.Decode 30 | 31 | type RVar = MVar (Either DNSError Reply) 32 | 33 | -- | Persistent resolver over TCP. 34 | tcpPersistentResolver :: PersistentResolver 35 | tcpPersistentResolver ri@ResolveInfo{..} body = E.bracket open close $ \sock -> do 36 | let send = sendVC $ sendTCP sock 37 | recv = recvVC rinfoVCLimit $ recvTCP sock 38 | vcPersistentResolver tag send recv ri body 39 | where 40 | tag = nameTag ri "TCP" 41 | open = openTCP rinfoIP rinfoPort 42 | 43 | -- | Making a persistent resolver. 44 | vcPersistentResolver :: NameTag -> (BS -> IO ()) -> IO BS -> PersistentResolver 45 | vcPersistentResolver tag send recv ResolveInfo{..} body = do 46 | inpQ <- newTQueueIO 47 | ref <- newIORef emp 48 | TAsync.race_ 49 | "vcPersistentResolver: sender/receiver" 50 | (TAsync.concurrently_ "vcPersistentResolver:sender" (sender inpQ) "vcPersistentResolver:receiver" (recver ref)) 51 | "vcPersistentResolver: body" 52 | (body $ resolve inpQ ref) 53 | where 54 | emp = IM.empty :: IntMap RVar 55 | resolve inpQ ref q qctl = do 56 | ident <- ractionGenId rinfoActions 57 | var <- newEmptyMVar :: IO RVar 58 | let key = fromIntegral ident 59 | qry = encodeQuery ident q qctl 60 | tx = BS.length qry 61 | atomicModifyIORef' ref (\m -> (IM.insert key var m, ())) 62 | atomically $ writeTQueue inpQ qry 63 | mres <- timeout (ractionTimeoutTime rinfoActions) $ takeMVar var 64 | return $ case mres of 65 | Nothing -> Left TimeoutExpired 66 | Just (Left e) -> Left e 67 | Just (Right rp) -> case checkRespM q ident (replyDNSMessage rp) of 68 | Nothing -> Right $ rp{replyTxBytes = tx} 69 | Just err -> Left err 70 | 71 | sender inpQ = forever (atomically (readTQueue inpQ) >>= send) 72 | 73 | del idnt m = swap $ IM.updateLookupWithKey (\_ _ -> Nothing) idnt m 74 | 75 | recver ref = forever $ do 76 | bs <- 77 | recv `E.catch` \ne -> do 78 | let e = fromIOException (fromNameTag tag) ne 79 | cleanup ref e 80 | E.throwIO e 81 | now <- ractionGetTime rinfoActions 82 | case decodeAt now bs of 83 | Left e -> do 84 | cleanup ref e 85 | E.throwIO e 86 | Right msg -> do 87 | let key = fromIntegral $ identifier msg 88 | Just var <- atomicModifyIORef' ref $ del key 89 | putMVar var $ Right $ Reply tag msg 0 {- dummy -} $ BS.length bs 90 | 91 | cleanup ref e = do 92 | vars <- IM.elems <$> readIORef ref 93 | mapM_ (\var -> putMVar var (Left e)) vars 94 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Server/Types.hs: -------------------------------------------------------------------------------- 1 | module DNS.Iterative.Server.Types ( 2 | ServerActions, 3 | Env, 4 | VcServerConfig (..), 5 | ToCacher, 6 | FromReceiver, 7 | ToWorker, 8 | FromCacher, 9 | ToSender, 10 | FromX, 11 | ReqNum, 12 | VcPendingOp (..), 13 | DoX (..), 14 | Input (..), 15 | Output (..), 16 | Peer (..), 17 | EpochTimeUsec, 18 | peerSockAddr, 19 | withLocationIOE, 20 | Socket, 21 | SockAddr (..), 22 | withFdSocket, 23 | socketName, 24 | SuperStream (..), 25 | ) where 26 | 27 | -- GHC 28 | import Data.ByteString (ByteString) 29 | import System.IO.Error (ioeSetLocation, tryIOError) 30 | 31 | -- libs 32 | import Data.IP (fromSockAddr) 33 | import qualified Network.HTTP2.Server.Internal as H2I 34 | import qualified Network.QUIC as QUIC 35 | import Network.Socket 36 | import Network.TLS (Credentials (..), SessionManager) 37 | 38 | -- dnsext 39 | import DNS.Types (DNSMessage) 40 | import DNS.Types.Time (EpochTimeUsec) 41 | 42 | -- this package 43 | import DNS.Iterative.Query (Env) 44 | 45 | data SuperStream = StreamH2 H2I.Stream | StreamQUIC QUIC.Stream deriving (Show) 46 | 47 | data Peer 48 | = PeerInfoUDP SockAddr [Cmsg] 49 | | PeerInfoStream SockAddr SuperStream 50 | | PeerInfoVC SockAddr 51 | deriving (Show) 52 | 53 | peerSockAddr :: Peer -> SockAddr 54 | peerSockAddr (PeerInfoUDP sa _) = sa 55 | peerSockAddr (PeerInfoStream sa _) = sa 56 | peerSockAddr (PeerInfoVC sa) = sa 57 | 58 | -- request identifier in one connection 59 | type ReqNum = Int 60 | 61 | data VcPendingOp 62 | = VcPendingOp 63 | { vpReqNum :: ReqNum 64 | , vpDelete :: IO () 65 | } 66 | 67 | data DoX 68 | = UDP 69 | | TCP 70 | | DoT 71 | | H2 72 | | H2C 73 | | H3 74 | | DoQ 75 | deriving (Eq, Show) 76 | 77 | data Input a = Input 78 | { inputQuery :: a 79 | , inputPendingOp :: VcPendingOp 80 | , inputMysa :: SockAddr 81 | , inputPeerInfo :: Peer 82 | , inputDoX :: DoX 83 | , inputToSender :: ToSender -> IO () 84 | , inputRecvTime :: EpochTimeUsec 85 | } 86 | 87 | data Output = Output 88 | { outputReplyBS :: ByteString 89 | , outputPendingOp :: VcPendingOp 90 | , outputPeerInfo :: Peer 91 | } 92 | 93 | -- Type of the action reveals its arguments and the context of the monad, 94 | -- eg. 95 | -- - toCacher :: ToCacher -> IO () 96 | -- - toSender :: IO ToSender 97 | type ToCacher = Input ByteString 98 | type FromReceiver = Input ByteString 99 | type ToWorker = Input DNSMessage 100 | type FromCacher = Input DNSMessage 101 | type ToSender = Output 102 | type FromX = Output 103 | 104 | type ServerActions = Env -> (ToCacher -> IO ()) -> [Socket] -> IO [IO ()] 105 | 106 | data VcServerConfig = VcServerConfig 107 | { vc_query_max_size :: Int 108 | , vc_idle_timeout :: Int 109 | , vc_slowloris_size :: Int 110 | , vc_credentials :: Credentials 111 | , vc_session_manager :: SessionManager 112 | , vc_early_data_size :: Int 113 | , vc_interface_automatic :: Bool 114 | } 115 | 116 | withLocationIOE :: String -> IO a -> IO a 117 | withLocationIOE loc action = do 118 | either left pure =<< tryIOError action 119 | where 120 | left ioe = ioError $ ioeSetLocation ioe loc 121 | 122 | socketName :: Socket -> IO String 123 | socketName s = do 124 | sa <- getSocketName s 125 | return $ case fromSockAddr sa of 126 | Nothing -> "(no name)" 127 | Just (ip, pn) -> show ip ++ "#" ++ show pn 128 | -------------------------------------------------------------------------------- /root-data/root.hints: -------------------------------------------------------------------------------- 1 | ; This file holds the information on root name servers needed to 2 | ; initialize cache of Internet domain name servers 3 | ; (e.g. reference this file in the "cache . " 4 | ; configuration file of BIND domain name servers). 5 | ; 6 | ; This file is made available by InterNIC 7 | ; under anonymous FTP as 8 | ; file /domain/named.cache 9 | ; on server FTP.INTERNIC.NET 10 | ; -OR- RS.INTERNIC.NET 11 | ; 12 | ; last update: January 24, 2024 13 | ; related version of root zone: 2024012401 14 | ; 15 | ; FORMERLY NS.INTERNIC.NET 16 | ; 17 | . 3600000 NS A.ROOT-SERVERS.NET. 18 | A.ROOT-SERVERS.NET. 3600000 A 198.41.0.4 19 | A.ROOT-SERVERS.NET. 3600000 AAAA 2001:503:ba3e::2:30 20 | ; 21 | ; FORMERLY NS1.ISI.EDU 22 | ; 23 | . 3600000 NS B.ROOT-SERVERS.NET. 24 | B.ROOT-SERVERS.NET. 3600000 A 170.247.170.2 25 | B.ROOT-SERVERS.NET. 3600000 AAAA 2801:1b8:10::b 26 | ; 27 | ; FORMERLY C.PSI.NET 28 | ; 29 | . 3600000 NS C.ROOT-SERVERS.NET. 30 | C.ROOT-SERVERS.NET. 3600000 A 192.33.4.12 31 | C.ROOT-SERVERS.NET. 3600000 AAAA 2001:500:2::c 32 | ; 33 | ; FORMERLY TERP.UMD.EDU 34 | ; 35 | . 3600000 NS D.ROOT-SERVERS.NET. 36 | D.ROOT-SERVERS.NET. 3600000 A 199.7.91.13 37 | D.ROOT-SERVERS.NET. 3600000 AAAA 2001:500:2d::d 38 | ; 39 | ; FORMERLY NS.NASA.GOV 40 | ; 41 | . 3600000 NS E.ROOT-SERVERS.NET. 42 | E.ROOT-SERVERS.NET. 3600000 A 192.203.230.10 43 | E.ROOT-SERVERS.NET. 3600000 AAAA 2001:500:a8::e 44 | ; 45 | ; FORMERLY NS.ISC.ORG 46 | ; 47 | . 3600000 NS F.ROOT-SERVERS.NET. 48 | F.ROOT-SERVERS.NET. 3600000 A 192.5.5.241 49 | F.ROOT-SERVERS.NET. 3600000 AAAA 2001:500:2f::f 50 | ; 51 | ; FORMERLY NS.NIC.DDN.MIL 52 | ; 53 | . 3600000 NS G.ROOT-SERVERS.NET. 54 | G.ROOT-SERVERS.NET. 3600000 A 192.112.36.4 55 | G.ROOT-SERVERS.NET. 3600000 AAAA 2001:500:12::d0d 56 | ; 57 | ; FORMERLY AOS.ARL.ARMY.MIL 58 | ; 59 | . 3600000 NS H.ROOT-SERVERS.NET. 60 | H.ROOT-SERVERS.NET. 3600000 A 198.97.190.53 61 | H.ROOT-SERVERS.NET. 3600000 AAAA 2001:500:1::53 62 | ; 63 | ; FORMERLY NIC.NORDU.NET 64 | ; 65 | . 3600000 NS I.ROOT-SERVERS.NET. 66 | I.ROOT-SERVERS.NET. 3600000 A 192.36.148.17 67 | I.ROOT-SERVERS.NET. 3600000 AAAA 2001:7fe::53 68 | ; 69 | ; OPERATED BY VERISIGN, INC. 70 | ; 71 | . 3600000 NS J.ROOT-SERVERS.NET. 72 | J.ROOT-SERVERS.NET. 3600000 A 192.58.128.30 73 | J.ROOT-SERVERS.NET. 3600000 AAAA 2001:503:c27::2:30 74 | ; 75 | ; OPERATED BY RIPE NCC 76 | ; 77 | . 3600000 NS K.ROOT-SERVERS.NET. 78 | K.ROOT-SERVERS.NET. 3600000 A 193.0.14.129 79 | K.ROOT-SERVERS.NET. 3600000 AAAA 2001:7fd::1 80 | ; 81 | ; OPERATED BY ICANN 82 | ; 83 | . 3600000 NS L.ROOT-SERVERS.NET. 84 | L.ROOT-SERVERS.NET. 3600000 A 199.7.83.42 85 | L.ROOT-SERVERS.NET. 3600000 AAAA 2001:500:9f::42 86 | ; 87 | ; OPERATED BY WIDE 88 | ; 89 | . 3600000 NS M.ROOT-SERVERS.NET. 90 | M.ROOT-SERVERS.NET. 3600000 A 202.12.27.33 91 | M.ROOT-SERVERS.NET. 3600000 AAAA 2001:dc3::35 92 | ; End of file 93 | -------------------------------------------------------------------------------- /dnsext-iterative/DNS/Iterative/Server/CtlRecv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module DNS.Iterative.Server.CtlRecv ( 4 | -- * Controlled receiving 5 | Check, 6 | CtlRecv, 7 | ctlRecvBreak, 8 | newCtlRecv, 9 | Terminate (..), 10 | withControlledRecv, 11 | getLeftover, 12 | 13 | -- * Internal 14 | controlledRecv, 15 | Result (..), 16 | ) where 17 | 18 | import Data.ByteString (ByteString) 19 | import qualified Data.ByteString as BS 20 | import Data.IORef 21 | 22 | -- | Return 'True' when a break (aka Timeout) happens. 23 | type Check = IO Bool 24 | 25 | -- | Control data for a receiving function. 26 | data CtlRecv = CtlRecv 27 | { ctlRecvBreak :: Check 28 | , ctlRecvBuillder :: IORef (Int, [ByteString] -> [ByteString]) 29 | } 30 | 31 | -- | Creating 'CtlRecv'. 32 | newCtlRecv 33 | :: Check 34 | -> IO CtlRecv 35 | newCtlRecv ctlRecvBreak = do 36 | ctlRecvBuillder <- newIORef (0, id) 37 | return CtlRecv{..} 38 | 39 | -- | The reason why the receiving function is terminated. 40 | data Terminate 41 | = -- | End of file. 42 | EOF 43 | | -- | When 'Check' returns 'False', 'Break' is retuned. 'Break' 44 | -- is timeout in the normal case. 45 | Break 46 | deriving (Eq, Show) 47 | 48 | -- | Result. 49 | data Result 50 | = Terminate Terminate 51 | | NotEnough 52 | | NBytes ByteString 53 | deriving (Eq, Show) 54 | 55 | -- | Controlled receiving function. 56 | -- 57 | -- one-shot blocking on `ctlRecvBreak` 58 | controlledRecv :: CtlRecv -> (Int -> IO ByteString) -> Int -> IO Result 59 | controlledRecv CtlRecv{..} recvN len = do 60 | brk <- ctlRecvBreak 61 | if brk 62 | then return $ Terminate Break 63 | else controlledRecv' ctlRecvBuillder recvN len 64 | 65 | controlledRecv' 66 | :: IORef (Int, [ByteString] -> [ByteString]) 67 | -> (Int -> IO ByteString) 68 | -> Int 69 | -> IO Result 70 | controlledRecv' recvBuillder recvN len = do 71 | (blen, builder) <- readIORef recvBuillder 72 | let wantN = len - blen 73 | bs <- recvN wantN 74 | let n = BS.length bs 75 | if n == 0 76 | then return $ Terminate EOF 77 | else do 78 | let builder' = builder . (bs :) 79 | if n == wantN 80 | then do 81 | let finalBS = BS.concat $ builder' [] 82 | writeIORef recvBuillder (0, id) 83 | return $ NBytes finalBS 84 | else do 85 | let blen' = blen + n 86 | writeIORef recvBuillder (blen', builder') 87 | return NotEnough 88 | 89 | -- | Use to get leftover for 'Terminate'. 90 | getLeftover :: CtlRecv -> IO ByteString 91 | getLeftover CtlRecv{..} = do 92 | (_blen, builder) <- readIORef ctlRecvBuillder 93 | let leftover = BS.concat $ builder [] 94 | return leftover 95 | 96 | -- | Calling an action with 'ByteString' of the exact size. 97 | -- 98 | -- event loop, blocking on waiting events. 99 | withControlledRecv 100 | :: CtlRecv 101 | -> (Int -> IO ByteString) 102 | -- ^ Receiving function 103 | -> Int 104 | -- ^ How many bytes are wanted. 105 | -> (ByteString -> IO a) 106 | -- ^ An action which receives 'ByteString' of the exact size. 107 | -> IO (Either Terminate a) 108 | withControlledRecv ctl recvN len action = go 109 | where 110 | go = do 111 | r <- controlledRecv ctl recvN len 112 | case r of 113 | NotEnough -> go 114 | Terminate t -> return $ Left t 115 | NBytes bs -> Right <$> action bs 116 | -------------------------------------------------------------------------------- /dnsext-bowline/bowline/Prometheus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Prometheus where 6 | 7 | import Data.ByteString.Builder 8 | import qualified Data.ByteString.Lazy.Char8 as BL 9 | import GHC.Stats 10 | 11 | toB :: Show a => a -> Builder 12 | toB = lazyByteString . BL.pack . show 13 | 14 | {- FOURMOLU_DISABLE -} 15 | fromRTSStats :: RTSStats -> Builder 16 | fromRTSStats RTSStats{..} = 17 | "ghc_gcs " <> toB gcs <> "\n" 18 | <> "ghc_ghc_major_gcs " <> toB major_gcs <> "\n" 19 | <> "ghc_allocated_bytes " <> toB allocated_bytes <> "\n" 20 | <> "ghc_max_live_bytes " <> toB max_live_bytes <> "\n" 21 | <> "ghc_max_large_objects_bytes " <> toB max_large_objects_bytes <> "\n" 22 | <> "ghc_max_compact_bytes " <> toB max_compact_bytes <> "\n" 23 | <> "ghc_max_slop_bytes " <> toB max_slop_bytes <> "\n" 24 | <> "ghc_max_mem_in_use_bytes " <> toB max_mem_in_use_bytes <> "\n" 25 | <> "ghc_cumulative_live_bytes " <> toB cumulative_live_bytes <> "\n" 26 | <> "ghc_copied_bytes " <> toB copied_bytes <> "\n" 27 | <> "ghc_par_copied_bytes " <> toB par_copied_bytes <> "\n" 28 | <> "ghc_cumulative_par_max_copied_bytes " <> toB cumulative_par_max_copied_bytes <> "\n" 29 | <> "ghc_cumulative_par_balanced_copied_bytes " <> toB cumulative_par_balanced_copied_bytes <> "\n" 30 | <> "ghc_init_cpu_ns " <> toB init_cpu_ns <> "\n" 31 | <> "ghc_init_elapsed_ns " <> toB init_elapsed_ns <> "\n" 32 | <> "ghc_mutator_cpu_ns " <> toB mutator_cpu_ns <> "\n" 33 | <> "ghc_mutator_elapsed_ns " <> toB mutator_elapsed_ns <> "\n" 34 | <> "ghc_gc_cpu_ns " <> toB gc_cpu_ns <> "\n" 35 | <> "ghc_gc_elapsed_ns " <> toB gc_elapsed_ns <> "\n" 36 | <> "ghc_cpu_ns " <> toB cpu_ns <> "\n" 37 | <> "ghc_elapsed_ns " <> toB elapsed_ns <> "\n" 38 | <> "ghc_nonmoving_gc_sync_cpu_ns " <> toB nonmoving_gc_sync_cpu_ns <> "\n" 39 | <> "ghc_nonmoving_gc_sync_elapsed_ns " <> toB nonmoving_gc_sync_elapsed_ns <> "\n" 40 | <> "ghc_nonmoving_gc_sync_max_elapsed_ns " <> toB nonmoving_gc_sync_max_elapsed_ns <> "\n" 41 | <> "ghc_nonmoving_gc_cpu_ns " <> toB nonmoving_gc_cpu_ns <> "\n" 42 | <> "ghc_nonmoving_gc_elapsed_ns " <> toB nonmoving_gc_elapsed_ns <> "\n" 43 | <> "ghc_nonmoving_gc_max_elapsed_ns " <> toB nonmoving_gc_max_elapsed_ns <> "\n" 44 | <> "ghc_gcdetails_gen " <> toB gcdetails_gen <> "\n" 45 | <> "ghc_gcdetails_threads " <> toB gcdetails_threads <> "\n" 46 | <> "ghc_gcdetails_allocated_bytes " <> toB gcdetails_allocated_bytes <> "\n" 47 | <> "ghc_gcdetails_live_bytes " <> toB gcdetails_live_bytes <> "\n" 48 | <> "ghc_gcdetails_large_objects_bytes " <> toB gcdetails_large_objects_bytes <> "\n" 49 | <> "ghc_gcdetails_compact_bytes " <> toB gcdetails_compact_bytes <> "\n" 50 | <> "ghc_gcdetails_slop_bytes " <> toB gcdetails_slop_bytes <> "\n" 51 | <> "ghc_gcdetails_mem_in_use_bytes " <> toB gcdetails_mem_in_use_bytes <> "\n" 52 | <> "ghc_gcdetails_copied_bytes " <> toB gcdetails_copied_bytes <> "\n" 53 | <> "ghc_gcdetails_par_max_copied_bytes " <> toB gcdetails_par_max_copied_bytes <> "\n" 54 | <> "ghc_gcdetails_par_balanced_copied_bytes " <> toB gcdetails_par_balanced_copied_bytes <> "\n" 55 | #if __GLASGOW_HASKELL__ >= 906 56 | <> "ghc_gcdetails_block_fragmentation_bytes " <> toB gcdetails_block_fragmentation_bytes <> "\n" 57 | #endif 58 | <> "ghc_gcdetails_sync_elapsed_ns " <> toB gcdetails_sync_elapsed_ns <> "\n" 59 | <> "ghc_gcdetails_cpu_ns " <> toB gcdetails_cpu_ns <> "\n" 60 | <> "ghc_gcdetails_elapsed_ns " <> toB gcdetails_elapsed_ns <> "\n" 61 | <> "ghc_gcdetails_nonmoving_gc_sync_cpu_ns " <> toB gcdetails_nonmoving_gc_sync_cpu_ns <> "\n" 62 | <> "ghc_gcdetails_nonmoving_gc_sync_elapsed_ns " <> toB gcdetails_nonmoving_gc_sync_elapsed_ns <> "\n" 63 | where 64 | GCDetails{..} = gc 65 | {- FOURMOLU_ENABLE -} 66 | --------------------------------------------------------------------------------