(**************************************************************************)
(*                                                                        *)
(*  Transport Layer Security                                              *)
(*  Copyright (C) 2025   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 TLSRecord;

        (********************************************************)
        (*                                                      *)
        (*                The TLS record protocol               *)
        (*                                                      *)
        (*  Programmer:         P. Moylan                       *)
        (*  Started:            4 July 2023                     *)
        (*  Last edited:        22 November 2025                *)
        (*  Status:             OK                              *)
        (*                                                      *)
        (********************************************************)

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

FROM SYSTEM IMPORT CARD8, CARD16, ADR, LOC, CAST;

IMPORT Strings;

FROM TLSBase IMPORT
    (* type *)  TextType,
    (* proc *)  NYI, DiscardFragment, AppendHexString;

FROM TLSCompression IMPORT
    (* type *)  CompressionMethod,
    (* proc *)  Compress, Decompress;

FROM TLSHMAC IMPORT
    (* const*)  MaxHMACSize,
    (* type *)  HMACType,
    (* proc *)  AppendHMACName, HMAClength, HMACkeylength, ComputeHMac;

FROM TLSCrypt IMPORT
    (* const*)  MaxBlockSize,
    (* type *)  BulkCipherAlgorithm, EncrRule,
    (* proc *)  InitEncryptionRule, SetEncryption, CloseEncryptionRule,
                Encrypt, Decrypt, AppendCipherName;

FROM Sockets IMPORT
    (* type *)  Socket,
    (* proc *)  send, recv, sock_errno;

FROM VarStrings IMPORT
    (* type *)  ByteStringPtr;

FROM Arith64 IMPORT
    (* type *)  CARD64LE,
    (* const*)  Zero64LE,
    (* proc *)  INC64LE;

FROM MiscFuncs IMPORT
    (* proc *)  Swap2, Swap4, AppendCard, AppendHex2;

FROM LowLevel IMPORT
    (* proc *)  Copy, AddOffset;

FROM TransLog IMPORT
    (* type *)  TransactionLogID,
    (* proc *)  LogTransaction, LogTransactionL;

FROM Alloc IMPORT
    (* proc *)  ALLOCATE, DEALLOCATE;

(* FOR DEBUGGING ONLY *)

IMPORT FileOps;

FROM FileOps IMPORT
    (* proc *)  FWriteString, FWriteLn;

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

TYPE
    Direction = (in, out);

    RLState = POINTER TO
                RECORD
                    server: BOOLEAN;
                    logID: TransactionLogID;
                    MaxSize: CARDINAL;
                    sock: Socket;
                    param: ARRAY Direction OF
                                RECORD
                                    seqnum: CARD64LE;
                                    compression: CompressionMethod;
                                    mac: HMACType;
                                    mackeylength: CARDINAL;
                                    maclength: CARDINAL;
                                    mackey: ARRAY [0..63] OF CARD8;
                                    cipher: BulkCipherAlgorithm;
                                    IV: ARRAY [0..MaxBlockSize-1] OF CARD8;
                                    rule: EncrRule;
                                    cipherchange: BOOLEAN;
                                END (*RECORD*)
                END (*RECORD*);

(************************************************************************)
(*                            DEBUGGING STUFF                           *)
(************************************************************************)

PROCEDURE RecordTraceOn;

    (* For testing/debugging.  Logs data sent or received until         *)
    (* RecordTraceOff is called.  This is a module-wide setting rather  *)
    (* that being specific to one thread, so it can be used only for    *)
    (* simple tests.  (And should probably be deleted in the long run.) *)

    BEGIN
        (*NYI ("RecordTraceOn");*)
    END RecordTraceOn;

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

PROCEDURE RecordTraceOff;

    (* Stops logging of data sent or received.  *)

    BEGIN
        (*NYI ("RecordTraceOff");*)
    END RecordTraceOff;

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

PROCEDURE FirstNBytes (logID: TransactionLogID;  prefix: ARRAY OF CHAR;
                                        buffer: TextType;  N: CARDINAL);

    (* Writes out the first N bytes of buffer, including the header. *)

    BEGIN
        NYI (logID, "FirstNBytes");
    END FirstNBytes;

(************************************************************************)
(*                        KEYS AND MAC COMPUTATION                      *)
(************************************************************************)

PROCEDURE SetCipher (sess: RLState;  server_write, truncate_MAC: BOOLEAN;
                newcipher: BulkCipherAlgorithm;  newmac: HMACType;
                    MACKey: ARRAY OF CARD8;  MACKeyLength: CARDINAL;
                    cryptKey: ARRAY OF CARD8;  cryptKeyLength: CARDINAL;
                    newIV: ARRAY OF CARD8;  IVlength: CARDINAL);

    (* Sets cipher and keys for one direction.  *)

    TYPE labeltype = ARRAY Direction OF ARRAY [0..7] OF CHAR;

    CONST label = labeltype {"input", "output"};

    VAR d: Direction;
        message: ARRAY [0..79] OF CHAR;

    BEGIN
        IF server_write = sess^.server THEN d := out
        ELSE d := in;
        END (*IF*);
        WITH sess^.param[d] DO
            cipher := newcipher;
            mac := newmac;
            maclength := HMAClength (newmac);
            IF truncate_MAC AND (maclength > 10) THEN
                maclength := 10;
            END (*IF*);
            mackeylength := MACKeyLength;
            IF MACKeyLength > 0 THEN
                Copy (ADR(MACKey), ADR(mackey), MACKeyLength);
            END (*IF*);
            IF IVlength > 0 THEN
                Copy (ADR(newIV), ADR(IV), IVlength);
            END (*IF*);
            CloseEncryptionRule (rule);
            seqnum := Zero64LE;
            SetEncryption (rule, newcipher, cryptKey, cryptKeyLength);
            cipherchange := TRUE;
        END (*WITH*);

        message := "Switched to ";
        Strings.Append (label[d], message);
        Strings.Append (" cipher ", message);
        AppendCipherName (newcipher, message);
        Strings.Append ("/", message);
        AppendHMACName (newmac, message);
        LogTransaction (sess^.logID, message);

    END SetCipher;

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

PROCEDURE GenerateMAC (sess: RLState;  d: Direction;  buffer: TextType;
                            VAR (*OUT*) result: ARRAY OF CARD8;
                            debug: BOOLEAN);

    (* The input to the MAC computation is the concatenation of         *)
    (* sequence number, type, version, length, and buffer.fragment.     *)

    (* The input data to the MAC algorithm has a sequence       *)
    (* number prepended to buffer, and the HMAC algorithms do   *)
    (* not allow the data to be supplied in sections.  For now  *)
    (* the only solution I see is to make a copy of the data    *)
    (* to be processed.  My HMACG would allow the data be fed   *)
    (* in in parts, but there's point in tampering with code    *)
    (* that is now working.                                     *)

    VAR p, q: ByteStringPtr;
        input: TextType;
        N, N2, size: CARDINAL;
        message: ARRAY [0..255] OF CHAR;

    BEGIN
        IF sess^.param[d].mac <> nullhmac THEN

            (* Create a new buffer with the input to the MAC calculation.   *)

            input := buffer;
            size := Swap2 (buffer.length);
            N2 := size + 8 + 5;
            ALLOCATE (p, N2);

            (* Copy sequence number. *)

            N := Swap4 (sess^.param[d].seqnum.high);
            Copy (ADR(N), p, 4);
            q := AddOffset (p, 4);
            N := Swap4 (sess^.param[d].seqnum.low);
            Copy (ADR(N), q, 4);
            q := AddOffset (q, 4);

            (* Copy the five header bytes. *)

            Copy (ADR(buffer), q, 5);
            q := AddOffset (q, 5);

            (* Finally the data fragment. *)

            Copy (buffer.fragment, q, size);

            IF debug THEN
                message := "Data for ";
                IF d = in THEN
                    Strings.Append (" inbound", message);
                ELSE
                    Strings.Append ("outbound", message);
                END (*IF*);
                Strings.Append (" MAC calculation: ", message);
                AppendHexString (p^, 0, N2, TRUE, message);
                LogTransaction (sess^.logID, message);
            END (*IF*);

            (* Now the MAC computation. *)

            ComputeHMac (sess^.param[d].mac, sess^.param[d].mackey,
                                sess^.param[d].mackeylength, p, N2,
                                 result, sess^.param[d].maclength);

            (* Discard the temporary data. *)

            DEALLOCATE (p, N2);
        END (*IF*);
    END GenerateMAC;

(************************************************************************)
(*                              OPEN/CLOSE                              *)
(************************************************************************)

PROCEDURE TLSRecordInit (S: Socket;  server: BOOLEAN;
                            logID: TransactionLogID): RLState;

    (* Initialises the record layer state for a TLS session. *)

    VAR sess: RLState;
        d: Direction;

    BEGIN
        NEW (sess);
        sess^.server := server;
        sess^.logID := logID;
        sess^.MaxSize := 16384;
        sess^.sock := S;
        FOR d := in TO out DO
            WITH sess^.param[d] DO
                seqnum := Zero64LE;
                compression := nocompression;
                mac := nullhmac;
                maclength := 0;
                cipher := nocipher;
                InitEncryptionRule(rule);
                cipherchange := FALSE;
            END (*WITH*);
        END (*FOR*);
        RETURN sess;
    END TLSRecordInit;

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

PROCEDURE TLSRecordClose (VAR (*INOUT*) sess: RLState);

    (* Closes this record layer state. *)

    BEGIN
        CloseEncryptionRule (sess^.param[in].rule);
        CloseEncryptionRule (sess^.param[out].rule);
        DISPOSE (sess);
    END TLSRecordClose;

(************************************************************************)
(*                                INPUT                                 *)
(************************************************************************)

PROCEDURE validtype (type: CARD8): BOOLEAN;

    (* Returns TRUE iff type is a valid TLS record type. *)

    BEGIN
        RETURN (type >= 20) AND (type <= 23);
    END validtype;

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

PROCEDURE LogFaultyData (sess: RLState;  N: CARDINAL;
                                        VAR (*IN*) data: ARRAY OF LOC);

    (* Logs N bytes of the data array.  Special case: if N = 5, we      *)
    (* log some extra bytes if they can be received.                    *)

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

    PROCEDURE Logem (N: CARDINAL;  VAR (*IN*) buf: ARRAY OF LOC);

        CONST bytesperline = 15;

        VAR togo, j, amount: CARDINAL;
            message: ARRAY [0..63] OF CHAR;

        BEGIN
            togo := N;
            j := 0;
            WHILE togo > 0 DO
                IF togo > bytesperline THEN
                    amount := bytesperline;
                ELSE
                    amount := togo;
                END (*IF*);
                DEC (togo, amount);
                message := "";
                WHILE amount > 0 DO
                    Strings.Append (' ', message);
                    AppendHex2 (CAST(CARD8, buf[j]), message);
                    INC (j);  DEC(amount);
                END (*WHILE*);
                LogTransaction (sess^.logID, message);
            END (*WHILE*)
        END Logem;

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

    CONST extrabufsize = 100;

    VAR k: CARDINAL;
        extrabuf: ARRAY [0..extrabufsize-1] OF CARD8;
        message: ARRAY [0..63] OF CHAR;

    BEGIN
        Logem (N, data);
        IF N = 5 THEN
            k := recv (sess^.sock, extrabuf, extrabufsize, 0);
            IF k = MAX(CARDINAL) THEN
                LogTransactionL (sess^.logID, "recv() failed");
            ELSIF k= 0 THEN
                LogTransactionL (sess^.logID, "recv() returned no data");
            ELSE
                message := "recv() returned ";
                AppendCard (k, message);
                Strings.Append (" bytes", message);
                LogTransaction (sess^.logID, message);
                Logem (k, extrabuf);
            END (*IF*);
        END (*IF*);
    END LogFaultyData;

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

PROCEDURE Append_sock_errno (VAR (*INOUT*) message: ARRAY OF CHAR);

    (* The numbers are taken from os2tk45\h\nerrno.h  *)
    VAR N: CARDINAL;
        name: ARRAY [0..31] OF CHAR;

    BEGIN
        N :=sock_errno ();
        name := "";
        CASE N OF
            |   10004:  name := "SOCEINTR";
            |   10014:  name := "SOCEFAULT";
            |   10022:  name := "SOCEINVAL";
            |   10035:  name := "SOCEWOULDBLOCK";
            |   10038:  name := "SOCENOTSOCK";
            |   10054:  name := "SOCECONNRESET";    (* connection reset by peer *)
        ELSE
            AppendCard (N, name);
        END (*IF*);
        Strings.Append (name, message);
    END Append_sock_errno;

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

PROCEDURE GetFragment (sess: RLState;  logID: TransactionLogID;
                            VAR (*OUT*) buffer: TextType;
                            VAR (*OUT*) ConnectionLost: BOOLEAN): BOOLEAN;

    (* Receives one record from the sender, in raw form.  It is up to   *)
    (* the caller to work out what to do with this record.              *)

    (* NOTE: We store buffer.length in BigEndian format.    *)

    VAR mac, newmac: ARRAY [0..MaxHMACSize-1] OF CARD8;
        k: CARDINAL;
        total: CARD16;
        N: CARDINAL;
        p: ByteStringPtr;
        match, success: BOOLEAN;
        message: ARRAY [0..127] OF CHAR;

    BEGIN
        ConnectionLost := FALSE;  success := TRUE;
        buffer.fragment := NIL;

        (* Get first 5 bytes of the input.  *)

        N := recv (sess^.sock, buffer, 5, 0);
        IF N = MAX(CARDINAL) THEN
            message := "recv{} returned -1, sock_errno = ";
            Append_sock_errno (message);
            LogTransaction (sess^.logID, message);
            success := FALSE;
        ELSIF N = 0 THEN
            message := "recv{} returned no data, sock_errno = ";
            Append_sock_errno (message);
            LogTransaction (sess^.logID, message);
            success := FALSE;
        ELSIF N < 5 THEN
            message := "recv{} returned only ";  AppendCard (N, message);
            Strings.Append (" of 5 header bytes, sock_errno = ", message);
            Append_sock_errno (message);
            LogTransaction (sess^.logID, message);
            ConnectionLost := TRUE;
            buffer.length := 0;
            success := FALSE;
            RETURN FALSE;
        ELSIF NOT validtype (buffer.contenttype) THEN
            LogTransactionL (sess^.logID, "invalid values in header");
            LogFaultyData (sess, 5, buffer);
            success := FALSE;
        END (*IF*);

        (* Check length for plausibility. *)

        IF success THEN
            N := Swap2(buffer.length);
            IF N > 16384 + 2048 THEN
                LogTransactionL (sess^.logID, "Fragment length error");
                message := "Header claims length is ";
                AppendCard (N, message);
                LogTransaction (sess^.logID, message);
                LogFaultyData (sess, 5, buffer);
                success := FALSE;
            END (*IF*);
        END (*IF*);

        IF NOT success THEN
            ConnectionLost := TRUE;
            buffer.length := 0;
            RETURN FALSE;
        END (*IF*);

        (* Now get the main part. *)

        ALLOCATE (buffer.fragment, N);
        IF buffer.fragment = NIL THEN
            RETURN FALSE;
        END (*IF*);
        total := 0;
        REPEAT
            p := ADR(buffer.fragment^[total]);
            k := recv (sess^.sock, p^, N-total, 0);
            IF k = MAX(CARDINAL) THEN ConnectionLost := TRUE;
            ELSE INC (total, k);
            END (*IF*);
        UNTIL ConnectionLost OR (total >= N);
        IF ConnectionLost THEN
            LogTransactionL (sess^.logID, "Did not receive fragment body");
            message := "type=";  AppendCard (buffer.contenttype, message);
            Strings.Append (", length=", message);  AppendCard (Swap2(buffer.length), message);
            Strings.Append (", ", message);  AppendCard (total, message);
            Strings.Append (" bytes received", message);
            LogTransaction (sess^.logID, message);
            DEALLOCATE (buffer.fragment, N);
            buffer.length := 0;
            RETURN FALSE;
        END (*IF*);

        (* Do the decryption. *)

        IF sess^.param[in].cipherchange THEN
            LogTransactionL (sess^.logID, "Received first enciphered fragment");
            sess^.param[in].cipherchange := FALSE;
        END (*F*);
        success := Decrypt (sess^.param[in].rule, logID, buffer, mac,
                                    sess^.param[in].maclength);

        IF success THEN
            (* Check the mac. *)

            IF sess^.param[in].maclength > 0 THEN
                GenerateMAC (sess, in, buffer, newmac, FALSE);
                match := TRUE;
                FOR k := 0 TO sess^.param[in].maclength-1 DO
                    match := match AND (mac[k] = newmac[k]);
                END (*FOR*);
                IF NOT match THEN
                    LogTransactionL (sess^.logID, "MAC mismatch in input");
                    success := FALSE;
                END (*IF*);
            END (*IF*);

            Decompress (sess^.param[in].compression, buffer);

            IF buffer.length = 0 THEN
                LogTransactionL (sess^.logID, "Empty fragment received");
            END (*IF*);
        END (*IF*);

        INC64LE (sess^.param[in].seqnum);

        RETURN success;
    END GetFragment;

(************************************************************************)
(*                              OUTPUT                                  *)
(************************************************************************)

CONST DUMP = FALSE;

VAR dump: FileOps.ChanId;
    enabledump: BOOLEAN;

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

PROCEDURE PutSmallFragment (sess: RLState;  logID: TransactionLogID;
                            VAR (*IN*) buffer: TextType): BOOLEAN;

    (* Sends buffer to the recipient.  This includes any necessary      *)
    (* encryption and compression.  The data in buffer^.fragment, a     *)
    (* TLSPlainText record, is then discarded.                          *)

    (* NOTE: The caller must use BigEndian format for buffer.length.    *)

    VAR mac: ARRAY [0..MaxHMACSize-1] OF CARD8;
        k, length: CARDINAL;  success: BOOLEAN;
        p: ByteStringPtr;
        dumpmessage: ARRAY [0..1023] OF CHAR;

    CONST JOINPARTS = TRUE;

    BEGIN
        IF (buffer.majversion <> 3) OR (buffer.minversion <> 3) THEN
            LogTransactionL (logID, "version error in PutFragment");
            HALT;
        END (*IF*);

        (* First do compression and MAC calculation.  *)

        success := TRUE;
        Compress (sess^.param[out].compression, buffer);
        GenerateMAC (sess, out, buffer, mac, FALSE);

        IF DUMP AND enabledump AND (sess^.param[out].cipher <> nocipher) THEN
            FWriteString (dump, "Original message"); FWriteLn (dump);
            length := Swap2(buffer.length);
            dumpmessage := "";
            AppendHexString (buffer.fragment^, 0, length, TRUE, dumpmessage);
            FWriteString (dump, dumpmessage);
            FWriteLn (dump);
        END (*IF*);

        (* Now the encryption.  This includes adding the MAC and padding. *)

        Encrypt (sess^.param[out].rule, logID, buffer, mac,
                                sess^.param[out].maclength);

        (* Send buffer, including its header.*)

        length := Swap2(buffer.length);
        IF JOINPARTS THEN
            (* This is an experimental version where we copy the header *)
            (* and fragment into a single byte string, to avoid using   *)
            (* two separate send() calls.                               *)

            ALLOCATE (p, length + 5);
            Copy (ADR(buffer), p, 5);
            Copy (buffer.fragment, ADR(p^[5]), length);
            k := send (sess^.sock, p^, length + 5, 0);
            IF k <> length + 5 THEN
                success := FALSE;
                LogTransactionL (sess^.logID, "Not all body output sent");
            END (*IF*);
            DEALLOCATE (p, length + 5);
        ELSE
            k := send (sess^.sock, buffer, 5, 0);
            IF k <> 5 THEN
                LogTransactionL (sess^.logID, "Not all header output sent");
            END (*IF*);

            k := send (sess^.sock, buffer.fragment^, length, 0);
            IF k <> length THEN
                success := FALSE;
                LogTransactionL (sess^.logID, "Not all body output sent");
            END (*IF*);
        END (*IF*);

        DiscardFragment (buffer);

        INC64LE (sess^.param[out].seqnum);
        RETURN success;

    END PutSmallFragment;

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

PROCEDURE PutFragment (sess: RLState;  logID: TransactionLogID;
                            VAR (*IN*) buffer: TextType): BOOLEAN;

    (* Sends buffer to the recipient.  This includes any necessary      *)
    (* encryption and compression.  The data in buffer.fragment, a      *)
    (* TLSPlainText record, is then discarded.                          *)

    (* Breaks up the fragment into smaller fragments if needed because  *)
    (* of fragment size restrictions.                                   *)

    VAR size, max: CARD16;  success: BOOLEAN;
        p, q: ByteStringPtr;
        buffer2: TextType;

    BEGIN
        size := Swap2 (buffer.length);
        max := sess^.MaxSize;
        success := TRUE;
        WHILE success AND (size > max) DO
            buffer2 := buffer;
            ALLOCATE (p, max);
            DEC (size, max);
            ALLOCATE (q, size);
            Copy (buffer.fragment, p, max);
            Copy (ADR(buffer.fragment^[max]), q, size);
            DEALLOCATE (buffer.fragment, max + size);
            buffer.fragment := q;
            buffer.length := Swap2 (size);
            buffer2.fragment := p;
            buffer2.length := Swap2 (max);
            success := PutSmallFragment (sess, logID, buffer2);
        END (*WHILE*);

        (* Now send the remainder, unless it is empty. *)

        IF success AND (size > 0) THEN
            success := PutSmallFragment (sess, logID, buffer);
        END (*IF*);

        RETURN success;

    END PutFragment;

(************************************************************************)
(*                            DEBUGGING STUFF                           *)
(************************************************************************)

PROCEDURE DumpOn;

    BEGIN
        enabledump := TRUE;
    END DumpOn;

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

PROCEDURE DumpOff;

    BEGIN
        enabledump := FALSE;
    END DumpOff;

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

CONST dumpname = "DUMP.TXT";

BEGIN
    IF DUMP THEN
        enabledump := FALSE;
        dump := FileOps.OpenGeneral ("DUMP.TXT", FALSE, TRUE, TRUE, TRUE, TRUE);
        FWriteString (dump, "___________________________");
        FWriteLn (dump);
    END (*IF*);
FINALLY
    IF DUMP THEN
        FileOps.CloseFile (dump);
    END (*IF*);
END TLSRecord.

