Core Banking System Modernization

1(* Money type that prevents arithmetic errors *)
2module Money : sig
3  type t
4  val zero : t
5  val of_string : string -> (t, string) result
6  val add : t -> t -> t
7  val subtract : t -> t -> (t, string) result
8  val multiply : t -> float -> t
9  val compare : t -> t -> int
10  val to_string : t -> string
11end = struct
12  (* Internal representation: cents to avoid floating point *)
13  type t = int64
14  
15  let zero = 0L
16  
17  let of_string s =
18    match String.split_on_char '.' s with
19    | [dollars; cents] ->
20        (try
21          let d = Int64.of_string dollars in
22          let c = Int64.of_string cents in
23          Ok (Int64.add (Int64.mul d 100L) c)
24        with Failure _ -> Error "Invalid money format")
25    | _ -> Error "Invalid money format"
26  
27  let add = Int64.add
28  
29  let subtract a b =
30    let result = Int64.sub a b in
31    if result < 0L then
32      Error "Insufficient funds"
33    else
34      Ok result
35  
36  let multiply m factor =
37    Int64.of_float (Int64.to_float m *. factor)
38  
39  let compare = Int64.compare
40  
41  let to_string m =
42    let dollars = Int64.div m 100L in
43    let cents = Int64.rem m 100L in
44    Printf.sprintf "%Ld.%02Ld" dollars cents
45end
46

1(* Account state machine with exhaustive matching *)
2type account_status =
3  | Active
4  | Frozen of freeze_reason
5  | Closed of closure_reason
6
7type freeze_reason =
8  | Suspicious_activity
9  | Court_order
10  | Compliance_hold
11
12type transaction_result =
13  | Success of transaction_id
14  | Rejected of rejection_reason
15
16let process_transaction account transaction =
17  match account.status with
18  | Active ->
19      (* Process normally *)
20      validate_and_execute account transaction
21  | Frozen Suspicious_activity ->
22      Rejected "Account frozen due to suspicious activity"
23  | Frozen Court_order ->
24      Rejected "Account frozen by court order"
25  | Frozen Compliance_hold ->
26      Rejected "Account under compliance review"
27  | Closed reason ->
28      Rejected (Printf.sprintf "Account closed: %s" 
29                  (closure_reason_to_string reason))
30

1(* Immutable transaction journal *)
2type transaction = {
3  id: transaction_id;
4  timestamp: timestamp;
5  from_account: account_id;
6  to_account: account_id;
7  amount: Money.t;
8  description: string;
9  status: transaction_status;
10}
11
12(* Events are immutable - can never be modified *)
13type event =
14  | Account_created of account_creation
15  | Money_deposited of deposit
16  | Money_withdrawn of withdrawal
17  | Transfer_executed of transfer
18  | Account_frozen of freeze_event
19  | Account_closed of closure_event
20
21(* Event sourcing - reconstruct state from events *)
22let replay_events initial_state events =
23  List.fold_left apply_event initial_state events
24

1┌──────────────────────────────────────────────────────┐
2│                     Digital Channels                 │
3│          Mobile App   │   Web   │   API              │
4└──────────────────────────┬───────────────────────────┘
5                           │      REST/GraphQL
6┌──────────────────────────▼───────────────────────────┐
7│                  API Gateway (Kong)                  │
8└──────────────────────────┬───────────────────────────┘
9                           │      gRPC
10       ┌──────────────┬────┴───────┬────────────┐
11       │              │            │            │
12  ┌────▼────┐    ┌────▼────┐  ┌────▼────┐  ┌────▼────┐
13  │ Account │    │ Trans-  │  │ Payment │  │  Loan   │
14  │ Service │    │ action  │  │ Service │  │ Service │
15  │ (OCaml) │    │ (OCaml) │  │ (OCaml) │  │ (OCaml) │
16  └────┬────┘    └────┬────┘  └────┬────┘  └────┬────┘
17       │              │            │            │
18       └──────────────┴────┬───────┴────────────┘
19                           │
20                   ┌───────▼───────┐
21                   │ PostgreSQL    │
22                   │ (Event Store) │
23                   └───────┬───────┘
24                           │
25                ┌──────────┴──────────┐
26                │                     │
27           ┌────▼────┐          ┌─────▼────┐
28           │  Redis  │          │  Kafka   │
29           │ (Cache) │          │ (Events) │
30           └─────────┘          └──────────┘
31

