From 9f93d4bff7eac697bd4269da248ec9a1bfff5886 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Fri, 19 Aug 2011 17:25:10 -0700
Subject: [PATCH] Adding 'ntp' client vocab.

---
 extra/ntp/authors.txt     |   1 +
 extra/ntp/ntp-docs.factor |  13 +++++
 extra/ntp/ntp.factor      | 116 ++++++++++++++++++++++++++++++++++++++
 extra/ntp/summary.txt     |   1 +
 4 files changed, 131 insertions(+)
 create mode 100644 extra/ntp/authors.txt
 create mode 100644 extra/ntp/ntp-docs.factor
 create mode 100644 extra/ntp/ntp.factor
 create mode 100644 extra/ntp/summary.txt

diff --git a/extra/ntp/authors.txt b/extra/ntp/authors.txt
new file mode 100644
index 0000000000..e091bb8164
--- /dev/null
+++ b/extra/ntp/authors.txt
@@ -0,0 +1 @@
+John Benediktsson
diff --git a/extra/ntp/ntp-docs.factor b/extra/ntp/ntp-docs.factor
new file mode 100644
index 0000000000..9fb3090bd5
--- /dev/null
+++ b/extra/ntp/ntp-docs.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.syntax help.markup ntp strings ;
+
+IN: ntp
+
+HELP: <ntp>
+{ $values { "host" string } }
+{ $description
+    "Requests the time from the specified NTP time server."
+} ;
+
diff --git a/extra/ntp/ntp.factor b/extra/ntp/ntp.factor
new file mode 100644
index 0000000000..064d1e1daf
--- /dev/null
+++ b/extra/ntp/ntp.factor
@@ -0,0 +1,116 @@
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays calendar combinators destructors
+fry formatting kernel io io.sockets math pack random
+sequences ;
+
+IN: ntp
+
+<PRIVATE
+
+CONSTANT: REQUEST B{ HEX: 1b 0 0 0 0 0 0 0
+                     0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+                     0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+                     0 0 0 0 0 0 0 0 }
+
+: (time) ( sequence -- timestamp )
+    [ first ] [ second 32 2^ / ] bi + seconds
+    1900 1 1 0 0 0 instant <timestamp> time+ ;
+
+: (leap) ( leap -- string/f )
+    {
+        { 0 [ "no warning" ] }
+        { 1 [ "last minute has 61 seconds" ] }
+        { 2 [ "last minute has 59 seconds" ] }
+        { 3 [ "alarm condition (clock not synchronized)" ] }
+        [ drop f ]
+    } case ;
+
+: (mode) ( mode -- string )
+    {
+        { 0 [ "unspecified" ] }
+        { 1 [ "symmetric active" ] }
+        { 2 [ "symmetric passive" ] }
+        { 3 [ "client" ] }
+        { 4 [ "server" ] }
+        { 5 [ "broadcast" ] }
+        { 6 [ "reserved for NTP control message" ] }
+        { 7 [ "reserved for private use" ] }
+        [ drop f ]
+    } case ;
+
+: (stratum) ( stratum -- string )
+    {
+        { 0 [ "unspecified or unavailable" ] }
+        { 1 [ "primary reference (e.g., radio clock)" ] }
+        [
+            [ 1 > ] [ 255 < ] bi and
+            [ "secondary reference (via NTP or SNTP)" ]
+            [ "invalid stratum" throw ] if
+        ]
+    } case ;
+
+: (ref-id) ( ref-id stratum -- string )
+    [
+        {
+            [ -24 shift HEX: ff bitand ]
+            [ -16 shift HEX: ff bitand ]
+            [ -8 shift HEX: ff bitand ]
+            [ HEX: ff bitand ]
+        } cleave
+    ] dip {
+        { 0 [ "%c%c%c%c" sprintf ] }
+        { 1 [ "%c%c%c%c" sprintf ] }
+        [
+            [ 1 > ] [ 255 < ] bi and
+            [ "%d.%d.%d.%d" sprintf ]
+            [ "invalid stratum" throw ] if
+        ]
+    } case ;
+
+TUPLE: ntp leap version mode stratum poll precision
+root-delay root-dispersion ref-id ref-timestamp
+orig-timestamp recv-timestamp tx-timestamp ;
+
+: (ntp) ( payload -- ntp )
+    "CCCcIIIIIIIIIII" unpack-be {
+        [ first -6 shift HEX: 3 bitand ]  ! leap
+        [ first -3 shift HEX: 7 bitand ]  ! version
+        [ first HEX: 7 bitand ]           ! mode
+        [ second ]                        ! stratum
+        [ third ]                         ! poll
+        [ [ 3 ] dip nth ]                 ! precision
+        [ [ 4 ] dip nth 16 2^ / ]         ! root-delay
+        [ [ 5 ] dip nth 16 2^ / ]         ! root-dispersion
+        [ [ 6 ] dip nth ]                 ! ref-id
+        [ [ { 7 8 } ] dip nths (time) ]   ! ref-timestamp
+        [ [ { 9 10 } ] dip nths (time) ]  ! orig-timestamp
+        [ [ { 11 12 } ] dip nths (time) ] ! recv-timestamp
+        [ [ { 13 14 } ] dip nths (time) ] ! tx-timestamp 
+    } cleave ntp boa
+    dup stratum>> '[ _ (ref-id) ] change-ref-id
+    [ dup (leap) 2array ] change-leap
+    [ dup (mode) 2array ] change-mode
+    [ dup (stratum) 2array ] change-stratum ;
+
+PRIVATE>
+
+! TODO:
+! - socket timeout?
+! - format request properly?
+! - strftime should format millis?
+! - why does <inet4> resolve-host not work?
+
+: <ntp> ( host -- ntp )
+    123 <inet> resolve-host [ inet4? ] filter random
+    f 0 <inet4> <datagram> [
+        [ REQUEST ] 2dip [ send ] [ receive drop ] bi (ntp)
+    ] with-disposal ;
+
+: default-ntp ( -- ntp )
+    "pool.ntp.org" <ntp> ;
+
+: local-ntp ( -- ntp )
+    "localhost" <ntp> ;
+
diff --git a/extra/ntp/summary.txt b/extra/ntp/summary.txt
new file mode 100644
index 0000000000..b70772b4d9
--- /dev/null
+++ b/extra/ntp/summary.txt
@@ -0,0 +1 @@
+Client for NTP protocol