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 assocs byte-arrays combinators growable io
   4 io.encodings.binary io.streams.byte-array kernel kernel.private
   5 literals math math.bitwise namespaces sbufs sequences
   6 sequences.private ;
   7 IN: base64
   8
   9 ERROR: malformed-base64 ;
  10
  11 <PRIVATE
  12
  13 <<
  14 CONSTANT: alphabet $[
  15     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  16     >byte-array
  17 ]
  18
  19 : alphabet-inverse ( alphabet -- seq )
  20     dup supremum 1 + f <array> [
  21         '[ swap _ set-nth ] each-index
  22     ] keep ;
  23 >>
  24
  25 : ch>base64 ( ch -- ch )
  26     alphabet nth ; inline
  27
  28 : base64>ch ( ch -- ch )
  29     $[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth
  30     [ malformed-base64 ] unless* { fixnum } declare ; inline
  31
  32 : encode3 ( x y z -- a b c d )
  33     { fixnum fixnum fixnum } declare {
  34         [ [ -2 shift ch>base64 ] [ 2 bits 4 shift ] bi ]
  35         [ [ -4 shift bitor ch>base64 ] [ 4 bits 2 shift ] bi ]
  36         [ [ -6 shift bitor ch>base64 ] [ 6 bits ch>base64 ] bi ]
  37     } spread ; inline
  38
  39 :: (stream-write-lines) ( column data stream -- column' )
  40     column data over 71 > [
  41         [
  42             stream stream-write1 1 + dup 76 = [
  43                 drop 0
  44                 B{ CHAR: \r CHAR: \n } stream stream-write
  45             ] when
  46         ] each
  47     ] [
  48         stream stream-write 4 +
  49     ] if ; inline
  50
  51 : stream-write-lines ( column data stream -- column' )
  52     pick [ (stream-write-lines) ] [ stream-write ] if ; inline
  53
  54 : write-lines ( column data -- column' )
  55     output-stream get stream-write-lines ; inline
  56
  57 :: (encode-base64) ( input output column -- )
  58     4 <byte-array> :> data
  59     column [ input stream-read1 dup ] [
  60         input stream-read1
  61         input stream-read1
  62         [ [ 0 or ] bi@ encode3 ] 2keep [ 0 1 ? ] bi@ + {
  63             { 0 [ ] }
  64             { 1 [ drop CHAR: = ] }
  65             { 2 [ 2drop CHAR: = CHAR: = ] }
  66         } case data (4sequence) output stream-write-lines
  67     ] while 2drop ; inline
  68
  69 PRIVATE>
  70
  71 : encode-base64 ( -- )
  72     input-stream get output-stream get f (encode-base64) ;
  73
  74 : encode-base64-lines ( -- )
  75     input-stream get output-stream get 0 (encode-base64) ;
  76
  77 <PRIVATE
  78
  79 : read1-ignoring ( ignoring stream -- ch )
  80     dup stream-read1 pick dupd member-eq?
  81     [ drop read1-ignoring ] [ 2nip ] if ; inline recursive
  82
  83 : read-ignoring ( n ignoring stream -- accum )
  84     pick <sbuf> [
  85         '[ _ _ read1-ignoring [ ] _ push-if ] times
  86     ] keep ;
  87
  88 : decode4 ( a b c d -- x y z )
  89     { fixnum fixnum fixnum fixnum } declare {
  90         [ base64>ch 2 shift ]
  91         [ base64>ch [ -4 shift bitor ] [ 4 bits 4 shift ] bi ]
  92         [ base64>ch [ -2 shift bitor ] [ 2 bits 6 shift ] bi ]
  93         [ base64>ch bitor ]
  94     } spread ; inline
  95
  96 :: (decode-base64) ( input output -- )
  97     3 <byte-array> :> data
  98     [ B{ CHAR: \n CHAR: \r } input read1-ignoring dup ] [
  99         B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
 100         B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
 101         B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
 102         [ decode4 data (3sequence) ] 3keep
 103         [ CHAR: = eq? 1 0 ? ] tri@ + +
 104         [ head-slice* ] unless-zero
 105         output stream-write
 106     ] while drop ;
 107
 108 PRIVATE>
 109
 110 : decode-base64 ( -- )
 111     input-stream get output-stream get (decode-base64) ;
 112
 113 <PRIVATE
 114
 115 : ensure-encode-length ( base64 -- base64 )
 116     dup length 3 /mod zero? [ 1 + ] unless 4 *
 117     output-stream get expand ;
 118
 119 : ensure-decode-length ( seq -- seq )
 120     dup length 4 /mod zero? [ 1 + ] unless 3 *
 121     output-stream get expand ;
 122
 123 PRIVATE>
 124
 125 : >base64 ( seq -- base64 )
 126     binary [
 127         ensure-encode-length
 128         binary [ encode-base64 ] with-byte-reader
 129     ] with-byte-writer ;
 130
 131 : base64> ( base64 -- seq )
 132     binary [
 133         ensure-decode-length
 134         binary [ decode-base64 ] with-byte-reader
 135     ] with-byte-writer ;
 136
 137 : >base64-lines ( seq -- base64 )
 138     binary [
 139         ensure-encode-length
 140         binary [ encode-base64-lines ] with-byte-reader
 141     ] with-byte-writer ;
 142
 143 : >urlsafe-base64 ( seq -- base64 )
 144     >base64 H{
 145         { CHAR: + CHAR: - }
 146         { CHAR: / CHAR: _ }
 147     } substitute ;
 148
 149 : >urlsafe-base64-jwt ( seq -- base64 )
 150     >urlsafe-base64 [ CHAR: = = ] trim-tail ;
 151
 152 : urlsafe-base64> ( base64 -- seq )
 153     H{
 154         { CHAR: - CHAR: + }
 155         { CHAR: _ CHAR: / }
 156     } substitute base64> ;
 157
 158 : >urlsafe-base64-lines ( seq -- base64 )
 159     >base64-lines H{
 160         { CHAR: + CHAR: - }
 161         { CHAR: / CHAR: _ }
 162     } substitute ;