(**************************************************************************)
(*                                                                        *)
(*  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 TLS;

        (********************************************************)
        (*                                                      *)
        (*                Transport Layer Security              *)
        (*                                                      *)
        (*  Programmer:         P. Moylan                       *)
        (*  Started:            2 April 2018                    *)
        (*  Last edited:        29 July 2025                    *)
        (*  Status:             Seems to be working             *)
        (*                                                      *)
        (********************************************************)

(************************************************************************)
(*  NOTE ABOUT VERSIONS                                                 *)
(*  Version numbering continues on from the SSL version numbers.        *)
(*  Thus we have:                                                       *)
(*          3.0 or lower    SSL versions pre-TLS                        *)
(*          3.1             TLS version 1.0                             *)
(*          3.2             TLS version 1.1                             *)
(*          3.3             TLS version 1.2                             *)
(*  The present code supports only 3.3.                                 *)
(************************************************************************)


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

IMPORT Strings, TLSHandshake, TLSCertificates;

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

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

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

FROM TLSHandshake IMPORT
    (* proc *)  DoHandshake;

FROM TLSAlerts IMPORT
    (* proc *)  LogAlert;

FROM TLSRecord IMPORT
    (* type *)  RLState,
    (* proc *)  TLSRecordInit, TLSRecordClose, FirstNBytes, GetFragment, PutFragment,
                RecordTraceOn, RecordTraceOff;

FROM VarStrings IMPORT
    (* type *)  ByteStr, ByteStringPtr,
    (* proc *)  MakeBS, BSDelete, BSAppend, TrimBS, DiscardBS;

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

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

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

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

CONST TESTING = FALSE;

CONST
    Nul = CHR(0);  CtrlZ = CHR(26);
    MajorVersion = 3;  MinorVersion = 3;
    BufSize = 64;

TYPE
    TLSsession = POINTER TO SessionState;

    SessionState =  RECORD
                        IsServer:   BOOLEAN;
                        loneCR:     BOOLEAN;
                        sock:       Socket;
                        logID:      TransactionLogID;
                        rlstate:    RLState;
                        excess:     ByteStr;
                    END (*RECORD*);

    (* The excess variable in this record holds data that have been     *)
    (* read from a lower level but not yet consumed.  loneCR is set iff *)
    (* a CR was the last character left in a buffer.                    *)

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

PROCEDURE SetSingleCertificateMode;

    (* Sets a mode where the domain name is ignored when fetching a     *)
    (* server certificate or private key, because the one certificate   *)
    (* is used for all domains.                                         *)

    BEGIN
        TLSHandshake.SetBlankDomainLegal;
        TLSCertificates.SetSingleCertificateMode;
    END SetSingleCertificateMode;

(************************************************************************)
(*                      OPENING AND CLOSING A SESSION                   *)
(************************************************************************)

PROCEDURE CreateSessionRecord (S: Socket;  as_server: BOOLEAN;
                                    logID: TransactionLogID): TLSsession;

    (* Sets up the initial TLS state.    *)

    VAR result: TLSsession;

    BEGIN
        NEW (result);
        result^.IsServer := as_server;
        result^.loneCR := FALSE;
        result^.sock := S;
        result^.logID := logID;
        MakeBS (result^.excess, 0);
        RETURN result;
    END CreateSessionRecord;

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

PROCEDURE OpenTLSsession (S: Socket;  as_server: BOOLEAN;
                            serveraddr: CARDINAL;
                            serverdomain: ARRAY OF CHAR;
                              logID: TransactionLogID;
                                VAR (*OUT*) session: TLSsession): BOOLEAN;

    (* Opens a new connection.  Returns FALSE if the operation failed.  *)

    (* If as_server is FALSE, the serverdomain parameter specifies the  *)
    (* domain the client is trying to contact. Otherwise, it specifies  *)
    (* an initial value for the domain the server is hosting, but in    *)
    (* that case it will probably be overwritten by the domain          *)
    (* specified in a ClientHello message.                              *)

    (* Opens a new connection.  Returns FALSE if the operation failed.  *)

    VAR success, ConnectionLost: BOOLEAN;

    (* Not clear whether this module needs to know about handshake      *)
    (* state.  We only need to know whether the handshake succeeded.    *)

    BEGIN
        session := CreateSessionRecord (S, as_server, logID);
        session^.rlstate := TLSRecordInit(S, as_server, logID);
        success := DoHandshake (S, as_server, serveraddr, serverdomain,
                             session^.rlstate, logID, ConnectionLost);
        IF NOT success THEN
            CloseTLSsession (session);
        END (*IF*);
        RETURN success;
    END OpenTLSsession;

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

PROCEDURE CloseTLSsession (VAR (*INOUT*) sess: TLSsession);

    (* Closes the session, deletes the session data. *)

    BEGIN
        (* There are probably some formalities I have to do here, but   *)
        (* I'll come back to that later.                                *)

        IF sess <> NIL THEN
            DiscardBS (sess^.excess);
            TLSRecordClose (sess^.rlstate);
            soclose (sess^.sock);
            DISPOSE (sess);
        END (*IF*);
    END CloseTLSsession;

(************************************************************************)
(*                    SENDING DATA TO RECORD LAYER                      *)
(************************************************************************)

PROCEDURE TLSsendsmall (sess: TLSsession;  VAR (*IN*) message: ARRAY OF LOC;
                                                 length: CARD16): BOOLEAN;

    (* Sends a message of up to 65535 bytes.                *)
    (* If length is > 16384, PutFragment will break it up.  *)

    CONST MaxSize = 16384;

    VAR buffer: TextType;
        (*info: ARRAY [0..79] OF CHAR;*)

    BEGIN
        IF sess = NIL THEN
            (* Session closed, so send nothing. *)
            RETURN TRUE;
        END (*IF*);
        buffer.contenttype := 23;
        buffer.majversion := MajorVersion;
        buffer.minversion := MinorVersion;
        buffer.length := Swap2(length);
        ALLOCATE (buffer.fragment, length);
        IF length > 0 THEN
            Copy (ADR(message), buffer.fragment, length);
        END (*IF*);
        (*
        IF TESTING THEN
            byte0 := CAST(CARD8, message[0]);
            IF (length <=  2) AND (byte0 = 13) THEN
                info := "> <eol>";
            ELSIF length <60 THEN
                info := ">";
                Copy (ADR(message), ADR(info[1]), length);
                info[length+1] := CHR(0);
            ELSE
                info := "Sending character string, ";
                AppendCard (length, info);
                Strings.Append (" characters", info);
            END (*IF*);
            LogTransaction (sess^.logID, info);
        END (*IF*);
        *)
        RETURN PutFragment (sess^.rlstate, sess^.logID, buffer);
    END TLSsendsmall;

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

PROCEDURE TLSsend (sess: TLSsession; message: ARRAY OF LOC;
                                               length: CARDINAL): BOOLEAN;

    (* Sends a message of "length" bytes.  *)

    CONST MaxSize = MAX(CARD16);

    VAR success: BOOLEAN;

    BEGIN
        IF sess = NIL THEN
            (* Session closed, so send nothing. *)
            RETURN TRUE;
        END (*IF*);
        success := TRUE;
        WHILE success AND (length > MaxSize) DO
            success := TLSsendsmall (sess, message, MaxSize);
            DEC (length, MaxSize);
            Copy (ADR(message[MaxSize]), ADR(message[0]), length);
        END (*WHILE*);

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

        IF success AND (length > 0) THEN
            success := TLSsendsmall (sess, message, length);
        END (*IF*);

        RETURN success;

    END TLSsend;

(************************************************************************)
(*                           RECEIVING DATA                             *)
(************************************************************************)

PROCEDURE TLSrecv (sess: TLSsession;  VAR (*OUT*) message: ARRAY OF LOC;
                    limit: CARDINAL;  VAR (*OUT*) actual: CARDINAL;
                    VAR (*OUT*) ConnectionLost: BOOLEAN);

    (* Receives a message of up to "limit" bytes.  The "actual"         *)
    (* parameter returns the actual number of bytes received, or        *)
    (* MAX(CARDINAL) if there was an error.                             *)

    VAR txtbuf: TextType;
        warning: ARRAY [0..79] OF CHAR;
        p, q: ByteStringPtr;
        count: CARDINAL;
        havedata, done: BOOLEAN;

    BEGIN
        ConnectionLost := FALSE;
        done := FALSE;
        actual := 0;
        p := ADR(message);

        (* Start by using the data in sess^.excess. *)

        count := sess^.excess.size;
        IF count > 0 THEN
            IF count > limit THEN
                Copy (sess^.excess.data, p, limit);
                p := AddOffset (p, limit);
                BSDelete (sess^.excess, 0, limit);
                actual := limit;
                limit := 0;
            ELSE
                (* Consume all of excess. *)

                Copy (sess^.excess.data, p, count);
                p := AddOffset (p, count);
                DiscardBS (sess^.excess);
                actual := count;
                DEC (limit, count);
            END (*IF*);
        END (*IF*);

        (* If more to get, call GetFragment until we get a data *)
        (* fragment.                                            *)

        IF limit > 0 THEN
            REPEAT
                havedata := GetFragment (sess^.rlstate, sess^.logID, txtbuf, ConnectionLost);
                count := 0;
                IF ConnectionLost THEN
                    havedata := TRUE;   (* to force loop exit *);
                ELSIF havedata THEN
                    IF txtbuf.contenttype = 23 THEN
                        count := Swap2 (txtbuf.length);
                    ELSIF txtbuf.contenttype = 21 THEN
                        IF (NOT LogAlert (sess^.logID, txtbuf, done, ConnectionLost))
                                        OR ConnectionLost OR done THEN
                            count := 0;
                            actual := MAX(CARDINAL);
                            havedata := TRUE;
                        END (*IF*);
                    ELSE
                        warning :="Not yet implemented: unexpected content type ";
                        AppendCard (txtbuf.contenttype, warning);
                        LogTransaction (sess^.logID, warning);
                        havedata := FALSE;
                    END (*IF*);
                ELSE
                    LogTransactionL (sess^.logID, "GetFragment returned no data");
                    count := 0;
                    ConnectionLost := TRUE;
                    actual := MAX(CARDINAL);
                    havedata := TRUE;
                END (*IF*);
            UNTIL havedata;

            IF ConnectionLost THEN
                DiscardFragment (txtbuf);
            ELSIF count > 0 THEN
                IF count > limit THEN
                    Copy (txtbuf.fragment, p, limit);
                    q := ADR(txtbuf.fragment^[limit]);
                    BSAppend (sess^.excess, count-limit, q^);
                    INC (actual, limit);
                ELSE
                    (* Consume all of fragment. *)

                    Copy (txtbuf.fragment, p, count);
                    DiscardBS (sess^.excess);
                    INC (actual, count);
                END (*IF*);
            END (*IF*);
        END (*IF*);

    END TLSrecv;

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

PROCEDURE GetNextFragment (sess: TLSsession): BOOLEAN;

    (* Calls GetFragment, repeatedly if necessary, until we get a data  *)
    (* fragment, then puts that data into sess^.excess.  Returns FALSE  *)
    (* if we lose the connection or get a fatal alert.                  *)

    VAR txtbuf: TextType;
        logmess: ARRAY [0..79] OF CHAR;
        count: CARDINAL;
        success, havedata, done, ConnectionLost: BOOLEAN;

    BEGIN
        (*LogTransactionL (sess^.logID, "Entering GetNextFragment");*)
        ConnectionLost := FALSE;  success := TRUE;
        REPEAT
            havedata := GetFragment (sess^.rlstate, sess^.logID, txtbuf, ConnectionLost);
            count := 0;
            IF ConnectionLost THEN
                success := FALSE;   (* which will terminate loop *)
            ELSIF havedata THEN

                (* Type 20 is change_cipher_spec, which can     *)
                (* only occur in the middle of a handshake.     *)
                (* Type 22 is a handshake message.  Both of     *)
                (* these have been handled, in another module,  *)
                (* before we got to this point.  Type 23 is the *)
                (* data we want, but this can be interrupted    *)
                (* by alerts (type 21).                         *)

                IF txtbuf.contenttype = 23 THEN
                    count := Swap2 (txtbuf.length);
                ELSIF txtbuf.contenttype = 21 THEN
                    IF (NOT LogAlert (sess^.logID, txtbuf, done, ConnectionLost))
                             OR ConnectionLost OR done THEN
                        count := 0;
                        success := FALSE;
                    END (*IF*);
                    havedata := FALSE;
                ELSE
                    logmess :="Not yet implemented: unexpected content type ";
                    AppendCard (txtbuf.contenttype, logmess);
                    LogTransaction (sess^.logID, logmess);
                    havedata := FALSE;
                END (*IF*);
            ELSE
                LogTransactionL (sess^.logID, "GetFragment returned no data");
                count := 0;
                ConnectionLost := TRUE;
                success := FALSE;
            END (*IF*);
        UNTIL havedata OR NOT success;

        (* Move txtbuf data into sess^.excess, where it's easier    *)
        (* to manage things like memory deallocation.               *)

        IF count = 0 THEN
            sess^.excess.data := NIL;
        ELSE
            sess^.excess.data := txtbuf.fragment;
        END (*IF*);
        sess^.excess.size := count;
        sess^.excess.allocated := count;

        (*
        logmess :="Received ";
        AppendCard (count, logmess);
        Strings.Append (" bytes", logmess);
        LogTransaction (sess^.logID, logmess);
        *)

        txtbuf.fragment := NIL;
        txtbuf.length := 0;

        (*LogTransactionL (sess^.logID, "Leaving GetNextFragment");*)
        RETURN success;

    END GetNextFragment;

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

PROCEDURE TLSrecvLine (sess: TLSsession;  VAR (*OUT*) message: ARRAY OF LOC;
                          limit: CARDINAL;
                                VAR (*OUT*) actual: CARDINAL): BOOLEAN;

    (* Like TLSrecv, but returns data up to the next CRLF line          *)
    (* terminator.  The CRLF is discarded.                              *)

    (* Remark: this is a terribly long procedure.  Is there a more      *)
    (* elegant way to do the job?                                       *)

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

    CONST CR = 13;  LF = 10;

    VAR pdest: ByteStringPtr;  foundEOL: BOOLEAN;

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

    PROCEDURE FindCR (VAR (*IN*) str: ARRAY OF CARD8;  limit: CARDINAL;
                                    VAR (*OUT*) pos: CARDINAL): BOOLEAN;

        (* pos is the position of the first CR or LF found.  Returns    *)
        (* FALSE, and sets pos = limit, if no CR or LF is found in the  *)
        (* first limit bytes.                                           *)

        VAR val: CARD8;  found: BOOLEAN;

        BEGIN
            pos := 0;  found := FALSE;
            WHILE (pos < limit) AND NOT found DO
                val := str[pos];
                found := (val = CR) OR (val = LF);
                IF NOT found THEN
                    INC (pos);
                END (*IF*);
            END (*WHILE*);
            RETURN found;
        END FindCR;

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

    PROCEDURE Process (VAR (*INOUT*) input: ByteStr);

        (* Extracts what we can from input, of length>0.  On return,    *)
        (* input.size has probably been decreased.  The result goes to  *)
        (* pdest^ and pdest is updated.  Parameter actual gives the     *)
        (* size of the result.                                          *)

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

        PROCEDURE DeleteLeading (N: CARDINAL);

            (* Deletes the first N bytes from input, adjusting size.    *)
            (* No data deallocation happens at this stage.              *)

            BEGIN
                Copy (ADR(input.data^[N]), input.data, input.size - N);
                DEC (input.size, N);
            END DeleteLeading;

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

        VAR pos: CARDINAL;
            (*logmess: ARRAY [0..127] OF CHAR;*)

        BEGIN
            (* First check for the special case where a lone CR was *)
            (* found at the end of the string on a previous call.   *)

            IF sess^.loneCR THEN
                IF input.data^[0] = LF THEN
                    (* This terminates a sentence that was already      *)
                    (* found in a previous call, so we mustn't say we   *)
                    (* have found a new end-of-line. Just discard the LF*)

                    DeleteLeading (1);
                END  (*IF*);
                sess^.loneCR := FALSE;
            END  (*IF*);

            foundEOL := FindCR (input.data^, input.size, pos);
            (*
            logmess :="Found ";
            AppendCard (pos, logmess);
            Strings.Append (" bytes before EOL", logmess);
            LogTransaction (sess^.logID, logmess);
            *)
            IF pos > 0 THEN
                (* Copy data regardless of whether terminator pessent.  *)
                IF pos > limit THEN
                    Copy (input.data, pdest, limit);
                    pdest := AddOffset (pdest, limit);
                    INC (actual, limit);
                    DeleteLeading (limit);
                    foundEOL := TRUE;
                    (* We report foundEOL = TRUE for a truncated    *)
                    (* line, because that's all that will fit.      *)
                ELSE
                    Copy (input.data, pdest, pos);
                    pdest := AddOffset (pdest, pos);
                    INC (actual, pos);
                    DeleteLeading (pos);
                    (* In this case it's not a truncated line.      *)
                    (* Depending on the foundEOL flag, we either    *)
                    (* have the whole line, or still have to fetch  *)
                    (* the rest of the line.                        *)
                END (*IF*);
            END (*IF*);

            (* Now check and remove the terminator, which by now    *)
            (* is at the beginning of the string.                   *)

            IF foundEOL THEN
                IF input.data^[0] = CR THEN
                    IF input.size = 1 THEN
                        (* Special case: lone CR at the end. *)
                        sess^.loneCR := TRUE;
                        input.size := 0;
                    ELSIF input.data^[1] = LF THEN
                        DeleteLeading (2);
                    ELSE
                        DeleteLeading (1);
                    END (*IF*);
                ELSE
                    (* Terminator is a LF. *)
                    DeleteLeading (1);
                END (*IF*);
            (*&LogTransactionL (sess^.logID, "Have deleted the EOL");*)
            END (*IF*);
        END Process;

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

    VAR success: BOOLEAN;

    BEGIN
        actual := 0;
        pdest := ADR(message);
        success := TRUE;  foundEOL := FALSE;

        REPEAT

            (* Start by using some or all of the data in sess^.excess. *)

            IF sess^.excess.size > 0 THEN
                Process (sess^.excess);
                TrimBS (sess^.excess);
            END (*IF*);

            IF success AND NOT foundEOL THEN
                success := GetNextFragment (sess);
            END (*IF*);

        UNTIL foundEOL OR NOT success;

        (* Any remaining data in sess^.excess will be used on the next call. *)

        (* Don't forget the terminating Nul. *)

        IF actual < limit THEN
            pdest^[0] := 0;
        END (*IF*);

        (*
        LogTransactionL (sess^.logID, "Returning from TLSrecvLine");
        IF success THEN
            LogTransactionL (sess^.logID, "success = TRUE");
        ELSE
            LogTransactionL (sess^.logID, "success = FALSE");
        END (*IF*);
        *)
        RETURN success;

    END TLSrecvLine;

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

BEGIN
END TLS.

