mercury/extras/base64/base64.m

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%------------------------------------------------------------------------------%
%
% Author: Michel Dehennin <mdh@missioncriticalit.com>
%
% Original C code is public domain code provided by TeX User Group
% http://www.tug.org/ftp/vm/base64-decode.c
% http://www.tug.org/ftp/vm/base64-encode.c
%
% This code is in the public domain.
%
%------------------------------------------------------------------------------%

:- module base64.
:- interface.

:- import_module list.

%------------------------------------------------------------------------------%

    % Encode a string in base64.
    %
:- pred encode64(string::in, string::out) is det.

    % Encodes a list of bytes as a base 64 string.
    % Note this means that the integers must be in the range 0-255.
    % This constraint is not checked.
    %
:- pred encode64_byte_list(list(int)::in, string::out) is det.

    % Decodes a base64 string to clear text.
    % WARNING: If the resulting string contains non-terminating null characters,
    % as in a PDF file for instance, the string is likely to be truncated
    %
:- pred decode64(string::in, string::out) is det.

%------------------------------------------------------------------------------%
%------------------------------------------------------------------------------%

:- implementation.

:- import_module bool.
:- import_module char.
:- import_module exception.
:- import_module float.
:- import_module int.
:- import_module map.
:- import_module require.
:- import_module std_util.
:- import_module string.

%------------------------------------------------------------------------------%

encode64(Data, Base64) :-
    encode64(Data, string.length(Data), Base64).

:- pragma foreign_decl("C", "
#include <string.h>

").

:- pragma foreign_decl("C", local, "

static unsigned char alphabet[64] = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\";

").

:- pred encode64(string::in, int::in, string::out) is det.

:- pragma foreign_proc("C",
    encode64(Data::in, Len::in, Base64::out),
    [will_not_call_mercury, thread_safe, promise_pure, may_not_duplicate],
"
    MR_Word base64_buff;
    char *base64_ptr;

    int cols, bits, c, char_count;
    int i;

    /*
     * Base64 encoded data uses 4:3 times more space than the original string
     * We need to foresee an extra MR_Word for the string terminator character 
     */
    MR_offset_incr_hp_atomic(base64_buff, 0, ((((Len + 2) / 3) * 4) + sizeof(MR_Word)) / sizeof(MR_Word));
    base64_ptr = (char *) base64_buff;  

    char_count = 0;
    bits = 0;
    cols = 0;

    for(i = 0; i < Len; i++) {
        /* need to cast to an unsigned char otherwise we might get negative values */
        c = (unsigned char) Data[i];
        bits += c;

        char_count++;
        if (char_count == 3) {
            *base64_ptr++ = alphabet[bits >> 18];
            *base64_ptr++ = alphabet[(bits >> 12) & 0x3f];
            *base64_ptr++ = alphabet[(bits >> 6) & 0x3f];
            *base64_ptr++ = alphabet[bits & 0x3f];
            
            /* Invalidates the size of allocated memory */
            /*
            cols += 4;
            if (cols == 72) {
                putchar('\n');
                cols = 0;
            }
            */
            bits = 0;
            char_count = 0;
        } else {
            bits <<= 8;
        }
    }
    
    if (char_count != 0) {
        bits <<= 16 - (8 * char_count);
        *base64_ptr++ = alphabet[bits >> 18];
        *base64_ptr++ = alphabet[(bits >> 12) & 0x3f];
        if (char_count == 1) {
            *base64_ptr++ = '=';
            *base64_ptr++ = '=';
        } else {
            *base64_ptr++ = alphabet[(bits >> 6) & 0x3f];
            *base64_ptr++ = '=';
        }
        /*
        if (cols > 0)
            putchar('\n');
        */
    }

    *base64_ptr = '\\0';

    Base64 = (char *) base64_buff;
").

:- pragma foreign_proc("C",
    decode64(Base64::in, Data::out),
    [will_not_call_mercury, thread_safe, promise_pure, may_not_duplicate],
"

    MR_Word data_buff;
    char *data_ptr;

    static char inalphabet[256], decoder[256];
    int i, bits, c, char_count, errors = 0;

    /* 
     * Decoded data uses 3:4 of the space of the Base64 string
     */
    MR_offset_incr_hp_atomic(data_buff, 0, (((strlen(Base64) * 3) / 4) + sizeof(MR_Word)) / sizeof(MR_Word));
    data_ptr = (char *) data_buff;  

    for (i = (sizeof alphabet) - 1; i >= 0 ; i--) {
        inalphabet[alphabet[i]] = 1;
        decoder[alphabet[i]] = i;
    }

    char_count = 0;
    bits = 0;
    for(i = 0; i < strlen(Base64); i++) {
        /* need to cast to an unsigned char otherwise we might get negative values */
        c = (unsigned char) Base64[i];
        if (c == '=')
          break;

        /* Skip invalid characters */
        if (c > 255 || ! inalphabet[c])
          continue;
        
        bits += decoder[c];
        char_count++;
        if (char_count == 4) {
            *data_ptr++ = (bits >> 16);
            *data_ptr++ = ((bits >> 8) & 0xff);
            *data_ptr++ = (bits & 0xff);
            bits = 0;
            char_count = 0;
        } else {
            bits <<= 6;
        }
    }

    if (i == strlen(Base64)) {
        if (char_count) {
            fprintf(stderr, \"base64 encoding incomplete: at least %d bits truncated\",
                ((4 - char_count) * 6));
            errors++;
        }
    } else { /* c == '=' */
        switch (char_count) {
          case 1:
            fprintf(stderr, \"base64 encoding incomplete: at least 2 bits missing\");
            errors++;
            break;
          case 2:
            *data_ptr++ = (bits >> 10);
            break;
          case 3:
            *data_ptr++ = (bits >> 16);
            *data_ptr++ = ((bits >> 8) & 0xff);
            break;
        }
    }

    *data_ptr = '\\0';

    Data = (char *) data_buff;
").

    %
    % We define our own version of map/2 so that we can
    % apply the --optimize-constructor-last-call optimization
    % (this optimization is turned off for the standard
    % library by default).
    %
:- func base64.map(func(X) = Y, list(X)) = list(Y).

base64.map(_, []) =  [].
base64.map(F, [H0 | T0]) = [H | T] :-
    H = F(H0),
    T = base64.map(F, T0).
        
encode64_byte_list(Bytes, Base64) :-
    Chars = base64.map(char.det_from_int, Bytes),
    Length = list.length(Chars),
    String = string.from_char_list(Chars),
    encode64(String, Length, Base64).

%------------------------------------------------------------------------------%
:- end_module base64.
%------------------------------------------------------------------------------%