commit 8136a36b99a4e0a0450d642f3a78cc0cba269e5f · anil.recoil.org/ocaml-jmap

+1 -1

bin/dune

···

       3
       3
        
        (public_name fastmail-list)

     

       4
       4
        
        (package jmap)

     

       5
       5
        
        (modules fastmail_list)

     

       6
       6
       -
        (libraries jmap jmap_mail lwt.unix))

     

       6
       6
       +
        (libraries jmap jmap_mail lwt.unix logs logs.fmt))

+94 -15

bin/fastmail_list.ml

···

       3
       3
        
        *

     

       4
       4
        
        * This binary connects to the Fastmail JMAP API using an authentication token

     

       5
       5
        
        * from the JMAP_API_TOKEN environment variable and lists the most recent 100

     

       6
       6
       -
        * emails with their subjects and sender details.

     

       6
       6
       +
        * emails with their subjects, sender details, and labels.

     

       7
       7
        
        *

     

       8
       8
        
        * Usage: 

     

       9
       9
       -
        *   JMAP_API_TOKEN=your_api_token ./fastmail_list

     

       9
       9
       +
        *   JMAP_API_TOKEN=your_api_token ./fastmail_list [options]

     

       10
       10
       +
        *

     

       11
       11
       +
        * Options:

     

       12
       12
       +
        *   -unread       List only unread messages

     

       13
       13
       +
        *   -labels       Show labels/keywords associated with messages

     

       14
       14
       +
        *   -debug LEVEL  Set debug level (0-4, where 4 is most verbose)

     

       10
       15
        
        *)

     

       11
       16
        
       

     

       12
       17
        
       open Lwt.Syntax

     
···

       15
       20
        
       module Mail = Jmap_mail.Types

     

       16
       21
        
       

     

       17
       22
        
       (** Prints the email details *)

     

       18
       18
       -
       let print_email (email : Mail.email) =

     

       23
       23
       +
       let print_email ~show_labels (email : Mail.email) =

     

       19
       24
        
         let sender = 

     

       20
       25
        
           match email.from with

     

       21
       26
        
           | Some (addr :: _) -> 

     
