(**************************************************************************)
(*                                                                        *)
(*  Weasel mail server                                                    *)
(*  Copyright (C) 2024   Peter Moylan                                     *)
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 3 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(*  You should have received a copy of the GNU General Public License     *)
(*  along with this program.  If not, see <http://www.gnu.org/licenses/>. *)
(*                                                                        *)
(*  To contact author:   http://www.pmoylan.org   peter@pmoylan.org       *)
(*                                                                        *)
(**************************************************************************)


IMPLEMENTATION MODULE PassEncrypt;

        (********************************************************)
        (*                                                      *)
        (*           Password encryption/decryption             *)
        (*                                                      *)
        (*   Several algorithms are supported because I have    *)
        (*           not yet decided which one to use           *)
        (*                                                      *)
        (*                                                      *)
        (*  Programmer:         P. Moylan                       *)
        (*  Started:            12 March 2024                   *)
        (*  Last edited:        14 March 2024                   *)
        (*  Status:             Working                         *)
        (*                                                      *)
        (********************************************************)


FROM SYSTEM IMPORT CARD8, ADR;

IMPORT Strings;

FROM RC4 IMPORT
    (* type *)  RC4state,
    (* proc *)  RC4Init, Encrypt, RC4Close;

FROM DES IMPORT
    (* type *)  DEScontext,
    (* proc *)  DESopen, DESEncrypt, DESfinal;

FROM AES IMPORT
    (* type *)  AEScontext,
    (* proc *)  AESopen, AESprocess, AESfinal;

FROM Digests IMPORT
    (* proc *)  DigestToString;

FROM TimeConv IMPORT
    (* proc *)  millisecs;

FROM STextIO IMPORT
    (* proc *)  WriteChar, WriteString, WriteLn;

FROM SIntIO IMPORT
    (* proc *)  WriteCard;

FROM SRealIO IMPORT
    (* proc *)  WriteReal;

FROM LowLevel IMPORT
    (* proc *)  Copy;

(************************************************************************)

TYPE
    KeyType = ARRAY [0..31] OF CARD8;

CONST
    Lpadded = 32;       (* length in bytes of padded pwd *)

TYPE
    PaddedType = ARRAY [0..Lpadded-1] OF CARD8;

VAR
    alg: algorithm;
    Key: ARRAY algorithm OF KeyType;

(************************************************************************)

PROCEDURE HexVal (ch: CHAR):  CARD8;

    (* Convert hex character to binary. *)

    BEGIN
        IF (ch >= '0') AND (ch <= '9') THEN
            RETURN ORD(ch) - ORD('0');
        ELSIF (ch >= 'A') AND (ch <= 'F') THEN
            RETURN ORD(ch) - ORD('A') + 10;
        ELSIF (ch >= 'a') AND (ch <= 'f') THEN
            RETURN ORD(ch) - ORD('a') + 10;
        ELSE
            RETURN 0;
        END (*IF*);
    END HexVal;

(************************************************************************)

PROCEDURE HexToBin (hexdata: ARRAY OF CHAR;  VAR (*OUT*) result: ARRAY OF CARD8);

    VAR j, k: CARDINAL;  val: CARD8;
    BEGIN
        j := 0;  k := 0;
        WHILE j < LENGTH(hexdata) DO
            val := HexVal (hexdata[j]);  INC(j);
            val := 16*val + HexVal (hexdata[j]);  INC(j);
            result[k] := val;  INC(k);
        END (*WHILE*);
    END HexToBin;

(************************************************************************)

PROCEDURE SetKey (alg: algorithm);

    BEGIN
        (*
        CASE alg OF
            |  rc4:     HexToBin ("2b7e151628aed2a6abf7158809cf4f3c", Key[alg]);
            |  des:     HexToBin ("2BD6459F82C5B300", Key[alg]);
            |  des3:    HexToBin ("400000000000000000000000000000008000000000000000", Key[alg]);
            |  aes128:  HexToBin ("2b7e151628aed2a6abf7158809cf4f3c", Key[alg]);
            |  aes192:  HexToBin ("8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b", Key[alg]);
            |  aes256:  HexToBin ("603deb1015ca71be2b73aef0857d7781"
                                    + "1f352c073b6108d72d9810a30914dff4", Key[alg]);
        ELSE
            WriteString ("ERROR, unknown algorithm");
            WriteLn;
        END (*CASE*);
        *)

        (* Actually, we can choose to use the same key for all  *)
        (* algorithms, without loss of security.                *)

        HexToBin ("603deb1015ca71be2b73aef0857d7781"
                          + "1f352c073b6108d72d9810a30914dff4", Key[alg]);

    END SetKey;

(************************************************************************)

PROCEDURE PadPassword (VAR (*IN*) pwd: ARRAY OF CHAR;
                                VAR (*OUT*) padded: ARRAY OF CARD8);

    (* Expand the password out to a fixed length.  *)

    CONST
        padval = 5;             (* padding byte *)

    VAR L: CARDINAL;

    BEGIN
        (* Pad the password out to a fixed length *)

        L := LENGTH (pwd);
        IF L > 32 THEN
            L := 32;
        END(*IF*);
        Copy (ADR(pwd), ADR(padded), L);
        IF L < 32 THEN
            padded[L] := 0;  INC (L);
        END(*IF*);
        WHILE L < 32 DO
            padded[L] := padval;  INC (L);
        END (*WHILE*);

    END PadPassword;

(************************************************************************)

PROCEDURE EncryptPassword (VAR pwd, encrypted: ARRAY OF CHAR);

    (* Encrypt a password.  The result is hex-encoded, therefore    *)
    (* twice the maximum password size.                             *)

    VAR padded: PaddedType;
        digest: ARRAY [0..31] OF CARD8;
        ctx: DEScontext;  actx: AEScontext;  state4: RC4state;
        outpos: CARDINAL;

    BEGIN
        PadPassword (pwd, padded);
        outpos := 0;
        CASE alg OF
            | rc4:
                state4 := RC4Init (0, Key[alg], keylength[alg]);
                Encrypt (state4, Lpadded, padded, digest);
                RC4Close (state4);
            | des, des3:
                ctx := DESopen (FALSE, FALSE, keylength[alg], Key[alg]);
                DESEncrypt (ctx, Lpadded, padded, digest, outpos);
                DESfinal (ctx, digest, outpos);
            | aes128:
                actx := AESopen (FALSE, FALSE, 128, Key[alg]);
                AESprocess (actx, Lpadded, padded, digest, outpos);
                AESfinal (actx, digest, outpos);
            | aes192:
                actx := AESopen (FALSE, FALSE, 192, Key[alg]);
                AESprocess (actx, Lpadded, padded, digest, outpos);
                AESfinal (actx, digest, outpos);
            | aes256:
                actx := AESopen (FALSE, FALSE, 256, Key[alg]);
                AESprocess (actx, Lpadded, padded, digest, outpos);
                AESfinal (actx, digest, outpos);
        ELSE
                WriteString ("ERROR, unknown algorithm");
                WriteLn;
                digest[0] := 0;
        END (*CASE*);
        DigestToString (32, digest, encrypted);

    END EncryptPassword;

(************************************************************************)

PROCEDURE DecryptPassword (VAR encrypted, pwd: ARRAY OF CHAR);

    (* Decrypt a hex-encoded encrypted password. *)

    VAR dctx: DEScontext;
        actx: AEScontext;
        state4: RC4state;
        padded, digest: ARRAY [0..Lpadded-1] OF CARD8;
        outpos: CARDINAL;

    BEGIN
        HexToBin (encrypted, digest);
        outpos := 0;
        CASE alg OF
            | rc4:
                state4 := RC4Init (0, Key[alg], keylength[alg]);
                Encrypt (state4, Lpadded, digest, padded);
                RC4Close (state4);
            | des, des3:
                dctx := DESopen (TRUE, FALSE, keylength[alg], Key[alg]);
                DESEncrypt (dctx, Lpadded, digest, padded, outpos);
                DESfinal (dctx, padded, outpos);
            | aes128:
                actx := AESopen (TRUE, FALSE, 128, Key[alg]);
                AESprocess (actx, Lpadded, digest, padded, outpos);
                AESfinal (actx, padded, outpos);
            | aes192:
                actx := AESopen (TRUE, FALSE, 192, Key[alg]);
                AESprocess (actx, Lpadded, digest, padded, outpos);
                AESfinal (actx, padded, outpos);
            | aes256:
                actx := AESopen (TRUE, FALSE, 256, Key[alg]);
                AESprocess (actx, Lpadded, digest, padded, outpos);
                AESfinal (actx, padded, outpos);
        ELSE
                WriteString ("ERROR, unknown algorithm");
                WriteLn;
        END (*CASE*);
        Copy (ADR(padded), ADR(pwd), Lpadded);
    END DecryptPassword;

(************************************************************************)

PROCEDURE SetAlgorithm (newalg: algorithm);

    (* Specifies the algorithm that will henceforth be used. *)

    BEGIN
        alg := newalg;
        SetKey (alg);
    END SetAlgorithm;

(************************************************************************)

BEGIN
    SetAlgorithm (rc4);
END PassEncrypt.

