basis/base64/base64.factor

   1 ! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays combinators fry io io.binary io.encodings.binary
   4 io.streams.byte-array kernel literals math namespaces sbufs
   5 sequences ;
   6 IN: base64
   7
   8 ERROR: malformed-base64 ;
   9
  10 <PRIVATE
  11
  12 : read1-ignoring ( ignoring stream -- ch )
  13     dup stream-read1 pick dupd member?
  14     [ drop read1-ignoring ] [ 2nip ] if ; inline recursive
  15
  16 : push-ignoring ( accum ch -- accum )
  17     dup { f 0 } member-eq? [ drop ] [ suffix! ] if ; inline
  18
  19 : read-ignoring ( n ignoring stream -- str/f )
  20     [ [ <sbuf> ] keep ] 2dip
  21     '[ _ _ read1-ignoring push-ignoring ] times
  22     [ f ] [ "" like ] if-empty ; inline
  23
  24 CONSTANT: alphabet
  25     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  26
  27 : alphabet-inverse ( alphabet -- seq )
  28     dup supremum 1 + f <array> [
  29         '[ swap _ set-nth ] each-index
  30     ] keep ;
  31
  32 : ch>base64 ( ch -- ch )
  33     alphabet nth ; inline
  34
  35 : base64>ch ( ch -- ch )
  36     $[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth
  37     [ malformed-base64 ] unless* ; inline
  38
  39 SYMBOL: column
  40
  41 : write1-lines ( column/f ch stream -- column' )
  42     [ stream-write1 ] keep swap [
  43         1 + swap
  44         '[ 76 = [ B{ CHAR: \r CHAR: \n } _ stream-write ] when ]
  45         [ 76 mod ] bi
  46     ] [ drop f ] if* ;
  47
  48 : write-lines ( str -- )
  49     column output-stream get '[
  50         swap [ _ write1-lines ] each
  51     ] change ;
  52
  53 : encode3 ( seq -- )
  54     column output-stream get '[
  55         swap be> { -18 -12 -6 0 } [
  56             shift 0x3f bitand ch>base64 _ write1-lines
  57         ] with each
  58     ] change ; inline
  59
  60 : encode-pad ( seq n -- )
  61     [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
  62     [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
  63
  64 : decode4 ( seq -- )
  65     [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
  66     [ [ CHAR: = = ] count ] bi head-slice*
  67     output-stream get '[ _ stream-write1 ] each ; inline
  68
  69 : (encode-base64) ( stream -- )
  70     3 over stream-read dup length {
  71         { 0 [ 2drop ] }
  72         { 3 [ encode3 (encode-base64) ] }
  73         [ encode-pad (encode-base64) ]
  74     } case ;
  75
  76 PRIVATE>
  77
  78 : encode-base64 ( -- )
  79     input-stream get (encode-base64) ;
  80
  81 : encode-base64-lines ( -- )
  82     0 column [ encode-base64 ] with-variable ;
  83
  84 <PRIVATE
  85
  86 : (decode-base64) ( stream -- )
  87     4 "\n\r" pick read-ignoring dup length {
  88         { 0 [ 2drop ] }
  89         { 4 [ decode4 (decode-base64) ] }
  90         [ malformed-base64 ]
  91     } case ;
  92
  93 PRIVATE>
  94
  95 : decode-base64 ( -- )
  96     input-stream get (decode-base64) ;
  97
  98 : >base64 ( seq -- base64 )
  99     binary [ binary [ encode-base64 ] with-byte-reader ] with-byte-writer ;
 100
 101 : base64> ( base64 -- seq )
 102     binary [ binary [ decode-base64 ] with-byte-reader ] with-byte-writer ;
 103
 104 : >base64-lines ( seq -- base64 )
 105     binary [ binary [ encode-base64-lines ] with-byte-reader ] with-byte-writer ;