···

       30
       35
        
           | None -> "<no subject>"

     

       31
       36
        
         in

     

       32
       37
        
         let date = email.received_at in

     

       33
       33
       -
         Printf.printf "%s | %s | %s\n" date sender subject

     

       38
       38
       +
         

     

       39
       39
       +
         (* Format labels/keywords if requested *)

     

       40
       40
       +
         let labels_str = 

     

       41
       41
       +
           if show_labels then

     

       42
       42
       +
             let active_keywords = 

     

       43
       43
       +
               List.filter_map (fun (keyword, active) -> 

     

       44
       44
       +
                 if active then Some (Jmap_mail.Json.string_of_keyword keyword) else None

     

       45
       45
       +
               ) email.keywords

     

       46
       46
       +
             in

     

       47
       47
       +
             if List.length active_keywords > 0 then

     

       48
       48
       +
               " [" ^ String.concat ", " active_keywords ^ "]"

     

       49
       49
       +
             else

     

       50
       50
       +
               ""

     

       51
       51
       +
           else

     

       52
       52
       +
             ""

     

       53
       53
       +
         in

     

       54
       54
       +
         

     

       55
       55
       +
         Printf.printf "%s | %s | %s%s\n" date sender subject labels_str

     

       56
       56
       +
       

     

       57
       57
       +
       (** Check if an email is unread *)

     

       58
       58
       +
       let is_unread (email : Mail.email) =

     

       59
       59
       +
         let is_unread_keyword = 

     

       60
       60
       +
           List.exists (fun (kw, active) -> 

     

       61
       61
       +
             kw = Mail.Unread && active

     

       62
       62
       +
           ) email.keywords

     

       63
       63
       +
         in

     

       64
       64
       +
         let is_not_seen = 

     

       65
       65
       +
           not (List.exists (fun (kw, active) -> 

     

       66
       66
       +
             kw = Mail.Seen && active

     

       67
       67
       +
           ) email.keywords)

     

       68
       68
       +
         in

     

       69
       69
       +
         is_unread_keyword || is_not_seen

     

       34
       70
        
       

     

       35
       71
        
       (** Main function *)

     

       36
       72
        
       let main () =

     

       73
       73
       +
         (* Parse command-line arguments *)

     

       74
       74
       +
         let unread_only = ref false in

     

       75
       75
       +
         let show_labels = ref false in

     

       76
       76
       +
         let debug_level = ref 0 in

     

       77
       77
       +
         

     

       78
       78
       +
         let args = [

     

       79
       79
       +
           ("-unread", Arg.Set unread_only, "List only unread messages");

     

       80
       80
       +
           ("-labels", Arg.Set show_labels, "Show labels/keywords associated with messages");

     

       81
       81
       +
           ("-debug", Arg.Int (fun level -> debug_level := level), "Set debug level (0-4, where 4 is most verbose)");

     

       82
       82
       +
         ] in

     

       83
       83
       +
         

     

       84
       84
       +
         let usage_msg = "Usage: JMAP_API_TOKEN=your_token fastmail_list [options]" in

     

       85
       85
       +
         Arg.parse args (fun _ -> ()) usage_msg;

     

       86
       86
       +
         

     

       87
       87
       +
         (* Configure logging *)

     

       88
       88
       +
         init_logging ~level:!debug_level ~enable_logs:(!debug_level > 0) ~redact_sensitive:true ();

     

       89
       89
       +
         

     

       37
       90
        
         match Sys.getenv_opt "JMAP_API_TOKEN" with

     

       38
       91
        
         | None -> 

     

       39
       92
        
             Printf.eprintf "Error: JMAP_API_TOKEN environment variable not set\n";

     

       40
       40
       -
             Printf.eprintf "Usage: JMAP_API_TOKEN=your_token ./fastmail_list\n";

     

       93
       93
       +
             Printf.eprintf "Usage: JMAP_API_TOKEN=your_token ./fastmail_list [options]\n";

     

       94
       94
       +
             Printf.eprintf "Options:\n";

     

       95
       95
       +
             Printf.eprintf "  -unread       List only unread messages\n";

     

       96
       96
       +
             Printf.eprintf "  -labels       Show labels/keywords associated with messages\n";

     

       97
       97
       +
             Printf.eprintf "  -debug LEVEL  Set debug level (0-4, where 4 is most verbose)\n";

     

       41
       98
        
             exit 1

     

       42
       99
        
         | Some token ->

     

       43
       43
       -
             Printf.printf "Using API token: %s\n" token;

     

       100
       100
       +
             (* Only print token info at Info level or higher *)

     

       101
       101
       +
             Logs.info (fun m -> m "Using API token: %s" (redact_token token));

     

       102
       102
       +
             

     

       44
       103
        
             (* Connect to Fastmail JMAP API *)

     

       45
       45
       -
             (* Check token format and print helpful messages *)

     

       46
       104
        
             let formatted_token = token in

     

       47
       47
       -
             Printf.printf "\nFastmail API Instructions:\n";

     

       48
       48
       -
             Printf.printf "1. Get a token from: https://app.fastmail.com/settings/tokens\n";

     

       49
       49
       -
             Printf.printf "2. Create a new token with Mail scope (read/write)\n";

     

       50
       50
       -
             Printf.printf "3. Copy the full token (example: 3de40-5fg1h2-a1b2c3...)\n";

     

       51
       51
       -
             Printf.printf "4. Run: env JMAP_API_TOKEN=\"your_full_token\" opam exec -- dune exec bin/fastmail_list.exe\n\n";

     

       52
       52
       -
             Printf.printf "Note: This example is working correctly but needs a valid Fastmail token.\n\n";

     

       105
       105
       +
             

     

       106
       106
       +
             (* Only print instructions at Info level *)

     

       107
       107
       +
             let level = match Logs.level () with

     

       108
       108
       +
               | None -> 0

     

       109
       109
       +
               | Some Logs.Error -> 1

     

       110
       110
       +
               | Some Logs.Info -> 2 

     

       111
       111
       +
               | Some Logs.Debug -> 3

     

       112
       112
       +
               | _ -> 2

     

       113
       113
       +
             in

     

       114
       114
       +
             if level >= 2 then begin

     

       115
       115
       +
               Printf.printf "\nFastmail API Instructions:\n";

     

       116
       116
       +
               Printf.printf "1. Get a token from: https://app.fastmail.com/settings/tokens\n";

     

       117
       117
       +
               Printf.printf "2. Create a new token with Mail scope (read/write)\n";

     

       118
       118
       +
               Printf.printf "3. Copy the full token (example: 3de40-5fg1h2-a1b2c3...)\n";

     

       119
       119
       +
               Printf.printf "4. Run: env JMAP_API_TOKEN=\"your_full_token\" opam exec -- dune exec bin/fastmail_list.exe [options]\n\n";

     

       120
       120
       +
               Printf.printf "Note: This example is working correctly but needs a valid Fastmail token.\n\n";

     

       121
       121
       +
             end;

     

       53
       122
        
             let* result = login_with_token 

     

       54
       123
        
               ~uri:"https://api.fastmail.com/jmap/session" 

     

       55
       124
        
               ~api_token:formatted_token

     
