├── .gitignore ├── .ocamlformat ├── .travis.yml ├── CHANGES ├── LICENSE ├── Makefile ├── README.md ├── dune-project ├── imap-unix.opam ├── imap.opam ├── lib ├── cmd.ml ├── cmd.mli ├── dune ├── parser.ml ├── parser.mli └── response.ml └── unix ├── dune ├── imap_unix.ml └── imap_unix.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .merlin 3 | *.install 4 | .gh-pages 5 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nojb/ocaml-imap/6e06e159597c3c1ea231edfe5ede53b28ae0c0ba/.ocamlformat -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | - OCAML_VERSION=4.03 PACKAGE=imap 7 | - OCAML_VERSION=4.04 PACKAGE=imap 8 | - OCAML_VERSION=4.05 PACKAGE=imap 9 | os: 10 | - linux 11 | - osx 12 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | trunk 2 | 3 | * Add lwt client example 4 | * Easier API: the continuation is returned directly to the user. 5 | * Redesigned parser into hybrid direct/cps style (*changes* API) 6 | (the new style is simpler and should be faster and use less memory than 7 | the existing pure cps design) 8 | * Fix bug in parsing address lists, by @phi-gamma (#24) 9 | 10 | 1.1.1 (2015-06-24) 11 | 12 | * Expose formatters for more types (#17) 13 | * Document Imap.mime and Imap.section types (#18) 14 | * Fix bug in parsing "BODY[...]" fetch attributes (#19) 15 | * Rename `Mutiple to `Multipart in Imap.mime 16 | 17 | 1.1.0 (2015-06-12) 18 | 19 | * Simplify API for AUTHENTICATE and IDLE 20 | * Correctly handle the case of an empty output buffer (#10) 21 | * Supress trailing space after FETCH command args (#12) 22 | * Fix serious bug when reading literals, reported by @rgrinberg (#14) 23 | * Switch from OASIS to ocamlbuild+opam-installer 24 | * Remove all the code in old/ 25 | 26 | 1.0.0 (2015-01-10) 27 | 28 | * Complete rewrite (again!) 29 | * Remove high-level api 30 | 31 | 0.20.0 (2014-09-26) 32 | 33 | * Complete rewrite 34 | * Include high-level API (only for Lwt for now) 35 | 36 | 0.9.1 (2014-04-05): 37 | 38 | * Functorialize over Lwt, Unix, Async 39 | * Split in different Findlib packages: 40 | imap, imap.gsasl, imap.async, imap.unix, imap.lwt 41 | 42 | 0.9.0 (2014-03-01): 43 | 44 | * Initial public release. 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Nicolas Ojeda Bar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. *) 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | dune build @all 4 | 5 | .PHONY: test 6 | test: 7 | dune runtest 8 | 9 | .PHONY: clean 10 | clean: 11 | dune clean 12 | 13 | .PHONY: fmt 14 | fmt: 15 | dune build @fmt --auto-promote 16 | 17 | .PHONY: install 18 | install: 19 | dune install 20 | 21 | .PHONY: uninstall 22 | uninstall: 23 | dune uninstall 24 | 25 | .PHONY: reinstall 26 | reinstall: uninstall install 27 | 28 | .PHONY: doc 29 | doc: 30 | dune build @doc 31 | 32 | .PHONY: publish-doc 33 | publish-doc: doc 34 | rm -rf .gh-pages 35 | git clone `git config --get remote.origin.url` .gh-pages --reference . 36 | git -C .gh-pages checkout --orphan gh-pages 37 | git -C .gh-pages reset 38 | git -C .gh-pages clean -dxf 39 | cp -r _build/default/_doc/* .gh-pages/ 40 | git -C .gh-pages add . 41 | git -C .gh-pages commit -m "Update Pages" 42 | git -C .gh-pages push origin gh-pages -f 43 | 44 | .PHONY: publish 45 | publish: gh-pages 46 | opam-publish submit "./imap.$(VERSION)" 47 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ocaml-imap -- IMAP4rev1 client library in OCaml 2 | 3 | [![Build Status](https://travis-ci.org/nojb/ocaml-imap.svg?branch=master)](https://travis-ci.org/nojb/ocaml-imap) 4 | 5 | Home page: https://github.com/nojb/ocaml-imap 6 | 7 | Contact: Nicolás Ojeda Bär `` 8 | 9 | ## Installation 10 | 11 | `ocaml-imap` can be installed with `opam`: 12 | 13 | opam install imap 14 | 15 | If you don't use `opam` consult the [`opam`](opam) file for build 16 | instructions and a complete specification of the dependencies. 17 | 18 | ## Documentation 19 | 20 | The documentation and API reference is automatically generated by `ocamldoc` 21 | from `imap.mli`. It can be consulted [online](https://nojb.github.io/ocaml-imap/imap). 22 | It can also be generated with: 23 | 24 | make doc 25 | 26 | and accessed at `_build/default/_doc`. 27 | 28 | ## Sample programs 29 | 30 | Sample programs are located in the `examples` directory of the 31 | distribution. They can be built with: 32 | 33 | make examples 34 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | 3 | (formatting (enabled_for ocaml dune)) 4 | 5 | (name imap) 6 | 7 | (license MIT) 8 | 9 | (authors 10 | "Nicolás Ojeda Bär ") 11 | 12 | (source 13 | (github nojb/ocaml-imap)) 14 | 15 | (package 16 | (name imap) 17 | (synopsis "Lwt-compatible IMAP4rev1 client library") 18 | (depends 19 | dune 20 | (base64 (>= 2.0.0)) 21 | uutf)) 22 | 23 | (package 24 | (name imap-unix) 25 | (depends ssl)) 26 | 27 | (generate_opam_files true) 28 | -------------------------------------------------------------------------------- /imap-unix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Nicolás Ojeda Bär "] 4 | license: "MIT" 5 | homepage: "https://github.com/nojb/ocaml-imap" 6 | bug-reports: "https://github.com/nojb/ocaml-imap/issues" 7 | depends: [ 8 | "dune" {>= "2.7"} 9 | "ssl" 10 | "odoc" {with-doc} 11 | ] 12 | build: [ 13 | ["dune" "subst"] {dev} 14 | [ 15 | "dune" 16 | "build" 17 | "-p" 18 | name 19 | "-j" 20 | jobs 21 | "@install" 22 | "@runtest" {with-test} 23 | "@doc" {with-doc} 24 | ] 25 | ] 26 | dev-repo: "git+https://github.com/nojb/ocaml-imap.git" 27 | -------------------------------------------------------------------------------- /imap.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Lwt-compatible IMAP4rev1 client library" 4 | authors: ["Nicolás Ojeda Bär "] 5 | license: "MIT" 6 | homepage: "https://github.com/nojb/ocaml-imap" 7 | bug-reports: "https://github.com/nojb/ocaml-imap/issues" 8 | depends: [ 9 | "dune" {>= "2.7"} 10 | "base64" {>= "2.0.0"} 11 | "uutf" 12 | "odoc" {with-doc} 13 | ] 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | [ 17 | "dune" 18 | "build" 19 | "-p" 20 | name 21 | "-j" 22 | jobs 23 | "@install" 24 | "@runtest" {with-test} 25 | "@doc" {with-doc} 26 | ] 27 | ] 28 | dev-repo: "git+https://github.com/nojb/ocaml-imap.git" 29 | -------------------------------------------------------------------------------- /lib/cmd.ml: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2015-2018 Nicolas Ojeda Bar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. *) 22 | 23 | open Response 24 | 25 | type uid = int32 26 | 27 | type modseq = int64 28 | 29 | (* module Time = struct *) 30 | (* type t = { hours : int; minutes : int; seconds : int; zone : int } *) 31 | 32 | (* let to_string { hours; minutes; seconds; zone } = *) 33 | (* Printf.sprintf "%02d:%02d:%02d %c%04d" hours minutes seconds *) 34 | (* (if zone >= 0 then '+' else '-') *) 35 | (* (abs zone) *) 36 | (* end *) 37 | 38 | module Encoder = struct 39 | module Mutf7 = struct 40 | let recode ?nln ?encoding out_encoding src dst = 41 | let rec loop d e = 42 | match Uutf.decode d with 43 | | `Uchar _ as u -> 44 | ignore (Uutf.encode e u); 45 | loop d e 46 | | `End -> ignore (Uutf.encode e `End) 47 | | `Malformed _ -> 48 | ignore (Uutf.encode e (`Uchar Uutf.u_rep)); 49 | loop d e 50 | | `Await -> assert false 51 | in 52 | let d = Uutf.decoder ?nln ?encoding src in 53 | let e = Uutf.encoder out_encoding dst in 54 | loop d e 55 | 56 | let replace s ch1 ch2 = 57 | String.init (String.length s) (fun i -> 58 | if s.[i] = ch1 then ch2 else s.[i]) 59 | 60 | let encode s = 61 | let b = Buffer.create 0 in 62 | let rec a i = 63 | if i >= String.length s then () 64 | else 65 | match s.[i] with 66 | | '&' -> 67 | Buffer.add_string b "&-"; 68 | a (i + 1) 69 | | '\x20' .. '\x7E' as c -> 70 | Buffer.add_char b c; 71 | a (i + 1) 72 | | _ -> 73 | Buffer.add_char b '&'; 74 | u i 75 | and u i = 76 | let upto j = 77 | let str = String.sub s i (j - i) and buf = Buffer.create 32 in 78 | recode ~encoding:`UTF_8 `UTF_16BE (`String str) (`Buffer buf); 79 | match Base64.encode ~pad:false (Buffer.contents buf) with 80 | | Ok str -> 81 | let str = replace str '/' ',' in 82 | Buffer.add_string b str; 83 | Buffer.add_char b '-' 84 | | Error (`Msg s) -> failwith s 85 | in 86 | let rec loop i = 87 | if i >= String.length s then upto i 88 | else 89 | match s.[i] with 90 | | '\x20' .. '\x7E' -> 91 | upto i; 92 | a i 93 | | _ -> loop (i + 1) 94 | in 95 | loop i 96 | in 97 | a 0; 98 | Buffer.contents b 99 | 100 | let _decode s = 101 | let b = Buffer.create 32 in 102 | let rec a i = 103 | if i >= String.length s then () 104 | else 105 | match s.[i] with 106 | | '&' -> 107 | if i + 1 < String.length s && s.[i] = '-' then ( 108 | Buffer.add_char b '&'; 109 | a (i + 2) ) 110 | else u (i + 1) 111 | | _ as c -> 112 | Buffer.add_char b c; 113 | a (i + 1) 114 | and u i = 115 | let start = i in 116 | let rec loop i = 117 | if i >= String.length s then invalid_arg "unterminated base64 input" 118 | else 119 | match s.[i] with 120 | | '-' -> 121 | let str = String.sub s start (i - start) in 122 | let str = replace str ',' '/' in 123 | ( match Base64.decode str with 124 | (* FIXME do we need to pad it with "===" ? *) 125 | | Ok str -> 126 | recode ~encoding:`UTF_16BE `UTF_8 (`String str) (`Buffer b) 127 | | Error (`Msg s) -> failwith s ); 128 | a (i + 1) 129 | | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '+' | ',' -> loop (i + 1) 130 | | _ -> invalid_arg "unexpected character" 131 | in 132 | loop i 133 | in 134 | a 0; 135 | Buffer.contents b 136 | end 137 | 138 | type s = Wait | Crlf | Raw of string 139 | 140 | type t = s list -> s list 141 | 142 | let raw s k = Raw s :: k 143 | 144 | let empty k = k 145 | 146 | let char c = raw (String.make 1 c) 147 | 148 | let ( & ) f g k = f (g k) 149 | 150 | let ( ++ ) f g = f & char ' ' & g 151 | 152 | let wait k = Wait :: k 153 | 154 | let crlf k = Crlf :: k 155 | 156 | let literal s = 157 | char '{' 158 | & raw (string_of_int (String.length s)) 159 | & char '}' & crlf & wait & raw s 160 | 161 | let str s = 162 | let literal_chars = function 163 | | '\x80' .. '\xFF' | '\r' | '\n' -> true 164 | | _ -> false 165 | in 166 | let quoted_chars = function 167 | | '(' | ')' | '{' | ' ' 168 | | '\x00' .. '\x1F' 169 | | '\x7F' | '%' | '*' | '\"' | '\\' -> 170 | true 171 | | _ -> false 172 | in 173 | let needs f s = 174 | let rec loop i = i < String.length s && (f s.[i] || loop (i + 1)) in 175 | loop 0 176 | in 177 | if s = "" then raw "\"\"" 178 | else if needs literal_chars s then literal s 179 | else if needs quoted_chars s then raw (Printf.sprintf "\"%s\"" s) 180 | else raw s 181 | 182 | let p f = char '(' & f & char ')' 183 | 184 | let mutf7 s = str (Mutf7.encode s) 185 | 186 | let int n = raw (string_of_int n) 187 | 188 | let uint64 m = raw (Printf.sprintf "%Lu" m) 189 | 190 | let label l = raw (Mutf7.encode l) 191 | 192 | let list ?(sep = ' ') f l = 193 | let rec loop = function 194 | | [] -> empty 195 | | [ x ] -> f x 196 | | x :: xs -> f x & char sep & loop xs 197 | in 198 | loop l 199 | 200 | let plist ?sep f l = char '(' & list ?sep f l & char ')' 201 | 202 | let eset s = 203 | let s = Uint32.Set.elements s in 204 | let elt = function 0l -> "*" | n -> Printf.sprintf "%lu" n in 205 | let f = function 206 | | lo, hi when lo = hi -> raw (elt lo) 207 | | lo, hi -> raw (Printf.sprintf "%s:%s" (elt lo) (elt hi)) 208 | in 209 | list ~sep:',' f s 210 | end 211 | 212 | let date_to_string { day; month; year } = 213 | let months = 214 | [| 215 | "Jan"; 216 | "Feb"; 217 | "Mar"; 218 | "Apr"; 219 | "May"; 220 | "Jun"; 221 | "Jul"; 222 | "Aug"; 223 | "Sep"; 224 | "Oct"; 225 | "Nov"; 226 | "Dec"; 227 | |] 228 | in 229 | Printf.sprintf "%2d-%s-%4d" day months.(month) year 230 | 231 | let encode_date d = Encoder.raw (date_to_string d) 232 | 233 | (* let _capability_to_string = function *) 234 | (* | IMAP4rev1 -> "IMAP4rev1" *) 235 | (* | ACL -> "ACL" *) 236 | (* | BINARY -> "BINARY" *) 237 | (* | CATENATE -> "CATENATE" *) 238 | (* | CHILDREN -> "CHILDREN" *) 239 | (* | COMPRESS_DEFLATE -> "COMPRESS=DEFLATE" *) 240 | (* | CONDSTORE -> "CONDSTORE" *) 241 | (* | ESEARCH -> "ESEARCH" *) 242 | (* | ENABLE -> "ENABLE" *) 243 | (* | IDLE -> "IDLE" *) 244 | (* | ID -> "ID" *) 245 | (* | LITERALPLUS -> "LITERAL+" *) 246 | (* | LITERALMINUS -> "LITERAL-" *) 247 | (* | UTF8_ACCEPT -> "UTF8=ACCEPT" *) 248 | (* | UTF8_ONLY -> "UTF8=ONLY" *) 249 | (* | MULTIAPPEND -> "MULTIAPPEND" *) 250 | (* | NAMESPACE -> "NAMESPACE" *) 251 | (* | QRESYNC -> "QRESYNC" *) 252 | (* | QUOTE -> "QUOTE" *) 253 | (* | SORT -> "SORT" *) 254 | (* | STARTTLS -> "STARTTLS" *) 255 | (* | UIDPLUS -> "UIDPLUS" *) 256 | (* | UNSELECT -> "UNSELECT" *) 257 | (* | XLIST -> "XLIST" *) 258 | (* | AUTH_ANONYMOUS -> "AUTH=ANONYMOUS" *) 259 | (* | AUTH_LOGIN -> "AUTH=LOGIN" *) 260 | (* | AUTH_PLAIN -> "AUTH=PLAIN" *) 261 | (* | XOAUTH2 -> "XOAUTH2" *) 262 | (* | X_GM_EXT_1 -> "X-GM-EXT-1" *) 263 | (* | OTHER s -> s *) 264 | 265 | let flag_to_string = function 266 | | Answered -> "\\Answered" 267 | | Flagged -> "\\Flagged" 268 | | Deleted -> "\\Deleted" 269 | | Seen -> "\\Seen" 270 | | Draft -> "\\Draft" 271 | | Keyword s -> s 272 | | Extension s -> "\\" ^ s 273 | | Recent -> "\\Recent" 274 | | Any -> "\\*" 275 | 276 | let encode_flag f = Encoder.raw (flag_to_string f) 277 | 278 | type status = { 279 | messages : int option; 280 | recent : int option; 281 | uidnext : int32 option; 282 | uidvalidity : int32 option; 283 | unseen : int option; 284 | highestmodseq : int64 option; 285 | } 286 | 287 | let empty_status = 288 | { 289 | messages = None; 290 | recent = None; 291 | uidnext = None; 292 | uidvalidity = None; 293 | unseen = None; 294 | highestmodseq = None; 295 | } 296 | 297 | let update_status t = function 298 | | MESSAGES n -> { t with messages = Some n } 299 | | RECENT n -> { t with recent = Some n } 300 | | UIDNEXT n -> { t with uidnext = Some n } 301 | | UIDVALIDITY n -> { t with uidvalidity = Some n } 302 | | UNSEEN n -> { t with unseen = Some n } 303 | | HIGHESTMODSEQ n -> { t with highestmodseq = Some n } 304 | 305 | type state = { 306 | next_tag : int; 307 | current_tag : int option; 308 | status : status; 309 | flags : flag list option; 310 | } 311 | 312 | let messages { status = { messages; _ }; _ } = messages 313 | 314 | let recent { status = { recent; _ }; _ } = recent 315 | 316 | let flags { flags; _ } = flags 317 | 318 | let uidnext { status = { uidnext; _ }; _ } = uidnext 319 | 320 | let uidvalidity { status = { uidvalidity; _ }; _ } = uidvalidity 321 | 322 | let unseen { status = { unseen; _ }; _ } = unseen 323 | 324 | let highestmodseq { status = { highestmodseq; _ }; _ } = highestmodseq 325 | 326 | let initial = 327 | { next_tag = 1; current_tag = None; status = empty_status; flags = None } 328 | 329 | type ('a, 'b) step = 330 | | Send of string * ('a, 'b) step 331 | | Wait of (response -> ('a, 'b) step) 332 | | Partial of state * 'a * ('a, 'b) step 333 | | Done of state * 'b 334 | | Error of string 335 | 336 | type ('a, 'b) cmd = 337 | | Cmd : { 338 | format : Encoder.t; 339 | process : 'x -> untagged -> 'x * 'a option; 340 | init : 'x; 341 | finish : 'x -> 'b; 342 | } 343 | -> ('a, 'b) cmd 344 | 345 | let run t (Cmd { format; process; init; finish }) = 346 | assert (t.current_tag = None); 347 | 348 | let current_tag = t.next_tag in 349 | 350 | let process t init u wait = 351 | let t = 352 | match u with 353 | | EXISTS n -> { t with status = { t.status with messages = Some n } } 354 | | RECENT n -> { t with status = { t.status with recent = Some n } } 355 | | FLAGS l -> { t with flags = Some l } 356 | | EXPUNGE _ -> 357 | { 358 | t with 359 | status = 360 | { t.status with messages = Option.map pred t.status.messages }; 361 | } 362 | | STATUS (_, l) -> 363 | { t with status = List.fold_left update_status t.status l } 364 | | _ -> t 365 | in 366 | let init, partial = process init u in 367 | let next = Wait (wait t init) in 368 | match partial with Some x -> Partial (t, x, next) | None -> next 369 | in 370 | 371 | let rec aux t init accu = function 372 | | Encoder.Wait :: k -> 373 | let rec wait t init = function 374 | | Cont _ -> aux t init [] k 375 | | Untagged u -> process t init u wait 376 | | Tagged _ -> assert false 377 | in 378 | if accu = [] then Wait (wait t init) 379 | else Send (String.concat "" (List.rev accu), Wait (wait t init)) 380 | | Raw s :: k -> aux t init (s :: accu) k 381 | | Crlf :: k -> aux t init ("\r\n" :: accu) k 382 | | [] -> 383 | let rec wait t init = function 384 | | Cont _ -> assert false 385 | | Untagged u -> process t init u wait 386 | | Tagged { status = NO | BAD; message; _ } -> Error message 387 | | Tagged { status = OK; _ } -> Done (t, finish init) 388 | in 389 | if accu = [] then Wait (wait t init) 390 | else Send (String.concat "" (List.rev accu), Wait (wait t init)) 391 | in 392 | 393 | let t = 394 | { t with next_tag = current_tag + 1; current_tag = Some current_tag } 395 | in 396 | 397 | ( t, 398 | aux t init [] 399 | (Encoder.((raw (Printf.sprintf "%04d" current_tag) ++ format) & crlf) []) 400 | ) 401 | 402 | let simple format init = 403 | let process res _ = (res, None) in 404 | let finish res = res in 405 | Cmd { format; process; finish; init } 406 | 407 | let login username password = 408 | let format = Encoder.(str "LOGIN" ++ str username ++ str password) in 409 | simple format () 410 | 411 | (* let _capability = *) 412 | (* let format = Encoder.(str "CAPABILITY") in *) 413 | (* let process caps = function CAPABILITY caps1 -> caps1 :: caps | _ -> caps in *) 414 | (* let finish l = List.rev l |> List.flatten in *) 415 | (* Cmd { format; u = E ([], process, finish) } *) 416 | 417 | let create_mailbox m = 418 | let format = Encoder.(str "CREATE" ++ mutf7 m) in 419 | simple format () 420 | 421 | let delete m = 422 | let format = Encoder.(str "DELETE" ++ mutf7 m) in 423 | simple format () 424 | 425 | let rename m1 m2 = 426 | let format = Encoder.(str "RENAME" ++ mutf7 m1 ++ mutf7 m2) in 427 | simple format () 428 | 429 | let logout = 430 | let format = Encoder.(str "LOGOUT") in 431 | simple format () 432 | 433 | let noop = 434 | let format = Encoder.(str "NOOP") in 435 | simple format () 436 | 437 | let list ?(ref = "") s = 438 | let format = Encoder.(str "LIST" ++ mutf7 ref ++ str s) in 439 | let process res = function 440 | | LIST (flags, delim, mbox) -> ((flags, delim, mbox) :: res, None) 441 | | _ -> (res, None) 442 | in 443 | let finish = List.rev in 444 | Cmd { format; process; finish; init = [] } 445 | 446 | module Status = struct 447 | type 'a t = 448 | | MESSAGES : int t 449 | | RECENT : int t 450 | | UIDNEXT : int32 t 451 | | UIDVALIDITY : int32 t 452 | | UNSEEN : int t 453 | | HIGHESTMODSEQ : int64 t 454 | | PAIR : 'a t * 'b t -> ('a * 'b) t 455 | | MAP : ('a -> 'b) * 'a t -> 'b t 456 | 457 | let messages = MESSAGES 458 | 459 | let recent = RECENT 460 | 461 | let uidnext = UIDNEXT 462 | 463 | let uidvalidity = UIDVALIDITY 464 | 465 | let unseen = UNSEEN 466 | 467 | let highestmodseq = HIGHESTMODSEQ 468 | 469 | let pair t1 t2 = PAIR (t1, t2) 470 | 471 | let map f t = MAP (f, t) 472 | 473 | module E = Encoder 474 | 475 | let rec encode : type a. a t -> E.t = function 476 | | MESSAGES -> E.raw "MESSAGES" 477 | | RECENT -> E.raw "RECENT" 478 | | UIDNEXT -> E.raw "UIDNEXT" 479 | | UIDVALIDITY -> E.raw "UIDVALIDITY" 480 | | UNSEEN -> E.raw "UNSEEN" 481 | | HIGHESTMODSEQ -> E.raw "HIGHESTMODSEQ" 482 | | MAP (_, x) -> encode x 483 | | PAIR _ as x -> 484 | let rec go : type a. _ -> a t -> _ = 485 | fun acc x -> 486 | match x with PAIR (x, y) -> go (go acc x) y | x -> encode x :: acc 487 | in 488 | E.list (fun x -> x) (List.rev (go [] x)) 489 | 490 | let matches t a = 491 | let r = List.fold_left update_status empty_status a in 492 | let rec go : type a. a t -> a option = function 493 | | MESSAGES -> r.messages 494 | | RECENT -> r.recent 495 | | UIDNEXT -> r.uidnext 496 | | UIDVALIDITY -> r.uidvalidity 497 | | UNSEEN -> r.unseen 498 | | HIGHESTMODSEQ -> r.highestmodseq 499 | | PAIR (x, y) -> ( 500 | match (go x, go y) with Some x, Some y -> Some (x, y) | _ -> None ) 501 | | MAP (f, x) -> ( match go x with Some x -> Some (f x) | None -> None ) 502 | in 503 | go t 504 | end 505 | 506 | let status m att = 507 | let format = Encoder.(str "STATUS" ++ mutf7 m ++ Status.encode att) in 508 | let process res = function 509 | | STATUS (mbox, items) when m = mbox -> Status.matches att items 510 | | _ -> res 511 | in 512 | let process init u = (process init u, None) in 513 | let finish res = res in 514 | Cmd { format; process; finish; init = None } 515 | 516 | let copy nums mbox = 517 | let format = 518 | Encoder.(raw "UID COPY" ++ eset (Uint32.Set.of_list nums) ++ mutf7 mbox) 519 | in 520 | simple format () 521 | 522 | let expunge nums = 523 | let format = Encoder.(str "UID EXPUNGE" ++ eset (Uint32.Set.of_list nums)) in 524 | simple format () 525 | 526 | module Search = struct 527 | open Encoder 528 | 529 | type t = Encoder.t 530 | 531 | let all = raw "ALL" 532 | 533 | let answered = raw "ANSWERED" 534 | 535 | let bcc s = raw "BCC" ++ str s 536 | 537 | let before t = raw "BEFORE" ++ encode_date t 538 | 539 | let body s = raw "BODY" ++ str s 540 | 541 | let cc s = raw "CC" ++ str s 542 | 543 | let deleted = raw "DELETED" 544 | 545 | let draft = raw "DRAFT" 546 | 547 | let flagged = raw "FLAGGED" 548 | 549 | let from s = raw "FROM" ++ str s 550 | 551 | let header s1 s2 = raw "HEADER" ++ str s1 ++ str s2 552 | 553 | let keyword s = raw "KEYWORD" ++ str s 554 | 555 | let larger n = raw "LARGER" ++ int n 556 | 557 | let new_ = raw "NEW" 558 | 559 | let not k = raw "NOT" ++ p k 560 | 561 | let old = raw "OLD" 562 | 563 | let on t = raw "ON" ++ encode_date t 564 | 565 | let ( || ) k1 k2 = raw "OR" ++ p k1 ++ p k2 566 | 567 | let recent = raw "RECENT" 568 | 569 | let seen = raw "SEEN" 570 | 571 | let sent_before t = raw "SENTBEFORE" ++ encode_date t 572 | 573 | let sent_on t = raw "SENTON" ++ encode_date t 574 | 575 | let sent_since t = raw "SENTSINCE" ++ encode_date t 576 | 577 | let since t = raw "SINCE" ++ encode_date t 578 | 579 | let smaller n = raw "SMALLER" ++ int n 580 | 581 | let subject s = raw "SUBJECT" ++ str s 582 | 583 | let text s = raw "TEXT" ++ str s 584 | 585 | let to_ s = raw "TO" ++ str s 586 | 587 | let uid s = raw "UID" ++ eset (Uint32.Set.of_list s) 588 | 589 | let unanswered = raw "UNANSWERED" 590 | 591 | let undeleted = raw "UNDELETED" 592 | 593 | let undraft = raw "UNDRAFT" 594 | 595 | let unflagged = raw "UNFLAGGED" 596 | 597 | let unkeyword s = raw "UNKEYWORD" ++ str s 598 | 599 | let unseen = raw "UNSEEN" 600 | 601 | let ( && ) k1 k2 = p k1 ++ p k2 602 | 603 | let modseq n = raw "MODSEQ" ++ uint64 n 604 | 605 | let x_gm_raw s = raw "X-GM-RAW" ++ str s 606 | 607 | let x_gm_msgid n = raw "X-GM-MSGID" ++ uint64 n 608 | 609 | let x_gm_thrid n = raw "X-GM-THRID" ++ uint64 n 610 | 611 | let x_gm_labels l = raw "X-GM-LABELS" ++ list str l 612 | end 613 | 614 | let search sk = 615 | let format = Encoder.(raw "UID SEARCH" ++ sk) in 616 | let process res = function 617 | | SEARCH (ids, modseq) -> ((ids :: fst res, modseq), None) 618 | | _ -> (res, None) 619 | in 620 | let finish (ids, modseq) = (List.(rev ids |> flatten), modseq) in 621 | Cmd { format; process; finish; init = ([], None) } 622 | 623 | let select_gen cmd m = 624 | let arg = 625 | if false (* List.mem Capability.CONDSTORE imap.capabilities *) then 626 | " (CONDSTORE)" 627 | else "" 628 | in 629 | let format = Encoder.((raw cmd ++ mutf7 m) & raw arg) in 630 | simple format () 631 | 632 | let select = select_gen "SELECT" 633 | 634 | let examine = select_gen "EXAMINE" 635 | 636 | let append m ?flags ?date data = 637 | let flags = 638 | match flags with 639 | | None -> Encoder.empty 640 | | Some l -> Encoder.(raw " " & p (list encode_flag l)) 641 | in 642 | let internaldate = 643 | match date with 644 | | None -> Encoder.empty 645 | | Some s -> Encoder.(raw " " & str s) 646 | in 647 | let format = 648 | Encoder.((raw "APPEND" ++ mutf7 m) & flags & (internaldate ++ literal data)) 649 | in 650 | simple format () 651 | 652 | module Int32Map = Map.Make (Int32) 653 | 654 | module Fetch = struct 655 | type 'a t = 656 | | FLAGS : flag list t 657 | | ENVELOPE : envelope t 658 | | INTERNALDATE : string t 659 | | UID : int32 t 660 | | X_GM_MSGID : int64 t 661 | | X_GM_THRID : int64 t 662 | | X_GM_LABELS : string list t 663 | | RFC822 : string t 664 | | RFC822_TEXT : string t 665 | | RFC822_HEADER : string t 666 | | RFC822_SIZE : int t 667 | | BODY : mime t 668 | | BODYSTRUCTURE : mime t 669 | | MODSEQ : int64 t 670 | | PAIR : 'a t * 'b t -> ('a * 'b) t 671 | | MAP : ('a -> 'b) * 'a t -> 'b t 672 | 673 | let flags = FLAGS 674 | 675 | let envelope = ENVELOPE 676 | 677 | let internaldate = INTERNALDATE 678 | 679 | let uid = UID 680 | 681 | let x_gm_msgid = X_GM_MSGID 682 | 683 | let x_gm_thrid = X_GM_THRID 684 | 685 | let x_gm_labels = X_GM_LABELS 686 | 687 | let rfc822 = RFC822 688 | 689 | let rfc822_text = RFC822_TEXT 690 | 691 | let rfc822_header = RFC822_HEADER 692 | 693 | let rfc822_size = RFC822_SIZE 694 | 695 | let body = BODY 696 | 697 | let bodystructure = BODYSTRUCTURE 698 | 699 | let modseq = MODSEQ 700 | 701 | let map f x = MAP (f, x) 702 | 703 | let pair x y = PAIR (x, y) 704 | 705 | (* module Request = struct *) 706 | (* open Encoder *) 707 | 708 | (* let section_msgtext = function *) 709 | (* | HEADER -> raw "HEADER" *) 710 | (* | HEADER_FIELDS l -> raw "HEADER.FIELDS" ++ plist str l *) 711 | (* | HEADER_FIELDS_NOT l -> raw "HEADER.FIELDS.NOT" ++ plist str l *) 712 | (* | TEXT -> raw "TEXT" *) 713 | (* | MIME -> raw "MIME" *) 714 | 715 | (* let encode (nl, sec) = *) 716 | (* let sec = *) 717 | (* match sec with None -> empty | Some sec -> section_msgtext sec *) 718 | (* in *) 719 | (* match nl with [] -> sec | _ :: _ -> list ~sep:'.' int nl & raw "." & sec *) 720 | 721 | (* let header ?(part = []) () = (part, Some HEADER) *) 722 | 723 | (* let header_fields ?(part = []) l = (part, Some (HEADER_FIELDS l)) *) 724 | 725 | (* let header_fields_not ?(part = []) l = (part, Some (HEADER_FIELDS_NOT l)) *) 726 | 727 | (* let text ?(part = []) () = (part, Some TEXT) *) 728 | 729 | (* let part ~part () = (part, None) *) 730 | 731 | (* let mime ~part () = (part, Some MIME) *) 732 | (* end *) 733 | 734 | let rec encode : type a. a t -> Encoder.t = function 735 | | ENVELOPE -> Encoder.raw "ENVELOPE" 736 | | INTERNALDATE -> Encoder.raw "INTERNALDATE" 737 | | RFC822_HEADER -> Encoder.raw "RFC822.HEADER" 738 | | RFC822_SIZE -> Encoder.raw "RFC822.SIZE" 739 | | RFC822_TEXT -> Encoder.raw "RFC822.TEXT" 740 | | MODSEQ -> Encoder.raw "MODSEQ" 741 | | RFC822 -> Encoder.raw "RFC822" 742 | | BODY -> Encoder.raw "BODY" 743 | | BODYSTRUCTURE -> Encoder.raw "BODYSTRUCTURE" 744 | | UID -> Encoder.raw "UID" 745 | | FLAGS -> Encoder.raw "FLAGS" 746 | | X_GM_MSGID -> Encoder.raw "X-GM-MSGID" 747 | | X_GM_THRID -> Encoder.raw "X-GM-THRID" 748 | | X_GM_LABELS -> Encoder.raw "X-GM-LABELS" 749 | | PAIR _ as x -> 750 | let rec go : type a. _ -> a t -> _ = 751 | fun acc x -> 752 | match x with PAIR (x, y) -> go (go acc x) y | x -> encode x :: acc 753 | in 754 | Encoder.plist (fun x -> x) (List.rev (go [] x)) 755 | | MAP (_, x) -> encode x 756 | 757 | (* let body_section ?(peek = true) ?section:(sec = [], None) () = 758 | raw (if peek then "BODY.PEEK" else "BODY") & raw "[" & MIME.Request.encode sec & raw "]" *) 759 | 760 | type u = { 761 | flags : flag list option; 762 | uid : int32 option; 763 | envelope : envelope option; 764 | internaldate : string option; 765 | rfc822 : string option; 766 | rfc822_header : string option; 767 | rfc822_text : string option; 768 | rfc822_size : int option; 769 | body : mime option; 770 | bodystructure : mime option; 771 | modseq : int64 option; 772 | x_gm_msgid : int64 option; 773 | x_gm_thrid : int64 option; 774 | x_gm_labels : string list option; 775 | } 776 | 777 | let empty = 778 | { 779 | flags = None; 780 | uid = None; 781 | envelope = None; 782 | internaldate = None; 783 | rfc822 = None; 784 | rfc822_header = None; 785 | rfc822_text = None; 786 | rfc822_size = None; 787 | body = None; 788 | bodystructure = None; 789 | modseq = None; 790 | x_gm_msgid = None; 791 | x_gm_thrid = None; 792 | x_gm_labels = None; 793 | } 794 | 795 | let matches t a = 796 | let aux u = function 797 | | (FLAGS l : message_attribute) -> { u with flags = Some l } 798 | | UID n -> { u with uid = Some n } 799 | | ENVELOPE e -> { u with envelope = Some e } 800 | | INTERNALDATE x -> { u with internaldate = Some x } 801 | | RFC822 x -> { u with rfc822 = Some x } 802 | | RFC822_HEADER x -> { u with rfc822_header = Some x } 803 | | RFC822_TEXT x -> { u with rfc822_text = Some x } 804 | | RFC822_SIZE x -> { u with rfc822_size = Some x } 805 | | BODY x -> { u with body = Some x } 806 | | BODYSTRUCTURE x -> { u with bodystructure = Some x } 807 | | MODSEQ x -> { u with modseq = Some x } 808 | | X_GM_MSGID x -> { u with x_gm_msgid = Some x } 809 | | X_GM_THRID x -> { u with x_gm_thrid = Some x } 810 | | X_GM_LABELS l -> { u with x_gm_labels = Some l } 811 | | BODY_SECTION _ -> u 812 | (* TODO *) 813 | in 814 | let u = List.fold_left aux empty a in 815 | let rec go : type a. a t -> a option = 816 | fun t -> 817 | match t with 818 | | FLAGS -> u.flags 819 | | UID -> u.uid 820 | | ENVELOPE -> u.envelope 821 | | INTERNALDATE -> u.internaldate 822 | | RFC822 -> u.rfc822 823 | | RFC822_HEADER -> u.rfc822_header 824 | | RFC822_TEXT -> u.rfc822_text 825 | | RFC822_SIZE -> u.rfc822_size 826 | | BODY -> u.body 827 | | BODYSTRUCTURE -> u.bodystructure 828 | | MODSEQ -> u.modseq 829 | | X_GM_MSGID -> u.x_gm_msgid 830 | | X_GM_THRID -> u.x_gm_thrid 831 | | X_GM_LABELS -> u.x_gm_labels 832 | | MAP (f, t) -> ( match go t with Some x -> Some (f x) | None -> None ) 833 | | PAIR (t1, t2) -> ( 834 | match (go t1, go t2) with 835 | | Some x1, Some x2 -> Some (x1, x2) 836 | | _ -> None ) 837 | in 838 | go t 839 | end 840 | 841 | let fetch ?since nums att = 842 | let open Encoder in 843 | let attx = Fetch.encode att in 844 | let changed_since = 845 | match since with 846 | | None -> empty 847 | | Some m -> p (raw " CHANGEDSINCE" ++ uint64 m ++ raw "VANISHED") 848 | in 849 | let format = 850 | (raw "UID FETCH" ++ eset (Uint32.Set.of_list nums) ++ attx) & changed_since 851 | in 852 | let process () = function 853 | | FETCH (_seq, items) -> ((), Fetch.matches att items) 854 | | _ -> ((), None) 855 | in 856 | Cmd { format; process; finish = ignore; init = () } 857 | 858 | type store_mode = Add | Remove | Set 859 | 860 | type _ store_kind = Flags : flag store_kind | Labels : string store_kind 861 | 862 | type 'a store_cmd = ?before:int64 -> int32 list -> 'a list -> (unit, unit) cmd 863 | 864 | let store (type a) mode (att : a store_kind) ?before nums (l : a list) = 865 | let open Encoder in 866 | let base = 867 | let mode = match mode with Add -> "+" | Set -> "" | Remove -> "-" in 868 | let name = match att with Flags -> "FLAGS" | Labels -> "X-GM-LABELS" in 869 | Printf.sprintf "%s%s.SILENT" mode name 870 | in 871 | let att = 872 | match att with Flags -> list encode_flag l | Labels -> list label l 873 | in 874 | let unchanged_since = 875 | match before with 876 | | None -> str "" 877 | | Some m -> p (raw "UNCHANGEDSINCE" ++ uint64 m) 878 | in 879 | let format = 880 | raw "UID STORE" 881 | ++ eset (Uint32.Set.of_list nums) 882 | ++ unchanged_since ++ raw base ++ p att 883 | in 884 | simple format () 885 | 886 | let add_flags ?before uids l = store Add Flags ?before uids l 887 | 888 | let set_flags ?before uids l = store Set Flags ?before uids l 889 | 890 | let remove_flags ?before uids l = store Remove Flags ?before uids l 891 | 892 | let add_labels ?before uids l = store Add Labels ?before uids l 893 | 894 | let remove_labels ?before uids l = store Remove Labels ?before uids l 895 | 896 | let set_labels ?before uids l = store Set Labels ?before uids l 897 | 898 | (* let _enable caps = *) 899 | (* let format = Encoder.(str "ENABLE" ++ list encode_capability caps) in *) 900 | (* simple format () *) 901 | -------------------------------------------------------------------------------- /lib/cmd.mli: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2015-2018 Nicolas Ojeda Bar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. *) 22 | 23 | open Response 24 | 25 | type uid = private int32 26 | 27 | type modseq = private int64 28 | 29 | type state 30 | (** The type of IMAP connections. Values of type [t] keep track of the implicit 31 | state in IMAP connections: number of unseen messages, total number of 32 | messages in the current mailbox, etc. Note that this state can be updated 33 | during the execution of almost any IMAP command. *) 34 | 35 | val messages : state -> int option 36 | (** Returns the number of messages in the selected mailbox. The server can 37 | update this count during most any interaction. 38 | 39 | This operation does not communicate with the server. It merely reports the 40 | result of previous communication. *) 41 | 42 | val recent : state -> int option 43 | (** Returns the number of "recent" messages in the currently selected mailbox, 44 | as most recently reported by the server. The server can update this count 45 | during most any interaction. 46 | 47 | This operation does not communicate with the server. It merely reports the 48 | result of previous communication. *) 49 | 50 | val flags : state -> flag list option 51 | (** Returns the set of flags supported by currently selected mailbox, as most 52 | recently reported by the server. 53 | 54 | This operation does not communicate with the server. It merely reports the 55 | result of previous communication. *) 56 | 57 | val uidnext : state -> uid option 58 | (** Returns the predicted next uid for a message in the currently selected 59 | mailbox, as most recently reported by the server. The server can update this 60 | count during most any interaction. Old IMAP servers might not report this 61 | value, in which case the result is [None]. 62 | 63 | This operation does not communicate with the server. It merely reports the 64 | result of previous communication. *) 65 | 66 | val uidvalidity : state -> uid option 67 | (** Returns an id number that changes when all uids become invalid. The server 68 | cannot update this number during a session. Old IMAP servers might not 69 | report this value, in which case the result is [None]. 70 | 71 | This operation does not communicate with the server. It merely reports the 72 | result of previous communication. *) 73 | 74 | val unseen : state -> int option 75 | (** Returns the number of "unseen" messages in the currently selected mailbox, 76 | as most recently reported by the server. The server can update this count 77 | during most any interaction. Old IMAP servers might not report this value, 78 | in which case the result is [None]. 79 | 80 | This operation does not communicate with the server. It merely reports the 81 | result of previous communication. *) 82 | 83 | val highestmodseq : state -> modseq option 84 | 85 | type ('a, 'b) cmd 86 | (** The type of IMAP commands which return a response of type ['a]. *) 87 | 88 | val initial : state 89 | 90 | type ('a, 'b) step = 91 | | Send of string * ('a, 'b) step 92 | | Wait of (response -> ('a, 'b) step) 93 | | Partial of state * 'a * ('a, 'b) step 94 | | Done of state * 'b 95 | | Error of string 96 | 97 | val run : state -> ('a, 'b) cmd -> state * ('a, 'b) step 98 | 99 | (** {2 IMAP Commands} *) 100 | 101 | val login : string -> string -> (unit, unit) cmd 102 | 103 | val logout : (unit, unit) cmd 104 | 105 | (* val poll : unit -> (unit -> unit) * (unit, unit) cmd *) 106 | 107 | val create_mailbox : string -> (unit, unit) cmd 108 | (** Creates mailbox. (It must not exist already.) *) 109 | 110 | val delete : string -> (unit, unit) cmd 111 | (** [delete imap name] deletes mailbox [name]. *) 112 | 113 | val rename : string -> string -> (unit, unit) cmd 114 | (** [rename imap oldname newname] renames mailbox [oldname] to [newname]. *) 115 | 116 | val noop : (unit, unit) cmd 117 | (** [noop imap] sends a "no-op" message to the server, typically to keep the 118 | session alive. As for many commands, the server may report message-state 119 | updates or expunges, which are recorded in [imap]. *) 120 | 121 | val list : 122 | ?ref:string -> 123 | string -> 124 | (unit, (mailbox_flag list * char option * string) list) cmd 125 | (** [list imap ref m] returns the list of mailboxes with names matching 126 | [ref]. *) 127 | 128 | module Status : sig 129 | type 'a t 130 | 131 | val messages : int t 132 | (** Number of messages. *) 133 | 134 | val recent : int t 135 | (** Number of recent messages. *) 136 | 137 | val uidnext : uid t 138 | (** Uid for next received message. *) 139 | 140 | val uidvalidity : uid t 141 | (** Id that changes when uids are modified. *) 142 | 143 | val unseen : int t 144 | (** Number of unseen messages. *) 145 | 146 | val highestmodseq : modseq t 147 | 148 | val pair : 'a t -> 'b t -> ('a * 'b) t 149 | 150 | val map : ('a -> 'b) -> 'a t -> 'b t 151 | end 152 | 153 | val status : string -> 'a Status.t -> (unit, 'a option) cmd 154 | (** Requests information about a mailbox from the server, typically not the 155 | currently selected mailbox. *) 156 | 157 | val copy : uid list -> string -> (unit, unit) cmd 158 | (** Copies the specified messages from the currently selected mailbox to the 159 | specified mailbox. 160 | 161 | Messages are specified by the *) 162 | 163 | val expunge : uid list -> (unit, unit) cmd 164 | (** Purges messages with the given uids which are {e also} marked with the 165 | [Deleted] flag from the mailbox. *) 166 | 167 | (** {2 Searching for messages} *) 168 | 169 | module Search : sig 170 | type t 171 | (** Message search *) 172 | 173 | val all : t 174 | (** All messages in the mailbox. *) 175 | 176 | val answered : t 177 | (** Messages with the [Answered] flag set. *) 178 | 179 | val bcc : string -> t 180 | (** Messages that contain the specified string in the envelope structure's 181 | "BCC" field. *) 182 | 183 | val before : date -> t 184 | (** Messages whose internal date (disregarding time and timezone) is earlier 185 | than the specified date. *) 186 | 187 | val body : string -> t 188 | (** Messages that contain the specified string in the body of the message. *) 189 | 190 | val cc : string -> t 191 | (** Messages that contain the specified string in the envelope structure's 192 | "CC" field. *) 193 | 194 | val deleted : t 195 | (** Messages with the [Deleted] {!flag} set. *) 196 | 197 | val draft : t 198 | (** Messages with the [Draft] {!flag} set. *) 199 | 200 | val flagged : t 201 | (** Messages with the [Flagged] {!flag} set. *) 202 | 203 | val from : string -> t 204 | (** Messages with FROM field containing given string. *) 205 | 206 | val header : string -> string -> t 207 | (** Messages with headers with the specified field-name and that 208 | contains the specified string in the text of the header (what comes after 209 | the colon). *) 210 | 211 | val keyword : string -> t 212 | (** Messages with the specified [Keyword] {!flag} set. *) 213 | 214 | val larger : int -> t 215 | (** Messages with size at least the given number of bytes. *) 216 | 217 | val new_ : t 218 | (** Messages that have the [Recent] {!flag} set but not the [Seen] {!flag}. *) 219 | 220 | val not : t -> t 221 | (** Negation of search criteria. *) 222 | 223 | val old : t 224 | (** Messages that do not have the [Recent] {!flag} set. *) 225 | 226 | val on : date -> t 227 | (** Messages whose internal date (disregarding time and timezone) is within 228 | the specified date. *) 229 | 230 | val ( || ) : t -> t -> t 231 | (** OR of search criteria. *) 232 | 233 | val recent : t 234 | (** Messages that have the [Recent] {!flag} set. *) 235 | 236 | val seen : t 237 | (** Messages that have the [Seen] {!flag} set. *) 238 | 239 | val sent_before : date -> t 240 | (** Messages whose "Date:" header (disregarding time and timezone) is earlier 241 | than the specified date. *) 242 | 243 | val sent_on : date -> t 244 | (** Messages whose "Date:" header (disregarding time and timezone) is within 245 | the specified date. *) 246 | 247 | val sent_since : date -> t 248 | (** Messages whose "Date:" header (disregarding time and timezone) is within 249 | or later than the specified date. *) 250 | 251 | val since : date -> t 252 | (** Messages whose internal date (disregarding time and timezone) is within or 253 | later than the specified date. *) 254 | 255 | val smaller : int -> t 256 | (** Messages with a size smaller than the specified number of octets. *) 257 | 258 | val subject : string -> t 259 | (** Messages that contain the specified string in the envelope structure's 260 | "SUBJECT" field. *) 261 | 262 | val text : string -> t 263 | (** Messages that contain the specified string in the header or body of the 264 | message. *) 265 | 266 | val to_ : string -> t 267 | (** Messages that contain the specified string in the envelope structure's 268 | "TO" field. *) 269 | 270 | val uid : uid list -> t 271 | (** Messages with UID in the given set. *) 272 | 273 | val unanswered : t 274 | (** Messages that do not have the [Answered] {!flag} set. *) 275 | 276 | val undeleted : t 277 | (** Messages that do not have the [Deleted] {!flag} set. *) 278 | 279 | val undraft : t 280 | (** Messages that do not have the [`Draft] {!flag} set. *) 281 | 282 | val unflagged : t 283 | (** Messages that do not have the [`Flagged] {!flag} set. *) 284 | 285 | val unkeyword : string -> t 286 | (** Messages that do not have the specified tword {!flag} set. *) 287 | 288 | val unseen : t 289 | (** Messages that do not have the [`Seen] {!flag} set. *) 290 | 291 | val ( && ) : t -> t -> t 292 | (** Messages that satisfy both search criteria. *) 293 | 294 | val modseq : modseq -> t 295 | (** Messages that have equal or greater modification sequence numbers. *) 296 | 297 | val x_gm_raw : string -> t 298 | (** Gmail search string *) 299 | 300 | val x_gm_msgid : int64 -> t 301 | (** Messages with a given Gmail Message ID. *) 302 | 303 | val x_gm_thrid : int64 -> t 304 | (** Messages with a given Gmail Thread ID. *) 305 | 306 | val x_gm_labels : string list -> t 307 | (** Messages with given Gmail labels. *) 308 | end 309 | 310 | val search : Search.t -> (unit, uid list * modseq option) cmd 311 | (** Returns the uids of messages satisfying the search criteria. *) 312 | 313 | val examine : string -> (unit, unit) cmd 314 | (** [select imap m] selects the mailbox [m] for access. *) 315 | 316 | val select : string -> (unit, unit) cmd 317 | (** [select imap m] selects the mailbox [m] for access. *) 318 | 319 | val append : 320 | string -> ?flags:flag list -> ?date:string -> string -> (unit, unit) cmd 321 | (** Adds a new message (containing message) to the given mailbox. *) 322 | 323 | (** {2 Fetch message data} *) 324 | 325 | module Fetch : sig 326 | type 'a t 327 | 328 | val flags : flag list t 329 | (** The list of message flags. *) 330 | 331 | val envelope : envelope t 332 | 333 | val internaldate : string t 334 | 335 | val uid : uid t 336 | (** The message uid. *) 337 | 338 | val x_gm_msgid : int64 t 339 | (** The Gmail message id. *) 340 | 341 | val x_gm_thrid : int64 t 342 | (** The Gmail thread id. *) 343 | 344 | val x_gm_labels : string list t 345 | (** The list of Gmail labels. *) 346 | 347 | val rfc822 : string t 348 | (** The raw RFC822 message contents. *) 349 | 350 | val rfc822_text : string t 351 | 352 | val rfc822_header : string t 353 | 354 | val rfc822_size : int t 355 | 356 | val body : mime t 357 | 358 | val bodystructure : mime t 359 | 360 | val modseq : modseq t 361 | (** The message modification sequence number. *) 362 | 363 | val map : ('a -> 'b) -> 'a t -> 'b t 364 | 365 | val pair : 'a t -> 'b t -> ('a * 'b) t 366 | end 367 | 368 | val fetch : ?since:modseq -> uid list -> 'a Fetch.t -> ('a, unit) cmd 369 | (** [fetch ?since uids fields] downloads information for a set of messages, 370 | specified by their uids [uids]. The [fields] argument specifies the type of 371 | information to download for each message. The available fields are specified 372 | above. 373 | 374 | The return value is a list of entry items in parallel to [uids]. 375 | 376 | If the [?since] argument is passed, only data for those messages with 377 | modification sequence value no less than this value will be fetched. *) 378 | 379 | (** {2 Modifying message metadata} *) 380 | 381 | type 'a store_cmd = ?before:modseq -> uid list -> 'a list -> (unit, unit) cmd 382 | 383 | val add_flags : flag store_cmd 384 | (** [add_flags ?before uids flags] adds flags [flags] to a set of messages. 385 | 386 | The [uids] argument specifies a set of messages by their uids. 387 | 388 | If [?before] is present, then only those messages with modification sequence 389 | number at most the given value are affected. *) 390 | 391 | val set_flags : flag store_cmd 392 | (** Like {!add_flags} but changes the set of existing flags, instead of adding 393 | to it. *) 394 | 395 | val remove_flags : flag store_cmd 396 | (** Like {!add_flags}, but removes the given flags instead of adding them. *) 397 | 398 | val add_labels : string store_cmd 399 | (** Like {!add_flags}, but modifies the set of Gmail labels, instead of message 400 | flags. *) 401 | 402 | val set_labels : string store_cmd 403 | (** Like {!add_labels}, but changes the set of Gmail labels, instead of 404 | adding to it. *) 405 | 406 | val remove_labels : string store_cmd 407 | (** Like {!add_labels}, but removes from the set of Gmail labels, instead of 408 | adding to it. *) 409 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name imap) 3 | (public_name imap) 4 | (libraries uutf base64 re)) 5 | -------------------------------------------------------------------------------- /lib/parser.ml: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2015-2018 Nicolas Ojeda Bar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. *) 22 | 23 | open Response 24 | 25 | type buffer = { s : string; mutable p : int } 26 | 27 | let some x = Some x 28 | 29 | (* type 'a t = buffer -> ('a, string * int) result *) 30 | 31 | let return x _ = Ok x 32 | 33 | let ( *> ) p q buf = match p buf with Ok () -> q buf | Error _ as e -> e 34 | 35 | let ( <* ) p q buf = 36 | match p buf with 37 | | Ok _ as o -> ( match q buf with Ok () -> o | Error _ as e -> e ) 38 | | Error _ as e -> e 39 | 40 | let ( <$> ) f p buf = match p buf with Ok x -> Ok (f x) | Error _ as e -> e 41 | 42 | let ( >>= ) p f buf = match p buf with Ok x -> f x buf | Error _ as e -> e 43 | 44 | let ( >|= ) p f buf = match p buf with Ok x -> Ok (f x) | Error _ as e -> e 45 | 46 | let error buf = Error (buf.s, buf.p) 47 | 48 | let is_eol buf = Ok (buf.p >= String.length buf.s) 49 | 50 | let eol = is_eol >>= function true -> return () | false -> error 51 | 52 | let curr buf = 53 | if buf.p >= String.length buf.s then Ok '\000' else Ok buf.s.[buf.p] 54 | 55 | let next buf = 56 | assert (buf.p < String.length buf.s); 57 | buf.p <- buf.p + 1; 58 | Ok () 59 | 60 | let take n buf = 61 | if buf.p + n > String.length buf.s then ( 62 | buf.p <- String.length buf.s; 63 | error buf ) 64 | else 65 | let s = String.sub buf.s buf.p n in 66 | buf.p <- buf.p + n; 67 | Ok s 68 | 69 | let char c = curr >>= fun c1 -> if c1 = c then next else error 70 | 71 | let take_while1 f buf = 72 | let pos0 = buf.p in 73 | let pos = ref pos0 in 74 | while !pos < String.length buf.s && f buf.s.[!pos] do 75 | incr pos 76 | done; 77 | if pos0 = !pos then error buf 78 | else ( 79 | buf.p <- !pos; 80 | Ok (String.sub buf.s pos0 (!pos - pos0)) ) 81 | 82 | (* 83 | CHAR = %x01-7F 84 | ; any 7-bit US-ASCII character, 85 | excluding NUL 86 | 87 | CTL = %x00-1F / %x7F 88 | ; controls 89 | 90 | ATOM-CHAR = 91 | 92 | atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards / 93 | quoted-specials / resp-specials 94 | 95 | quoted-specials = DQUOTE / "\\" 96 | 97 | resp-specials = "]" 98 | 99 | list-wildcards = "%" / "*" 100 | 101 | atom = 1*ATOM-CHAR 102 | *) 103 | 104 | let is_atom_char = function 105 | | '(' | ')' | '{' | ' ' 106 | | '\x00' .. '\x1F' 107 | | '\x7F' | '%' | '*' | '"' | '\\' | ']' -> 108 | false 109 | | '\x01' .. '\x7F' -> true 110 | | _ -> false 111 | 112 | let atom = take_while1 is_atom_char 113 | 114 | (* 115 | quoted = DQUOTE *QUOTED-CHAR DQUOTE 116 | 117 | QUOTED-CHAR = / 118 | '\\' quoted-specials 119 | *) 120 | 121 | let quoted_char = 122 | curr >>= function 123 | | '\\' -> ( 124 | next *> curr >>= function 125 | | ('\\' | '"') as c -> next *> return c 126 | | _ -> error ) 127 | | '"' -> error 128 | | '\x01' .. '\x7f' as c -> next *> return c 129 | | _ -> error 130 | 131 | let quoted = 132 | let rec loop b = 133 | curr >>= function 134 | | '"' -> next *> return (Buffer.contents b) 135 | | _ -> 136 | quoted_char >>= fun c -> 137 | Buffer.add_char b c; 138 | loop b 139 | in 140 | char '"' >>= fun () -> loop (Buffer.create 17) 141 | 142 | (* 143 | number = 1*DIGIT 144 | ; Unsigned 32-bit integer 145 | ; (0 <= n < 4,294,967,296) 146 | 147 | nz-number = digit-nz *DIGIT 148 | ; Non-zero unsigned 32-bit integer 149 | ; (0 < n < 4,294,967,296) 150 | 151 | uniqueid = nz-number 152 | ; Strictly ascending 153 | *) 154 | 155 | let is_digit = function '0' .. '9' -> true | _ -> false 156 | 157 | let number = 158 | let f s = Scanf.sscanf s "%lu" (fun n -> n) in 159 | f <$> take_while1 is_digit 160 | 161 | let nz_number = number 162 | 163 | let uniqueid = number 164 | 165 | (* 166 | literal = "{" number "}" CRLF *CHAR8 167 | ; Number represents the number of CHAR8s 168 | 169 | string = quoted / literal 170 | *) 171 | 172 | let get_exactly n buf = 173 | if n + buf.p > String.length buf.s then error buf 174 | else 175 | let s = String.sub buf.s buf.p n in 176 | buf.p <- buf.p + n; 177 | Ok s 178 | 179 | let literal = 180 | char '{' *> number >>= fun n -> 181 | char '}' *> eol *> get_exactly (Int32.to_int n) 182 | 183 | let imap_string = 184 | curr >>= function '"' -> quoted | '{' -> literal | _ -> error 185 | 186 | (* 187 | ASTRING-CHAR = ATOM-CHAR / resp-specials 188 | 189 | astring = 1*ASTRING-CHAR / string 190 | *) 191 | 192 | let is_astring_char c = is_atom_char c || c = ']' 193 | 194 | let astring = 195 | curr >>= function 196 | | '"' | '{' -> imap_string 197 | | _ -> take_while1 is_astring_char 198 | 199 | (* 200 | nil = "NIL" 201 | 202 | nstring = string / nil 203 | *) 204 | 205 | let nstring = 206 | curr >>= function 207 | | '"' | '{' -> imap_string 208 | | _ -> char 'N' *> char 'I' *> char 'L' *> return "" 209 | 210 | (* 211 | TEXT-CHAR = 212 | 213 | text = 1*TEXT-CHAR 214 | *) 215 | 216 | let is_text_char = function 217 | | '\r' | '\n' -> false 218 | | '\x01' .. '\x7F' -> true 219 | | _ -> false 220 | 221 | let text = 222 | is_eol >>= function true -> return "" | false -> take_while1 is_text_char 223 | 224 | let is_text_other_char = function ']' -> false | c -> is_text_char c 225 | 226 | let text_1 = 227 | is_eol >>= function 228 | | true -> return "" 229 | | false -> take_while1 is_text_other_char 230 | 231 | (* 232 | mbx-list-sflag = "\Noselect" / "\Marked" / "\Unmarked" 233 | ; Selectability flags; only one per LIST response 234 | 235 | mbx-list-oflag = "\Noinferiors" / flag-extension 236 | ; Other flags; multiple possible per LIST response 237 | 238 | mbx-list-flags = *(mbx-list-oflag SP) mbx-list-sflag 239 | *(SP mbx-list-oflag) / 240 | mbx-list-oflag *(SP mbx-list-oflag) 241 | 242 | HasChildren = "\HasChildren" 243 | 244 | HasNoChildren = "\HasNoChildren" 245 | 246 | mbx-list-oflag =/ use-attr 247 | ; Extends "mbx-list-oflag" from IMAP base [RFC3501] 248 | 249 | use-attr = "\All" / "\Archive" / "\Drafts" / "\Flagged" / 250 | "\Junk" / "\Sent" / "\Trash" / use-attr-ext 251 | 252 | use-attr-ext = '\\' atom 253 | ; Reserved for future extensions. Clients 254 | ; MUST ignore list attributes they do not understand 255 | ; Server implementations MUST NOT generate 256 | ; extension attributes except as defined by 257 | ; future Standards-Track revisions of or 258 | ; extensions to this specification. 259 | *) 260 | 261 | let mbx_flag = 262 | char '\\' *> atom >|= fun a -> 263 | match String.lowercase_ascii a with 264 | | "noselect" -> Noselect 265 | | "marked" -> Marked 266 | | "unmarked" -> Unmarked 267 | | "noinferiors" -> Noinferiors 268 | | "haschildren" -> HasChildren 269 | | "hasnochildren" -> HasNoChildren 270 | | "all" -> All 271 | | "archive" -> Archive 272 | | "drafts" -> Drafts 273 | | "flagged" -> Flagged 274 | | "junk" -> Junk 275 | | "sent" -> Sent 276 | | "trash" -> Trash 277 | | _ -> Extension a 278 | 279 | let delim = 280 | curr >>= function 281 | | '"' -> some <$> (char '"' *> quoted_char <* char '"') 282 | | _ -> char 'N' *> char 'I' *> char 'L' *> return None 283 | 284 | (* 285 | mailbox = "INBOX" / astring 286 | ; INBOX is case-insensitive. All case variants of 287 | ; INBOX (e.g., "iNbOx") MUST be interpreted as INBOX 288 | ; not as an astring. An astring which consists of 289 | ; the case-insensitive sequence "I" "N" "B" "O" "X" 290 | ; is considered to be INBOX and not an astring. 291 | ; Refer to section 5.1 for further 292 | ; semantic details of mailbox names. 293 | *) 294 | 295 | let is_inbox s = 296 | String.length s = String.length "INBOX" && String.uppercase_ascii s = "INBOX" 297 | 298 | let mailbox = astring >|= fun s -> if is_inbox s then "INBOX" else s 299 | 300 | (* 301 | mailbox-list = "(" [mbx-list-flags] ")" SP 302 | (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox 303 | *) 304 | 305 | let plist p = 306 | char '(' *> curr >>= function 307 | | ')' -> next *> return [] 308 | | _ -> 309 | let rec loop acc = 310 | curr >>= function 311 | | ' ' -> next *> p >>= fun x -> loop (x :: acc) 312 | | ')' -> next *> return (List.rev acc) 313 | | _ -> error 314 | in 315 | p >>= fun x -> loop [ x ] 316 | 317 | let mailbox_list = 318 | plist mbx_flag >>= fun flags -> 319 | char ' ' *> delim >>= fun delim -> 320 | char ' ' *> mailbox >>= fun mbox -> return (flags, delim, mbox) 321 | 322 | (* 323 | auth-type = atom 324 | ; Defined by [SASL] 325 | 326 | capability = ("AUTH=" auth-type) / atom 327 | ; New capabilities MUST begin with "X" or be 328 | ; registered with IANA as standard or 329 | ; standards-track 330 | *) 331 | 332 | let capability = atom 333 | 334 | (* 335 | seq-number = nz-number / "*" 336 | ; message sequence number (COPY, FETCH, STORE 337 | ; commands) or unique identifier (UID COPY, 338 | ; UID FETCH, UID STORE commands). 339 | ; * represents the largest number in use. In 340 | ; the case of message sequence numbers, it is 341 | ; the number of messages in a non-empty mailbox. 342 | ; In the case of unique identifiers, it is the 343 | ; unique identifier of the last message in the 344 | ; mailbox or, if the mailbox is empty, the 345 | ; mailbox's current UIDNEXT value. 346 | ; The server should respond with a tagged BAD 347 | ; response to a command that uses a message 348 | ; sequence number greater than the number of 349 | ; messages in the selected mailbox. This 350 | ; includes "*" if the selected mailbox is empty. 351 | 352 | seq-range = seq-number ":" seq-number 353 | ; two seq-number values and all values between 354 | ; these two regardless of order. 355 | ; Example: 2:4 and 4:2 are equivalent and indicate 356 | ; values 2, 3, and 4. 357 | ; Example: a unique identifier sequence range of 358 | ; 3291:* includes the UID of the last message in 359 | ; the mailbox, even if that value is less than 3291. 360 | 361 | sequence-set = (seq-number / seq-range) *("," sequence-set) 362 | ; set of seq-number values, regardless of order. 363 | ; Servers MAY coalesce overlaps and/or execute the 364 | ; sequence in any order. 365 | ; Example: a message sequence number set of 366 | ; 2,4:7,9,12:* for a mailbox with 15 messages is 367 | ; equivalent to 2,4,5,6,7,9,12,13,14,15 368 | ; Example: a message sequence number set of *:4,5:7 369 | ; for a mailbox with 10 messages is equivalent to 370 | ; 10,9,8,7,6,5,4,5,6,7 and MAY be reordered and 371 | ; overlap coalesced to be 4,5,6,7,8,9,10. 372 | 373 | uid-set = (uniqueid / uid-range) *("," uid-set) 374 | 375 | uid-range = (uniqueid ":" uniqueid) 376 | ; two uniqueid values and all values 377 | ; between these two regards of order. 378 | ; Example: 2:4 and 4:2 are equivalent. 379 | *) 380 | 381 | let mod_sequence_value = 382 | let f s = Scanf.sscanf s "%Lu" (fun n -> n) in 383 | f <$> take_while1 is_digit 384 | 385 | let uid_range = 386 | uniqueid >>= fun n -> 387 | curr >>= function 388 | | ':' -> next *> uniqueid >|= fun m -> (n, m) 389 | | _ -> return (n, n) 390 | 391 | let uid_set = 392 | let rec loop acc = 393 | curr >>= function 394 | | ',' -> next *> uid_range >>= fun r -> loop (r :: acc) 395 | | _ -> return (List.rev acc) 396 | in 397 | uid_range >>= fun r -> loop [ r ] 398 | 399 | let sequence_set = uid_set 400 | 401 | let set = sequence_set 402 | 403 | (* 404 | flag-extension = "\\" atom 405 | ; Future expansion. Client implementations 406 | ; MUST accept flag-extension flags. Server 407 | ; implementations MUST NOT generate 408 | ; flag-extension flags except as defined by 409 | ; future standard or standards-track 410 | ; revisions of this specification. 411 | 412 | flag-keyword = atom 413 | 414 | flag = "\Answered" / "\Flagged" / "\Deleted" / 415 | "\Seen" / "\Draft" / flag-keyword / flag-extension 416 | ; Does not include "\Recent" 417 | 418 | flag-perm = flag / "\*" 419 | 420 | flag-fetch = flag / "\Recent" 421 | *) 422 | 423 | let flag_gen recent any = 424 | curr >>= function 425 | | '\\' -> ( 426 | next *> curr >>= function 427 | | '*' when any -> next *> return Any 428 | | _ -> ( 429 | atom >|= fun a -> 430 | match String.lowercase_ascii a with 431 | | "recent" when recent -> Recent 432 | | "answered" -> Answered 433 | | "flagged" -> Flagged 434 | | "deleted" -> Deleted 435 | | "seen" -> Seen 436 | | "draft" -> Draft 437 | | _ -> Extension a ) ) 438 | | _ -> atom >|= fun a -> Keyword a 439 | 440 | let flag = flag_gen false false 441 | 442 | let flag_fetch = flag_gen true false 443 | 444 | let flag_perm = flag_gen false true 445 | 446 | (* 447 | capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1" 448 | *(SP capability) 449 | ; Servers MUST implement the STARTTLS, AUTH=PLAIN, 450 | ; and LOGINDISABLED capabilities 451 | ; Servers which offer RFC 1730 compatibility MUST 452 | ; list "IMAP4" as the first capability. 453 | 454 | resp-text-code = "ALERT" / 455 | "BADCHARSET" [SP "(" astring *(SP astring) ")" ] / 456 | capability-data / "PARSE" / 457 | "PERMANENTFLAGS" SP "(" 458 | [flag-perm *(SP flag-perm)] ")" / 459 | "READ-ONLY" / "READ-WRITE" / "TRYCREATE" / 460 | "UIDNEXT" SP nz-number / "UIDVALIDITY" SP nz-number / 461 | "UNSEEN" SP nz-number / 462 | atom [SP 1*] 463 | 464 | resp-text-code =/ "HIGHESTMODSEQ" SP mod-sequence-value / 465 | "NOMODSEQ" / 466 | "MODIFIED" SP set 467 | 468 | resp-text-code =/ "CLOSED" 469 | 470 | append-uid = uniqueid 471 | 472 | resp-code-apnd = "APPENDUID" SP nz-number SP append-uid 473 | 474 | resp-code-copy = "COPYUID" SP nz-number SP uid-set SP uid-set 475 | 476 | resp-text-code =/ resp-code-apnd / resp-code-copy / "UIDNOTSTICKY" 477 | ; incorporated before the expansion rule of 478 | ; atom [SP 1*] 479 | ; that appears in [IMAP] 480 | 481 | resp-text-code =/ "COMPRESSIONACTIVE" 482 | 483 | 484 | resp-text-code =/ "USEATTR" 485 | ; Extends "resp-text-code" from 486 | ; IMAP [RFC3501] 487 | *) 488 | 489 | let append_uid = uniqueid 490 | 491 | let slist p = 492 | let rec loop acc = 493 | curr >>= function 494 | | ' ' -> next *> p >>= fun x -> loop (x :: acc) 495 | | _ -> return (List.rev acc) 496 | in 497 | loop [] 498 | 499 | let resp_text_code = 500 | char '[' *> atom 501 | >>= (function 502 | | "ALERT" -> return ALERT 503 | | "BADCHARSET" -> ( 504 | curr >>= function 505 | | ' ' -> next *> plist astring >|= fun l -> BADCHARSET l 506 | | _ -> return (BADCHARSET []) ) 507 | | "CAPABILITY" -> slist atom >|= fun l -> (CAPABILITY l : code) 508 | | "PARSE" -> return PARSE 509 | | "PERMANENTFLAGS" -> 510 | char ' ' *> plist flag_perm >|= fun l -> PERMANENTFLAGS l 511 | | "READ-ONLY" -> return READ_ONLY 512 | | "READ-WRITE" -> return READ_WRITE 513 | | "TRYCREATE" -> return TRYCREATE 514 | | "UIDNEXT" -> char ' ' *> nz_number >|= fun n -> (UIDNEXT n : code) 515 | | "UIDVALIDITY" -> 516 | char ' ' *> nz_number >|= fun n -> (UIDVALIDITY n : code) 517 | | "UNSEEN" -> 518 | char ' ' *> nz_number >|= fun n -> (UNSEEN (Int32.to_int n) : code) 519 | | "CLOSED" -> return CLOSED 520 | | "HIGHESTMODSEQ" -> 521 | char ' ' *> mod_sequence_value >|= fun n -> (HIGHESTMODSEQ n : code) 522 | | "NOMODSEQ" -> return NOMODSEQ 523 | | "MODIFIED" -> char ' ' *> set >|= fun set -> MODIFIED set 524 | | "APPENDUID" -> 525 | char ' ' *> nz_number >>= fun n -> 526 | char ' ' *> append_uid >|= fun uid -> APPENDUID (n, uid) 527 | | "COPYUID" -> 528 | char ' ' *> nz_number >>= fun n -> 529 | char ' ' *> set >>= fun s1 -> 530 | char ' ' *> set >|= fun s2 -> COPYUID (n, s1, s2) 531 | | "UIDNOTSTICKY" -> return UIDNOTSTICKY 532 | | "COMPRESSIONACTIVE" -> return COMPRESSIONACTIVE 533 | | "USEATTR" -> return USEATTR 534 | | a -> ( 535 | curr >>= function 536 | | ' ' -> text_1 >|= fun x -> OTHER (a, Some x) 537 | | _ -> return (OTHER (a, None)) )) 538 | <* char ']' 539 | 540 | (* 541 | resp-text = ["[" resp-text-code "]" SP] text 542 | *) 543 | 544 | let resp_text = 545 | (curr >>= function ' ' -> next | _ -> return ()) >>= fun () -> 546 | (curr >>= function '[' -> resp_text_code >|= Option.some | _ -> return None) 547 | >>= fun c -> 548 | (curr >>= function ' ' -> next | _ -> return ()) >>= fun () -> 549 | text >|= fun t -> (c, t) 550 | 551 | let search_sort_mod_seq = 552 | char '(' *> atom 553 | >>= (function "MODSEQ" -> char ' ' *> mod_sequence_value | _ -> error) 554 | <* char ')' 555 | 556 | (* 557 | address = "(" addr-name SP addr-adl SP addr-mailbox SP 558 | addr-host ")" 559 | 560 | addr-adl = nstring 561 | ; Holds route from [RFC-2822] route-addr if 562 | ; non-NIL 563 | 564 | addr-host = nstring 565 | ; NIL indicates [RFC-2822] group syntax. 566 | ; Otherwise, holds [RFC-2822] domain name 567 | 568 | addr-mailbox = nstring 569 | ; NIL indicates end of [RFC-2822] group; if 570 | ; non-NIL and addr-host is NIL, holds 571 | ; [RFC-2822] group name. 572 | ; Otherwise, holds [RFC-2822] local-part 573 | ; after removing [RFC-2822] quoting 574 | 575 | addr-name = nstring 576 | ; If non-NIL, holds phrase from [RFC-2822] 577 | ; mailbox after removing [RFC-2822] quoting 578 | *) 579 | 580 | let address = 581 | char '(' *> nstring >>= fun ad_name -> 582 | char ' ' *> nstring >>= fun ad_adl -> 583 | char ' ' *> nstring >>= fun ad_mailbox -> 584 | char ' ' *> nstring >>= fun ad_host -> 585 | char ')' *> return { ad_name; ad_adl; ad_mailbox; ad_host } 586 | 587 | (* 588 | envelope = "(" env-date SP env-subject SP env-from SP 589 | env-sender SP env-reply-to SP env-to SP env-cc SP 590 | env-bcc SP env-in-reply-to SP env-message-id ")" 591 | 592 | env-bcc = "(" 1*address ")" / nil 593 | 594 | env-cc = "(" 1*address ")" / nil 595 | 596 | env-date = nstring 597 | 598 | env-from = "(" 1*address ")" / nil 599 | 600 | env-in-reply-to = nstring 601 | 602 | env-message-id = nstring 603 | 604 | env-reply-to = "(" 1*address ")" / nil 605 | 606 | env-sender = "(" 1*address ")" / nil 607 | 608 | env-subject = nstring 609 | 610 | env-to = "(" 1*address ")" / nil 611 | *) 612 | 613 | let address_list = 614 | curr >>= function 615 | | '(' -> 616 | let rec loop acc = 617 | curr >>= function 618 | | ')' -> next *> return (List.rev acc) 619 | | _ -> address >>= fun ad -> loop (ad :: acc) 620 | in 621 | next *> loop [] 622 | | _ -> char 'N' *> char 'I' *> char 'L' *> return [] 623 | 624 | let envelope = 625 | char '(' *> nstring >>= fun env_date -> 626 | char ' ' *> nstring >>= fun env_subject -> 627 | char ' ' *> address_list >>= fun env_from -> 628 | char ' ' *> address_list >>= fun env_sender -> 629 | char ' ' *> address_list >>= fun env_reply_to -> 630 | char ' ' *> address_list >>= fun env_to -> 631 | char ' ' *> address_list >>= fun env_cc -> 632 | char ' ' *> address_list >>= fun env_bcc -> 633 | char ' ' *> nstring >>= fun env_in_reply_to -> 634 | char ' ' *> nstring >>= fun env_message_id -> 635 | char ')' 636 | *> return 637 | { 638 | env_date; 639 | env_subject; 640 | env_from; 641 | env_sender; 642 | env_reply_to; 643 | env_to; 644 | env_cc; 645 | env_bcc; 646 | env_in_reply_to; 647 | env_message_id; 648 | } 649 | 650 | (* 651 | body-extension = nstring / number / 652 | "(" body-extension *(SP body-extension) ")" 653 | ; Future expansion. Client implementations 654 | ; MUST accept body-extension fields. Server 655 | ; implementations MUST NOT generate 656 | ; body-extension fields except as defined by 657 | ; future standard or standards-track 658 | ; revisions of this specification. 659 | *) 660 | 661 | let _body_extension = error 662 | 663 | (* 664 | body-fld-param = "(" string SP string *(SP string SP string) ")" / nil 665 | 666 | body-fld-enc = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/ 667 | "QUOTED-PRINTABLE") DQUOTE) / string 668 | 669 | body-fld-id = nstring 670 | 671 | body-fld-desc = nstring 672 | 673 | body-fld-octets = number 674 | 675 | body-fields = body-fld-param SP body-fld-id SP body-fld-desc SP 676 | body-fld-enc SP body-fld-octets 677 | *) 678 | 679 | let body_fld_param = 680 | curr >>= function 681 | | '(' -> 682 | plist 683 | ( imap_string >>= fun x -> 684 | char ' ' *> imap_string >|= fun y -> (x, y) ) 685 | | _ -> char 'N' *> char 'I' *> char 'L' *> return [] 686 | 687 | let body_fld_octets = Int32.to_int <$> number 688 | 689 | let body_fields = 690 | body_fld_param >>= fun fld_params -> 691 | char ' ' *> (some <$> nstring) >>= fun fld_id -> 692 | char ' ' *> (some <$> nstring) >>= fun fld_desc -> 693 | char ' ' *> imap_string >>= fun fld_enc -> 694 | char ' ' *> body_fld_octets >|= fun fld_octets -> 695 | { fld_params; fld_id; fld_desc; fld_enc; fld_octets } 696 | 697 | (* 698 | body-fld-md5 = nstring 699 | 700 | body-fld-dsp = "(" string SP body-fld-param ")" / nil 701 | 702 | body-fld-lang = nstring / "(" string *(SP string) ")" 703 | 704 | body-fld-loc = nstring 705 | 706 | body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang 707 | [SP body-fld-loc *(SP body-extension)]]] 708 | ; MUST NOT be returned on non-extensible 709 | ; "BODY" fetch 710 | 711 | body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang 712 | [SP body-fld-loc *(SP body-extension)]]] 713 | ; MUST NOT be returned on non-extensible 714 | ; "BODY" fetch 715 | *) 716 | 717 | let body_fld_md5 = nstring 718 | 719 | let body_fld_dsp = 720 | curr >>= function 721 | | '(' -> 722 | next *> imap_string >>= fun s -> 723 | char ' ' *> body_fld_param >>= fun l -> char ')' *> return (Some (s, l)) 724 | | _ -> char 'N' *> char 'I' *> char 'L' *> return None 725 | 726 | let body_fld_lang = 727 | curr >>= function 728 | | '(' -> plist imap_string 729 | | _ -> ( nstring >|= function "" -> [] | s -> [ s ] ) 730 | 731 | let body_fld_loc = nstring 732 | 733 | let body_ext_1part = 734 | body_fld_md5 >>= fun _md5 -> 735 | curr >>= function 736 | | ' ' -> ( 737 | next *> body_fld_dsp >>= fun ext_dsp -> 738 | curr >>= function 739 | | ' ' -> ( 740 | next *> body_fld_lang >>= fun ext_lang -> 741 | curr >>= function 742 | | ' ' -> 743 | next *> body_fld_loc >|= fun ext_loc -> 744 | { ext_dsp; ext_lang; ext_loc; ext_ext = [] } 745 | | _ -> return { ext_dsp; ext_lang; ext_loc = ""; ext_ext = [] } ) 746 | | _ -> return { ext_dsp; ext_lang = []; ext_loc = ""; ext_ext = [] } ) 747 | | _ -> return { ext_dsp = None; ext_lang = []; ext_loc = ""; ext_ext = [] } 748 | 749 | let body_ext_mpart = 750 | body_fld_param >>= fun p -> 751 | (curr >>= function 752 | | ' ' -> ( 753 | next *> body_fld_dsp >>= fun _ -> 754 | curr >>= function 755 | | ' ' -> ( 756 | next *> body_fld_lang >>= fun _ -> 757 | curr >>= function 758 | | ' ' -> next *> body_fld_loc >|= ignore 759 | | _ -> return () ) 760 | | _ -> return () ) 761 | | _ -> return ()) 762 | *> return p 763 | 764 | (* 765 | body-fld-lines = number 766 | 767 | media-subtype = string 768 | ; Defined in [MIME-IMT] 769 | 770 | media-basic = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" / 771 | "MESSAGE" / "VIDEO") DQUOTE) / string) SP 772 | media-subtype 773 | ; Defined in [MIME-IMT] 774 | 775 | media-message = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE 776 | ; Defined in [MIME-IMT] 777 | 778 | media-text = DQUOTE "TEXT" DQUOTE SP media-subtype 779 | ; Defined in [MIME-IMT] 780 | 781 | body-type-basic = media-basic SP body-fields 782 | ; MESSAGE subtype MUST NOT be "RFC822" 783 | 784 | body-type-msg = media-message SP body-fields SP envelope 785 | SP body SP body-fld-lines 786 | 787 | body-type-text = media-text SP body-fields SP body-fld-lines 788 | 789 | body-type-1part = (body-type-basic / body-type-msg / body-type-text) 790 | [SP body-ext-1part] 791 | 792 | body-type-mpart = 1*body SP media-subtype 793 | [SP body-ext-mpart] 794 | 795 | body = "(" (body-type-1part / body-type-mpart) ")" 796 | *) 797 | 798 | let fix f = 799 | let rec p buf = f p buf in 800 | f p 801 | 802 | let body_fld_lines = Int32.to_int <$> number 803 | 804 | let body_type_msg body = 805 | body_fields >>= fun fields -> 806 | char ' ' *> envelope >>= fun envelope -> 807 | char ' ' *> body >>= fun b -> 808 | char ' ' *> body_fld_lines >|= fun fld_lines -> 809 | Message (fields, envelope, b, fld_lines) 810 | 811 | let body_type_text media_subtype = 812 | body_fields >>= fun fields -> 813 | char ' ' *> body_fld_lines >|= fun fld_lines -> 814 | Text (media_subtype, fields, fld_lines) 815 | 816 | let body_type_basic media_type media_subtype = 817 | body_fields >|= fun fields -> Basic (media_type, media_subtype, fields) 818 | 819 | let body_type_1part body = 820 | imap_string >>= fun media_type -> 821 | char ' ' *> imap_string >>= fun media_subtype -> 822 | ( match (media_type, media_subtype) with 823 | | "MESSAGE", "RFC822" -> char ' ' *> body_type_msg body 824 | | "TEXT", _ -> char ' ' *> body_type_text media_subtype 825 | | _ -> char ' ' *> body_type_basic media_type media_subtype ) 826 | >>= fun body -> 827 | (curr >>= function 828 | | ' ' -> next *> body_ext_1part >>= fun _ -> return () 829 | | _ -> return ()) 830 | *> return body 831 | 832 | let body_type_mpart body = 833 | let rec loop acc = 834 | curr >>= function 835 | | ' ' -> 836 | next *> imap_string >>= fun media_subtype -> 837 | (curr >>= function ' ' -> next *> body_ext_mpart | _ -> return []) 838 | >|= fun params -> Multipart (List.rev acc, media_subtype, params) 839 | | _ -> body >>= fun b -> loop (b :: acc) 840 | in 841 | loop [] 842 | 843 | let body body = 844 | char '(' *> curr 845 | >>= (function '(' -> body_type_mpart body | _ -> body_type_1part body) 846 | <* char ')' 847 | 848 | let body = fix body 849 | 850 | (* 851 | DIGIT = %x30-39 852 | ; 0-9 853 | 854 | date-day-fixed = (SP DIGIT) / 2DIGIT 855 | ; Fixed-format version of date-day 856 | 857 | date-month = "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" / 858 | "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec" 859 | 860 | time = 2DIGIT ":" 2DIGIT ":" 2DIGIT 861 | ; Hours minutes seconds 862 | 863 | zone = ("+" / "-") 4DIGIT 864 | ; Signed four-digit value of hhmm representing 865 | ; hours and minutes east of Greenwich (that is, 866 | ; the amount that the given time differs from 867 | ; Universal Time). Subtracting the timezone 868 | ; from the given time will give the UT form. 869 | ; The Universal Time zone is "+0000". 870 | 871 | date-year = 4DIGIT 872 | 873 | date-time = DQUOTE date-day-fixed "-" date-month "-" date-year 874 | SP time SP zone DQUOTE 875 | *) 876 | 877 | (* DD-MMM-YYYY HH:MM:SS +ZZZZ *) 878 | let date_time = char '"' *> take 26 <* char '"' 879 | 880 | (* 881 | header-fld-name = astring 882 | 883 | header-list = "(" header-fld-name *(SP header-fld-name) ")" 884 | 885 | section-msgtext = "HEADER" / "HEADER.FIELDS" [".NOT"] SP header-list / 886 | "TEXT" 887 | ; top-level or MESSAGE/RFC822 part 888 | 889 | section-part = nz-number *("." nz-number) 890 | ; body part nesting 891 | 892 | section-spec = section-msgtext / (section-part ["." section-text]) 893 | 894 | section-text = section-msgtext / "MIME" 895 | ; text other than actual body part (headers, etc.) 896 | 897 | section = "[" [section-spec] "]" 898 | *) 899 | 900 | let _section = error 901 | 902 | (* TODO *) 903 | 904 | (* 905 | msg-att-static = "ENVELOPE" SP envelope / "INTERNALDATE" SP date-time / 906 | "RFC822" [".HEADER" / ".TEXT"] SP nstring / 907 | "RFC822.SIZE" SP number / 908 | "BODY" ["STRUCTURE"] SP body / 909 | "BODY" section ["<" number ">"] SP nstring / 910 | "UID" SP uniqueid 911 | ; MUST NOT change for a message 912 | 913 | msg-att-dynamic = "FLAGS" SP "(" [flag-fetch *(SP flag-fetch)] ")" 914 | ; MAY change for a message 915 | 916 | msg-att = "(" (msg-att-dynamic / msg-att-static) 917 | *(SP (msg-att-dynamic / msg-att-static)) ")" 918 | 919 | permsg-modsequence = mod-sequence-value 920 | ;; per message mod-sequence 921 | 922 | mod-sequence-value = 1*DIGIT 923 | ;; Positive unsigned 64-bit integer 924 | ;; (mod-sequence) 925 | ;; (1 <= n < 18,446,744,073,709,551,615) 926 | 927 | fetch-mod-resp = "MODSEQ" SP "(" permsg-modsequence ")" 928 | 929 | msg-att-dynamic =/ fetch-mod-resp 930 | 931 | msg-att-dynamic =/ "X-GM-LABELS" SP "(" [astring 0*(SP astring)] ")" / nil 932 | ; https://developers.google.com/gmail/imap_extensions 933 | 934 | msg-att-static =/ "X-GM-MSGID" SP mod-sequence-value / 935 | "X-GM-THRID" SP mod-sequecne-value 936 | ; https://developers.google.com/gmail/imap_extensions 937 | *) 938 | 939 | let permsg_modsequence = mod_sequence_value 940 | 941 | let msg_att = 942 | atom >>= function 943 | | "FLAGS" -> 944 | char ' ' *> plist flag_fetch >|= fun l -> (FLAGS l : message_attribute) 945 | | "MODSEQ" -> 946 | char ' ' *> char '(' *> permsg_modsequence >>= fun n -> 947 | char ')' *> return (MODSEQ n) 948 | | "X-GM-LABELS" -> ( 949 | char ' ' *> curr >>= function 950 | | '(' -> plist astring >|= fun l -> X_GM_LABELS l 951 | | _ -> char 'N' *> char 'I' *> char 'L' *> return (X_GM_LABELS []) ) 952 | | "ENVELOPE" -> char ' ' *> envelope >|= fun e -> ENVELOPE e 953 | | "INTERNALDATE" -> char ' ' *> date_time >|= fun s -> INTERNALDATE s 954 | | "RFC822.HEADER" -> char ' ' *> nstring >|= fun s -> RFC822_HEADER s 955 | | "RFC822.TEXT" -> char ' ' *> nstring >|= fun s -> RFC822_TEXT s 956 | | "RFC822.SIZE" -> 957 | char ' ' *> number >|= fun n -> RFC822_SIZE (Int32.to_int n) 958 | | "RFC822" -> char ' ' *> nstring >|= fun s -> RFC822 s 959 | | "BODYSTRUCTURE" -> char ' ' *> body >|= fun b -> BODYSTRUCTURE b 960 | (* | "BODY" -> 961 | * let section = 962 | * section >>= fun s -> sp *> nstring >>| fun x -> 963 | * BODY_SECTION (s, x) 964 | * in 965 | * choice [sp *> body >>| (fun b -> BODY b); section] *) 966 | | "UID" -> char ' ' *> uniqueid >|= fun n -> UID n 967 | | "X-GM-MSGID" -> char ' ' *> mod_sequence_value >|= fun n -> X_GM_MSGID n 968 | | "X-GM-THRID" -> char ' ' *> mod_sequence_value >|= fun n -> X_GM_THRID n 969 | | _ -> error 970 | 971 | (* 972 | status = "STATUS" SP mailbox SP 973 | "(" status-att *(SP status-att) ")" 974 | 975 | status-att = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" / 976 | "UNSEEN" 977 | 978 | status-att-list = status-att SP number *(SP status-att SP number) 979 | 980 | mod-sequence-valzer = "0" / mod-sequence-value 981 | 982 | status-att-val =/ "HIGHESTMODSEQ" SP mod-sequence-valzer 983 | ;; extends non-terminal defined in [IMAPABNF]. 984 | ;; Value 0 denotes that the mailbox doesn't 985 | ;; support persistent mod-sequences 986 | ;; as described in Section 3.1.2 987 | *) 988 | 989 | let mod_sequence_valzer = 990 | let f s = Scanf.sscanf s "%Lu" (fun n -> n) in 991 | f <$> take_while1 is_digit 992 | 993 | let status_att = 994 | atom >>= function 995 | | "MESSAGES" -> char ' ' *> number >|= fun n -> MESSAGES (Int32.to_int n) 996 | | "RECENT" -> 997 | char ' ' *> number >|= fun n -> 998 | (RECENT (Int32.to_int n) : mailbox_attribute) 999 | | "UIDNEXT" -> char ' ' *> number >|= fun n -> UIDNEXT n 1000 | | "UIDVALIDITY" -> char ' ' *> number >|= fun n -> UIDVALIDITY n 1001 | | "UNSEEN" -> char ' ' *> number >|= fun n -> UNSEEN (Int32.to_int n) 1002 | | "HIGHESTMODSEQ" -> 1003 | char ' ' *> mod_sequence_valzer >|= fun n -> HIGHESTMODSEQ n 1004 | | _ -> error 1005 | 1006 | let known_ids = 1007 | uid_set >|= fun l -> 1008 | List.fold_left 1009 | (fun accu (n, m) -> Uint32.Set.add_interval n m accu) 1010 | Uint32.Set.empty l 1011 | 1012 | (* 1013 | resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text 1014 | ; Status condition 1015 | 1016 | mailbox-data = "FLAGS" SP flag-list / "LIST" SP mailbox-list / 1017 | "LSUB" SP mailbox-list / "SEARCH" *(SP nz-number) / 1018 | "STATUS" SP mailbox SP "(" [status-att-list] ")" / 1019 | number SP "EXISTS" / number SP "RECENT" 1020 | 1021 | message-data = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att)) 1022 | 1023 | resp-cond-bye = "BYE" SP resp-text 1024 | 1025 | response-data = "*" SP (resp-cond-state / resp-cond-bye / 1026 | mailbox-data / message-data / capability-data) CRLF 1027 | 1028 | search-sort-mod-seq = "(" "MODSEQ" SP mod-sequence-value ")" 1029 | 1030 | mailbox-data =/ "SEARCH" [1*(SP nz-number) SP 1031 | search-sort-mod-seq] 1032 | 1033 | known-uids = sequence-set 1034 | ;; sequence of UIDs, "*" is not allowed 1035 | 1036 | expunged-resp = "VANISHED" [SP "(EARLIER)"] SP known-uids 1037 | 1038 | message-data =/ expunged-resp 1039 | 1040 | enable-data = "ENABLED" *(SP capability) 1041 | 1042 | resp-cond-bye = "BYE" SP resp-text 1043 | 1044 | resp-cond-auth = ("OK" / "PREAUTH") SP resp-text 1045 | ; Authentication condition 1046 | 1047 | response-data =/ "*" SP enable-data CRLF 1048 | *) 1049 | 1050 | let response_data = 1051 | char '*' *> char ' ' *> curr >>= function 1052 | | '0' .. '9' -> ( 1053 | number >>= fun n -> 1054 | char ' ' *> atom >>= function 1055 | | "EXISTS" -> return (EXISTS (Int32.to_int n)) 1056 | | "RECENT" -> return (RECENT (Int32.to_int n)) 1057 | | "EXPUNGE" -> return (EXPUNGE n) 1058 | | "FETCH" -> char ' ' *> plist msg_att >|= fun x -> FETCH (n, x) 1059 | | _ -> error ) 1060 | | _ -> ( 1061 | atom >>= function 1062 | | "OK" -> 1063 | resp_text >|= fun (code, message) -> (OK { code; message } : untagged) 1064 | | "NO" -> 1065 | resp_text >|= fun (code, message) -> (NO { code; message } : untagged) 1066 | | "BAD" -> 1067 | resp_text >|= fun (code, message) -> (BAD { code; message } : untagged) 1068 | | "BYE" -> resp_text >|= fun (code, message) -> BYE { code; message } 1069 | | "FLAGS" -> char ' ' *> plist flag >|= fun l -> FLAGS l 1070 | | "LIST" -> char ' ' *> mailbox_list >|= fun (xs, c, m) -> LIST (xs, c, m) 1071 | | "LSUB" -> char ' ' *> mailbox_list >|= fun (xs, c, m) -> LSUB (xs, c, m) 1072 | | "SEARCH" -> 1073 | let rec loop acc = 1074 | curr >>= function 1075 | | ' ' -> ( 1076 | next *> curr >>= function 1077 | | '(' -> 1078 | search_sort_mod_seq >|= fun n -> 1079 | SEARCH (List.rev acc, Some n) 1080 | | _ -> nz_number >>= fun n -> loop (n :: acc) ) 1081 | | _ -> return (SEARCH (List.rev acc, None)) 1082 | in 1083 | loop [] 1084 | | "STATUS" -> 1085 | char ' ' *> mailbox >>= fun mbox -> 1086 | char ' ' *> plist status_att >|= fun l -> STATUS (mbox, l) 1087 | | "CAPABILITY" -> slist capability >|= fun l -> CAPABILITY l 1088 | | "ENABLED" -> slist capability >|= fun l -> ENABLED l 1089 | | "PREAUTH" -> resp_text >|= fun (code, text) -> PREAUTH (code, text) 1090 | | "VANISHED" -> ( 1091 | char ' ' *> curr >>= function 1092 | | '(' -> 1093 | (next *> atom >>= function "EARLIER" -> char ')' | _ -> error) 1094 | >>= fun () -> 1095 | char ' ' *> known_ids >|= fun ids -> VANISHED_EARLIER ids 1096 | | _ -> known_ids >|= fun ids -> VANISHED ids ) 1097 | | _ -> error ) 1098 | 1099 | (* 1100 | greeting = "*" SP (resp-cond-auth / resp-cond-bye) CRLF 1101 | 1102 | continue-req = "+" SP (resp-text / base64) CRLF 1103 | 1104 | tag = 1* 1105 | 1106 | response-tagged = tag SP resp-cond-state CRLF 1107 | 1108 | response-fatal = "*" SP resp-cond-bye CRLF 1109 | ; Server closes connection immediately 1110 | 1111 | response-done = response-tagged / response-fatal 1112 | *) 1113 | 1114 | let is_tag_char = function '+' -> false | c -> is_astring_char c 1115 | 1116 | let tag = take_while1 is_tag_char 1117 | 1118 | let resp_cond_state = 1119 | atom >>= function 1120 | | "OK" -> resp_text >|= fun (code, message) -> (OK, code, message) 1121 | | "NO" -> resp_text >|= fun (code, message) -> (NO, code, message) 1122 | | "BAD" -> resp_text >|= fun (code, message) -> (BAD, code, message) 1123 | | _ -> error 1124 | 1125 | let response = 1126 | curr >>= function 1127 | | '+' -> next *> resp_text >|= fun (_, x) -> Cont x 1128 | | '*' -> response_data >|= fun x -> Untagged x 1129 | | _ -> 1130 | tag >>= fun tag -> 1131 | char ' ' *> resp_cond_state >|= fun (status, code, message) -> 1132 | Tagged { tag; status; code; message } 1133 | 1134 | let response s p = response { s; p } 1135 | -------------------------------------------------------------------------------- /lib/parser.mli: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2015-2018 Nicolas Ojeda Bar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. *) 22 | 23 | val response : string -> int -> (Response.response, string * int) result 24 | -------------------------------------------------------------------------------- /lib/response.ml: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2015-2018 Nicolas Ojeda Bar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. *) 22 | 23 | type date = { day : int; month : int; year : int } 24 | 25 | module Uint32 : sig 26 | type t = int32 27 | 28 | module Set : sig 29 | type elt 30 | 31 | type t 32 | 33 | val empty : t 34 | 35 | val singleton : elt -> t 36 | 37 | val union : t -> t -> t 38 | 39 | val add : elt -> t -> t 40 | 41 | val add_interval : elt -> elt -> t -> t 42 | 43 | val of_list : elt list -> t 44 | 45 | val elements : t -> (elt * elt) list 46 | end 47 | with type elt := t 48 | end = struct 49 | type t = int32 50 | 51 | let msb n = Int32.(logand n (shift_left 1l 31)) <> 0l 52 | 53 | let compare n1 n2 = 54 | match (msb n1, msb n2) with 55 | | true, true -> 56 | Int32.(compare (logand n1 0x7fffffffl) (logand n2 0x7fffffffl)) 57 | | true, false -> 1 58 | | false, true -> -1 59 | | false, false -> Int32.compare n1 n2 60 | 61 | let succ n = Int32.succ n 62 | 63 | let ( < ) n m = compare n m < 0 64 | 65 | let ( <= ) n m = compare n m <= 0 66 | 67 | let min n m = if n <= m then n else m 68 | 69 | let max n m = if n <= m then m else n 70 | 71 | module Set = struct 72 | type t = (int32 * int32) list 73 | 74 | (* disjoint, sorted intervals *) 75 | 76 | let empty = [] 77 | 78 | let singleton n = [ (n, n) ] 79 | 80 | let elements x = x 81 | 82 | let rec union s1 s2 = 83 | let rec loop s1 s2 = 84 | match (s1, s2) with 85 | | [], s2 -> s2 86 | | s1, [] -> s1 87 | | (a, b) :: x1, (c, d) :: x2 -> 88 | if succ b < c then (a, b) :: loop x1 s2 89 | else if succ d < a then (c, d) :: loop s1 x2 90 | else union [ (min a c, max b d) ] (union x1 x2) 91 | in 92 | loop s1 s2 93 | 94 | let add n s = union (singleton n) s 95 | 96 | let add_interval n m s = if n <= m then union [ (n, m) ] s else s 97 | 98 | let of_list l = List.fold_left (fun s n -> add n s) empty l 99 | end 100 | end 101 | 102 | type flag = 103 | | Answered 104 | | Flagged 105 | | Deleted 106 | | Seen 107 | | Draft 108 | | Keyword of string 109 | | Extension of string 110 | | Recent 111 | | Any 112 | 113 | type code = 114 | | ALERT 115 | | BADCHARSET of string list 116 | | CAPABILITY of string list 117 | | PARSE 118 | | PERMANENTFLAGS of flag list 119 | | READ_ONLY 120 | | READ_WRITE 121 | | TRYCREATE 122 | | UIDNEXT of int32 123 | | UIDVALIDITY of int32 124 | | UNSEEN of int 125 | | OTHER of string * string option 126 | | CLOSED 127 | | HIGHESTMODSEQ of int64 128 | | NOMODSEQ 129 | | MODIFIED of (int32 * int32) list 130 | | APPENDUID of int32 * int32 131 | | COPYUID of int32 * (int32 * int32) list * (int32 * int32) list 132 | | UIDNOTSTICKY 133 | | COMPRESSIONACTIVE 134 | | USEATTR 135 | 136 | type mime_msgtext = 137 | | HEADER 138 | | HEADER_FIELDS of string list 139 | | HEADER_FIELDS_NOT of string list 140 | | TEXT 141 | | MIME 142 | 143 | type address = { 144 | ad_name : string; 145 | ad_adl : string; 146 | ad_mailbox : string; 147 | ad_host : string; 148 | } 149 | 150 | type envelope = { 151 | env_date : string; 152 | env_subject : string; 153 | env_from : address list; 154 | env_sender : address list; 155 | env_reply_to : address list; 156 | env_to : address list; 157 | env_cc : address list; 158 | env_bcc : address list; 159 | env_in_reply_to : string; 160 | env_message_id : string; 161 | } 162 | 163 | type mime_section = int list * mime_msgtext option 164 | 165 | type mime_fields = { 166 | fld_params : (string * string) list; 167 | fld_id : string option; 168 | fld_desc : string option; 169 | fld_enc : string; 170 | fld_octets : int; 171 | } 172 | 173 | type sexp = List of sexp list | Number of int32 | String of string 174 | 175 | type mime_extension = { 176 | ext_dsp : (string * (string * string) list) option; 177 | ext_lang : string list; 178 | ext_loc : string; 179 | ext_ext : sexp list; 180 | } 181 | 182 | type mime = 183 | | Text of string * mime_fields * int 184 | | Message of mime_fields * envelope * mime * int 185 | | Basic of string * string * mime_fields 186 | | Multipart of mime list * string * (string * string) list 187 | 188 | type message_attribute = 189 | | FLAGS of flag list 190 | | ENVELOPE of envelope 191 | | INTERNALDATE of string (* Date.t * Time.t *) 192 | | RFC822 of string 193 | | RFC822_HEADER of string 194 | | RFC822_TEXT of string 195 | | RFC822_SIZE of int 196 | | BODY of mime 197 | | BODYSTRUCTURE of mime 198 | | BODY_SECTION of mime_section * string option 199 | | UID of int32 200 | | MODSEQ of int64 201 | | X_GM_MSGID of int64 202 | | X_GM_THRID of int64 203 | | X_GM_LABELS of string list 204 | 205 | type mailbox_flag = 206 | | Noselect 207 | | Marked 208 | | Unmarked 209 | | Noinferiors 210 | | HasChildren 211 | | HasNoChildren 212 | | All 213 | | Archive 214 | | Drafts 215 | | Flagged 216 | | Junk 217 | | Sent 218 | | Trash 219 | | Extension of string 220 | 221 | type mailbox_attribute = 222 | | MESSAGES of int 223 | | RECENT of int 224 | | UIDNEXT of int32 225 | | UIDVALIDITY of int32 226 | | UNSEEN of int 227 | | HIGHESTMODSEQ of int64 228 | 229 | type untagged = 230 | | OK of { code : code option; message : string } 231 | | NO of { code : code option; message : string } 232 | | BAD of { code : code option; message : string } 233 | | BYE of { code : code option; message : string } 234 | | PREAUTH of code option * string 235 | | FLAGS of flag list 236 | | LIST of mailbox_flag list * char option * string 237 | | LSUB of mailbox_flag list * char option * string 238 | | SEARCH of int32 list * int64 option 239 | | STATUS of string * mailbox_attribute list 240 | | EXISTS of int 241 | | RECENT of int 242 | | EXPUNGE of int32 243 | | FETCH of int32 * message_attribute list 244 | | CAPABILITY of string list 245 | | VANISHED of Uint32.Set.t 246 | | VANISHED_EARLIER of Uint32.Set.t 247 | | ENABLED of string list 248 | 249 | type status = OK | NO | BAD 250 | 251 | type response = 252 | | Untagged of untagged 253 | | Cont of string 254 | | Tagged of { 255 | tag : string; 256 | status : status; 257 | code : code option; 258 | message : string; 259 | } 260 | -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name imap_unix) 3 | (public_name imap-unix) 4 | (libraries imap unix ssl)) 5 | -------------------------------------------------------------------------------- /unix/imap_unix.ml: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2015-2018 Nicolas Ojeda Bar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. *) 22 | 23 | open Imap 24 | 25 | module L = struct 26 | type state = Begin | Int of int | Cr of int | Lf of int 27 | 28 | let is_complete s len = 29 | assert (len <= Bytes.length s); 30 | let rec loop state i = 31 | if i >= len then None 32 | else 33 | match (state, Bytes.get s i) with 34 | | Begin, '{' -> loop (Int 0) (i + 1) 35 | | Int n, ('0' .. '9' as c) -> 36 | loop (Int ((10 * n) + Char.code c - Char.code '0')) (i + 1) 37 | | Int n, '}' -> loop (Cr n) (i + 1) 38 | | Begin, '\r' -> loop (Lf (-1)) (i + 1) 39 | | Cr n, '\r' -> loop (Lf n) (i + 1) 40 | | Lf -1, '\n' -> Some (i + 1) 41 | | Lf n, '\n' -> loop Begin (i + 1 + n) 42 | | _ -> loop Begin (i + 1) 43 | in 44 | loop Begin 0 45 | end 46 | 47 | type t = { 48 | mutable imap : Cmd.state; 49 | sock : Ssl.socket; 50 | mutable tag : int; 51 | mutable buf : Bytes.t; 52 | mutable len : int; 53 | } 54 | 55 | let parse t = 56 | let rec loop () = 57 | match L.is_complete t.buf t.len with 58 | | Some pos -> 59 | let s = Bytes.sub_string t.buf 0 pos in 60 | t.len <- t.len - pos; 61 | Bytes.blit t.buf pos t.buf 0 t.len; 62 | Printf.eprintf "S: %s\n%!" (String.sub s 0 (String.length s - 2)); 63 | s 64 | | None -> 65 | let n = Ssl.read t.sock t.buf t.len (Bytes.length t.buf - t.len) in 66 | t.len <- t.len + n; 67 | loop () 68 | in 69 | let s = loop () in 70 | match Parser.response s 0 with 71 | | Ok x -> x 72 | | Error _ -> failwith "parsing error" 73 | 74 | let really f ofs len = 75 | let rec loop ofs len = 76 | if len <= 0 then () 77 | else 78 | let n = f ofs len in 79 | loop (ofs + n) (len - n) 80 | in 81 | loop ofs len 82 | 83 | let run t cmd notify = 84 | let rec loop t imap = function 85 | | Cmd.Send (s, next) -> 86 | let b = Bytes.unsafe_of_string s in 87 | Printf.eprintf "C: %s\n%!" (Bytes.sub_string b 0 (Bytes.length b - 2)); 88 | really (Ssl.write t.sock b) 0 (Bytes.length b); 89 | loop t imap next 90 | | Wait next -> loop t imap (next (parse t)) 91 | | Partial (imap, x, next) -> 92 | notify x; 93 | loop t imap next 94 | | Done (imap, x) -> (imap, x) 95 | | Error s -> failwith s 96 | in 97 | let imap, state = Cmd.run t.imap cmd in 98 | let imap, x = loop t imap state in 99 | t.imap <- imap; 100 | x 101 | 102 | let ssl_init = Lazy.from_fun Ssl.init 103 | 104 | let connect ?(port = 993) host = 105 | Lazy.force ssl_init; 106 | let sock = 107 | let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in 108 | let he = Unix.gethostbyname host in 109 | let sa = Unix.ADDR_INET (he.Unix.h_addr_list.(0), port) in 110 | Ssl.open_connection_with_context ctx sa 111 | in 112 | let t = 113 | { imap = Cmd.initial; sock; tag = 1; buf = Bytes.create 4096; len = 0 } 114 | in 115 | match parse t with 116 | | Response.Untagged _ -> t 117 | | Tagged _ | Cont _ -> failwith "unexpected response" 118 | 119 | let disconnect t = Ssl.shutdown_connection t.sock 120 | -------------------------------------------------------------------------------- /unix/imap_unix.mli: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2015-2018 Nicolas Ojeda Bar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. *) 22 | 23 | type t 24 | (** The type for connections. *) 25 | 26 | val connect : ?port:int -> string -> t 27 | (** [connect ?port host]. *) 28 | 29 | val disconnect : t -> unit 30 | (** Disconnect. *) 31 | 32 | val run : t -> ('a, 'b) Imap.Cmd.cmd -> ('a -> unit) -> 'b 33 | (** Run an IMAP command. *) 34 | --------------------------------------------------------------------------------