basis/ip-parser/ip-parser.factor

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