···

       119
       188
        
                           | Api.Authentication_error -> "Authentication error");

     

       120
       189
        
                         Lwt.return 1

     

       121
       190
        
                     | Ok emails ->

     

       122
       122
       -
                         Printf.printf "Listing the most recent %d emails in your inbox:\n" (List.length emails);

     

       191
       191
       +
                         (* Filter emails if unread-only mode is enabled *)

     

       192
       192
       +
                         let filtered_emails = 

     

       193
       193
       +
                           if !unread_only then

     

       194
       194
       +
                             List.filter is_unread emails

     

       195
       195
       +
                           else 

     

       196
       196
       +
                             emails

     

       197
       197
       +
                         in

     

       198
       198
       +
                         

     

       199
       199
       +
                         Printf.printf "Listing %s %d emails in your inbox:\n" 

     

       200
       200
       +
                           (if !unread_only then "unread" else "the most recent")

     

       201
       201
       +
                           (List.length filtered_emails);

     

       123
       202
        
                         Printf.printf "--------------------------------------------\n";

     

       124
       124
       -
                         List.iter print_email emails;

     

       203
       203
       +
                         List.iter (print_email ~show_labels:!show_labels) filtered_emails;

     

       125
       204
        
                         Lwt.return 0

     

       126
       205
        
       

     

       127
       206
        
       (** Program entry point *)

+1 -1

lib/dune

···

       2
       2
        
         (name jmap)

     

       3
       3
        
         (public_name jmap)

     

       4
       4
        
         (modules jmap)

     

       5
       5
       -
         (libraries str ezjsonm ptime cohttp cohttp-lwt-unix uri lwt))

     

       5
       5
       +
         (libraries str ezjsonm ptime cohttp cohttp-lwt-unix uri lwt logs logs.fmt))

     

       6
       6
        
       

     

       7
       7
        
       (library

     

       8
       8
        
         (name jmap_mail)

+113 -25

lib/jmap.ml

···

       3
       3
        
        * https://datatracker.ietf.org/doc/html/rfc8620

     

       4
       4
        
        *)

     

       5
       5
        
       

     

       6
       6
       +
       (** Whether to redact sensitive information *)

     

       7
       7
       +
       let should_redact_sensitive = ref true

     

       8
       8
       +
       

     

       9
       9
       +
       (** Initialize and configure logging for JMAP *)

     

       10
       10
       +
       let init_logging ?(level=2) ?(enable_logs=true) ?(redact_sensitive=true) () =

     

       11
       11
       +
         if enable_logs then begin

     

       12
       12
       +
           Logs.set_reporter (Logs.format_reporter ());

     

       13
       13
       +
           match level with

     

       14
       14
       +
           | 0 -> Logs.set_level None

     

       15
       15
       +
           | 1 -> Logs.set_level (Some Logs.Error)

     

       16
       16
       +
           | 2 -> Logs.set_level (Some Logs.Info)

     

       17
       17
       +
           | 3 -> Logs.set_level (Some Logs.Debug)

     

       18
       18
       +
           | _ -> Logs.set_level (Some Logs.Debug)

     

       19
       19
       +
         end else

     

       20
       20
       +
           Logs.set_level None;

     

       21
       21
       +
         should_redact_sensitive := redact_sensitive

     

       22
       22
       +
       

     

       23
       23
       +
       (** Redact sensitive data like tokens *)

     

       24
       24
       +
       let redact_token ?(redact=true) token =

     

       25
       25
       +
         if redact && !should_redact_sensitive && String.length token > 8 then

     

       26
       26
       +
           let prefix = String.sub token 0 4 in

     

       27
       27
       +
           let suffix = String.sub token (String.length token - 4) 4 in

     

       28
       28
       +
           prefix ^ "..." ^ suffix

     

       29
       29
       +
         else

     

       30
       30
       +
           token

     

       31
       31
       +
       

     

       32
       32
       +
       (** Redact sensitive headers like Authorization *)

     

       33
       33
       +
       let redact_headers headers =

     

       34
       34
       +
         List.map (fun (k, v) ->

     

       35
       35
       +
           if String.lowercase_ascii k = "authorization" then

     

       36
       36
       +
             if !should_redact_sensitive then

     

       37
       37
       +
               let parts = String.split_on_char ' ' v in

     

       38
       38
       +
               match parts with

     

       39
       39
       +
               | scheme :: token :: _ -> (k, scheme ^ " " ^ redact_token token)

     

       40
       40
       +
               | _ -> (k, v)

     

       41
       41
       +
             else (k, v)

     

       42
       42
       +
           else (k, v)

     

       43
       43
       +
         ) headers

     

       44
       44
       +
       

     

       45
       45
       +
       (* Initialize logging with defaults *)

     

       46
       46
       +
       let () = init_logging ()

     

       47
       47
       +
       

     

       6
       48
        
       (** Module for managing JMAP capability URIs and other constants *)

     

       7
       49
        
       module Capability = struct

     

       8
       50
        
         (** Core JMAP capability URI *)

     