1(* Account module with strong guarantees *)
2module Account : sig
3  type t
4  type error =
5    | Insufficient_funds
6    | Account_frozen
7    | Daily_limit_exceeded
8    | Invalid_amount
9  
10  val create : account_id -> customer_id -> Money.t -> t
11  val balance : t -> Money.t
12  val deposit : t -> Money.t -> (t, error) result
13  val withdraw : t -> Money.t -> (t, error) result
14  val transfer : t -> t -> Money.t -> (t * t, error) result
15  val freeze : t -> freeze_reason -> t
16  val unfreeze : t -> t
17end = struct
18  type t = {
19    id: account_id;
20    customer_id: customer_id;
21    balance: Money.t;
22    status: account_status;
23    daily_withdrawal: Money.t;
24    daily_limit: Money.t;
25    created_at: timestamp;
26    updated_at: timestamp;
27  }
28  
29  type error =
30    | Insufficient_funds
31    | Account_frozen
32    | Daily_limit_exceeded
33    | Invalid_amount
34  
35  let create id customer_id initial_balance = {
36    id;
37    customer_id;
38    balance = initial_balance;
39    status = Active;
40    daily_withdrawal = Money.zero;
41    daily_limit = Money.of_string "5000.00" |> Result.get_ok;
42    created_at = now ();
43    updated_at = now ();
44  }
45  
46  let balance account = account.balance
47  
48  let deposit account amount =
49    if Money.compare amount Money.zero <= 0 then
50      Error Invalid_amount
51    else
52      match account.status with
53      | Active ->
54          let new_balance = Money.add account.balance amount in
55          Ok { account with balance = new_balance; updated_at = now () }
56      | Frozen _ ->
57          Error Account_frozen
58      | Closed _ ->
59          Error Account_frozen
60  
61  let withdraw account amount =
62    match account.status with
63    | Active ->
64        (* Check sufficient funds *)
65        (match Money.subtract account.balance amount with
66        | Error _ -> Error Insufficient_funds
67        | Ok new_balance ->
68            (* Check daily limit *)
69            let new_daily = Money.add account.daily_withdrawal amount in
70            if Money.compare new_daily account.daily_limit > 0 then
71              Error Daily_limit_exceeded
72            else
73              Ok { account with
74                balance = new_balance;
75                daily_withdrawal = new_daily;
76                updated_at = now ();
77              })
78    | Frozen _ -> Error Account_frozen
79    | Closed _ -> Error Account_frozen
80  
81  let transfer from_account to_account amount =
82    match withdraw from_account amount with
83    | Error e -> Error e
84    | Ok from' ->
85        match deposit to_account amount with
86        | Error e -> Error e
87        | Ok to' -> Ok (from', to')
88  
89  let freeze account reason =
90    { account with status = Frozen reason; updated_at = now () }
91  
92  let unfreeze account =
93    { account with status = Active; updated_at = now () }
94end
95

1(* Atomic transaction processing with event sourcing *)
2module Transaction_processor = struct
3  type command =
4    | Process_deposit of account_id * Money.t
5    | Process_withdrawal of account_id * Money.t
6    | Process_transfer of account_id * account_id * Money.t
7  
8  type event =
9    | Deposit_processed of transaction_id * account_id * Money.t * timestamp
10    | Withdrawal_processed of transaction_id * account_id * Money.t * timestamp
11    | Transfer_processed of transaction_id * account_id * account_id * Money.t * timestamp
12    | Transaction_failed of transaction_id * string * timestamp
13  
14  (* Process command and generate events *)
15  let process_command db_conn command =
16    Lwt_main.run begin
17      match command with
18      | Process_deposit (account_id, amount) ->
19          let%lwt account = Repository.load_account db_conn account_id in
20          (match Account.deposit account amount with
21          | Ok updated_account ->
22              let event = Deposit_processed (
23                generate_id (),
24                account_id,
25                amount,
26                now ()
27              ) in
28              let%lwt () = Repository.save_account db_conn updated_account in
29              let%lwt () = Repository.append_event db_conn event in
30              Lwt.return (Ok event)
31          | Error e ->
32              let event = Transaction_failed (
33                generate_id (),
34                error_to_string e,
35                now ()
36              ) in
37              let%lwt () = Repository.append_event db_conn event in
38              Lwt.return (Error e))
39      | Process_transfer (from_id, to_id, amount) ->
40          (* Two-phase commit for transfer *)
41          let%lwt from_account = Repository.load_account db_conn from_id in
42          let%lwt to_account = Repository.load_account db_conn to_id in
43          (match Account.transfer from_account to_account amount with
44          | Ok (from', to') ->
45              let event = Transfer_processed (
46                generate_id (),
47                from_id,
48                to_id,
49                amount,
50                now ()
51              ) in
52              let%lwt () = Repository.begin_transaction db_conn in
53              let%lwt () = Repository.save_account db_conn from' in
54              let%lwt () = Repository.save_account db_conn to' in
55              let%lwt () = Repository.append_event db_conn event in
56              let%lwt () = Repository.commit_transaction db_conn in
57              Lwt.return (Ok event)
58          | Error e ->
59              let%lwt () = Repository.rollback_transaction db_conn in
60              Lwt.return (Error e))
61      | _ -> (* other cases *)
62          Lwt.return (Error Account.Invalid_amount)
63    end
64end
65