basis/ntp/ntp.factor

   1 ! Copyright (C) 2010 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays calendar combinators formatting
   5 io.sockets kernel math pack random sequences ;
   6
   7 IN: ntp
   8
   9 <PRIVATE
  10
  11 CONSTANT: REQUEST B{ 0x1b 0 0 0 0 0 0 0
  12                      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
  13                      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
  14                      0 0 0 0 0 0 0 0 }
  15
  16 : (time) ( sequence -- timestamp )
  17     [ first ] [ second 32 2^ / ] bi + seconds
  18     1900 1 1 0 0 0 instant <timestamp> time+ ;
  19
  20 : (leap) ( leap -- string/f )
  21     {
  22         { 0 [ "no warning" ] }
  23         { 1 [ "last minute has 61 seconds" ] }
  24         { 2 [ "last minute has 59 seconds" ] }
  25         { 3 [ "alarm condition (clock not synchronized)" ] }
  26         [ drop f ]
  27     } case ;
  28
  29 : (mode) ( mode -- string )
  30     {
  31         { 0 [ "unspecified" ] }
  32         { 1 [ "symmetric active" ] }
  33         { 2 [ "symmetric passive" ] }
  34         { 3 [ "client" ] }
  35         { 4 [ "server" ] }
  36         { 5 [ "broadcast" ] }
  37         { 6 [ "reserved for NTP control message" ] }
  38         { 7 [ "reserved for private use" ] }
  39         [ drop f ]
  40     } case ;
  41
  42 : (stratum) ( stratum -- string )
  43     {
  44         { 0 [ "unspecified or unavailable" ] }
  45         { 1 [ "primary reference (e.g., radio clock)" ] }
  46         [
  47             [ 1 > ] [ 255 < ] bi and
  48             [ "secondary reference (via NTP or SNTP)" ]
  49             [ "invalid stratum" throw ] if
  50         ]
  51     } case ;
  52
  53 : (ref-id) ( ref-id stratum -- string )
  54     [
  55         {
  56             [ -24 shift 0xff bitand ]
  57             [ -16 shift 0xff bitand ]
  58             [ -8 shift 0xff bitand ]
  59             [ 0xff bitand ]
  60         } cleave
  61     ] dip {
  62         { 0 [ "%c%c%c%c" sprintf ] }
  63         { 1 [ "%c%c%c%c" sprintf ] }
  64         [
  65             [ 1 > ] [ 255 < ] bi and
  66             [ "%d.%d.%d.%d" sprintf ]
  67             [ "invalid stratum" throw ] if
  68         ]
  69     } case ;
  70
  71 TUPLE: ntp leap version mode stratum poll precision
  72 root-delay root-dispersion ref-id ref-timestamp
  73 orig-timestamp recv-timestamp tx-timestamp ;
  74
  75 : (ntp) ( payload -- ntp )
  76     "CCCcIIIIIIIIIII" unpack-be {
  77         [ first -6 shift 0x3 bitand ]  ! leap
  78         [ first -3 shift 0x7 bitand ]  ! version
  79         [ first 0x7 bitand ]           ! mode
  80         [ second ]                        ! stratum
  81         [ third ]                         ! poll
  82         [ [ 3 ] dip nth ]                 ! precision
  83         [ [ 4 ] dip nth 16 2^ / ]         ! root-delay
  84         [ [ 5 ] dip nth 16 2^ / ]         ! root-dispersion
  85         [ [ 6 ] dip nth ]                 ! ref-id
  86         [ [ { 7 8 } ] dip nths (time) ]   ! ref-timestamp
  87         [ [ { 9 10 } ] dip nths (time) ]  ! orig-timestamp
  88         [ [ { 11 12 } ] dip nths (time) ] ! recv-timestamp
  89         [ [ { 13 14 } ] dip nths (time) ] ! tx-timestamp
  90     } cleave ntp boa
  91     dup stratum>> '[ _ (ref-id) ] change-ref-id
  92     [ dup (leap) 2array ] change-leap
  93     [ dup (mode) 2array ] change-mode
  94     [ dup (stratum) 2array ] change-stratum ;
  95
  96 PRIVATE>
  97
  98 ! TODO:
  99 ! - socket timeout?
 100 ! - format request properly?
 101 ! - strftime should format millis?
 102 ! - why does <inet4> resolve-host not work?
 103
 104 : <ntp> ( host -- ntp )
 105     123 <inet> resolve-host
 106     [ inet4? ] filter random [
 107         [ REQUEST ] 2dip [ send ] [ receive drop ] bi (ntp)
 108     ] with-any-port-local-datagram ;
 109
 110 : default-ntp ( -- ntp )
 111     "pool.ntp.org" <ntp> ;
 112
 113 : local-ntp ( -- ntp )
 114     "localhost" <ntp> ;