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