! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators io io.binary io.encodings.binary
-io.streams.byte-array io.streams.string kernel math namespaces
-sequences strings io.crlf ;
+! See https://factorcode.org/license.txt for BSD license.
+USING: arrays assocs byte-arrays combinators growable io
+io.encodings.binary io.streams.byte-array kernel kernel.private
+literals math math.bitwise namespaces sbufs sequences
+sequences.private ;
IN: base64
+ERROR: malformed-base64 ;
+
<PRIVATE
-: read1-ignoring ( ignoring -- ch )
- read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
+<<
+CONSTANT: alphabet $[
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+ >byte-array
+]
-: read-ignoring ( ignoring n -- str )
- [ drop read1-ignoring ] with map harvest
- [ f ] [ >string ] if-empty ;
+: alphabet-inverse ( alphabet -- seq )
+ dup maximum 1 + f <array> [
+ '[ swap _ set-nth ] each-index
+ ] keep ;
+>>
: ch>base64 ( ch -- ch )
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
- nth ; inline
+ alphabet nth ; inline
: base64>ch ( ch -- ch )
- {
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f 62 f f f 63 52 53 54 55 56 57 58 59 60 61 f f
- f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
- 22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
- 40 41 42 43 44 45 46 47 48 49 50 51
- } nth ; inline
-
-SYMBOL: column
-
-: write1-lines ( ch -- )
- write1
- column get [
- 1+ [ 76 = [ crlf ] when ]
- [ 76 mod column set ] bi
- ] when* ;
-
-: write-lines ( str -- )
- [ write1-lines ] each ;
-
-: encode3 ( seq -- )
- be> 4 <reversed> [
- -6 * shift HEX: 3f bitand ch>base64 write1-lines
- ] with each ; inline
-
-: encode-pad ( seq n -- )
- [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
- [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
-
-ERROR: malformed-base64 ;
-
-: decode4 ( seq -- )
- [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
- [ [ CHAR: = = ] count ] bi head-slice*
- [ write1 ] each ; inline
+ $[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth
+ [ malformed-base64 ] unless* { fixnum } declare ; inline
+
+: encode3 ( x y z -- a b c d )
+ { fixnum fixnum fixnum } declare {
+ [ [ -2 shift ch>base64 ] [ 2 bits 4 shift ] bi ]
+ [ [ -4 shift bitor ch>base64 ] [ 4 bits 2 shift ] bi ]
+ [ [ -6 shift bitor ch>base64 ] [ 6 bits ch>base64 ] bi ]
+ } spread ; inline
+
+:: (stream-write-lines) ( column data stream -- column' )
+ column data over 71 > [
+ [
+ stream stream-write1 1 + dup 76 = [
+ drop 0
+ B{ CHAR: \r CHAR: \n } stream stream-write
+ ] when
+ ] each
+ ] [
+ stream stream-write 4 +
+ ] if ; inline
+
+: stream-write-lines ( column data stream -- column' )
+ pick [ (stream-write-lines) ] [ stream-write ] if ; inline
+
+: write-lines ( column data -- column' )
+ output-stream get stream-write-lines ; inline
+
+:: (encode-base64) ( input output column -- )
+ 4 <byte-array> :> data
+ column [ input stream-read1 dup ] [
+ input stream-read1
+ input stream-read1
+ [ [ 0 or ] bi@ encode3 ] 2keep [ 0 1 ? ] bi@ + {
+ { 0 [ ] }
+ { 1 [ drop CHAR: = ] }
+ { 2 [ 2drop CHAR: = CHAR: = ] }
+ } case data (4sequence) output stream-write-lines
+ ] while 2drop ; inline
PRIVATE>
: encode-base64 ( -- )
- 3 read dup length {
- { 0 [ drop ] }
- { 3 [ encode3 encode-base64 ] }
- [ encode-pad encode-base64 ]
- } case ;
+ input-stream get output-stream get f (encode-base64) ;
: encode-base64-lines ( -- )
- 0 column [ encode-base64 ] with-variable ;
+ input-stream get output-stream get 0 (encode-base64) ;
+
+<PRIVATE
+
+: read1-ignoring ( ignoring stream -- ch )
+ dup stream-read1 pick dupd member-eq?
+ [ drop read1-ignoring ] [ 2nip ] if ; inline recursive
+
+: read-ignoring ( n ignoring stream -- accum )
+ pick <sbuf> [
+ '[ _ _ read1-ignoring [ ] _ push-when ] times
+ ] keep ;
+
+: decode4 ( a b c d -- x y z )
+ { fixnum fixnum fixnum fixnum } declare {
+ [ base64>ch 2 shift ]
+ [ base64>ch [ -4 shift bitor ] [ 4 bits 4 shift ] bi ]
+ [ base64>ch [ -2 shift bitor ] [ 2 bits 6 shift ] bi ]
+ [ base64>ch bitor ]
+ } spread ; inline
+
+:: (decode-base64) ( input output -- )
+ 3 <byte-array> :> data
+ [ B{ CHAR: \n CHAR: \r } input read1-ignoring ] [
+ B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+ B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+ B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+ [ decode4 data (3sequence) ] 3keep
+ [ CHAR: = eq? 1 0 ? ] tri@ + +
+ [ head-slice* ] unless-zero
+ output stream-write
+ ] while* ;
+
+PRIVATE>
: decode-base64 ( -- )
- "\n\r" 4 read-ignoring dup length {
- { 0 [ drop ] }
- { 4 [ decode4 decode-base64 ] }
- [ malformed-base64 ]
- } case ;
+ input-stream get output-stream get (decode-base64) ;
+
+<PRIVATE
+
+: ensure-encode-length ( base64 -- base64 )
+ dup length 3 /mod zero? [ 1 + ] unless 4 *
+ output-stream get expand ;
+
+: ensure-decode-length ( seq -- seq )
+ dup length 4 /mod zero? [ 1 + ] unless 3 *
+ output-stream get expand ;
+
+PRIVATE>
: >base64 ( seq -- base64 )
- binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
+ binary [
+ ensure-encode-length
+ binary [ encode-base64 ] with-byte-reader
+ ] with-byte-writer ;
: base64> ( base64 -- seq )
- [ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
+ binary [
+ ensure-decode-length
+ binary [ decode-base64 ] with-byte-reader
+ ] with-byte-writer ;
: >base64-lines ( seq -- base64 )
- binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;
+ binary [
+ ensure-encode-length
+ binary [ encode-base64-lines ] with-byte-reader
+ ] with-byte-writer ;
+
+: >urlsafe-base64 ( seq -- base64 )
+ >base64 H{
+ { CHAR: + CHAR: - }
+ { CHAR: / CHAR: _ }
+ } substitute ;
+
+: >urlsafe-base64-jwt ( seq -- base64 )
+ >urlsafe-base64 [ CHAR: = = ] trim-tail ;
+
+: urlsafe-base64> ( base64 -- seq )
+ H{
+ { CHAR: - CHAR: + }
+ { CHAR: _ CHAR: / }
+ } substitute base64> ;
+
+: >urlsafe-base64-lines ( seq -- base64 )
+ >base64-lines H{
+ { CHAR: + CHAR: - }
+ { CHAR: / CHAR: _ }
+ } substitute ;
projects / factor.git / blobdiff