basis/ip-parser/ip-parser.factor

   1 ! Copyright (C) 2012-2014 John Benediktsson
   2 ! See https://factorcode.org/license.txt for BSD license
   3
   4 USING: arrays byte-arrays combinators combinators.short-circuit
   5 endian grouping kernel math math.bitwise math.parser regexp
   6 sequences splitting ;
   7
   8 IN: ip-parser
   9
  10 ERROR: malformed-ipv4 string ;
  11
  12 ERROR: malformed-ipv6 string ;
  13
  14 ERROR: bad-ipv4-component string ;
  15
  16 <PRIVATE
  17
  18 : octal? ( str -- ? )
  19     { [ "0" = not ] [ "0" head? ] [ "0x" head? not ] } 1&& ;
  20
  21 : ipv4-component ( str -- n )
  22     dup dup octal? [ oct> ] [ string>number ] if
  23     [ ] [ bad-ipv4-component ] ?if-old ;
  24
  25 : split-ipv4 ( str -- array )
  26     "." split [ ipv4-component ] map ;
  27
  28 : bubble ( array -- newarray )
  29     reverse 0 swap [ + 256 /mod ] map reverse nip ;
  30
  31 : ?bubble ( array -- array )
  32     dup [ 255 > ] any? [ bubble ] when ;
  33
  34 : join-ipv4 ( array -- str )
  35     [ number>string ] { } map-as "." join ;
  36
  37 PRIVATE>
  38
  39 : parse-ipv4 ( str -- byte-array )
  40     dup split-ipv4 dup length {
  41         { 1 [ { 0 0 0 } prepend ] }
  42         { 2 [ 1 cut { 0 0 } glue ] }
  43         { 3 [ 2 cut { 0 } glue ] }
  44         { 4 [ ] }
  45         [ 2drop malformed-ipv4 ]
  46     } case ?bubble nip B{ } like ; inline
  47
  48 : normalize-ipv4 ( str -- newstr )
  49     parse-ipv4 join-ipv4 ;
  50
  51 : ipv4-ntoa ( integer -- ip )
  52     { -24 -16 -8 0 } [ 8 shift-mod ] with map join-ipv4 ;
  53
  54 : ipv4-aton ( ip -- integer )
  55     parse-ipv4 { 24 16 8 0 } [ shift ] [ + ] 2map-reduce ;
  56
  57 ERROR: bad-ipv6-component obj ;
  58
  59 ERROR: bad-ipv4-embedded-prefix obj ;
  60
  61 ERROR: more-than-8-components ;
  62
  63 <PRIVATE
  64
  65 : ipv6-component ( str -- n )
  66     dup hex> [ ] [ bad-ipv6-component ] ?if-old ;
  67
  68 : split-ipv6 ( string -- seq )
  69     ":" split CHAR: . over last member? [ unclip-last ] [ f ] if
  70     [ [ ipv6-component ] map ]
  71     [ [ parse-ipv4 append ] unless-empty ] bi* ;
  72
  73 : pad-ipv6 ( string1 string2 -- seq )
  74     2dup 2length + 8 swap -
  75     dup 0 < [ more-than-8-components ] when
  76     <byte-array> glue ;
  77
  78 PRIVATE>
  79
  80 : parse-ipv6 ( string -- seq )
  81     "::" split1 [ [ f ] [ split-ipv6 ] if-empty ] bi@ pad-ipv6 ;
  82
  83 : ipv6-ntoa ( integer -- ip )
  84     16 >be bytes>hex-string 4 <groups>
  85     [ [ CHAR: 0 = ] trim-head ] map ":" join
  86     R/ [:][:]+/ "::" re-replace ;
  87
  88 : ipv6-aton ( ip -- integer )
  89     parse-ipv6 0 [ [ 16 shift ] [ + ] bi* ] reduce ;