unmaintained: New home for misfit Factor vocabularies.

[factor-unmaintained.git] / dns / resolver / resolver.factor

diff --git a/dns/resolver/resolver.factor b/dns/resolver/resolver.factor
new file mode 100644 (file)
index 0000000..32ad236
--- /dev/null
+++ b/dns/resolver/resolver.factor
@@ -0,0 +1,72 @@
+
+USING: kernel accessors namespaces continuations
+       io io.sockets io.binary io.timeouts io.encodings.binary
+       destructors
+       locals strings sequences random prettyprint calendar dns dns.misc ;
+
+IN: dns.resolver
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: send-receive-udp ( BA SERVER -- ba )
+   T{ inet4 f f 0 } <datagram>
+   T{ duration { second 3 } } over set-timeout
+     [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
+   with-disposal ;
+
+:: send-receive-tcp ( BA SERVER -- ba )
+   [let | BA [ BA length 2 >be BA append ] |
+     SERVER binary
+       [
+         T{ duration { second 3 } } input-stream get set-timeout
+         BA write flush 2 read be> read
+       ]
+     with-client                                        ] ;
+
+:: send-receive-server ( BA SERVER -- msg )
+   [let | RESULT [ BA SERVER send-receive-udp parse-message ] |
+     RESULT tc>> 1 =
+       [ BA SERVER send-receive-tcp parse-message ]
+       [ RESULT                                   ]
+     if                                                 ] ;
+
+: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
+
+:: send-receive-servers ( BA SERVERS -- msg )
+   SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
+   [let | SERVER [ SERVERS random >dns-inet4 ] |
+     ! if this throws an error ...
+     [ BA SERVER send-receive-server ]
+     ! we try with the other servers...
+     [ drop BA SERVER SERVERS remove send-receive-servers ]
+     recover                                            ] ;
+
+:: ask-servers ( MSG SERVERS -- msg )
+   MSG message->ba SERVERS send-receive-servers ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-servers ( -- seq )
+  \ dns-servers get
+    [ ]
+    [ resolv-conf-servers \ dns-servers set dns-servers ]
+  if* ;
+
+! : dns-server ( -- server ) dns-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-ip4 ( name -- ips )
+  fully-qualified
+  [let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
+    MSG rcode>> NO-ERROR =
+      [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
+      [ "dns-ip: rcode = " MSG rcode>> unparse append throw        ]
+    if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+