···

       448
       490
        
           let open Cohttp_lwt_unix in

     

       449
       491
        
           let headers = Header.add_list (Header.init ()) headers in

     

       450
       492
        
           

     

       451
       451
       -
           (* Debug: print request details *)

     

       452
       452
       -
           Printf.printf "\n===== HTTP REQUEST =====\n";

     

       453
       453
       -
           Printf.printf "URI: %s\n" (Uri.to_string uri);

     

       454
       454
       -
           Printf.printf "METHOD: %s\n" method_;

     

       455
       455
       -
           Printf.printf "HEADERS:\n";

     

       456
       456
       -
           Header.iter (fun k v -> Printf.printf "  %s: %s\n" k v) headers;

     

       457
       457
       -
           Printf.printf "BODY:\n%s\n" body;

     

       458
       458
       -
           Printf.printf "======================\n\n";

     

       493
       493
       +
           (* Log request details at debug level *)

     

       494
       494
       +
           let header_list = Cohttp.Header.to_list headers in

     

       495
       495
       +
           let redacted_headers = redact_headers header_list in

     

       496
       496
       +
           Logs.debug (fun m -> 

     

       497
       497
       +
             m "\n===== HTTP REQUEST =====\n\

     

       498
       498
       +
                URI: %s\n\

     

       499
       499
       +
                METHOD: %s\n\

     

       500
       500
       +
                HEADERS:\n%s\n\

     

       501
       501
       +
                BODY:\n%s\n\

     

       502
       502
       +
                ======================\n"

     

       503
       503
       +
               (Uri.to_string uri)

     

       504
       504
       +
               method_

     

       505
       505
       +
               (String.concat "\n" (List.map (fun (k, v) -> Printf.sprintf "  %s: %s" k v) redacted_headers))

     

       506
       506
       +
               body);

     

       459
       507
        
           

     

       460
       508
        
           Lwt.catch

     

       461
       509
        
             (fun () ->

     
···

       468
       516
        
               let* body_str = Cohttp_lwt.Body.to_string body in

     

       469
       517
        
               let status = Response.status resp |> Code.code_of_status in

     

       470
       518
        
               

     

       471
       471
       -
               (* Debug: print response details *)

     

       472
       472
       -
               Printf.printf "\n===== HTTP RESPONSE =====\n";

     

       473
       473
       -
               Printf.printf "STATUS: %d\n" status;

     

       474
       474
       -
               Printf.printf "HEADERS:\n";

     

       475
       475
       -
               Response.headers resp |> Header.iter (fun k v -> Printf.printf "  %s: %s\n" k v);

     

       476
       476
       -
               Printf.printf "BODY:\n%s\n" body_str;

     

       477
       477
       -
               Printf.printf "========================\n\n";

     

       519
       519
       +
               (* Log response details at debug level *)

     

       520
       520
       +
               let header_list = Cohttp.Header.to_list (Response.headers resp) in

     

       521
       521
       +
               let redacted_headers = redact_headers header_list in

     

       522
       522
       +
               Logs.debug (fun m -> 

     

       523
       523
       +
                 m "\n===== HTTP RESPONSE =====\n\

     

       524
       524
       +
                    STATUS: %d\n\

     

       525
       525
       +
                    HEADERS:\n%s\n\

     

       526
       526
       +
                    BODY:\n%s\n\

     

       527
       527
       +
                    ======================\n"

     

       528
       528
       +
                   status

     

       529
       529
       +
                   (String.concat "\n" (List.map (fun (k, v) -> Printf.sprintf "  %s: %s" k v) redacted_headers))

     

       530
       530
       +
                   body_str);

     

       478
       531
        
               

     

       479
       532
        
               if status >= 200 && status < 300 then

     

       480
       533
        
                 Lwt.return (Ok body_str)

     
···

       482
       535
        
                 Lwt.return (Error (HTTP_error (status, body_str))))

     

       483
       536
        
             (fun e -> 

     

       484
       537
        
               let error_msg = Printexc.to_string e in

     

       485
       485
       -
               Printf.printf "\n===== HTTP ERROR =====\n%s\n======================\n\n" error_msg;

     

       538
       538
       +
               Logs.err (fun m -> m "%s" error_msg);

     

       486
       539
        
               Lwt.return (Error (Connection_error error_msg)))

     

       487
       540
        
       

     

       488
       541
        
         (** Make a raw JMAP API request 

     
···

       499
       552
        
               (* API token (bearer authentication) *)

     

       500
       553
        
               "Bearer " ^ config.authentication_token

     

       501
       554
        
           in

     

       502
       502
       -
           Printf.printf "Using authorization header: %s\n" auth_header;

     

       555
       555
       +
           

     

       556
       556
       +
           (* Log auth header at debug level with redaction *)

     

       557
       557
       +
           let redacted_header =

     

       558
       558
       +
             if String.length config.username > 0 then

     

       559
       559
       +
               "Basic " ^ redact_token (Base64.encode_string (config.username ^ ":" ^ config.authentication_token))

     

       560
       560
       +
             else

     

       561
       561
       +
               "Bearer " ^ redact_token config.authentication_token

     

       562
       562
       +
           in

     

       563
       563
       +
           Logs.debug (fun m -> m "Using authorization header: %s" redacted_header);

     

       564
       564
       +
           

     

       503
       565
        
           let headers = [

     

       504
       566
        
             ("Content-Type", "application/json");

     

       505
       567
        
             ("Content-Length", string_of_int (String.length body));

     
···

       509
       571
        
           match result with

     

       510
       572
        
           | Ok response_body ->

     

       511
       573
        
               (match parse_json_string response_body with

     

       512
       512
       -
                | Ok json -> Lwt.return (parse_response json)

     

       513
       513
       -
                | Error e -> Lwt.return (Error e))

     

       514
       514
       -
           | Error e -> Lwt.return (Error e)

     

       574
       574
       +
                | Ok json -> 

     

       575
       575
       +
                    Logs.debug (fun m -> m "Successfully parsed JSON response");

     

       576
       576
       +
                    Lwt.return (parse_response json)

     

       577
       577
       +
                | Error e -> 

     

       578
       578
       +
                    let msg = match e with Parse_error m -> m | _ -> "unknown error" in

     

       579
       579
       +
                    Logs.err (fun m -> m "Failed to parse response: %s" msg);

     

       580
       580
       +
                    Lwt.return (Error e))

     

       581
       581
       +
           | Error e -> 

     

       582
       582
       +
               (match e with

     

       583
       583
       +
                | Connection_error msg -> Logs.err (fun m -> m "Connection error: %s" msg)

     

       584
       584
       +
                | HTTP_error (code, _) -> Logs.err (fun m -> m "HTTP error %d" code)

     

       585
       585
       +
                | Parse_error msg -> Logs.err (fun m -> m "Parse error: %s" msg)

     

       586
       586
       +
                | Authentication_error -> Logs.err (fun m -> m "Authentication error"));

     

       587
       587
       +
               Lwt.return (Error e)

     

       515
       588
        
       

     

       516
       589
        
         (** Parse a JSON object as a Session object *)

     

       517
       590
        
         let parse_session_object json =

     
···

       577
       650
        
             match (username, authentication_token, api_token) with

     

       578
       651
        
             | (Some u, Some t, _) -> 

     

       579
       652
        
                 let auth = "Basic " ^ Base64.encode_string (u ^ ":" ^ t) in

     

       580
       580
       -
                 Printf.printf "Session using Basic auth: %s\n" auth;

     

       653
       653
       +
                 let redacted_auth = "Basic " ^ redact_token (Base64.encode_string (u ^ ":" ^ t)) in

     

       654
       654
       +
                 Logs.info (fun m -> m "Session using Basic auth: %s" redacted_auth);

     

       581
       655
        
                 [

     

       582
       656
        
                   ("Content-Type", "application/json");

     

       583
       657
        
                   ("Authorization", auth)

     

       584
       658
        
                 ]

     

       585
       659
        
             | (_, _, Some token) -> 

     

       586
       660
        
                 let auth = "Bearer " ^ token in

     

       587
       587
       -
                 Printf.printf "Session using Bearer auth: %s\n" auth;

     

       661
       661
       +
                 let redacted_token = redact_token token in

     

       662
       662
       +
                 Logs.info (fun m -> m "Session using Bearer auth: %s" ("Bearer " ^ redacted_token));

     

       588
       663
        
                 [

     

       589
       664
        
                   ("Content-Type", "application/json");

     

       590
       665
        
                   ("Authorization", auth)

     
···

       596
       671
        
           match result with

     

       597
       672
        
           | Ok response_body ->

     

       598
       673
        
               (match parse_json_string response_body with

     

       599
       599
       -
                | Ok json -> Lwt.return (parse_session_object json)

     

       600
       600
       -
                | Error e -> Lwt.return (Error e))

     

       601
       601
       -
           | Error e -> Lwt.return (Error e)

     

       674
       674
       +
                | Ok json -> 

     

       675
       675
       +
                    Logs.debug (fun m -> m "Successfully parsed session response");

     

       676
       676
       +
                    Lwt.return (parse_session_object json)

     

       677
       677
       +
                | Error e -> 

     

       678
       678
       +
                    let msg = match e with Parse_error m -> m | _ -> "unknown error" in

     

       679
       679
       +
                    Logs.err (fun m -> m "Failed to parse session response: %s" msg);

     

       680
       680
       +
                    Lwt.return (Error e))

     

       681
       681
       +
           | Error e -> 

     

       682
       682
       +
               let err_msg = match e with

     

       683
       683
       +
                | Connection_error msg -> "Connection error: " ^ msg

     

       684
       684
       +
                | HTTP_error (code, _) -> Printf.sprintf "HTTP error %d" code

     

       685
       685
       +
                | Parse_error msg -> "Parse error: " ^ msg

     

       686
       686
       +
                | Authentication_error -> "Authentication error"

     

       687
       687
       +
               in

     

       688
       688
       +
               Logs.err (fun m -> m "Failed to get session: %s" err_msg);

     

       689
       689
       +
               Lwt.return (Error e)

     

       602
       690
        
       

     

       603
       691
        
         (** Upload a binary blob to the server

     

       604
       692

lib/jmap.mli

···

       3
       3
        
        * https://datatracker.ietf.org/doc/html/rfc8620

     

       4
       4
        
        *)

     

       5
       5
        
       

     

       6
       6
       +
       (** Initialize and configure logging for JMAP *)

     

       7
       7
       +
       val init_logging : ?level:int -> ?enable_logs:bool -> ?redact_sensitive:bool -> unit -> unit

     

       8
       8
       +
       

     

       9
       9
       +
       (** Redact sensitive data like tokens *)

     

       10
       10
       +
       val redact_token : ?redact:bool -> string -> string

     

       11
       11
       +
       

     

       6
       12
        
       (** Module for managing JMAP capability URIs and other constants *)

     

       7
       13
        
       module Capability : sig

     

       8
       14
        
         (** Core JMAP capability URI *)