extra/base32/base32.factor

   1 ! Copyright (C) 2019 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: base64.private byte-arrays combinators endian io
   4 io.encodings.binary io.streams.byte-array kernel kernel.private
   5 literals math namespaces sequences ;
   6 IN: base32
   7
   8 ERROR: malformed-base32 ;
   9
  10 ! XXX: Optional map 0 as O
  11 ! XXX: Optional map 1 as L or I
  12 ! XXX: Optional handle lower-case input
  13
  14 <PRIVATE
  15
  16 <<
  17 CONSTANT: alphabet $[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" >byte-array ]
  18 >>
  19
  20 : ch>base32 ( ch -- ch )
  21     alphabet nth ; inline
  22
  23 : base32>ch ( ch -- ch )
  24     $[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth
  25     [ malformed-base32 ] unless* { fixnum } declare ; inline
  26
  27 : encode5 ( seq -- byte-array )
  28     be> { -35 -30 -25 -20 -15 -10 -5 0 } '[
  29         shift 0x1f bitand ch>base32
  30     ] with B{ } map-as ; inline
  31
  32 : encode-pad ( seq n -- byte-array )
  33     [ 5 0 pad-tail encode5 ] [ B{ 0 2 4 5 7 } nth ] bi* head-slice
  34     8 CHAR: = pad-tail ; inline
  35
  36 : (encode-base32) ( stream column -- )
  37     5 pick stream-read dup length {
  38         { 0 [ 3drop ] }
  39         { 5 [ encode5 write-lines (encode-base32) ] }
  40         [ encode-pad write-lines (encode-base32) ]
  41     } case ;
  42
  43 PRIVATE>
  44
  45 : encode-base32 ( -- )
  46     input-stream get f (encode-base32) ;
  47
  48 : encode-base32-lines ( -- )
  49     input-stream get 0 (encode-base32) ;
  50
  51 <PRIVATE
  52
  53 : decode8 ( seq -- )
  54     [ 0 [ base32>ch swap 5 shift bitor ] reduce 5 >be ]
  55     [ [ CHAR: = = ] count ] bi
  56     [ write ] [ B{ 0 4 0 3 2 0 1 } nth head-slice write ] if-zero ; inline
  57
  58 : (decode-base32) ( stream -- )
  59     8 "\n\r" pick read-ignoring dup length {
  60         { 0 [ 2drop ] }
  61         { 8 [ decode8 (decode-base32) ] }
  62         [ drop 8 CHAR: = pad-tail decode8 (decode-base32) ]
  63     } case ;
  64
  65 PRIVATE>
  66
  67 : decode-base32 ( -- )
  68     input-stream get (decode-base32) ;
  69
  70 : >base32 ( seq -- base32 )
  71     binary [ binary [ encode-base32 ] with-byte-reader ] with-byte-writer ;
  72
  73 : base32> ( base32 -- seq )
  74     binary [ binary [ decode-base32 ] with-byte-reader ] with-byte-writer ;
  75
  76 : >base32-lines ( seq -- base32 )
  77     binary [ binary [ encode-base32-lines ] with-byte-reader ] with-byte-writer ;