├── test ├── mdir │ ├── cur │ │ └── .gitkeep │ └── tmp │ │ └── .gitkeep ├── cache │ ├── aspmx.pardot.com.dns │ ├── sgmail.github.com.dns │ ├── _dmarc.github.com.dns │ ├── bloomberg.net.dns │ ├── mail148.suw18.rsgsv.net.dns │ ├── _spf.google.com.dns │ ├── _dmarc.discoursemail.com.dns │ ├── _dmarc.janestreet.com.dns │ ├── janestreet.com.dns │ ├── _netblocks2.google.com.dns │ ├── github.com.dns │ ├── sendgrid.net.dns │ ├── _netblocks3.google.com.dns │ ├── _netblocks.google.com.dns │ ├── k1._domainkey.mailchimpapp.net.dns │ ├── pf2014._domainkey.github.com.dns │ ├── s20150108._domainkey.github.com.dns │ ├── smtpapi._domainkey.sendgrid.info.dns │ ├── et._spf.pardot.com.dns │ ├── google._domainkey.janestreet.com.dns │ ├── arc-20240116._domainkey.subspace.kernel.org.dns │ ├── k1._domainkey.mcc.mcsv.net.dns │ ├── whs1._domainkey.webhostingserver.nl.dns │ ├── arc-20160816._domainkey.google.com.dns │ ├── sjc2._domainkey.discoursemail.com.dns │ ├── arcselector10001._domainkey.microsoft.com.dns │ └── discoursemail.com.dns ├── dune ├── iso.t ├── server.t ├── okapi.t ├── map.t ├── descr.t ├── submit.t ├── mdir.t ├── send.t ├── pack.t ├── spf.t ├── wrap.t ├── arc.t ├── dkim.t ├── put.t ├── recv.t ├── make.t ├── addr.t ├── hdr.t ├── dmarc.t ├── 003.mail ├── 001.mail ├── 002.mail └── 004.mail ├── dune-project ├── lib ├── mbox.mli ├── blaze_tmp.mli ├── smart.mli ├── mbox_lexer.mll ├── pop3_miou_unix.mli ├── pop3.mli ├── dns_static.mli ├── blaze_tmp.ml ├── pack.mli ├── email.mli ├── dune ├── protocol.mli ├── mbox.ml ├── stem.ml ├── pop3.ml ├── pop3_miou_unix.ml ├── smart.ml ├── git_miou_unix.ml ├── dns_static.ml ├── pack.ml └── protocol.ml ├── .gitignore ├── .ocamlformat ├── bin ├── blaze.ml ├── doc.ml ├── rand.ml ├── iso.ml ├── crlf.ml ├── dune ├── okapi.ml ├── mdir.ml ├── blaze_mbox.ml ├── map.ml ├── addr.ml ├── descr.ml ├── recv.ml ├── hdr.ml └── fetch.ml ├── blaze.opam └── README.md /test/mdir/cur/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/mdir/tmp/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (cram enable) 3 | -------------------------------------------------------------------------------- /test/cache/aspmx.pardot.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 include:et._spf.pardot.com -all 2 | -------------------------------------------------------------------------------- /test/cache/sgmail.github.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:192.30.252.0/22 include:sendgrid.net ~all 2 | -------------------------------------------------------------------------------- /lib/mbox.mli: -------------------------------------------------------------------------------- 1 | val of_in_channel : in_channel -> [ `From of string | `Line of string ] Seq.t 2 | -------------------------------------------------------------------------------- /test/cache/_dmarc.github.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=DMARC1; p=reject; pct=100; rua=mailto:dmarc@github.com 2 | -------------------------------------------------------------------------------- /test/cache/bloomberg.net.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:69.184.0.0/13 ip4:199.172.169.0/24 ip4:208.22.56.0/24 -all 2 | -------------------------------------------------------------------------------- /test/cache/mail148.suw18.rsgsv.net.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:198.2.181.148 include:spf.mandrillapp.com -all 2 | -------------------------------------------------------------------------------- /test/cache/_spf.google.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 include:_netblocks.google.com include:_netblocks2.google.com include:_netblocks3.google.com ~all 2 | -------------------------------------------------------------------------------- /test/cache/_dmarc.discoursemail.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=DMARC1;p=quarantine;fo=1;rua=mailto:dmarc-reports@discourse.org;ruf=mailto:dmarc@discourse.org 2 | -------------------------------------------------------------------------------- /test/cache/_dmarc.janestreet.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=DMARC1;p=quarantine;rua=mailto:dmarc-reports-aggregate@janestreet.com; ruf=mailto:dmarc-reports-failure@janestreet.com; 2 | -------------------------------------------------------------------------------- /test/cache/janestreet.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 +ip4:38.105.200.78 +ip4:38.105.200.79 +ip4:64.215.233.18 +ip4:64.215.233.21 include:bloomberg.net include:_spf.google.com include:aspmx.pardot.com -all 2 | -------------------------------------------------------------------------------- /test/cache/_netblocks2.google.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip6:2001:4860:4000::/36 ip6:2404:6800:4000::/36 ip6:2607:f8b0:4000::/36 ip6:2800:3f0:4000::/36 ip6:2a00:1450:4000::/36 ip6:2c0f:fb50:4000::/36 ~all 2 | -------------------------------------------------------------------------------- /test/cache/github.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:192.30.252.0/22 include:_spf.google.com include:esp.github.com include:servers.mcsv.net include:_spf.salesforce.com include:spf.protection.outlook.com ~all 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps 3 | 001.mail 4 | 002.mail 5 | 003.mail 6 | 004.mail 7 | 005.mail 8 | 006.mail 9 | (source_tree mdir) 10 | (source_tree cache) 11 | %{bin:blaze})) 12 | -------------------------------------------------------------------------------- /test/cache/sendgrid.net.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:167.89.0.0/17 ip4:208.117.48.0/20 ip4:50.31.32.0/19 ip4:198.37.144.0/20 ip4:198.21.0.0/21 ip4:192.254.112.0/20 ip4:168.245.0.0/17 ip4:149.72.0.0/16 include:ab.sendgrid.net ~all 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | setup.data 3 | setup.log 4 | doc/*.html 5 | *.native 6 | *.byte 7 | *.so 8 | lib/decompress_conf.ml 9 | *.tar.gz 10 | _tests 11 | lib_test/files 12 | zpipe 13 | c/dpipe 14 | *.merlin 15 | *.install -------------------------------------------------------------------------------- /lib/blaze_tmp.mli: -------------------------------------------------------------------------------- 1 | val set_temp_dirname : string -> unit 2 | val get_temp_dirname : unit -> string 3 | 4 | val temp_filepath : 5 | ?clean:bool -> 6 | (int -> string, Format.formatter, unit, string) format4 -> 7 | string 8 | -------------------------------------------------------------------------------- /test/cache/_netblocks3.google.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:172.217.0.0/19 ip4:172.217.32.0/20 ip4:172.217.128.0/19 ip4:172.217.160.0/20 ip4:172.217.192.0/19 ip4:172.253.56.0/21 ip4:172.253.112.0/20 ip4:108.177.96.0/19 ip4:35.191.0.0/16 ip4:130.211.0.0/22 ~all 2 | -------------------------------------------------------------------------------- /test/cache/_netblocks.google.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:35.190.247.0/24 ip4:64.233.160.0/19 ip4:66.102.0.0/20 ip4:66.249.80.0/20 ip4:72.14.192.0/18 ip4:74.125.0.0/16 ip4:108.177.8.0/21 ip4:173.194.0.0/16 ip4:209.85.128.0/17 ip4:216.58.192.0/19 ip4:216.239.32.0/19 ~all 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.28.1 2 | break-infix = fit-or-vertical 3 | parse-docstrings = true 4 | indicate-multiline-delimiters=no 5 | nested-match=align 6 | sequence-style=separator 7 | break-before-in=auto 8 | if-then-else=keyword-first 9 | exp-grouping=preserve 10 | -------------------------------------------------------------------------------- /test/cache/k1._domainkey.mailchimpapp.net.dns: -------------------------------------------------------------------------------- 1 | txt:k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDbNrX2cY/GUKIFx2G/1I00ftdAj713WP9AQ1xir85i89sA2guU0ta4UX1Xzm06XIU6iBP41VwmPwBGRNofhBVR+e6WHUoNyIR4Bn84LVcfZE20rmDeXQblIupNWBqLXM1Q+VieI/eZu/7k9/vOkLSaQQdml4Cv8lb3PcnluMVIhQIDAQAB; 2 | -------------------------------------------------------------------------------- /test/cache/pf2014._domainkey.github.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDaCCQ+CiOqRkMAM/Oi04Xjhnxv3bXkTtA8KXt49RKQExLCmBxRpMp0PMMI73noKL/bZwEXljPO8HIfzG43ntPp1QRBUpn1UEvbp1/rlWPUop3i1j6aUpjxYGHEEzgmT+ncLUBDEPO4n4Zzt36DG3ZcJaLhvKtRkk2off5XD+BMvQIDAQAB 2 | -------------------------------------------------------------------------------- /test/cache/s20150108._domainkey.github.com.dns: -------------------------------------------------------------------------------- 1 | txt:k=rsa; t=s; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDF3DepunKacQZV1E0etEESNkTOG1GlIDm03+1gscZ7Tf/Vsyy9OMsTkOHFPNcbe7iBpJUfo3eC0jJGeHw+EKtvT5Ed2yDpGBxpWX8/TSW7lBrIOul2/QXoyWYXv7/EqWld/NZ+tyndBRPW+q6M2gILPrjdl9A/0TBCRZdGiAJDkwIDAQAB 2 | -------------------------------------------------------------------------------- /test/cache/smtpapi._domainkey.sendgrid.info.dns: -------------------------------------------------------------------------------- 1 | txt:k=rsa; t=s; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDPtW5iwpXVPiH5FzJ7Nrl8USzuY9zqqzjE0D1r04xDN6qwziDnmgcFNNfMewVKN2D1O+2J9N14hRprzByFwfQW76yojh54Xu3uSbQ3JP0A7k8o8GutRF8zbFUA8n0ZH2y0cIEjMliXY4W4LwPA7m4q0ObmvSjhd63O9d8z1XkUBwIDAQAB 2 | -------------------------------------------------------------------------------- /test/cache/et._spf.pardot.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:198.245.81.0/24 ip4:136.147.176.0/24 ip4:13.111.0.0/22 ip4:13.111.52.0/22 ip4:13.111.63.0/24 ip4:13.111.68.0/24 ip4:13.111.72.0/22 ip4:13.111.92.0/24 ip4:13.111.111.0/24 ip4:136.147.182.0/24 ip4:136.147.135.0/24 ip4:199.122.123.0/24 -all 2 | -------------------------------------------------------------------------------- /test/cache/google._domainkey.janestreet.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDZr8DcbuZ/BsBrNh7kyYIM6tO3Z4P3UQKuyKSN9nFmPlCmkYu7A6zm+069O3iwNUvyHwk+n67KyNzA6mC4B4/x/NHZ1gr6rXJoAha4ORxNPPpxUWKfYsCwnaSP9c8HgWOw4HigJReR5G1kiamGL+4BNy/WknWxT04E6I3c+KEOIQIDAQAB 2 | -------------------------------------------------------------------------------- /test/cache/arc-20240116._domainkey.subspace.kernel.org.dns: -------------------------------------------------------------------------------- 1 | txt:v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC8bBweNGbY7NPgfcmEcH//5Hg/lfNJwol10xQOOZsnvNR6pRDmop8Lph/A5Jy32VDw+c7uKS+x++090jnp6Upd7WiPzqelBKr/tNc1reJQJ6zkPtn6Z67F0iRUcKE+2q8q4JiB3qjJBQLpxNOyCJww1HS4kW4V6yNQHa4vETwGfwIDAQAB 2 | -------------------------------------------------------------------------------- /lib/smart.mli: -------------------------------------------------------------------------------- 1 | type error = 2 | [ Protocol.error 3 | | `No_branch 4 | | `Invalid_version of string 5 | | `Invalid_negotiation ] 6 | 7 | val pp_error : error Fmt.t 8 | 9 | val clone : 10 | protocol:[> `Git of string ] -> 11 | Protocol.ctx -> 12 | (string, 'r) Flux.Bqueue.t -> 13 | (bool, [> error ]) Protocol.t 14 | -------------------------------------------------------------------------------- /lib/mbox_lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | let from = ref "" 3 | let to_lf = ref "" 4 | let to_crlf = ref "" 5 | } 6 | 7 | rule token = parse 8 | (* | "From " ([^ '\n']* as str) "\n" { from := str; 0x200 } *) 9 | | ([^ '\r' '\n' ]* as v) "\r\n" { to_crlf := v ^ "\r\n"; 0x300 } 10 | | ([^ '\r' '\n' ]* as v) "\n" { to_lf := v ^ "\n"; 0x200 } 11 | | "\r\n" { 0x100 } 12 | | _ as chr { Char.code chr } 13 | | eof { 0x500 } 14 | -------------------------------------------------------------------------------- /test/iso.t: -------------------------------------------------------------------------------- 1 | $ blaze crlf 001.mail > 001.crlf 2 | $ blaze iso 001.crlf > 001.new 3 | $ diff 001.crlf 001.new 4 | $ blaze crlf 002.mail > 002.crlf 5 | $ blaze iso 002.crlf > 002.new 6 | $ diff 002.crlf 002.new 7 | $ blaze crlf 003.mail > 003.crlf 8 | $ blaze iso 003.crlf > 003.new 9 | $ diff 003.crlf 003.new 10 | $ blaze crlf 004.mail > 004.crlf 11 | $ blaze iso 004.crlf > 004.new 12 | $ diff 004.crlf 004.new 13 | -------------------------------------------------------------------------------- /test/cache/k1._domainkey.mcc.mcsv.net.dns: -------------------------------------------------------------------------------- 1 | txt:k=rsa; p=MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA0DKpJK+wvTrV2krJV344VRPr7/waGXuqrba2gRhHbRAltfz5ufHL5fdBzVmDyXAePAMWU83PlC7jo8EerIrrYrM+wkbj1zUlmbBJg6wHW6sA1Np6o3OSjTjM5dihy8y1AjGLUcI10hRiE+v3GinaGeGxXqvdneInMbOBWFC7ZJm+w7kjZH1jaiPmbziiY7USpicaYWCgqDqfPLER43KEw7NujbkbwyYQ6JocucDSmOJvjIN1QgQKwYNFdHp8P3VimFYl2pA5eeM5vFt3Dhg5b4PtdeRPjKouFwA82VdlPfTyQx9KjmgqY/HykfFOO/Hm4mxfq71JBVzMKIupaSVdzwIDAQAB 2 | -------------------------------------------------------------------------------- /test/cache/whs1._domainkey.webhostingserver.nl.dns: -------------------------------------------------------------------------------- 1 | txt:p=MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAzx9rOCWB+Wpls0eQwsqKqUHNO7vZAyWNfEQy/OxPlapkORuJSlcbT/2iyLdDwzmcsWPaxEVo++uR/hZISjRakOfteC96ruicbcaZPxFOHg4MTu6SXR88XWh0qPnI7FtGObEWIhj1xkpgfATY80uLw8LpyOOEe5Vb/gxuPW124DwV8JImEAJcxT2cLdRzTqeZN4fun9Su31eX21SbrX6bNYWehQ64kwzXfH1Zfe1aywGmwOBIs01PygMROj+14ta/P+oPtFnuwewAEm88zYBLazO9jYrL47xAjyNhZnjtULVBctpKw8AFsIJ7VMDACY270s+ZMmJIbd2v8v6gPJ3/KwIDAQAB 2 | -------------------------------------------------------------------------------- /test/cache/arc-20160816._domainkey.google.com.dns: -------------------------------------------------------------------------------- 1 | txt:k=rsa; p=MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA1Lztpxs7yUxQEsbDFhjMc9kZVZu5P/COYEUIX4B39IL4SXAbv4viIlT9E6F6iZmTh1go7+9WQLywwgwjXMJx/Dz0RgMoPeyp5NRy4l320DPYibNqVMWa5iQ2WiImQC0en1O9uhLLvzaSZJ03fvGmCo9jMo0GwKzLNe14xMgn/px2L5N/3IKlKX4bqUAJTUt8L993ZlWzvgMnSFSt8B+euSKSrtAiopdy4r1yO4eN5goBASrGW0eLQc1lYouNvCrcTQpos4/GEAqiGzpqueJLmBfOO4clNvVvpPkvQs2BHw9I9LmIjaMxTNGxkGBRaP3utDiKXXqu1K+LRzl0HCNSdQIDAQAB 2 | -------------------------------------------------------------------------------- /test/server.t: -------------------------------------------------------------------------------- 1 | Test on the simple server 2 | $ export PORT=25252 3 | $ blaze srv 127.0.0.1:$PORT -o new.eml & 4 | $ cat >old.eml < From: admin@blaze.org 6 | > To: foo@bar 7 | > Subject: Hello Blaze! 8 | > 9 | > Hello fellow! 10 | > EOF 11 | $ cat old.eml | blaze send --sender admin@blaze.org -r foo@bar - 127.0.0.1:$PORT 12 | $ tr -d '\r' < new.eml > new_without_crlf.eml 13 | $ diff old.eml new_without_crlf.eml 14 | -------------------------------------------------------------------------------- /test/cache/sjc2._domainkey.discoursemail.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=DKIM1; k=rsa; p=MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAsTING4yp/RLlN2i+FnLNo1YJ3SQPvs9fAYIS+ykQRX/TZj0OEfrM9WtZLmy+5CwWQWYlJguWY6Fz02wmIdunxBfZ3bgd5NJHQBN76DIaNfiyLUudbYP5vdrcJG5TwymZ03TVtRtfpqocvKU7X/o9GQiTgeTKRRajK6CBirinlINTXnrwJOA6ZQ1A02SDHAAf/B+rSYQ3mx9vAd8JlXdD7sIFaWK4Sz3YPad6M4d1p+FWrZ94D0Z6RFPzl/Q+AN5QnVAyjCjVqaQ+QQoUW3TYFc7uaKwbDaATpPOadz7lXNqr9C+i4DNWSU+Lff48e9WQ6tt+MZTJWeaZtL8g9OfBdwIDAQAB 2 | -------------------------------------------------------------------------------- /test/okapi.t: -------------------------------------------------------------------------------- 1 | Test about search engine 2 | $ blaze crlf 001.mail > 01.eml 3 | $ blaze crlf 002.mail > 02.eml 4 | $ blaze crlf 003.mail > 03.eml 5 | $ blaze crlf 004.mail > 04.eml 6 | $ blaze pack make -o pack.pack < 01.eml 8 | > 02.eml 9 | > 03.eml 10 | > 04.eml 11 | > EOF 12 | $ blaze pack index pack.pack 13 | $ blaze okapi pack.idx "decompress" | head -n1 | cut -d':' -f1 14 | 9afdd2f7a07de00e5de93bc1f706a2ab2f5caee9 15 | -------------------------------------------------------------------------------- /test/cache/arcselector10001._domainkey.microsoft.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=DKIM1; k=rsa; p=MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAzXBaxYIoWlL1E1RK3QPh2KHH+Mi5XsdFAW7Wz6HDJVXhFTlYqL939p1S9e/VfG3cu210r+O2YR2n1Q3Zp9rTUBCVI8qEfpDaCANKwGTjQdKcJsGw9QlIS/j+lK6qzF00qVQLVkrqWFewBy4TU6IDj3WtySBJL6AMg1FfOMooK55J8/GoglNJNoCDyL47q+57nNmAQ26o7AyPLSm0aAzzebkEGvialcdrT48sfZcAo1+fkTYRb5+iTWf0EHSmR0ZeMd0zn5leBSPW2lfi+3JBcAwoc7+dqdI6lPhnpvdymw1GdN0RHcU4NBPoGRl2KTnlQaYW78ZDP+0l5ov/RqrAaQIDAQAB 2 | -------------------------------------------------------------------------------- /test/cache/discoursemail.com.dns: -------------------------------------------------------------------------------- 1 | txt:v=spf1 ip4:184.104.202.128/27 ip4:184.104.202.96/27 ip4:216.218.159.0/27 ip4:216.218.240.64/26 ip4:64.71.168.192/26 ip4:65.19.128.64/26 ip4:66.220.12.128/27 ip4:72.52.80.0/26 ip4:64.62.250.96/27 ip6:2001:470:1:235::/64 ip6:2001:470:1:258::/64 ip6:2001:470:1:3a8::/64 ip6:2001:470:1:59e::/64 ip6:2001:470:1:669::/64 ip6:2001:470:1:791::/64 ip6:2001:470:1:9a5::/64 ip6:2001:470:1:9f1::/64 ip6:2602:fd3f:0000:ff06::/64 include:mailgun.org mx ptr ~all 2 | -------------------------------------------------------------------------------- /lib/pop3_miou_unix.mli: -------------------------------------------------------------------------------- 1 | type error = [ Pop3.error | `Msg of string ] 2 | 3 | val pp_error : error Fmt.t 4 | 5 | val fetch : 6 | ?authentication:string * string -> 7 | ?cfg:Tls.Config.client -> 8 | ?authenticator:X509.Authenticator.t -> 9 | ?ports:int list -> 10 | server:string -> 11 | filter:(Pop3.Uid.t list -> Pop3.Uid.t list) -> 12 | Happy_eyeballs_miou_unix.t -> 13 | (Pop3.Uid.t * string Flux.Bqueue.c) Flux.Bqueue.c -> 14 | (unit, [> error ]) result 15 | -------------------------------------------------------------------------------- /test/map.t: -------------------------------------------------------------------------------- 1 | Tests isomorphism 2 | $ blaze map -o 001.prim < 001.mail 3 | $ blaze addr 001.prim > addr.prim 4 | $ blaze addr 001.mail > addr.mail 5 | $ diff addr.prim addr.mail 6 | $ blaze map -o 002.prim < 002.mail 7 | $ blaze addr 002.prim > addr.prim 8 | $ blaze addr 002.mail > addr.mail 9 | $ diff addr.prim addr.mail 10 | $ blaze map -o 003.prim < 003.mail 11 | $ blaze addr 003.prim > addr.prim 12 | $ blaze addr 003.mail > addr.mail 13 | $ diff addr.prim addr.mail 14 | -------------------------------------------------------------------------------- /test/descr.t: -------------------------------------------------------------------------------- 1 | Tests on descr 2 | $ export BLAZE_UTF_8=false 3 | $ echo "Foo" > text 4 | $ blaze make < new.eml 5 | > Hello 6 | > EOF 7 | $ blaze descr new.eml 8 | .-- related 9 | | |-- mixed 10 | | | |-- text/plain 11 | | | `-- text/plain 12 | | `-- text/plain 13 | -------------------------------------------------------------------------------- /lib/pop3.mli: -------------------------------------------------------------------------------- 1 | module Uid : sig 2 | type t 3 | 4 | val equal_to_string : t -> string -> bool 5 | val pp : t Fmt.t 6 | val to_string : t -> string 7 | end 8 | 9 | type choose = Uid.t list -> Uid.t list 10 | type emitters = uid:Uid.t -> string option -> unit 11 | type error = [ Protocol.error | `POP3 of string ] 12 | 13 | val pp_error : error Fmt.t 14 | 15 | val fetch : 16 | ?authentication:string * string -> 17 | choose:choose -> 18 | emitter_of:emitters -> 19 | Protocol.ctx -> 20 | (unit, [> error ]) Protocol.t 21 | -------------------------------------------------------------------------------- /test/submit.t: -------------------------------------------------------------------------------- 1 | Test on submit command 2 | $ blaze submit --verbosity=error -h omelet --sender admin@blaze.org -r romain.calascibetta@gmail.com - - < From admin@blaze.org 4 | > To: romain.calascibetta@gmail.com 5 | > Subject: Hello Blaze! 6 | > 7 | > Hello fellow! 8 | > EOF 9 | EHLO omelet 10 | MAIL FROM: 11 | RCPT TO: 12 | DATA 13 | From admin@blaze.org 14 | To: romain.calascibetta@gmail.com 15 | Subject: Hello Blaze! 16 | 17 | Hello fellow! 18 | . 19 | QUIT 20 | -------------------------------------------------------------------------------- /test/mdir.t: -------------------------------------------------------------------------------- 1 | Tests on mdir executable 2 | $ export BLAZE_DNS_STATIC=cache 3 | $ export OCAMLRUNPARAM=b 4 | $ NEW=$(blaze mdir new -h blaze -D mdir | tail -n1) 5 | $ blaze mdir get -h blaze -D mdir -o result --new $NEW 6 | $ diff result mdir/new/$NEW 7 | $ blaze mdir get -h blaze -D mdir --new $NEW | blaze dkim verify 8 | [OK]: mcc.mcsv.net 9 | [OK]: mailchimpapp.net 10 | $ blaze mdir get -h blaze -D mdir --new $NEW | blaze spf analyze 11 | bounce-mc.us11_46973437.796437-romain.calascibetta=gmail.com@mail148.suw18.rsgsv.net from 198.2.181.148: pass (expected: pass) 12 | $ export BLAZE_MDIR=mdir 13 | $ test -f mdir/new/$(blaze mdir new -h blaze | tail -n1) 14 | $ blaze mdir commit -h blaze -D mdir --new $NEW 15 | $ test -f mdir/cur/$NEW 16 | -------------------------------------------------------------------------------- /test/send.t: -------------------------------------------------------------------------------- 1 | Test on send command 2 | $ blaze send --verbosity=error -h omelet --sender admin@blaze.org -r romain.calascibetta@gmail.com - - < From: admin@blaze.org 4 | > To: romain.calascibetta@gmail.com 5 | > Subject: Hello Blaze! 6 | > 7 | > Hello fellow! 8 | > EOF 9 | EHLO omelet 10 | MAIL FROM: 11 | RCPT TO: 12 | DATA 13 | From: admin@blaze.org 14 | To: romain.calascibetta@gmail.com 15 | Subject: Hello Blaze! 16 | 17 | Hello fellow! 18 | . 19 | QUIT 20 | $ blaze send --verbosity=error -h omelet --sender foo@bar -r a@foo -r b@foo - - < EOF 22 | EHLO omelet 23 | MAIL FROM: 24 | RCPT TO: 25 | RCPT TO: 26 | DATA 27 | . 28 | QUIT 29 | -------------------------------------------------------------------------------- /test/pack.t: -------------------------------------------------------------------------------- 1 | Test about the PACK file 2 | $ blaze crlf 001.mail > 01.eml 3 | $ blaze crlf 002.mail > 02.eml 4 | $ blaze crlf 003.mail > 03.eml 5 | $ blaze crlf 004.mail > 04.eml 6 | $ blaze pack make -o pack.pack < 01.eml 8 | > 02.eml 9 | > 03.eml 10 | > 04.eml 11 | > EOF 12 | $ blaze pack index pack.pack 13 | $ blaze pack get pack.pack ccfebcbe87d582eb6897f526ab98d40827398ddd > 001.eml 14 | $ blaze pack get pack.pack 9afdd2f7a07de00e5de93bc1f706a2ab2f5caee9 > 002.eml 15 | $ blaze pack get pack.pack 2f630dd27d847c56e51ea7b3528f63962f896c04 > 003.eml 16 | $ blaze pack get pack.pack 573847dc0ca288f10a37da35e71a6292cd1e1aba > 004.eml 17 | $ diff 001.eml 01.eml 18 | $ diff 002.eml 02.eml 19 | $ diff 003.eml 03.eml 20 | $ diff 004.eml 04.eml 21 | -------------------------------------------------------------------------------- /bin/blaze.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | let default = 4 | let open Term in 5 | ret (const (`Help (`Pager, None))) 6 | 7 | let () = 8 | let doc = "A swiss-army knife for emails." in 9 | let man = [] in 10 | let info = Cmd.info "blaze" ~doc ~man in 11 | let cmd = 12 | Cmd.group ~default info 13 | [ 14 | Addr.cmd; 15 | Blaze_dkim.cmd; 16 | Srv.cmd; 17 | Descr.cmd; 18 | Send.cmd; 19 | Fetch.cmd; 20 | Submit.cmd; 21 | Make.cmd; 22 | Rand.cmd; 23 | Crlf.cmd; 24 | Iso.cmd; 25 | Blaze_mbox.cmd; 26 | Blaze_pack.cmd; 27 | Hdr.cmd; 28 | Mdir.cmd; 29 | Map.cmd; 30 | Spf.cmd; 31 | Recv.cmd; 32 | Blaze_dmarc.cmd; 33 | Blaze_arc.cmd; 34 | Okapi.cmd; 35 | ] in 36 | Cmd.(exit (eval cmd)) 37 | -------------------------------------------------------------------------------- /test/spf.t: -------------------------------------------------------------------------------- 1 | Tests on SPF fields 2 | $ export BLAZE_DNS_STATIC=cache 3 | $ blaze spf analyze 001.mail 4 | bounces+848413-e276-romain.calascibetta=gmail.com@sgmail.github.com from 192.254.112.98: pass (expected: pass) 5 | $ blaze spf analyze 002.mail 6 | noreply@github.com from 192.30.252.192: pass (expected: pass) 7 | $ blaze spf analyze 003.mail 8 | tbraibant@janestreet.com from 38.105.200.233: fail (expected: pass) 9 | $ blaze spf stamp -h blaze --ip 38.105.200.78 --sender tbraibant@janestreet.com < 003.mail > 003.diff 10 | $ head -n4 003.diff 11 | Received-SPF: pass (blaze: domain of tbraibant@janestreet.com designates 38.105.200.78 as 12 | permitted sender) client-ip=38.105.200.78; envelope-from= 13 | tbraibant@janestreet.com; identity=mailfrom; receiver=blaze; mechanism= 14 | ip4:38.105.200.78/32; 15 | $ blaze spf analyze 004.mail 16 | ocaml+verp-cdef9eaa098cd788943a4314c682b75a@discoursemail.com from 216.218.240.121: pass (expected: pass) 17 | 18 | -------------------------------------------------------------------------------- /test/wrap.t: -------------------------------------------------------------------------------- 1 | Tests on wrap 2 | $ blaze make --date 2009-07-12T12:00:00Z < Hello World! 4 | > EOF 5 | Content-Type: multipart/mixed; boundary=foo 6 | MIME-Version: 1.0 7 | Date: Sun, 12 Jul 2009 12:00:00 +0000 8 | 9 | --foo 10 | Content-Type: text/plain; charset=utf-8 11 | Content-Transfer-Encoding: 7bit 12 | 13 | Hello World! 14 | 15 | --foo-- 16 | $ blaze make --date 2009-07-12T12:00:00Z --encoding quoted-printable < Волим слани краставац. 18 | > EOF 19 | Content-Type: multipart/mixed; boundary=foobar 20 | MIME-Version: 1.0 21 | Date: Sun, 12 Jul 2009 12:00:00 +0000 22 | 23 | --foobar 24 | Content-Type: text/plain; charset=utf-8 25 | Content-Transfer-Encoding: quoted-printable 26 | 27 | =D0=92=D0=BE=D0=BB=D0=B8=D0=BC=20=D1=81=D0=BB=D0=B0=D0=BD=D0=B8=20=D0=BA=D1= 28 | =80=D0=B0=D1=81=D1=82=D0=B0=D0=B2=D0=B0=D1=86. 29 | 30 | --foobar-- 31 | -------------------------------------------------------------------------------- /test/arc.t: -------------------------------------------------------------------------------- 1 | Tests on ARC 2 | $ export BLAZE_DNS_STATIC=cache 3 | $ blaze arc verify 001.mail 4 | notifications@github.com 5 | $ blaze arc verify 002.mail 6 | notifications@github.com -✓-> 01:google.com 7 | $ blaze arc verify 004.mail 8 | ocaml@discoursemail.com -✓-> 01:google.com 9 | $ blaze arc verify 005.mail 10 | fntoth@gmail.com -✓-> 01:webhostingserver.nl -✓-> 02:webhostingserver.nl 11 | -✓-> 03:subspace.kernel.org 12 | $ blaze arc verify 006.mail 13 | mihail.atanassov@arm.com -✓-> 01:microsoft.com -✓-> 02:microsoft.com 14 | -🞩-> 03:subspace.kernel.org 15 | $ blaze rand --seed foo= 16 > seed 16 | $ blaze dkim gen --seed $(cat seed) key.pem | cut -d' ' -f3 > seed.out 17 | $ diff seed seed.out 18 | $ blaze dkim gen --seed $(cat seed) | tail -n1 | cut -d' ' -f4 > pub 19 | $ blaze arc sign --seed $(cat seed) --seal-selector blaze --signature-selector blaze -h x25519.net 004.mail > mail 20 | $ blaze arc verify -e 'blaze:x25519.net:'$(cat pub) mail 21 | ocaml@discoursemail.com -✓-> 01:google.com -✓-> 02:x25519.net 22 | -------------------------------------------------------------------------------- /lib/dns_static.mli: -------------------------------------------------------------------------------- 1 | type t 2 | type record = Record : ('a Dns.Rr_map.rr * 'a) -> record 3 | type local = record list Domain_name.Map.t 4 | 5 | type error = 6 | [ `Msg of string 7 | | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t 8 | | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ] 9 | 10 | val getaddrinfo : 11 | t -> 12 | 'response Dns.Rr_map.key -> 13 | 'a Domain_name.t -> 14 | ('response, [> `Msg of string ]) result 15 | 16 | val gethostbyname : 17 | t -> [ `host ] Domain_name.t -> (Ipaddr.V4.t, [> `Msg of string ]) result 18 | 19 | val gethostbyname6 : 20 | t -> [ `host ] Domain_name.t -> (Ipaddr.V6.t, [> `Msg of string ]) result 21 | 22 | val get_resource_record : 23 | t -> 24 | 'response Dns.Rr_map.key -> 25 | 'a Domain_name.t -> 26 | ('response, [> error ]) result 27 | 28 | val of_directory : Fpath.t -> (local, [> `Msg of string ]) result 29 | 30 | val create : 31 | ?cache_size:int -> 32 | ?edns:[ `Auto | `Manual of Dns.Edns.t | `None ] -> 33 | ?nameservers:Dns.proto * Dns_client_miou_unix.Transport.io_addr list -> 34 | ?timeout:int64 -> 35 | ?local:local -> 36 | Happy_eyeballs_miou_unix.t -> 37 | t 38 | -------------------------------------------------------------------------------- /lib/blaze_tmp.ml: -------------------------------------------------------------------------------- 1 | let kprng = Domain.DLS.new_key Random.State.make_self_init 2 | 3 | let kdirname = 4 | Domain.DLS.new_key ~split_from_parent:Fun.id @@ fun () -> 5 | match Sys.getenv "TMPDIR" with 6 | | value -> value 7 | | exception Not_found -> "/tmp" 8 | 9 | let set_temp_dirname v = Domain.DLS.set kdirname v 10 | let get_temp_dirname () = Domain.DLS.get kdirname 11 | let to_delete = ref [] 12 | let register_to_delete filepath = to_delete := filepath :: !to_delete 13 | let () = at_exit @@ fun () -> List.iter Unix.unlink !to_delete 14 | 15 | let temp_filename fmt = 16 | let g = Domain.DLS.get kprng in 17 | let v = Random.State.bits g land 0xffffff in 18 | Fmt.kstr (Filename.concat (get_temp_dirname ())) fmt v 19 | 20 | let temp_filepath ?(clean = true) fmt = 21 | let flags = [ Open_wronly; Open_creat; Open_excl ] in 22 | let rec try_filepath counter = 23 | let filepath = temp_filename fmt in 24 | match close_in (open_in_gen flags 0o600 filepath) with 25 | | () -> 26 | if clean then register_to_delete filepath ; 27 | filepath 28 | | exception Sys_error _ -> 29 | if counter >= 20 30 | then invalid_arg "Impossible to create a temporary file." 31 | else try_filepath (succ counter) in 32 | try_filepath 0 33 | -------------------------------------------------------------------------------- /test/dkim.t: -------------------------------------------------------------------------------- 1 | Tests on DKIM fields 2 | $ export BLAZE_DNS_STATIC=cache 3 | $ blaze dkim verify 001.mail 4 | [OK]: sendgrid.info 5 | [OK]: github.com 6 | $ blaze dkim verify 002.mail 7 | [EX]: github.com 8 | $ blaze dkim verify 003.mail 9 | [OK]: janestreet.com 10 | $ blaze dkim verify -q 001.mail 11 | $ cat 002.mail | blaze dkim verify -q 12 | $ cat 002.mail | blaze dkim verify -q 13 | $ blaze rand --seed foo= 16 > seed 14 | $ blaze dkim gen --seed $(cat seed) key.pem | cut -d' ' -f3 > seed.out 15 | $ diff seed seed.out 16 | $ blaze dkim sign --seed $(cat seed) -s blaze -h x25519.org -f subject 001.mail > mail 17 | $ blaze dkim verify -q -e 'blaze:x25519.org:key.pem' mail 18 | $ blaze dkim gen --seed $(cat seed) | tail -n1 | cut -d' ' -f4 > pub 19 | $ blaze dkim sign --seed $(cat seed) -s blaze -h x25519.org 002.mail > mail 20 | $ blaze dkim verify -q -e 'blaze:x25519.org:'$(cat pub) mail 21 | $ blaze dkim sign --seed $(cat seed) -s blaze -h x25519.org -f received -f received 003.mail > mail 22 | $ blaze dkim verify --fields -e 'blaze:x25519.org:key.pem' mail 23 | From 24 | Received 25 | Received 26 | Mime-Version 27 | Date 28 | Message-Id 29 | Subject 30 | To 31 | Content-Type 32 | $ blaze dkim verify 004.mail 33 | [EX]: discoursemail.com 34 | -------------------------------------------------------------------------------- /test/put.t: -------------------------------------------------------------------------------- 1 | Tests on put 2 | $ echo "J'adore le concombre salé." > text 3 | $ blaze make --date none --encoding quoted-printable < Волим слани краставац. 5 | > EOF 6 | Content-Type: multipart/mixed; boundary=foobar 7 | MIME-Version: 1.0 8 | 9 | --foobar 10 | Content-Type: text/plain; charset=utf-8 11 | Content-Transfer-Encoding: quoted-printable 12 | 13 | =D0=92=D0=BE=D0=BB=D0=B8=D0=BC=20=D1=81=D0=BB=D0=B0=D0=BD=D0=B8=20=D0=BA=D1= 14 | =80=D0=B0=D1=81=D1=82=D0=B0=D0=B2=D0=B0=D1=86. 15 | 16 | --foobar 17 | Content-Transfer-Encoding: quoted-printable 18 | Content-Type: text/plain; charset=utf-8 19 | 20 | J'adore=20le=20concombre=20sal=C3=A9. 21 | 22 | --foobar-- 23 | $ blaze make --date none < EOF 25 | Content-Type: multipart/mixed; boundary=foobar 26 | MIME-Version: 1.0 27 | 28 | --foobar 29 | Content-Type: text/plain; charset=utf-8 30 | Content-Transfer-Encoding: 7bit 31 | 32 | 33 | --foobar 34 | Content-Transfer-Encoding: base64 35 | Content-Type: text/plain; charset=utf-8 36 | 37 | SidhZG9yZSBsZSBjb25jb21icmUgc2Fsw6kuCg== 38 | --foobar-- 39 | -------------------------------------------------------------------------------- /test/recv.t: -------------------------------------------------------------------------------- 1 | Tests on received fields 2 | $ blaze recv extract 001.mail 3 | from:github-smtp2b-ext-cp1-prd.iad.github.net -> by:ismtpd0004p1iad1.sendgrid.net -> for: 4 | with ESMTP 5 | by:10.103.97.5 6 | with SMTP 7 | from:o3.sgmail.github.com -> by:mx.google.com -> for: 8 | with ESMTPS 9 | $ blaze recv extract 002.mail 10 | from:out-1.smtp.github.com -> by:mx.google.com -> for: 11 | with ESMTPS 12 | by:2002:a0c:8b6e:: 13 | with SMTP 14 | $ blaze recv extract 003.mail 15 | by:10.31.135.131 16 | with HTTP 17 | from:tot-qpr-mailcore2.delacy.com -> by:mxout4.mail.janestreet.com -> for: 18 | with esmtps 19 | from:mail-vk0-f48.google.com -> by:mxgoog1.mail.janestreet.com -> for: 20 | with esmtps 21 | by:10.36.56.134 22 | with SMTP 23 | by:tot-qpr-mailcore2 24 | with JS-mailcore 25 | from:mxout4.mail.janestreet.com -> by:mx.google.com -> for: 26 | with ESMTPS 27 | by:vkex70 -> for: 28 | with SMTP 29 | $ printf "To: romain.calascibetta@gmail.com\n\n" > mail 30 | $ cat mail | blaze recv stamp -f smtp.google.com romain.calascibetta@gmail.com -h omelet | blaze recv extract 31 | from:smtp.google.com -> by:omelet -> for: 32 | with UTF8LMTP 33 | via UUCP 34 | -------------------------------------------------------------------------------- /lib/pack.mli: -------------------------------------------------------------------------------- 1 | type src = 2 | | Mail of string 3 | | Body of Fpath.t * int * int 4 | | Stem of Carton.Uid.t * Carton.Uid.t * int * (string, int) Hashtbl.t 5 | 6 | val sha1 : Carton.First_pass.digest 7 | val mail_identify : Digestif.SHA1.ctx Carton.First_pass.identify 8 | 9 | val config : 10 | ?pagesize:int -> 11 | ?cachesize:int -> 12 | ?threads:int -> 13 | ?on_entry:(max:int -> Carton_miou_unix.entry -> unit) -> 14 | ?on_object:(cursor:int -> Carton.Value.t -> Carton.Uid.t -> unit) -> 15 | unit -> 16 | Carton_miou_unix.config 17 | 18 | val filename_to_email : Fpath.t -> Fpath.t * (int * int) Email.t 19 | 20 | val email_to_entries : 21 | Fpath.t * (int * int) Email.t -> src Cartonnage.Entry.t list 22 | 23 | val uid_of_value : Carton.Value.t -> Carton.Uid.t 24 | 25 | val delta : 26 | load:(Carton.Uid.t -> 'meta -> Carton.Value.t) -> 27 | 'meta Cartonnage.Entry.t Seq.t -> 28 | 'meta Cartonnage.Target.t Seq.t 29 | 30 | val to_pack : 31 | ?with_header:int -> 32 | ?with_signature:Digestif.SHA1.ctx -> 33 | load:(Carton.Uid.t -> 'meta -> Carton.Value.t) -> 34 | 'meta Cartonnage.Target.t Seq.t -> 35 | string Seq.t 36 | 37 | val verify_from_pack : 38 | cfg:Carton_miou_unix.config -> Fpath.t -> Carton.status array * string 39 | 40 | val verify_from_idx : 41 | cfg:Carton_miou_unix.config -> Fpath.t -> Carton.status array * string 42 | 43 | val make : 44 | ?index:(Carton.Uid.t -> Carton.location) -> 45 | Fpath.t -> 46 | Carton_miou_unix.file_descr Carton.t 47 | 48 | val index : Fpath.t -> Carton_miou_unix.file_descr Classeur.t 49 | -------------------------------------------------------------------------------- /bin/doc.ml: -------------------------------------------------------------------------------- 1 | open Mrmime 2 | 3 | let rec map_on_edge_headers ~to_headers fn path acc 4 | { Email.Skeleton.headers; body } = 5 | let headers = to_headers headers in 6 | match body with 7 | | Multipart { parts; _ } -> 8 | let fn acc (_, t) = 9 | map_on_edge_headers ~to_headers fn (headers :: path) t acc in 10 | List.fold_left fn acc parts 11 | | Single contents -> fn (headers :: path) acc contents 12 | | Message t -> map_on_edge_headers ~to_headers fn (headers :: path) acc t 13 | 14 | let content_type = Field_name.content_type 15 | 16 | let is_multipart_mixed = function 17 | | { Content_type.ty = `Multipart; subty = `Iana_token "mixed"; _ } -> true 18 | | _ -> false 19 | 20 | let is_multipart_mixed hdrs = 21 | match Header.assoc content_type hdrs with 22 | | Field.(Field (_, Content, v)) :: _ -> is_multipart_mixed v 23 | | _ -> false 24 | 25 | let is_text hdrs = 26 | match Header.assoc content_type hdrs with 27 | | Field.(Field (_, Content, { Content_type.ty = `Text; _ })) :: _ -> true 28 | | _ -> false 29 | 30 | let is_mixed path = List.exists is_multipart_mixed path 31 | 32 | type 'contents document = 33 | | Mixed of (Header.t * 'contents) list 34 | | Alternated of (Header.t * 'contents) list 35 | | Parallel of (Header.t * 'contents) list 36 | | Signed of Header.t * 'contents * 'contents signature 37 | | Encrypted of Header.t * 'contents * 'contents signature 38 | 39 | and 'contents signature = { headers : Mrmime.Header.t; contents : 'contents } 40 | 41 | let select path acc contents = 42 | match path with 43 | | [] -> assert false 44 | | [ headers ] -> if is_text headers then contents :: acc else acc 45 | | headers :: path -> 46 | if is_mixed path && is_text headers then contents :: acc else acc 47 | -------------------------------------------------------------------------------- /test/make.t: -------------------------------------------------------------------------------- 1 | Tests on make 2 | $ blaze make --date 2009-07-12T12:00:00Z < Hello World! 4 | > EOF 5 | Date: Sun, 12 Jul 2009 12:00:00 +0000 6 | Content-Transfer-Encoding: 7bit 7 | Content-Type: text/plain; charset=utf-8 8 | 9 | Hello World! 10 | $ blaze make --date 2009-07-12T12:00:00Z --encoding quoted-printable < Волим слани краставац. 12 | > EOF 13 | Date: Sun, 12 Jul 2009 12:00:00 +0000 14 | Content-Transfer-Encoding: quoted-printable 15 | Content-Type: text/plain; charset=utf-8 16 | 17 | =D0=92=D0=BE=D0=BB=D0=B8=D0=BC=20=D1=81=D0=BB=D0=B0=D0=BD=D0=B8=20=D0=BA=D1= 18 | =80=D0=B0=D1=81=D1=82=D0=B0=D0=B2=D0=B0=D1=86. 19 | $ blaze make --date=none --from romain@blaze.org --to foo@bar.org,romain@gmail.com < EOF 21 | To: foo@bar.org, romain@gmail.com 22 | Sender: romain@blaze.org 23 | From: romain@blaze.org 24 | Content-Transfer-Encoding: 7bit 25 | Content-Type: text/plain; charset=utf-8 26 | 27 | $ blaze make --date none -f "Subject: Hello World!" < EOF 29 | Content-Transfer-Encoding: 7bit 30 | Content-Type: text/plain; charset=utf-8 31 | Subject: Hello World! 32 | 33 | $ cat >body < Hello World! 35 | > EOF 36 | $ blaze make --date none body 37 | Content-Transfer-Encoding: 7bit 38 | Content-Type: text/plain; charset=utf-8 39 | 40 | Hello World! 41 | $ blaze make --date none body -o email 42 | $ cat email 43 | Content-Transfer-Encoding: 7bit 44 | Content-Type: text/plain; charset=utf-8 45 | 46 | Hello World! 47 | $ blaze make --date none < Hello World! 49 | > EOF 50 | Sender: din@osau.re 51 | From: din@osau.re 52 | Content-Transfer-Encoding: 7bit 53 | Content-Type: text/plain; charset=utf-8 54 | 55 | Hello World! 56 | -------------------------------------------------------------------------------- /lib/email.mli: -------------------------------------------------------------------------------- 1 | type bigstring = 2 | (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 3 | 4 | module Skeleton : sig 5 | type transport_padding = string 6 | 7 | type 'octet body = 8 | | Multipart of 'octet multipart 9 | | Single of 'octet option 10 | | Message of 'octet t 11 | 12 | and 'octet part = { headers : 'octet; body : 'octet body } 13 | 14 | and 'octet multipart = { 15 | preamble : string; 16 | epilogue : string * transport_padding; 17 | boundary : string; 18 | parts : (transport_padding * 'octet part) list; 19 | } 20 | 21 | and 'octet t = 'octet part 22 | 23 | val map : ('a -> 'b) -> 'a t -> 'b t 24 | val fold : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc 25 | val pp : 'a Fmt.t -> 'a t Fmt.t 26 | end 27 | 28 | module Semantic : sig 29 | type 'octet document = 30 | | Leaf of { mime : string; lang : Snowball.Language.t; contents : 'octet } 31 | | Choose of { mime : string; parts : 'octet document list } 32 | 33 | and 'octet t = 'octet document option 34 | 35 | val fold : 36 | ('acc -> string * Snowball.Language.t * 'a -> 'acc) -> 'acc -> 'a t -> 'acc 37 | 38 | val pp : 'a Fmt.t -> 'a t Fmt.t 39 | end 40 | 41 | type 'octet t = 'octet Skeleton.t * 'octet Semantic.t 42 | 43 | val map : ('a -> 'b) -> 'a t -> 'b t 44 | 45 | module Format : sig 46 | val t : string t Encore.t 47 | end 48 | 49 | module Parser : sig 50 | val t : (int * int) Skeleton.t Angstrom.t 51 | end 52 | 53 | val of_filename : 54 | ?lang:Snowball.Language.t -> 55 | Fpath.t -> 56 | ((int * int) t, [> `Invalid | `No_symmetry | `Not_enough ]) result 57 | 58 | val to_seq : 59 | load:('a -> 'b) -> 'a Skeleton.t -> [ `String of string | `Value of 'b ] Seq.t 60 | 61 | val of_string : string -> (string t, [> `Msg of string ]) result 62 | val of_bigstring : bigstring -> (string t, [> `Msg of string ]) result 63 | val to_string : string t -> string 64 | 65 | (**/**) 66 | 67 | val output_bigstring : out_channel -> bigstring -> unit 68 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_static) 3 | (public_name blaze.dns-static) 4 | (modules dns_static) 5 | (libraries bos logs dns dns-client-miou-unix fpath astring)) 6 | 7 | (library 8 | (name blaze_tmp) 9 | (public_name blaze.tmp) 10 | (modules blaze_tmp) 11 | (libraries unix fpath fmt)) 12 | 13 | (library 14 | (name email) 15 | (public_name blaze.email) 16 | (modules email) 17 | (libraries flux stem.snowball bstr logs fpath encore mrmime)) 18 | 19 | (library 20 | (name protocol) 21 | (public_name blaze.protocol) 22 | (modules protocol) 23 | (libraries hxd.core hxd.string logs fmt)) 24 | 25 | (library 26 | (name pop3) 27 | (public_name blaze.pop3) 28 | (modules pop3) 29 | (libraries astring blaze.protocol)) 30 | 31 | (library 32 | (name pop3_miou_unix) 33 | (public_name blaze.pop3-miou-unix) 34 | (modules pop3_miou_unix) 35 | (libraries 36 | flux 37 | hxd.core 38 | hxd.string 39 | tls-miou-unix 40 | happy-eyeballs-miou-unix 41 | ca-certs 42 | blaze.pop3 43 | miou.unix)) 44 | 45 | (library 46 | (name mbox) 47 | (public_name blaze.mbox) 48 | (modules mbox mbox_lexer) 49 | (libraries hxd.core hxd.string logs)) 50 | 51 | (ocamllex mbox_lexer) 52 | 53 | (library 54 | (name pack) 55 | (public_name blaze.pack) 56 | (modules pack) 57 | (libraries 58 | hxd.core 59 | hxd.string 60 | digestif 61 | carton-miou.unix 62 | blaze.email 63 | blaze.stem 64 | stem.stopwords 65 | stem.snowball 66 | stem.tokenizer)) 67 | 68 | (library 69 | (name stem) 70 | (public_name blaze.stem) 71 | (modules stem) 72 | (libraries digestif encore logs)) 73 | 74 | (library 75 | (name smart) 76 | (public_name blaze.smart) 77 | (modules smart) 78 | (libraries blaze.protocol flux miou)) 79 | 80 | (library 81 | (name git_miou_unix) 82 | (public_name blaze.git-miou-unix) 83 | (modules git_miou_unix) 84 | (libraries 85 | flux 86 | carton 87 | digestif 88 | carton-miou.unix 89 | carton-miou.flux 90 | hxd.core 91 | hxd.string 92 | happy-eyeballs-miou-unix 93 | blaze.smart 94 | miou.unix)) 95 | -------------------------------------------------------------------------------- /bin/rand.ml: -------------------------------------------------------------------------------- 1 | let run _ seed len output = 2 | let g = Mirage_crypto_rng.Fortuna.create () in 3 | let g = Mirage_crypto_rng.(create ~g ~seed (module Fortuna)) in 4 | Mirage_crypto_rng.set_default_generator g ; 5 | let res = Mirage_crypto_rng.generate ~g len in 6 | match output with 7 | | `Base64 -> 8 | let b64 = Base64.encode_exn res in 9 | Fmt.pr "%s\n%!" b64 10 | | `Hex -> 11 | let hex = Ohex.encode res in 12 | Fmt.pr "%s\n%!" hex 13 | | `Raw -> Fmt.pr "%s" res 14 | 15 | open Cmdliner 16 | open Blaze_cli 17 | 18 | let seed = 19 | let parser str = 20 | match Base64.decode ~pad:true str with 21 | | Ok _ as value -> value 22 | | Error _ as err -> err in 23 | let pp ppf str = Fmt.string ppf (Base64.encode_string ~pad:true str) in 24 | Arg.conv (parser, pp) 25 | 26 | let seed = 27 | let doc = "Seed used to initialize the Fortuna random number generator." in 28 | Arg.(required & opt (some seed) None & info [ "seed" ] ~doc ~docv:"BASE64") 29 | 30 | let length = 31 | let doc = "The length of the random value (in bytes)" in 32 | Arg.(required & pos 0 (some int) None & info [] ~doc ~docv:"LENGTH") 33 | 34 | let output = 35 | let base64 = 36 | let doc = "Outputs the random value in the base64 format." in 37 | Arg.info [ "base64" ] ~doc in 38 | let hex = 39 | let doc = "Outputs the random value in the hex format." in 40 | Arg.info [ "hex" ] ~doc in 41 | let raw = 42 | let doc = "Outputs the random value as it is." in 43 | Arg.info [ "raw" ] ~doc in 44 | Arg.(value & vflag `Base64 [ (`Base64, base64); (`Hex, hex); (`Raw, raw) ]) 45 | 46 | let cmd = 47 | let doc = "Generate a random value from a seed with the fortuna algorithm." in 48 | let man = 49 | [ 50 | `S Manpage.s_description; 51 | `P 52 | "$(tname) generates a random value from a seed with the $(b,fortuna) \ 53 | algorithm. The user can set the output of the value (base64 or hex)"; 54 | ] in 55 | let open Term in 56 | let info = Cmd.info "rand" ~doc ~man in 57 | let term = const run $ setup_logs $ seed $ length $ output in 58 | Cmd.v info term 59 | -------------------------------------------------------------------------------- /test/addr.t: -------------------------------------------------------------------------------- 1 | Tests on addresses 2 | $ printf "From: romain.calascibetta@blaze.com\n\n" | blaze addr 3 | romain.calascibetta@blaze.com 4 | $ cat >simple < From: a@foo.com 6 | > Sender: b@bar.org 7 | > 8 | > EOF 9 | $ blaze addr simple 10 | a@foo.com 11 | b@bar.org 12 | $ cat >simple < BLAZE-From: romain@blaze.org 14 | > From: romain@foo.com 15 | > 16 | > EOF 17 | $ blaze addr -f BLAZE-From simple 18 | romain@blaze.org 19 | romain@foo.com 20 | $ blaze addr -f BLAZE-From:BLAZE-To < BLAZE-From: romain@blaze.org 22 | > BLAZE-To: anil@blaze.org 23 | > From: romain@foo.com 24 | > To: anil@bar.org 25 | > 26 | > EOF 27 | romain@blaze.org 28 | anil@blaze.org 29 | romain@foo.com 30 | anil@bar.org 31 | $ printf "From: θσερ@εχαμπλε.ψομ\n\n" | blaze addr 32 | θσερ@εχαμπλε.ψομ 33 | $ printf "From: romain@foo.com\n\n" | blaze addr - 34 | romain@foo.com 35 | $ blaze addr 001.mail 36 | Thomas Gazagnaire 37 | mirage/irmin 38 | 39 | mirage/irmin 40 | $ blaze addr -d 002.mail 41 | Yann Régis Gianas 42 | mirage/decompress 43 | 44 | mirage/decompress 45 | Mention 46 | Calascibetta Romain 47 | $ blaze addr -d 003.mail 48 | Thomas Braibant 49 | Romain Calascibetta 50 | Gabriel Scherer 51 | Louis Roché 52 | Roberto Di Cosmo 53 | $ blaze addr --without-name 002.mail 54 | notifications@github.com 55 | reply+0004e976d9ee97bc1d2d238f13f646219cc36441871e86af92cf000000011820dbf092a169ce1722a3ee@reply.github.com 56 | decompress@noreply.github.com 57 | mention@noreply.github.com 58 | romain.calascibetta@gmail.com 59 | -------------------------------------------------------------------------------- /blaze.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "blaze" 3 | synopsis: "Tools to manipulate emails" 4 | description: """\ 5 | Conan is a re-implementation in OCaml of the file command. 6 | The library is system-agnostic and can be used with MirageOS.""" 7 | maintainer: "Romain Calascibetta " 8 | authors: "Romain Calascibetta " 9 | license: "MIT" 10 | homepage: "https://github.com/dinosaure/blaze" 11 | doc: "https://dinosaure.github.io/blaze/" 12 | bug-reports: "https://github.com/dinosaure/blaze/issues" 13 | depends: [ 14 | "ocaml" {>= "5.4.0"} 15 | "mrmime" {>= "0.7.1"} 16 | "bstr" 17 | "emile" 18 | "domain-name" 19 | "maildir" 20 | "astring" 21 | "base64" 22 | "bos" 23 | "dns" 24 | "cmdliner" {>= "1.1.0"} 25 | "colombe" {>= "0.7.0"} 26 | "sendmail" {>= "0.12.1"} 27 | "ca-certs" 28 | "tls" 29 | "dkim" {>= "0.9.0"} 30 | "dns-client" {>= "10.2.0"} 31 | "dns-client-miou-unix" 32 | "dune" {>= "2.8.5"} 33 | "fmt" 34 | "fpath" 35 | "logs" 36 | "ocamlgraph" {>= "2.0.0"} 37 | "ptime" 38 | "received" 39 | "uspf" {>= "0.0.2"} 40 | "uri" {>= "4.2.0"} 41 | "ipaddr" {>= "5.2.0"} 42 | "encore" 43 | "progress" 44 | "carton-miou" 45 | "dmarc" 46 | "arc" 47 | "stem" 48 | "bm25" 49 | "ke" {>= "0.4"} 50 | "mirage-crypto-rng-miou-unix" 51 | "sendmail-miou-unix" 52 | ] 53 | build: [ 54 | ["dune" "build" "-p" name "-j" jobs] 55 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 56 | ] 57 | dev-repo: "git+https://github.com/dinosaure/blaze.git" 58 | pin-depends: [ 59 | [ "maildir.dev" "git+https://github.com/dinosaure/ocaml-maildir.git#597823c7d2d4fd2aef26a581f6828f2b458371ea" ] 60 | [ "carton.dev" "git+https://github.com/robur-coop/carton.git#a7543fadc0c67c684a647551bf869faefe6b66b5" ] 61 | [ "carton-miou.dev" "git+https://github.com/robur-coop/carton.git#a7543fadc0c67c684a647551bf869faefe6b66b5" ] 62 | [ "flux.dev" "git+https://github.com/robur-coop/flux.git#55af39880aa080059396259fc126bb857374a989" ] 63 | [ "stem.dev" "git+https://github.com/robur-coop/stem.git#66ce4f85ec2ad317ef2bd01bad71c93c0af68210" ] 64 | [ "bm25.dev" "git+https://github.com/robur-coop/stem.git#66ce4f85ec2ad317ef2bd01bad71c93c0af68210" ] 65 | [ "mrmime.dev" "git+https://github.com/mirage/mrmime.git#ffce7951d3df81d5555c0686489535e21e6443da" ] 66 | ] 67 | -------------------------------------------------------------------------------- /bin/iso.ml: -------------------------------------------------------------------------------- 1 | let to_output_channel_from_filename filename t oc = 2 | let fd = Unix.openfile (Fpath.to_string filename) Unix.[ O_RDONLY ] 0o644 in 3 | let finally () = Unix.close fd in 4 | Fun.protect ~finally @@ fun () -> 5 | let map ~off ~len = 6 | Logs.debug (fun m -> m "map off:%08x len:%d" off len) ; 7 | let barr = 8 | Unix.map_file fd ~pos:(Int64.of_int off) Bigarray.char Bigarray.c_layout 9 | false [| len |] in 10 | Bigarray.array1_of_genarray barr in 11 | let load (pos, pos_end) = map ~off:pos ~len:(pos_end - pos) in 12 | let seq = Email.to_seq ~load t in 13 | let fn = function 14 | | `String str -> output_string oc str 15 | | `Value bstr -> Email.output_bigstring oc bstr in 16 | Seq.iter fn seq 17 | 18 | let run _quiet filename output = 19 | let filename = Fpath.v filename in 20 | match Email.of_filename filename with 21 | | Ok (t, _) -> 22 | let oc, finally = 23 | match output with 24 | | Some filename -> 25 | let oc = open_out (Fpath.to_string filename) in 26 | let finally () = close_out oc in 27 | (oc, finally) 28 | | None -> (stdout, ignore) in 29 | Fun.protect ~finally @@ fun () -> 30 | to_output_channel_from_filename filename t oc ; 31 | `Ok () 32 | | Error `Invalid -> `Error (false, "Invalid email") 33 | | Error `No_symmetry -> 34 | `Error (false, "No symmetry between Mr.MIME and our skeleton") 35 | | Error `Not_enough -> `Error (false, "Not enough input for an email") 36 | 37 | open Cmdliner 38 | open Blaze_cli 39 | 40 | let input = 41 | let doc = "The incoming email." in 42 | let open Arg in 43 | required & pos 0 (some file) None & info [] ~doc ~docv:"FILE" 44 | 45 | let output = 46 | let doc = "The output of the $(tname) program." in 47 | let parser str = 48 | match Fpath.of_string str with 49 | | Ok value when Sys.file_exists str -> 50 | error_msgf "%a already exists" Fpath.pp value 51 | | Ok _ as value -> value 52 | | Error _ as err -> err in 53 | let non_existing_filename = Arg.conv (parser, Fpath.pp) in 54 | let open Arg in 55 | value 56 | & opt (some non_existing_filename) None 57 | & info [ "o"; "output" ] ~doc ~docv:"FILE" 58 | 59 | let term = 60 | let open Term in 61 | ret (const run $ setup_logs $ input $ output) 62 | 63 | let cmd = 64 | let doc = "Explode and reconstruct the given email." in 65 | let man = [] in 66 | let info = Cmd.info "iso" ~doc ~man in 67 | Cmd.v info term 68 | -------------------------------------------------------------------------------- /lib/protocol.mli: -------------------------------------------------------------------------------- 1 | module Decoder : sig 2 | type t = { buffer : bytes; mutable pos : int; mutable max : int } 3 | 4 | val make : int -> t 5 | val leftover : t -> string 6 | 7 | type ('v, 'err) state = 8 | | Done of 'v 9 | | Read of { 10 | buffer : bytes; 11 | off : int; 12 | len : int; 13 | continue : ('v, 'err) continue; 14 | } 15 | | Error of 'err info 16 | 17 | and ('v, 'err) continue = [ `End | `Len of int ] -> ('v, 'err) state 18 | and 'err info = { error : 'err; buffer : bytes; committed : int } 19 | 20 | type error = 21 | [ `End_of_input | `Not_enough_space | `Expected_eol | `Invalid_pkt_line ] 22 | 23 | val at_least_one_line : t -> bool 24 | val at_least_one_pkt : t -> bool 25 | val return : 'v -> t -> ('v, 'err) state 26 | 27 | val prompt : 28 | at_least:(t -> bool) -> 29 | (t -> ('v, ([> error ] as 'err)) state) -> 30 | t -> 31 | ('v, 'err) state 32 | 33 | val peek_while_eol : t -> bytes * int * int 34 | end 35 | 36 | module Encoder : sig 37 | type t 38 | 39 | val make : int -> t 40 | 41 | type 'err state = 42 | | Write of { 43 | buffer : string; 44 | off : int; 45 | len : int; 46 | continue : 'err continue; 47 | } 48 | | Error of 'err 49 | | Done 50 | 51 | and 'err continue = int -> 'err state 52 | 53 | type error = [ `Not_enough_space ] 54 | 55 | val flush : (t -> ([> error ] as 'err) state) -> t -> 'err state 56 | val write : string -> t -> unit 57 | val blit : string -> off:int -> len:int -> t -> unit 58 | val safe : (t -> ([> error ] as 'err) state) -> t -> 'err state 59 | end 60 | 61 | type (+'a, 'err) t = 62 | | Read of { 63 | buffer : bytes; 64 | off : int; 65 | len : int; 66 | k : [ `End | `Len of int ] -> ('a, 'err) t; 67 | } 68 | | Write of { buffer : string; off : int; len : int; k : int -> ('a, 'err) t } 69 | | Return of 'a 70 | | Error of 'err 71 | 72 | val reword_error : ('err0 -> 'err1) -> ('a, 'err0) t -> ('a, 'err1) t 73 | val bind : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t 74 | val return : 'a -> ('a, 'err) t 75 | val error : 'err -> ('a, 'err) t 76 | 77 | type ctx 78 | type error = [ Decoder.error | Encoder.error ] 79 | 80 | val pp_error : error Fmt.t 81 | val ctx : unit -> ctx 82 | val leftover : ctx -> string 83 | 84 | type ('r, 'err) fmt = 85 | ('r, Format.formatter, unit, (unit, ([> Encoder.error ] as 'err)) t) format4 86 | 87 | val encode_str : ctx -> string -> (unit, [> Encoder.error ]) t 88 | val encode_line : ctx -> string -> (unit, [> Encoder.error ]) t 89 | val encode_pkt : ctx -> ('r, 'err) fmt -> 'r 90 | val encode_flush_pkt : ctx -> (unit, [> Encoder.error ]) t 91 | val encode_delim_pkt : ctx -> (unit, [> Encoder.error ]) t 92 | 93 | (**/*) 94 | 95 | val decode_line : ctx -> (string, [> Decoder.error ]) t 96 | val decode_pkt : ctx -> (string, [> Decoder.error ]) t 97 | -------------------------------------------------------------------------------- /test/hdr.t: -------------------------------------------------------------------------------- 1 | Test on headers 2 | $ printf "From: romain.calascibetta@blaze.com,\n root@foo.org\nTo: root@bar.org\n\n" | blaze hdr 3 | From: romain.calascibetta@blaze.com, 4 | root@foo.org 5 | To: root@bar.org 6 | $ blaze hdr < Date: Thu, 30 Mar 2017 15:00:00 +0200 8 | > 9 | > EOF 10 | Date: 2017-03-30 15:00:00 +02:00 11 | $ blaze hdr < Subject: Hello World! 13 | > 14 | > EOF 15 | Subject: Hello World! 16 | $ blaze hdr < Subject: 18 | > 19 | > EOF 20 | Subject:$ 21 | $ printf "Content-Type: text/example\n\n" | blaze hdr 22 | Content-Type: text/example 23 | $ printf "Content-Type: text/example; charset=utf-8\n\n" | blaze hdr 24 | Content-Type: text/example; charset=utf-8 25 | $ printf "A: foo\nB: bar\n\n" | blaze hdr 26 | A: foo 27 | B: bar 28 | $ printf "A: foo\nB: bar\n\n" | blaze hdr -h A 29 | A: foo 30 | $ printf "A: foo\nB: bar\n\n" | blaze hdr -h B 31 | B: bar 32 | $ printf "A: foo\nA: bar\n\n" | blaze hdr -h A 33 | A: foo 34 | $ printf "A: foo\nA: bar\n\n" | blaze hdr -h A:A 35 | A: foo 36 | A: bar 37 | $ blaze hdr -h From:To < From: romain@blaze.org 39 | > Subject: Hello World! 40 | > To: foo@blaze.org 41 | > To: bar@blaze.org 42 | > 43 | > EOF 44 | From: romain@blaze.org 45 | To: foo@blaze.org 46 | $ blaze hdr -h Content-Type -p charset < Content-Type: text/example; charset=utf-8 48 | > 49 | > EOF 50 | utf-8 51 | $ blaze hdr -h Content-Type:Google-Content-type -p charset < Content-Type: text/ascii; charset=utf-8 53 | > GOOGLE-Content-Type: text/utf-8; charset=utf-8 54 | > 55 | > EOF 56 | utf-8 57 | utf-8 58 | $ printf "From: =?US-ASCII?Q?Keith_Moore?= \n\n" | blaze hdr 59 | From: =?US-ASCII?Q?Keith_Moore?= 60 | $ printf "From: =?US-ASCII?Q?Keith_Moore?= \n\n" | blaze hdr -d 61 | From: Keith Moore 62 | $ printf "From: romain@blaze.org\n\n" | blaze hdr -H 63 | > From: romain@blaze.org 64 | $ cat >email < From: romain.calascibetta@blaze.org 66 | > 67 | > EOF 68 | $ blaze hdr -H email 69 | email From: romain.calascibetta@blaze.org 70 | $ blaze hdr -h Subject:Date 001.mail 71 | Date: 2016-11-09 12:10:27 -08:00 72 | Subject: Re: [mirage/irmin] use a numerical version in META (_NUM strips leading v) (#378) 73 | $ blaze hdr -h Date:Subject 002.mail 74 | Date: 2018-12-06 04:45:36 -08:00 75 | Subject: Re: [mirage/decompress] Outdated documentation (#65) 76 | $ blaze hdr -d -h From:Date:Subject:To 003.mail 77 | From: Thomas Braibant 78 | Date: 2015-10-29 11:38:12 -04:00 79 | Subject: Salle Algorithme, 10 novembre 80 | To: Roberto Di Cosmo , 81 | Louis Roché , 82 | Gabriel Scherer , 83 | Romain Calascibetta 84 | -------------------------------------------------------------------------------- /lib/mbox.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "blaze.mbox" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | let sub str off len = 6 | if String.length str - off < len then None else Some (String.sub str off len) 7 | 8 | let of_in_channel ic = 9 | let lexbuf = Lexing.from_channel ic in 10 | let buf = Buffer.create 0x7ff in 11 | let rec go () = 12 | let code = Mbox_lexer.token lexbuf in 13 | match code with 14 | | 0x500 -> Seq.Nil 15 | | 0x300 -> 16 | let line = !Mbox_lexer.to_crlf in 17 | let lf = String.index line '\n' in 18 | begin match (sub line 0 5, lf == String.length line - 1) with 19 | | Some "From ", true -> Seq.Cons (`Line line, go) 20 | | Some "From ", false -> 21 | let from = String.sub line 0 lf in 22 | Log.debug (fun m -> m "[0x300] From %s" from) ; 23 | let line = 24 | String.sub line (lf + 1) (String.length line - (lf + 1)) in 25 | let _00 = `From (String.sub from 5 (String.length line - 5)) in 26 | let _01 = `Line line in 27 | Seq.(Cons (_00, fun () -> Cons (_01, go))) 28 | | Some "\nFrom", false -> 29 | let lf = String.index_from line (lf + 1) '\n' in 30 | let from = String.sub line 1 (lf - 1) in 31 | Log.debug (fun m -> m "[0x300] From %s" from) ; 32 | let line = 33 | String.sub line (lf + 1) (String.length line - (lf + 1)) in 34 | let _00 = `From (String.sub from 5 (String.length line - 5)) in 35 | let _01 = `Line line in 36 | Seq.(Cons (_00, fun () -> Cons (_01, go))) 37 | | Some ">From", true -> 38 | let line = String.sub line 1 (String.length line - 1) in 39 | Log.debug (fun m -> m "[0x300]-> %S" line) ; 40 | Seq.Cons (`Line line, go) 41 | | _ -> 42 | Log.debug (fun m -> m "[0x300]-> %S" line) ; 43 | Seq.Cons (`Line line, go) 44 | end 45 | | 0x200 -> 46 | let line = !Mbox_lexer.to_lf in 47 | begin match sub line 0 5 with 48 | | Some "From " -> 49 | let from = String.sub line 5 (String.length line - (5 + 1)) in 50 | Log.debug (fun m -> m "[0x200] From %s" from) ; 51 | Seq.Cons (`From from, go) 52 | | Some ">From" -> 53 | let line = String.sub line 1 (String.length line - (5 + 1)) in 54 | let line = line ^ "\r\n" in 55 | Log.debug (fun m -> m "[0x200]-> %S" line) ; 56 | Seq.Cons (`Line line, go) 57 | | _ -> 58 | let line = String.sub line 0 (String.length line - 1) ^ "\r\n" in 59 | Log.debug (fun m -> m "[0x200]-> %S" line) ; 60 | Seq.Cons (`Line line, go) 61 | end 62 | | 0x100 -> 63 | let line = Buffer.contents buf in 64 | Buffer.clear buf ; 65 | let line = line ^ "\r\n" in 66 | Log.debug (fun m -> m "[0x100]-> %S" line) ; 67 | Seq.Cons (`Line line, go) 68 | | chr -> 69 | Log.debug (fun m -> m "[0x0??]") ; 70 | Buffer.add_char buf (Char.chr chr) ; 71 | go () in 72 | go 73 | -------------------------------------------------------------------------------- /lib/stem.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "blaze.stem" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt 6 | 7 | type t = { 8 | mail : string; 9 | blob : string; 10 | length : int; 11 | tokens : (string, int) Hashtbl.t; 12 | } 13 | 14 | module Format = struct 15 | open Encore 16 | open Syntax 17 | 18 | let c_string = 19 | let c_string = 20 | let fwd str = 21 | if String.contains str '\000' then raise Bij.Bijection ; 22 | str in 23 | let bwd str = str in 24 | Bij.v ~fwd ~bwd in 25 | let null = 26 | let fwd = function "\000" -> () | _ -> raise Bij.Bijection in 27 | let bwd () = "\000" in 28 | Bij.v ~fwd ~bwd in 29 | c_string 30 | <$> while0 (function '\000' -> false | _ -> true) 31 | <* (null <$> const "\000") 32 | 33 | let int = 34 | let int = 35 | let fwd str = String.get_int64_be str 0 |> Int64.to_int in 36 | let bwd n = 37 | let buf = Bytes.create 8 in 38 | Bytes.set_int64_be buf 0 (Int64.of_int n) ; 39 | Bytes.unsafe_to_string buf in 40 | Bij.v ~fwd ~bwd in 41 | int <$> fixed 8 42 | 43 | let hex = fixed 20 44 | 45 | let t = 46 | let fwd (((uid, blob), length), tokens) = 47 | let tbl = Hashtbl.create 0x7ff in 48 | let fn (token, count) = Hashtbl.add tbl token count in 49 | List.iter fn tokens ; 50 | (uid, blob, length, tbl) in 51 | let bwd (uid, blob, length, tokens) = 52 | let seq = Hashtbl.to_seq tokens in 53 | (((uid, blob), length), List.of_seq seq) in 54 | Bij.v ~fwd ~bwd 55 | <$> (hex <*> hex <*> int <*> rep0 (c_string <*> int <* commit)) 56 | end 57 | 58 | let to_string t = 59 | let emitter = Encore.to_lavoisier Format.t in 60 | try Encore.Lavoisier.emit_string ~chunk:0x7ff t emitter 61 | with exn -> 62 | let bt = Printexc.get_raw_backtrace () in 63 | Log.err (fun m -> m "%s" (Printexc.raw_backtrace_to_string bt)) ; 64 | raise exn 65 | 66 | let of_string str = 67 | let parser = Encore.to_angstrom Format.t in 68 | match Angstrom.parse_string ~consume:All parser str with 69 | | Ok t -> Ok t 70 | | Error _ -> error_msgf "Invalid stem object" 71 | 72 | let to_length_and_hash ((_, _, _, tbl) as t) = 73 | let emitter = Encore.to_lavoisier Format.t in 74 | let length = 75 | Hashtbl.fold (fun str _ acc -> String.length str + 1 + 8 + acc) tbl 0 76 | |> ( + ) 20 77 | |> ( + ) 20 78 | |> ( + ) 8 in 79 | let rec go length' ctx = function 80 | | Encore.Lavoisier.Fail -> failwith "Stem.to_length_and_hash" 81 | | Done -> 82 | if length <> length' then failwith "Stem.to_length_and_hash" ; 83 | (length, Digestif.SHA1.(to_raw_string (get ctx))) 84 | | Partial { buffer; off; len; continue } -> 85 | let ctx = Digestif.SHA1.feed_string ctx buffer ~off ~len in 86 | let length' = length' + len in 87 | go length' ctx (continue ~committed:len) in 88 | let ctx = Digestif.SHA1.empty in 89 | let hdr = Fmt.str "stem %d\000" length in 90 | let ctx = Digestif.SHA1.feed_string ctx hdr in 91 | go 0 ctx (Encore.Lavoisier.emit t emitter) 92 | -------------------------------------------------------------------------------- /bin/crlf.ml: -------------------------------------------------------------------------------- 1 | let run _quiet filename output = 2 | let oc, finally = 3 | match output with 4 | | Some filename -> 5 | let oc = open_out (Fpath.to_string filename) in 6 | let finally () = close_out oc in 7 | (oc, finally) 8 | | None -> (stdout, ignore) in 9 | Fun.protect ~finally @@ fun () -> 10 | let ic = open_in filename in 11 | let finally () = close_in ic in 12 | Fun.protect ~finally @@ fun () -> 13 | let rec go () = 14 | match input_line ic with 15 | | line -> 16 | output_string oc line ; 17 | output_char oc '\r' ; 18 | output_char oc '\n' ; 19 | go () 20 | | exception End_of_file -> () in 21 | go () 22 | 23 | open Cmdliner 24 | open Blaze_cli 25 | 26 | let input = 27 | let doc = "The email which uses the $(i,lf) line feed." in 28 | let open Arg in 29 | required & pos 0 (some file) None & info [] ~doc ~docv:"FILE" 30 | 31 | let output = 32 | let doc = "The output of the $(tname) program." in 33 | let parser str = 34 | match Fpath.of_string str with 35 | | Ok value when Sys.file_exists str -> 36 | error_msgf "%a already exists" Fpath.pp value 37 | | Ok _ as value -> value 38 | | Error _ as err -> err in 39 | let non_existing_filename = Arg.conv (parser, Fpath.pp) in 40 | let open Arg in 41 | value 42 | & opt (some non_existing_filename) None 43 | & info [ "o"; "output" ] ~doc ~docv:"FILE" 44 | 45 | let term = 46 | let open Term in 47 | const run $ setup_logs $ input $ output 48 | 49 | let cmd = 50 | let doc = 51 | "Transforms an email using the $(i,lf) line feed into an email compatible \ 52 | with the SMTP protocol (the $(i,crlf) line feed)." in 53 | let man = 54 | [ 55 | `S Manpage.s_description; 56 | `P 57 | "$(tname) reads a file line by line (where the line feed is $(i,lf)) \ 58 | and re-emits the lines but with a new line feed: $(i,crlf) (the one \ 59 | used in particular by the SMTP protocol)."; 60 | `P 61 | "It is preferable to handle emails using the $(i,crlf) line feed, as \ 62 | this is also the line feed described in $(i,RFC822) (which describes \ 63 | the format of emails)."; 64 | `P 65 | "For example, the $(b,blaze) archiving system uses the $(i,crlf) line \ 66 | feed rather than $(i,lf). Verification tools such as DKIM also rely \ 67 | on the $(i,crlf) line feed."; 68 | `P 69 | "There are cases where the $(b,LF) character can have real \ 70 | significance for the user but has no significance in terms of \ 71 | $(i,RFC822). A parallel can be drawn with the fact that $(b,LF) has \ 72 | no particular significance in an HTML document (except in a few \ 73 | exceptional cases) but $(b,
) has significance in the display of \ 74 | the document. For emails, it's the same: $(i,lf) can have meaning for \ 75 | the user, whereas $(i,crlf) is completely transparent to the user. We \ 76 | can therefore find emails with $(b,) where our second \ 77 | $(b,) is part of the email content."; 78 | ] in 79 | let info = Cmd.info "crlf" ~doc ~man in 80 | Cmd.v info term 81 | -------------------------------------------------------------------------------- /test/dmarc.t: -------------------------------------------------------------------------------- 1 | Tests on DMARC fields 2 | $ export BLAZE_DNS_STATIC=cache 3 | $ blaze dmarc verify --hostname omelet 001.mail -o 001.dmarc 4 | $ blaze dmarc collect 001.dmarc 5 | omelet: ✓ spf 6 | ✓ dkim (header.i=@github.com header.s="s20150108" 7 | header.b="SuEKjwfk") 8 | ✓ dkim (header.i=@sendgrid.info header.s="smtpapi" 9 | header.b="iIicLeoJ") 10 | ✓ dmarc (header.from="github.com") 11 | mx.google.com: ✓ dkim (header.i=@github.com) 12 | ✓ dkim (header.i=@sendgrid.info) 13 | ✓ spf (smtp.mailfrom=bounces+848413-e276-romain.calascibetta=gmail.com@sgmail.github.com) 14 | ✓ dmarc (header.from="github.com") 15 | $ blaze dmarc verify --hostname omelet 002.mail -o 002.dmarc 16 | $ blaze dmarc collect 002.dmarc 17 | omelet: ✓ spf 18 | ✓ dkim (header.i=@github.com header.s="pf2014" 19 | header.b="1crXUDuJ") 20 | ✓ dmarc (header.from="github.com") 21 | mx.google.com: ✓ dkim (header.i=@github.com header.s="pf2014" 22 | header.b="1crXUDuJ") 23 | ✓ spf (smtp.mailfrom=noreply@github.com) 24 | ✓ dmarc (header.from="github.com") 25 | $ blaze dmarc verify --hostname omelet 003.mail -o 003.dmarc 26 | $ blaze dmarc collect 003.dmarc 27 | omelet: 🞩 spf 28 | ✓ dkim (header.i=@janestreet.com header.s="google" 29 | header.b="MglJGvGH") 30 | ✓ dmarc (header.from="janestreet.com") 31 | mx.google.com: ✓ spf (smtp.mailfrom=tbraibant@janestreet.com) 32 | ✓ dkim (header.i=@janestreet.com) 33 | $ blaze dmarc verify --hostname omelet 004.mail -o 004.dmarc 34 | $ blaze dmarc collect 004.dmarc 35 | omelet: ✓ spf 36 | 🞩 dkim (header.i=@discoursemail.com header.s="sjc2" 37 | header.b="VmvuZ8wM") 38 | ✓ dmarc (header.from="discoursemail.com") 39 | mx.google.com: ✓ dkim (header.i=@discoursemail.com header.s="sjc2" 40 | header.b="VmvuZ8wM") 41 | ✓ spf (smtp.mailfrom=ocaml+verp-cdef9eaa098cd788943a4314c682b75a@discoursemail.com) 42 | ✓ dmarc (header.from="discoursemail.com") 43 | $ blaze dmarc collect 005.mail 44 | smtp.subspace.kernel.org: ✓ arc (smtp.client-ip="141.138.168.70") 45 | smtp.subspace.kernel.org: 🞩 dmarc (header.from="gmail.com") 46 | smtp.subspace.kernel.org: 🞩 spf (smtp.mailfrom="gmail.com") 47 | webhostingserver.nl: ✓ iprev (smtp.remote-ip="178.250.146.69") 48 | ✓ auth (smtp.auth=ferry.toth@elsinga.info) 49 | spf=softfail (smtp.mailfrom="gmail.com") 50 | dmarc=skipped (header.from="gmail.com") 51 | arc=none 52 | $ blaze dmarc collect 006.mail 53 | smtp.subspace.kernel.org: 🞩 arc (smtp.client-ip="40.107.21.84") 54 | smtp.subspace.kernel.org: ✓ dmarc (header.from="arm.com") 55 | smtp.subspace.kernel.org: ✓ spf (smtp.mailfrom="arm.com") 56 | smtp.subspace.kernel.org: ✓ dkim (header.d="arm.com" header.i=@arm.com 57 | header.b="KoxoQrPZ") 58 | ✓ dkim (header.d="arm.com" header.i=@arm.com 59 | header.b="KoxoQrPZ") 60 | -------------------------------------------------------------------------------- /lib/pop3.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "pop3" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | let ( let* ) = Protocol.bind 6 | 7 | let transmit ~emitter ctx = 8 | let rec go () = 9 | let* str = Protocol.decode_line ctx in 10 | match str with 11 | | "." -> 12 | emitter None ; 13 | Protocol.return () 14 | | ".." -> 15 | emitter (Some ".\r\n") ; 16 | go () 17 | | str -> 18 | emitter (Some (str ^ "\r\n")) ; 19 | go () in 20 | go () 21 | 22 | module Uid = struct 23 | type t = { sid : int; uid : string } 24 | 25 | let equal_to_string { uid; _ } str = String.equal uid str 26 | let pp ppf { uid; _ } = Fmt.string ppf uid 27 | let to_string { uid; _ } = uid 28 | end 29 | 30 | type choose = Uid.t list -> Uid.t list 31 | type emitters = uid:Uid.t -> string option -> unit 32 | type error = [ Protocol.error | `POP3 of string ] 33 | 34 | let pp_error ppf = function 35 | | #Protocol.error as err -> Protocol.pp_error ppf err 36 | | `POP3 msg -> Fmt.string ppf msg 37 | 38 | let pop3f fmt = Fmt.kstr (fun str -> Protocol.error (`POP3 str)) fmt 39 | 40 | let is_ok str = 41 | if Astring.String.is_prefix ~affix:"+OK" str 42 | then Protocol.return () 43 | else begin 44 | Log.err (fun m -> m "Invalid POP3 response: %S" str) ; 45 | pop3f "Invalid POP3 response: %S" str 46 | end 47 | 48 | let entry str = 49 | match Astring.String.cut ~sep:" " str with 50 | | Some (sid, uid) -> begin 51 | match int_of_string sid with 52 | | sid -> Protocol.return { Uid.sid; uid } 53 | | exception _ -> 54 | Log.err (fun m -> m "Invalid UIDL response: %S" str) ; 55 | pop3f "Invalid UIDL response: %S" str 56 | end 57 | | None -> 58 | Log.err (fun m -> m "Invalid UIDL response: %S" str) ; 59 | pop3f "Invalid UIDL response: %S" str 60 | 61 | let fetch ?authentication ~choose ~emitter_of ctx = 62 | let* _greeting = Protocol.decode_line ctx in 63 | Log.debug (fun m -> m "Greeting: %S" _greeting) ; 64 | let* () = 65 | match authentication with 66 | | Some (username, password) -> 67 | Log.debug (fun m -> m "authentication state") ; 68 | let* () = Protocol.encode_line ctx (Fmt.str "USER %s" username) in 69 | let* resp = Protocol.decode_line ctx in 70 | let* () = is_ok resp in 71 | let* () = Protocol.encode_line ctx (Fmt.str "PASS %s" password) in 72 | let* resp = Protocol.decode_line ctx in 73 | is_ok resp 74 | | None -> Protocol.return () in 75 | let* () = Protocol.encode_line ctx "UIDL" in 76 | let* resp = Protocol.decode_line ctx in 77 | let* () = is_ok resp in 78 | let rec go acc = 79 | let* str = Protocol.decode_line ctx in 80 | match str with 81 | | "." -> Protocol.return (List.rev acc) 82 | | str -> 83 | let* uid = entry str in 84 | go (uid :: acc) in 85 | let* lst = go [] in 86 | let lst = choose lst in 87 | let rec go = function 88 | | [] -> Protocol.encode_line ctx "QUIT" 89 | | ({ Uid.sid; _ } as uid) :: rest -> 90 | let* () = Protocol.encode_line ctx (Fmt.str "RETR %d" sid) in 91 | let* resp = Protocol.decode_line ctx in 92 | let* () = is_ok resp in 93 | let emitter = emitter_of ~uid in 94 | let* () = transmit ~emitter ctx in 95 | let* () = Protocol.encode_line ctx "NOOP" in 96 | let* resp = Protocol.decode_line ctx in 97 | let* () = is_ok resp in 98 | go rest in 99 | go lst 100 | -------------------------------------------------------------------------------- /lib/pop3_miou_unix.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "pop3.miou.unix" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | let authenticator : 6 | (X509.Authenticator.t, [ `Msg of string ]) result Miou.Lazy.t = 7 | Miou.Lazy.from_fun Ca_certs.authenticator 8 | 9 | let tls_config user's_tls_config user's_authenticator = 10 | match user's_tls_config with 11 | | Some cfg -> Ok cfg 12 | | None -> 13 | let ( let* ) = Result.bind in 14 | let* authenticator = 15 | match (Miou.Lazy.force authenticator, user's_authenticator) with 16 | | Ok authenticator, None -> Ok authenticator 17 | | _, Some authenticator -> Ok authenticator 18 | | Error (`Msg msg), None -> Error (`Msg msg) in 19 | Tls.Config.client ~authenticator () 20 | 21 | let rec clear fd = function 22 | | Protocol.Error err -> Result.Error err 23 | | Return v -> Ok v 24 | | Read { k; buffer; off; len } -> 25 | let len = Miou_unix.read fd ~off ~len buffer in 26 | let res = if len = 0 then `End else `Len len in 27 | clear fd (k res) 28 | | Write { k; buffer; off; len } -> 29 | Miou_unix.write fd ~off ~len buffer ; 30 | clear fd (k len) 31 | 32 | let rec tls fd = function 33 | | Protocol.Error err -> Result.Error err 34 | | Return v -> Ok v 35 | | Read { k; buffer; off; len } -> 36 | let len = Tls_miou_unix.read fd ~off ~len buffer in 37 | let res = if len = 0 then `End else `Len len in 38 | tls fd (k res) 39 | | Write { k; buffer; off; len } -> 40 | Tls_miou_unix.write fd buffer ~off ~len ; 41 | tls fd (k len) 42 | 43 | let ( $ ) f g x = match f x with Ok x -> g x | Error _ as err -> err 44 | 45 | type error = [ Pop3.error | `Msg of string ] 46 | 47 | let pp_error ppf = function 48 | | #Pop3.error as err -> Pop3.pp_error ppf err 49 | | `Msg msg -> Fmt.string ppf msg 50 | 51 | let fetch ?authentication ?cfg:user's_tls_config 52 | ?authenticator:user's_authenticator ?(ports = [ 110; 995 ]) ~server 53 | ~filter:choose he stream = 54 | let ( let* ) = Result.bind in 55 | let* tls_cfg = tls_config user's_tls_config user's_authenticator in 56 | let* (_, port), socket = Happy_eyeballs_miou_unix.connect he server ports in 57 | Log.debug (fun m -> m "Connected to %s:%d" server port) ; 58 | let finally () = Miou_unix.close socket in 59 | Fun.protect ~finally @@ fun () -> 60 | let protocol = 61 | match (port, authentication) with 62 | | 110, None -> `Clear 63 | | 110, Some _ -> 64 | Log.err (fun m -> 65 | m "Unallowed to start a clear connection with an authentication") ; 66 | Fmt.failwith 67 | "We don't initiate a clear POP3 connection with an authentication" 68 | | _ -> `Tls tls_cfg in 69 | let ctx = Protocol.ctx () in 70 | let emitter_of ~uid = 71 | let mail = Flux.Bqueue.(create with_close) 0x7ff in 72 | let push = function 73 | | Some chunk -> Flux.Bqueue.put mail chunk 74 | | None -> Flux.Bqueue.close mail in 75 | Flux.Bqueue.put stream (uid, mail) ; 76 | push in 77 | let finally () = Flux.Bqueue.close stream in 78 | Fun.protect ~finally @@ fun () -> 79 | Log.debug (fun m -> m "fetch emails from %s" server) ; 80 | let t = Pop3.fetch ?authentication ~choose ~emitter_of ctx in 81 | match protocol with 82 | | `Clear -> clear socket t 83 | | `Tls cfg -> 84 | Log.debug (fun m -> m "Start a TLS connection with %s:%d" server port) ; 85 | let host = 86 | match Domain_name.(of_string $ host) server with 87 | | Ok host -> Some host 88 | | Error _ -> None in 89 | let fd = Tls_miou_unix.client_of_fd cfg ?host socket in 90 | tls fd t 91 | -------------------------------------------------------------------------------- /lib/smart.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "smart" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | let ( let* ) = Protocol.bind 6 | 7 | let rec comment ctx = 8 | let* pkt = Protocol.decode_pkt ctx in 9 | if String.length pkt > 0 then comment ctx else Protocol.return () 10 | 11 | let _zero_uid = String.for_all (function '0' -> true | _ -> false) 12 | 13 | let clonev2 ctx q = 14 | let* pkt = Protocol.decode_pkt ctx in 15 | let* () = 16 | if String.length pkt >= 1 && pkt.[0] = '#' 17 | then comment ctx 18 | else Protocol.return () in 19 | match String.split_on_char ' ' (String.trim pkt) with 20 | | [ "version"; "2" ] -> 21 | let* _capabilities = 22 | let rec go acc ctx = 23 | let* pkt = Protocol.decode_pkt ctx in 24 | match String.trim pkt with 25 | | "" -> Protocol.return (List.rev acc) 26 | | capability -> go (capability :: acc) ctx in 27 | go [] ctx in 28 | let* () = Protocol.encode_pkt ctx "command=ls-refs\n" in 29 | let* () = Protocol.encode_pkt ctx "object-format=sha1" in 30 | let* () = Protocol.encode_delim_pkt ctx in 31 | let* () = Protocol.encode_flush_pkt ctx in 32 | let* refs = 33 | let rec go acc ctx = 34 | let* pkt = Protocol.decode_pkt ctx in 35 | match String.trim pkt with 36 | | "" -> Protocol.return (List.rev acc) 37 | | str -> 38 | let[@warning "-8"] (hash :: reference) = 39 | String.split_on_char ' ' str in 40 | let reference = String.concat " " reference in 41 | go ((reference, hash) :: acc) ctx in 42 | go [] ctx in 43 | let* head = 44 | match List.assoc "HEAD" refs with 45 | | hash -> Protocol.return hash 46 | | exception Not_found -> Protocol.error `No_branch in 47 | let* () = Protocol.encode_pkt ctx "command=fetch" in 48 | let* () = Protocol.encode_pkt ctx "object-format=sha1" in 49 | let* () = Protocol.encode_delim_pkt ctx in 50 | let* () = Protocol.encode_pkt ctx "ofs-delta" in 51 | let* () = Protocol.encode_pkt ctx "no-progress" in 52 | let* () = Protocol.encode_pkt ctx "want %s" head in 53 | let* () = Protocol.encode_pkt ctx "done" in 54 | let* () = Protocol.encode_flush_pkt ctx in 55 | let* () = 56 | let* pkt = Protocol.decode_pkt ctx in 57 | match String.trim pkt with 58 | | "packfile" -> Protocol.return () 59 | | _ -> Protocol.error `Invalid_pkt_line in 60 | let rec go errored ctx = 61 | let* pkt = Protocol.decode_pkt ctx in 62 | if String.length pkt = 0 63 | then Protocol.return errored 64 | else 65 | let data = String.sub pkt 1 (String.length pkt - 1) in 66 | match pkt.[0] with 67 | | '\001' -> 68 | Flux.Bqueue.put q data ; 69 | go errored ctx 70 | | '\003' -> 71 | Log.err (fun m -> m "[remote]: %s" data) ; 72 | go true ctx 73 | | _ -> go errored ctx in 74 | go false ctx 75 | | [ "version"; v ] -> Protocol.error (`Invalid_version v) 76 | | _ -> Protocol.error `Invalid_pkt_line 77 | 78 | type error = 79 | [ Protocol.error 80 | | `No_branch 81 | | `Invalid_version of string 82 | | `Invalid_negotiation ] 83 | 84 | let pp_error ppf = function 85 | | #Protocol.error as err -> Protocol.pp_error ppf err 86 | | `No_branch -> Fmt.string ppf "No branch available" 87 | | `Invalid_version v -> Fmt.pf ppf "Invalid Smart version: %S" v 88 | | `Invalid_negotiation -> Fmt.string ppf "Failed to negotiate" 89 | 90 | let clone ~protocol ctx q = 91 | let* () = 92 | match protocol with 93 | | `Git path -> 94 | Protocol.encode_pkt ctx 95 | "git-upload-pack %s\000host=localhost\000\000version=2\000" path 96 | | _ -> Protocol.return () in 97 | clonev2 ctx q 98 | -------------------------------------------------------------------------------- /test/003.mail: -------------------------------------------------------------------------------- 1 | Return-Path: 2 | Delivered-To: romain.calascibetta@gmail.com 3 | Received: by 10.36.56.134 with SMTP id b128csp540801ita; 4 | Thu, 29 Oct 2015 08:38:33 -0700 (PDT) 5 | X-Received: by 10.55.52.210 with SMTP id b201mr3082180qka.37.1446133113260; 6 | Thu, 29 Oct 2015 08:38:33 -0700 (PDT) 7 | Received: from mxout4.mail.janestreet.com (mxout4.mail.janestreet.com. [38.105.200.233]) 8 | by mx.google.com with ESMTPS id e37si1673465qgd.116.2015.10.29.08.38.33 9 | for 10 | (version=TLSv1.2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); 11 | Thu, 29 Oct 2015 08:38:33 -0700 (PDT) 12 | Received-SPF: pass (google.com: domain of tbraibant@janestreet.com designates 38.105.200.233 as permitted sender) client-ip=38.105.200.233; 13 | Authentication-Results: mx.google.com; 14 | spf=pass (google.com: domain of tbraibant@janestreet.com designates 38.105.200.233 as permitted sender) smtp.mailfrom=tbraibant@janestreet.com; 15 | dkim=pass header.i=@janestreet.com 16 | Received: from tot-qpr-mailcore2.delacy.com ([172.27.56.106] helo=tot-qpr-mailcore2) 17 | by mxout4.mail.janestreet.com with esmtps (TLSv1:DHE-RSA-AES256-SHA:256) 18 | (Exim 4.82) 19 | (envelope-from ) 20 | id 1ZrpHc-0003HL-Rl 21 | for romain.calascibetta@gmail.com; Thu, 29 Oct 2015 11:38:32 -0400 22 | X-JS-Flow: external 23 | Received: by tot-qpr-mailcore2 with JS-mailcore (0.1) 24 | (envelope-from ) 25 | id BWMj14-AAAA79-Zg; 2015-10-29 11:38:32.817089-04:00 26 | Received: from mail-vk0-f48.google.com ([209.85.213.48]) 27 | by mxgoog1.mail.janestreet.com with esmtps (UNKNOWN:AES128-GCM-SHA256:128) 28 | (Exim 4.72) 29 | (envelope-from ) 30 | id 1ZrpHc-0006AE-Mz 31 | for romain.calascibetta@gmail.com; Thu, 29 Oct 2015 11:38:32 -0400 32 | Received: by vkex70 with SMTP id x70so28855493vke.3 33 | for ; Thu, 29 Oct 2015 08:38:32 -0700 (PDT) 34 | DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; 35 | d=janestreet.com; s=google; 36 | h=mime-version:from:date:message-id:subject:to:content-type; 37 | bh=GyAmxDGX0W8Gqaw7woZv/Z1PRyMhWnPrYABiKZttB+E=; 38 | b=MglJGvGHXDs+h1G34fzV5w0CLUPwlTpI9SVPFYP3gb504ilBSpDXPBD/6o0SjTNwdB 39 | wKZY0tZC7zdTZVsnSd0lbgYYyCNRx1poSAfHSLuvkSLzf9uSrQj/u8LyqnDlIYml3Cw2 40 | 9OmWEpOoACV11Ews5BgKT4MisOkm+jxPvWA0c= 41 | X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; 42 | d=1e100.net; s=20130820; 43 | h=x-gm-message-state:mime-version:from:date:message-id:subject:to 44 | :content-type; 45 | bh=GyAmxDGX0W8Gqaw7woZv/Z1PRyMhWnPrYABiKZttB+E=; 46 | b=H/MIUPm780gvxECQ2E6zVqht23yPf7VIUGg7W8In1ElH7K/bd8erkFs4Ory2Tn7BhG 47 | eTo/TDM2V3ZJrkc9MNQ5dHBoEsCWV4M+ocm7vwnbU2c08LXiswrW+LVDY15yi6KMp7QP 48 | gLw+8L0u+TC8xaqLU5zyluPPbgW6xZjoRI0SRrIV24SWhdz/so/aru4aDmKNiOphTSwX 49 | rEzvu9GvxXHQXilQKpo6fVKv94JA2iqfX8OqN0i0KzePLdT4IgZXiKe7qsJn+jWtsQka 50 | f6Uui5FskxKDmhel9Qp4nTW9FvxWyLJGPg3+6/k9W4LAXAMGLdEvc6iFQAtO9Ey8jKfb 51 | 9jCw== 52 | X-Gm-Message-State: ALoCoQnOehqqM8cKBmU5xD6x9K2QS1fn5pgrfVkXc6ueHy/+yb43RMqFrkVD9wfV0pf6DdUyKaKtgxo+eRuobnJWnN80Zc/NlHJzBzfcJR6H+gg0/scPh07uznBHaXurujxcwnVbZgj0GtCK+5cZMk77f+Ih/qenag== 53 | X-Received: by 10.31.33.75 with SMTP id h72mr1665920vkh.144.1446133112476; 54 | Thu, 29 Oct 2015 08:38:32 -0700 (PDT) 55 | X-Received: by 10.31.33.75 with SMTP id h72mr1665915vkh.144.1446133112403; 56 | Thu, 29 Oct 2015 08:38:32 -0700 (PDT) 57 | MIME-Version: 1.0 58 | Received: by 10.31.135.131 with HTTP; Thu, 29 Oct 2015 08:38:12 -0700 (PDT) 59 | From: Thomas Braibant 60 | Date: Thu, 29 Oct 2015 11:38:12 -0400 61 | Message-ID: 62 | Subject: Salle Algorithme, 10 novembre 63 | To: Roberto Di Cosmo , 64 | =?UTF-8?B?TG91aXMgUm9jaMOp?= , 65 | Gabriel Scherer , 66 | Romain Calascibetta 67 | Content-Type: text/plain; charset=UTF-8 68 | X-JS-Processed-by: mailcore 69 | X-getmail-retrieved-from-mailbox: INBOX 70 | X-GMAIL-LABELS: =?utf-8?b?IlxcSW1wb3J0YW50Ig==?= 71 | X-GMAIL-THRID: =?utf-8?q?1516380475326008196?= 72 | X-GMAIL-MSGID: =?utf-8?q?1516380475326008196?= 73 | 74 | Bonjour Roberto, 75 | 76 | Est ce que tu peux nous confirmer que la salle algorithme est bien 77 | reservee pour le meetup le 10 novembre? 78 | 79 | Merci d'avance. 80 | -- 81 | Thomas 82 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name blaze_cli) 3 | (modules blaze_cli) 4 | (public_name blaze.cli) 5 | (libraries 6 | logs.threaded 7 | blaze.dns-static 8 | blaze.tmp 9 | fpath 10 | ipaddr 11 | ipaddr.unix 12 | uri 13 | cmdliner 14 | ca-certs 15 | tls 16 | hxd.core 17 | hxd.string 18 | progress 19 | logs.fmt 20 | logs.cli 21 | fmt.tty 22 | fmt.cli 23 | stem.cli)) 24 | 25 | (library 26 | (name addr) 27 | (modules addr) 28 | (public_name blaze.addr) 29 | (libraries blaze.cli cmdliner fpath mrmime bigstringaf emile)) 30 | 31 | (library 32 | (name hdr) 33 | (modules hdr) 34 | (public_name blaze.hdr) 35 | (libraries cmdliner fpath mrmime bigstringaf fmt)) 36 | 37 | (library 38 | (name map) 39 | (modules map) 40 | (public_name blaze.map) 41 | (libraries bstr cmdliner blaze.cli fpath mrmime)) 42 | 43 | (library 44 | (name mdir) 45 | (modules mdir) 46 | (public_name blaze.mdir) 47 | (libraries base64 blaze.cli domain-name cmdliner fpath maildir.unix)) 48 | 49 | (library 50 | (name spf) 51 | (modules spf) 52 | (public_name blaze.spf) 53 | (libraries 54 | cmdliner 55 | fpath 56 | uri 57 | blaze.cli 58 | mirage-crypto-rng-miou-unix 59 | uspf.unix)) 60 | 61 | (library 62 | (name recv) 63 | (modules recv) 64 | (public_name blaze.recv) 65 | (libraries 66 | blaze.cli 67 | ocamlgraph 68 | cmdliner 69 | fpath 70 | mrmime 71 | bigstringaf 72 | fmt 73 | received 74 | colombe.emile 75 | unix 76 | ptime.clock.os)) 77 | 78 | (library 79 | (name blaze_dkim) 80 | (modules blaze_dkim) 81 | (public_name blaze.dkim) 82 | (libraries 83 | blaze.dns-static 84 | cmdliner 85 | fpath 86 | mrmime 87 | bigstringaf 88 | fmt 89 | uri 90 | dkim 91 | mirage-crypto-rng-miou-unix 92 | blaze.cli)) 93 | 94 | (library 95 | (name submit) 96 | (modules submit) 97 | (public_name blaze.submit) 98 | (libraries 99 | blaze.cli 100 | cmdliner 101 | fpath 102 | mrmime 103 | bigstringaf 104 | fmt 105 | tls 106 | colombe 107 | uri 108 | ca-certs 109 | happy-eyeballs-miou-unix 110 | dns-client-miou-unix 111 | sendmail-miou-unix 112 | mirage-crypto-rng-miou-unix 113 | colombe.emile)) 114 | 115 | (library 116 | (name send) 117 | (modules send) 118 | (public_name blaze.send) 119 | (libraries 120 | blaze.cli 121 | cmdliner 122 | fpath 123 | mrmime 124 | bigstringaf 125 | fmt 126 | tls 127 | colombe 128 | uri 129 | ca-certs 130 | sendmail-miou-unix 131 | happy-eyeballs-miou-unix 132 | dns-client-miou-unix 133 | sendmail 134 | sendmail.starttls 135 | colombe.emile)) 136 | 137 | (library 138 | (name srv) 139 | (modules srv) 140 | (public_name blaze.srv) 141 | (libraries fpath sendmail.starttls blaze.cli colombe)) 142 | 143 | (library 144 | (name make) 145 | (modules make) 146 | (public_name blaze.make) 147 | (libraries unix blaze.cli cmdliner fpath ptime.clock.os mrmime)) 148 | 149 | (library 150 | (name descr) 151 | (modules descr) 152 | (public_name blaze.descr) 153 | (libraries bstr blaze.cli cmdliner mrmime fpath)) 154 | 155 | (library 156 | (name rand) 157 | (modules rand) 158 | (public_name blaze.rand) 159 | (libraries blaze.cli cmdliner fmt mirage-crypto-rng ohex base64)) 160 | 161 | (library 162 | (name iso) 163 | (modules iso) 164 | (public_name blaze.iso) 165 | (libraries blaze.cli cmdliner blaze.email)) 166 | 167 | (library 168 | (name crlf) 169 | (modules crlf) 170 | (public_name blaze.crlf) 171 | (libraries blaze.cli cmdliner)) 172 | 173 | (library 174 | (name doc) 175 | (modules doc) 176 | (public_name blaze.doc) 177 | (libraries blaze.cli blaze.email)) 178 | 179 | (library 180 | (name blaze_pack) 181 | (modules blaze_pack) 182 | (public_name blaze.epack) 183 | (libraries 184 | blaze.cli 185 | blaze.pack 186 | carton-miou.unix 187 | carton-miou.flux 188 | blaze.email)) 189 | 190 | (library 191 | (name fetch) 192 | (modules fetch) 193 | (public_name blaze.fetch) 194 | (libraries 195 | flux 196 | emile 197 | mirage-crypto-rng-miou-unix 198 | blaze.cli 199 | blaze.pop3-miou-unix 200 | blaze.git-miou-unix)) 201 | 202 | (library 203 | (name blaze_mbox) 204 | (modules blaze_mbox) 205 | (public_name blaze.embox) 206 | (libraries blaze.cli blaze.pack carton-miou.unix blaze.mbox blaze.email)) 207 | 208 | (library 209 | (name blaze_dmarc) 210 | (modules blaze_dmarc) 211 | (public_name blaze.dmarc) 212 | (libraries blaze.cli mirage-crypto-rng-miou-unix dmarc)) 213 | 214 | (library 215 | (name blaze_arc) 216 | (modules blaze_arc) 217 | (public_name blaze.arc) 218 | (libraries blaze.cli flux mirage-crypto-rng-miou-unix arc)) 219 | 220 | (library 221 | (name okapi) 222 | (modules okapi) 223 | (public_name blaze.okapi) 224 | (libraries 225 | blaze.stem 226 | bm25 227 | blaze.cli 228 | blaze.pack 229 | carton-miou.unix 230 | blaze.email)) 231 | 232 | (executable 233 | (name blaze) 234 | (modules blaze) 235 | (public_name blaze) 236 | (libraries 237 | blaze.addr 238 | blaze.dkim 239 | blaze.srv 240 | blaze.descr 241 | blaze.send 242 | blaze.fetch 243 | blaze.submit 244 | blaze.make 245 | blaze.rand 246 | blaze.epack 247 | blaze.embox 248 | blaze.crlf 249 | blaze.iso 250 | blaze.mdir 251 | blaze.hdr 252 | blaze.map 253 | blaze.spf 254 | blaze.recv 255 | blaze.dmarc 256 | blaze.arc 257 | blaze.okapi 258 | cmdliner)) 259 | -------------------------------------------------------------------------------- /bin/okapi.ml: -------------------------------------------------------------------------------- 1 | let to_document pack offset = 2 | match Carton.kind_of_offset pack ~cursor:offset with 3 | | `A | `B | `D -> None 4 | | `C -> begin 5 | let zero = Carton.Size.zero in 6 | let size = Carton.size_of_offset pack ~cursor:offset zero in 7 | let blob = Carton.Blob.make ~size in 8 | let value = Carton.of_offset pack blob ~cursor:offset in 9 | let str = Carton.Value.string value in 10 | match Stem.of_string str with 11 | | Ok (uid, blob, length, tokens) -> 12 | let uid = Classeur.unsafe_uid_of_string uid 13 | and blob = Carton.Uid.unsafe_of_string blob in 14 | let guid = (uid, blob) in 15 | Some (guid, `Document (Bm25.document ~length ~tokens guid)) 16 | | Error _ -> None 17 | end 18 | 19 | let threads (pack, idx, queue) = 20 | let idx = Pack.index idx in 21 | let index (uid : Carton.Uid.t) = 22 | let uid = Classeur.uid_of_string_exn idx (uid :> string) in 23 | let offset = Classeur.find_offset idx uid in 24 | Logs.debug (fun m -> m "%s -> %08x" (Ohex.encode (uid :> string)) offset) ; 25 | Carton.Local offset in 26 | let pack = Pack.make ~index pack in 27 | let rec go acc = 28 | match Flux.Bqueue.get queue with 29 | | Some offset -> 30 | let entry = 31 | try to_document pack offset 32 | with exn -> 33 | Logs.err (fun m -> 34 | m "Unexpected error (for %08x): %s" offset 35 | (Printexc.to_string exn)) ; 36 | None in 37 | Option.fold ~none:acc ~some:(fun entry -> entry :: acc) entry |> go 38 | | None -> acc in 39 | go [] 40 | 41 | let producer idx queue = 42 | let idx = Pack.index idx in 43 | let fn ~uid:_ ~crc:_ ~offset = 44 | Logs.debug (fun m -> m "Produce %08x" offset) ; 45 | Flux.Bqueue.put queue offset in 46 | Classeur.iter ~fn idx ; 47 | Flux.Bqueue.close queue ; 48 | Logs.debug (fun m -> m "Offsets sent!") 49 | 50 | let run domains _quiet bm25 (pack, idx, _stem) query = 51 | Miou_unix.run ~domains @@ fun () -> 52 | let queue = Flux.Bqueue.(create with_close) 0x7ff in 53 | let producer = Miou.async @@ fun () -> producer idx queue in 54 | let lst = List.init (Miou.Domain.available ()) (fun _ -> (pack, idx, queue)) in 55 | let consumers = Miou.parallel threads lst in 56 | let documents = 57 | List.map (function Ok docs -> docs | Error exn -> raise exn) consumers in 58 | let documents = List.flatten documents in 59 | Miou.await_exn producer ; 60 | let t = Bm25.make ~cfg:bm25 documents in 61 | let lst = Bm25.score t query in 62 | let lst = List.sort (fun (_, a) (_, b) -> Float.compare b a) lst in 63 | let show (((uid : Classeur.uid), _), score) = 64 | if score > 0.0 then Fmt.pr "%s: %f\n%!" (Ohex.encode (uid :> string)) score 65 | in 66 | List.iter show lst 67 | 68 | open Cmdliner 69 | open Blaze_cli 70 | 71 | let errorf ?(usage = true) fmt = Fmt.kstr (fun err -> `Error (usage, err)) fmt 72 | 73 | let setup_pack filename = 74 | let exists ~ext t = 75 | let t = Fpath.(to_string (set_ext ~multi:false ext t)) in 76 | Sys.file_exists t && Sys.is_regular_file t in 77 | let idx_exists = exists ~ext:".idx" 78 | and pack_exists = exists ~ext:".pack" 79 | and stem_exists = exists ~ext:".stem" in 80 | let to_idx = Fpath.set_ext ~multi:false ".idx" 81 | and to_pack = Fpath.set_ext ~multi:false ".pack" 82 | and to_stem_if_exists t = 83 | if stem_exists t then Some (Fpath.set_ext ~multi:false ".stem" t) else None 84 | in 85 | match Fpath.get_ext filename with 86 | | ".pack" when idx_exists filename -> 87 | `Ok (filename, to_idx filename, to_stem_if_exists filename) 88 | | ".idx" when pack_exists filename -> 89 | `Ok (to_pack filename, filename, to_stem_if_exists filename) 90 | | ".stem" when idx_exists filename && pack_exists filename -> 91 | `Ok (to_pack filename, to_idx filename, Some filename) 92 | | ".pack" | ".idx" | ".stem" -> 93 | let basename = Fpath.basename (Fpath.rem_ext filename) in 94 | errorf ~usage:false 95 | "Missing a file from an archive (%s.pack and %s.idx must exist)" 96 | basename basename 97 | | _ -> errorf ~usage:true "Invalid extension of %a" Fpath.pp filename 98 | 99 | let existing_file = 100 | let parser str = 101 | match Fpath.of_string str with 102 | | Ok v when Sys.file_exists str && Sys.is_regular_file str -> Ok v 103 | | Ok v -> error_msgf "%a not found" Fpath.pp v 104 | | Error _ as err -> err in 105 | let existing_file = Arg.conv (parser, Fpath.pp) in 106 | let doc = "The $(i,blaze) archive (*.pack or *.idx, both are required)." in 107 | let open Arg in 108 | required & pos 0 (some existing_file) None & info [] ~doc ~docv:"FILENAME" 109 | 110 | let setup_pack = 111 | let open Term in 112 | ret (const setup_pack $ existing_file) 113 | 114 | let setup_bm25 parallel encoding actions language = 115 | Bm25.config ~parallel ~encoding ~actions language 116 | 117 | let parallel = 118 | let doc = 119 | "With this option, calculation of occurrences is decoupled from the \ 120 | $(i,tokenisation) of a document." in 121 | Arg.(value & flag & info [ "parallel" ] ~doc) 122 | 123 | let setup_bm25 = 124 | let open Term in 125 | const setup_bm25 $ parallel $ encoding $ actions $ language 126 | 127 | let query = 128 | let doc = "The sentence to search into the given $(i,blaze) archive." in 129 | let open Arg in 130 | required & pos 1 (some string) None & info [] ~doc ~docv:"QUERY" 131 | 132 | let min = Int.min 4 (Stdlib.Domain.recommended_domain_count () - 1) 133 | 134 | let cmd = 135 | let doc = "The Okapi search engine applied into a $(i,blaze) archive." in 136 | let man = [] in 137 | let info = Cmd.info "okapi" ~doc ~man in 138 | let term = 139 | let open Term in 140 | const run $ threads ~min () $ setup_logs $ setup_bm25 $ setup_pack $ query 141 | in 142 | Cmd.v info term 143 | -------------------------------------------------------------------------------- /lib/git_miou_unix.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "blaze.git-miou-unix" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | let ( let@ ) finally fn = Fun.protect ~finally fn 6 | let ( let* ) = Result.bind 7 | 8 | type error = [ Smart.error | `Msg of string ] 9 | 10 | let pp_error ppf = function 11 | | #Smart.error as err -> Smart.pp_error ppf err 12 | | `Msg msg -> Fmt.string ppf msg 13 | 14 | let rec clear fd = function 15 | | Protocol.Error err -> Result.Error err 16 | | Return v -> Ok v 17 | | Read { k; buffer; off; len } -> 18 | let len = Miou_unix.read fd ~off ~len buffer in 19 | let res = if len = 0 then `End else `Len len in 20 | clear fd (k res) 21 | | Write { k; buffer; off; len } -> 22 | Miou_unix.write fd ~off ~len buffer ; 23 | clear fd (k len) 24 | 25 | let rec through (ic, oc) = function 26 | | Protocol.Error err -> Result.Error err 27 | | Return v -> Ok v 28 | | Read { k; buffer; off; len } -> 29 | let len = Stdlib.input ic buffer off len in 30 | Log.debug (fun m -> m "+%d byte(s)" len) ; 31 | Log.debug (fun m -> 32 | m "@[%a@]" 33 | (Hxd_string.pp Hxd.default) 34 | (Bytes.sub_string buffer off len)) ; 35 | let res = if len = 0 then `End else `Len len in 36 | through (ic, oc) (k res) 37 | | Write { k; buffer; off; len } -> 38 | output_substring oc buffer off len ; 39 | flush oc ; 40 | through (ic, oc) (k len) 41 | 42 | let digest = 43 | let open Digestif in 44 | let feed_bigstring bstr ctx = SHA1.feed_bigstring ctx bstr in 45 | let feed_bytes buf ~off ~len ctx = SHA1.feed_bytes ctx ~off ~len buf in 46 | let hash = 47 | { 48 | Carton.First_pass.feed_bytes; 49 | feed_bigstring; 50 | serialize = Fun.compose SHA1.to_raw_string SHA1.get; 51 | length = SHA1.digest_size; 52 | } in 53 | Carton.First_pass.Digest (hash, SHA1.empty) 54 | 55 | let identify = 56 | let open Digestif in 57 | let pp_kind ppf = function 58 | | `A -> Fmt.string ppf "commit" 59 | | `B -> Fmt.string ppf "tree" 60 | | `C -> Fmt.string ppf "blob" 61 | | `D -> Fmt.string ppf "tag" in 62 | let init kind (len : Carton.Size.t) = 63 | let hdr = Fmt.str "%a %d\000" pp_kind kind (len :> int) in 64 | let ctx = SHA1.empty in 65 | SHA1.feed_string ctx hdr in 66 | let feed bstr ctx = SHA1.feed_bigstring ctx bstr in 67 | let ( $ ) = Fun.compose in 68 | let serialize = SHA1.(Carton.Uid.unsafe_of_string $ to_raw_string $ get) in 69 | { Carton.First_pass.init; feed; serialize } 70 | 71 | let fetch_over_ssh ~user ~server ?(port = 22) path = 72 | let remote = Fmt.str "%s@%s" user server in 73 | let cmd = Fmt.str "git-upload-pack '%s'" path in 74 | let cmd = 75 | Fmt.str "ssh -p %d %s GIT_PROTOCOL=version=2 %a" port remote 76 | Fmt.(quote string) 77 | cmd in 78 | let ctx = Protocol.ctx () in 79 | let from = 80 | Flux.Source.with_task ~size:0x7ff @@ fun q -> 81 | let resource = Miou.Ownership.create ~finally:Flux.Bqueue.close q in 82 | Miou.Ownership.own resource ; 83 | let@ () = fun () -> Miou.Ownership.release resource in 84 | let t = Smart.clone ~protocol:`SSH ctx q in 85 | let ic, oc = Unix.open_process cmd in 86 | let git_result = through (ic, oc) t in 87 | let cmd_result = Unix.close_process (ic, oc) in 88 | match (git_result, cmd_result) with 89 | | Ok false, Unix.WEXITED 0 -> () 90 | | Ok _, Unix.WEXITED n -> 91 | Log.err (fun m -> m "SSH process exited with %d code" n) 92 | | _, Unix.(WSIGNALED _ | WSTOPPED _) -> 93 | Log.err (fun m -> m "SSH process abnormally stopped") 94 | | Error err, _ -> Log.err (fun m -> m "%a" Smart.pp_error err) in 95 | Ok from 96 | 97 | let fetch_over_tcp ~server ?(port = 9418) path he = 98 | let* _, socket = Happy_eyeballs_miou_unix.connect he server [ port ] in 99 | let ctx = Protocol.ctx () in 100 | let from = 101 | Flux.Source.with_task ~size:0x7ff @@ fun q -> 102 | let t = Smart.clone ~protocol:(`Git path) ctx q in 103 | let@ () = fun () -> Miou_unix.close socket in 104 | match clear socket t with 105 | | Ok false -> () 106 | | Ok true -> Log.warn (fun m -> m "Remote Git server failed") 107 | | Error err -> Log.err (fun m -> m "%a" Smart.pp_error err) in 108 | Ok from 109 | 110 | let fetch remote he producer = 111 | let@ () = fun () -> Flux.Bqueue.close producer in 112 | let* from = 113 | match remote with 114 | | `Git (server, port, path) -> fetch_over_tcp ~server ?port path he 115 | | `SSH (user, server, port, path) -> fetch_over_ssh ~user ~server ?port path 116 | in 117 | let filename = Filename.temp_file "public-inbox-" ".pack" in 118 | let oc = open_out_bin filename in 119 | let@ () = fun () -> close_out oc in 120 | let into_filename str = 121 | output_string oc str ; 122 | flush oc in 123 | let via = 124 | let open Flux.Flow in 125 | let flow = Carton_miou_flux.first_pass ~ref_length:20 ~digest in 126 | compose (tap into_filename) flow in 127 | let into = Carton_miou_flux.oracle ~identify in 128 | Log.debug (fun m -> m "Start to analyze incoming PACK file") ; 129 | let oracle, _leftover = Flux.Stream.run ~from ~via ~into in 130 | Log.debug (fun m -> m "Repository cloned into %s" filename) ; 131 | let pack = Carton_miou_unix.make ~ref_length:20 (Fpath.v filename) in 132 | let entries = Carton_miou_flux.entries pack oracle in 133 | let fn (value, _cursor, uid) = 134 | match Carton.Value.kind value with 135 | | `C -> 136 | Log.debug (fun m -> m "New Git object: %a" Carton.Uid.pp uid) ; 137 | let raw = Carton.Value.bigstring value in 138 | Log.debug (fun m -> 139 | m "@[%a@]" (Hxd_string.pp Hxd.default) (Bstr.to_string raw)) ; 140 | Flux.Bqueue.put producer (uid, raw) 141 | | _ -> () in 142 | Log.debug (fun m -> m "Start to collect Git objects") ; 143 | Flux.Source.each fn entries ; 144 | Ok () 145 | -------------------------------------------------------------------------------- /lib/dns_static.ml: -------------------------------------------------------------------------------- 1 | let msgf fmt = Fmt.kstr (fun msg -> `Msg msg) fmt 2 | let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt 3 | let src = Logs.Src.create "dns-cache" 4 | 5 | module Log = (val Logs.src_log src : Logs.LOG) 6 | 7 | type record = Record : ('a Dns.Rr_map.rr * 'a) -> record 8 | type local = record list Domain_name.Map.t 9 | 10 | let rec assoc : type a. a Dns.Rr_map.rr -> record list -> a = 11 | fun record lst -> 12 | match (record, lst) with 13 | | Dns.Rr_map.Mx, Record (Mx, v) :: _ -> v 14 | | Dns.Rr_map.A, Record (A, v) :: _ -> v 15 | | Dns.Rr_map.Aaaa, Record (Aaaa, v) :: _ -> v 16 | | Dns.Rr_map.Txt, Record (Txt, v) :: _ -> v 17 | | _, [] -> raise Not_found 18 | | _, _ :: lst -> assoc record lst 19 | 20 | exception Invalid_line of string 21 | 22 | let mx (v, preference) = 23 | { 24 | Dns.Mx.preference = int_of_string preference; 25 | Dns.Mx.mail_exchange = Domain_name.(host_exn (of_string_exn v)); 26 | } 27 | 28 | let is_colon = ( = ) ':' 29 | 30 | let parse_line line = 31 | match Astring.String.cut ~sep:":" line with 32 | | Some ("txt", str) -> 33 | Record (Dns.Rr_map.Txt, (0l, Dns.Rr_map.Txt_set.singleton str)) 34 | | Some ("a", ipv4s) -> 35 | let lst = Astring.String.cuts ~sep:" " ipv4s in 36 | let lst = List.map Ipaddr.V4.of_string_exn lst in 37 | let set = Ipaddr.V4.Set.of_list lst in 38 | Record (Dns.Rr_map.A, (0l, set)) 39 | | Some ("aaaa", ipv6s) -> 40 | let lst = Astring.String.cuts ~sep:" " ipv6s in 41 | let lst = List.map Ipaddr.V6.of_string_exn lst in 42 | let set = Ipaddr.V6.Set.of_list lst in 43 | Record (Dns.Rr_map.Aaaa, (0l, set)) 44 | | Some ("mx", mxs) -> 45 | let lst = Astring.String.cuts ~sep:" " mxs in 46 | let lst = List.map (Astring.String.span ~sat:is_colon) lst in 47 | let lst = List.map mx lst in 48 | Record (Dns.Rr_map.Mx, (0l, Dns.Rr_map.Mx_set.of_list lst)) 49 | | _ -> raise (Invalid_line line) 50 | 51 | let parse_line line = 52 | try parse_line line with 53 | | Invalid_line _ as exn -> raise exn 54 | | _ -> raise (Invalid_line line) 55 | 56 | let of_fpath local fpath = 57 | if Fpath.get_ext fpath = ".dns" 58 | then 59 | let domain_name = Fpath.(basename (rem_ext fpath)) in 60 | match Domain_name.of_string domain_name with 61 | | Error _ -> 62 | Log.warn (fun m -> m "%a is not a valid DNS cache file." Fpath.pp fpath) ; 63 | error_msgf "Invalid filename as a DNS cache: %a" Fpath.pp fpath 64 | | Ok domain_name -> 65 | let ic = open_in (Fpath.to_string fpath) in 66 | let rec go acc = 67 | match input_line ic |> parse_line with 68 | | value -> go (value :: acc) 69 | | exception End_of_file -> List.rev acc 70 | | exception Invalid_line _ -> go acc in 71 | let records = go [] in 72 | Ok (Domain_name.Map.add domain_name records local) 73 | else error_msgf "Invalid filename as a DNS cache: %a" Fpath.pp fpath 74 | 75 | let of_directory directory = 76 | let fold fpath local = 77 | match of_fpath local fpath with 78 | | Ok local -> local 79 | | Error _ -> 80 | Log.warn (fun m -> m "%a is ignored." Fpath.pp fpath) ; 81 | local in 82 | Bos.OS.Dir.fold_contents ~elements:`Files ~dotfiles:true ~traverse:`None fold 83 | Domain_name.Map.empty directory 84 | 85 | let getaddrinfo : type a. 86 | local -> 87 | a Dns.Rr_map.rr -> 88 | 'v Domain_name.t -> 89 | (a, [> `Msg of string ]) result = 90 | fun local record domain_name -> 91 | let none = msgf "record does not exist locally" in 92 | Domain_name.Map.find (Domain_name.raw domain_name) local 93 | |> Option.map (assoc record) 94 | |> Option.to_result ~none 95 | 96 | type t = { dns : Dns_client_miou_unix.t; local : local } 97 | 98 | let create ?cache_size ?edns ?nameservers ?timeout 99 | ?(local = Domain_name.Map.empty) stack = 100 | let dns = 101 | Dns_client_miou_unix.create ?cache_size ?edns ?nameservers ?timeout stack 102 | in 103 | { dns; local } 104 | 105 | let getaddrinfo : type a. 106 | t -> a Dns.Rr_map.rr -> 'v Domain_name.t -> (a, [> `Msg of string ]) result 107 | = 108 | fun t record domain_name -> 109 | match getaddrinfo t.local record domain_name with 110 | | Ok _ as v -> v 111 | | Error _ -> Dns_client_miou_unix.getaddrinfo t.dns record domain_name 112 | 113 | let gethostbyname { local; dns } domain_name = 114 | let cached = 115 | Domain_name.Map.find (Domain_name.raw domain_name) local 116 | |> Option.map (assoc Dns.Rr_map.A) in 117 | match cached with 118 | | Some (_, vs) -> Ok (Ipaddr.V4.Set.choose vs) 119 | | None -> Dns_client_miou_unix.gethostbyname dns domain_name 120 | 121 | let gethostbyname6 { local; dns } domain_name = 122 | let cached = 123 | Domain_name.Map.find (Domain_name.raw domain_name) local 124 | |> Option.map (assoc Dns.Rr_map.Aaaa) in 125 | match cached with 126 | | Some (_, vs) -> Ok (Ipaddr.V6.Set.choose vs) 127 | | None -> Dns_client_miou_unix.gethostbyname6 dns domain_name 128 | 129 | type error = 130 | [ `Msg of string 131 | | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t 132 | | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ] 133 | 134 | let get_resource_record : type a. 135 | local -> a Dns.Rr_map.rr -> 'v Domain_name.t -> (a, [> error ]) result = 136 | fun local record domain_name -> 137 | let domain_name = Domain_name.raw domain_name in 138 | let cached = 139 | Domain_name.Map.find_opt domain_name local |> Option.map (assoc record) 140 | in 141 | match cached with 142 | | Some v -> Ok v 143 | | None -> error_msgf "record does not exist locally" 144 | 145 | let get_resource_record : type a. 146 | t -> a Dns.Rr_map.rr -> 'v Domain_name.t -> (a, [> error ]) result = 147 | fun t record domain_name -> 148 | match get_resource_record t.local record domain_name with 149 | | Ok _ as v -> v 150 | | Error _ -> Dns_client_miou_unix.get_resource_record t.dns record domain_name 151 | -------------------------------------------------------------------------------- /bin/mdir.ml: -------------------------------------------------------------------------------- 1 | let rec transmit ic oc = 2 | let tmp = Bytes.create 0x1000 in 3 | go tmp ic oc 4 | 5 | and go tmp ic oc = 6 | let len = input ic tmp 0 (Bytes.length tmp) in 7 | if len > 0 8 | then ( 9 | output oc tmp 0 len ; 10 | go tmp ic oc) 11 | 12 | let random g () = Random.State.int64 g Int64.max_int 13 | let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt 14 | 15 | let get _ g hostname maildir new_message message output = 16 | let message = if new_message then Maildir.with_new message else message in 17 | let host = Domain_name.to_string hostname in 18 | if message.Maildir.value.Maildir.host <> host 19 | then 20 | Logs.warn (fun m -> 21 | m "The given host (%s) is different from the host's message (%s)." host 22 | message.Maildir.value.Maildir.host) ; 23 | let maildir = 24 | Maildir.create ~pid:(Unix.getpid ()) ~host ~random:(random g) maildir in 25 | let fpath = Maildir_unix.get maildir message in 26 | if Sys.file_exists (Fpath.to_string fpath) 27 | then ( 28 | let ic = open_in (Fpath.to_string fpath) in 29 | let oc, close_oc = 30 | match output with 31 | | Some fpath -> (open_out (Fpath.to_string fpath), close_out) 32 | | None -> (stdout, ignore) in 33 | transmit ic oc ; 34 | close_in ic ; 35 | close_oc oc ; 36 | `Ok ()) 37 | else `Error (false, Fmt.str "%a does not exist." Fpath.pp fpath) 38 | 39 | let new_messages _ g hostname maildir = 40 | let host = Domain_name.to_string hostname in 41 | let maildir = 42 | Maildir.create ~pid:(Unix.getpid ()) ~host ~random:(random g) maildir in 43 | let fold () { Maildir.value; _ } = Fmt.pr "%a\n%!" Maildir.pp_message value in 44 | Maildir_unix.scan_only_new fold () Maildir_unix.fs maildir ; 45 | `Ok () 46 | 47 | let commit _ g hostname maildir flags new_message message = 48 | let message = if new_message then Maildir.with_new message else message in 49 | let host = Domain_name.to_string hostname in 50 | if message.Maildir.value.Maildir.host <> host 51 | then 52 | Logs.warn (fun m -> 53 | m "The given host (%s) is different from the host's message (%s)." host 54 | message.Maildir.value.Maildir.host) ; 55 | let maildir = 56 | Maildir.create ~pid:(Unix.getpid ()) ~host ~random:(random g) maildir in 57 | Maildir_unix.commit Maildir_unix.fs maildir ~flags message ; 58 | `Ok () 59 | 60 | open Cmdliner 61 | open Blaze_cli 62 | 63 | let maildir = 64 | let parser str = 65 | match Fpath.of_string str with 66 | | Ok _ as v when Sys.is_directory str -> v 67 | | Ok v -> error_msgf "%a is not an existing directory" Fpath.pp v 68 | | Error _ as err -> err in 69 | Arg.conv (parser, Fpath.pp) 70 | 71 | let maildir = 72 | let doc = "The $(i,maildir) path." in 73 | let env = Cmd.Env.info ~doc "BLAZE_MDIR" in 74 | Arg.(required & opt (some maildir) None & info [ "D"; "maildir" ] ~env ~doc) 75 | 76 | let message = 77 | let parser str = Maildir.of_filename str in 78 | let pp ppf { Maildir.value; _ } = Maildir.pp_message ppf value in 79 | Arg.conv (parser, pp) 80 | 81 | let message = 82 | let doc = "The message identifier." in 83 | Arg.(required & pos ~rev:true 0 (some message) None & info [] ~doc) 84 | 85 | let new_file = Arg.conv (Fpath.of_string, Fpath.pp) 86 | 87 | let output = 88 | let doc = "The path of the file to store the given email." in 89 | Arg.(value & opt (some new_file) None & info [ "o"; "output" ] ~doc) 90 | 91 | let domain_name = Arg.conv (Domain_name.of_string, Domain_name.pp) 92 | 93 | let hostname = 94 | let doc = "The hostname of the computer." in 95 | Arg.( 96 | value 97 | & opt domain_name (Domain_name.of_string_exn (Unix.gethostname ())) 98 | & info [ "h"; "hostname" ] ~doc) 99 | 100 | let new_message = 101 | let doc = "If the message is a new one." in 102 | Arg.(value & flag & info [ "n"; "new" ] ~doc) 103 | 104 | let seed = 105 | let doc = "Seed used by the random number generator." in 106 | let base64 = 107 | Arg.conv 108 | ((fun str -> Base64.decode str), Fmt.using Base64.encode_string Fmt.string) 109 | in 110 | Arg.(value & opt (some base64) None & info [ "s"; "seed" ] ~doc) 111 | 112 | let flags = 113 | let flags = 114 | let open Arg in 115 | [ 116 | (Maildir.SEEN, info [ "seen" ] ~doc:"The message is tagged as seen."); 117 | ( Maildir.REPLIED, 118 | info [ "replied" ] ~doc:"The message is tagged as replied." ); 119 | ( Maildir.FLAGGED, 120 | info [ "flagged" ] ~doc:"The message is tagged as flagged." ); 121 | ( Maildir.TRASHED, 122 | info [ "trashed" ] ~doc:"The message is tagged as trashed." ); 123 | (Maildir.PASSED, info [ "passed" ] ~doc:"The message is tagged as passed."); 124 | (Maildir.DRAFT, info [ "draft" ] ~doc:"The message is tagged as a draft."); 125 | ] in 126 | Arg.(value & vflag_all [] flags) 127 | 128 | let get = 129 | let doc = "Load and store the given message to the $(i,output)." in 130 | let man = [] in 131 | let term = 132 | let open Term in 133 | ret 134 | (const get 135 | $ setup_logs 136 | $ setup_random 137 | $ hostname 138 | $ maildir 139 | $ new_message 140 | $ message 141 | $ output) in 142 | Cmd.v (Cmd.info "get" ~doc ~man) term 143 | 144 | let new_messages = 145 | let doc = "Scan and show new messages from the given $(i,maildir)." in 146 | let man = 147 | [ 148 | `S Manpage.s_description; 149 | `P "From the given $(i,maildir), $(b,new) shows new messages."; 150 | ] in 151 | let term = 152 | let open Term in 153 | ret (const new_messages $ setup_logs $ setup_random $ hostname $ maildir) 154 | in 155 | Cmd.v (Cmd.info "new" ~doc ~man) term 156 | 157 | let commit = 158 | let doc = 159 | "Commit the specified message with some flags from the given $(i,maildir)." 160 | in 161 | let man = 162 | [ 163 | `S Manpage.s_description; 164 | `P "Tag and move the specified message from the given $(i,maildir)."; 165 | ] in 166 | let term = 167 | let open Term in 168 | ret 169 | (const commit 170 | $ setup_logs 171 | $ setup_random 172 | $ hostname 173 | $ maildir 174 | $ flags 175 | $ new_message 176 | $ message) in 177 | Cmd.v (Cmd.info "commit" ~doc ~man) term 178 | 179 | let default = Term.(ret (const (`Help (`Pager, None)))) 180 | 181 | let cmd = 182 | let doc = "A tool to manipulate a $(i,maildir) directory." in 183 | let man = 184 | [ 185 | `S Manpage.s_description; 186 | `P 187 | "From the given $(i,maildir) and the message $(i,id), $(b,get) loads \ 188 | and shows the entire message."; 189 | ] in 190 | Cmd.group ~default (Cmd.info "mdir" ~doc ~man) [ get; new_messages; commit ] 191 | -------------------------------------------------------------------------------- /bin/blaze_mbox.ml: -------------------------------------------------------------------------------- 1 | let ( $ ) f g = fun x -> f (g x) 2 | 3 | let parallel ~fn lst = 4 | let domains = Miou.Domain.available () in 5 | let chop len lst = 6 | let rec go acc n lst = 7 | if n <= 0 8 | then (acc, lst) 9 | else match lst with [] -> (acc, []) | x :: r -> go (x :: acc) (n - 1) r 10 | in 11 | go [] len lst in 12 | let rec go acc lst = 13 | match (acc, lst) with 14 | | (Error _ as err), _ -> err 15 | | Ok acc, [] -> Ok acc 16 | | Ok acc, lst -> 17 | let todo, lst = chop domains lst in 18 | let results = Miou.parallel fn todo in 19 | let rec check acc = function 20 | | [] -> go (Ok acc) lst 21 | | Ok value :: rest -> check (value :: acc) rest 22 | | (Error _ as err) :: _ -> err in 23 | check acc results in 24 | go (Ok []) lst 25 | 26 | let load _uid = function 27 | | Pack.Stem (_uid, _blob, _length, _tbl) -> assert false (* TODO *) 28 | | Pack.Mail str -> Carton.Value.of_string ~kind:`A str 29 | | Pack.Body (filename, pos, len) -> 30 | let fd = 31 | Unix.openfile (Fpath.to_string filename) Unix.[ O_RDONLY ] 0o644 in 32 | let finally () = Unix.close fd in 33 | Fun.protect ~finally @@ fun () -> 34 | let barr = 35 | Unix.map_file fd ~pos:(Int64.of_int pos) Bigarray.char Bigarray.c_layout 36 | false [| len |] in 37 | let bstr = Bigarray.array1_of_genarray barr in 38 | Carton.Value.make ~kind:`B bstr 39 | 40 | let delete_duplicates ?(quiet = true) entriess = 41 | let tbl = Hashtbl.create 0x100 in 42 | let cnt = ref 0 in 43 | let rec go acc = function 44 | | [] -> List.rev acc 45 | | entry :: rest -> ( 46 | let hash = Cartonnage.Entry.uid entry in 47 | match Hashtbl.find tbl hash with 48 | | _ -> 49 | incr cnt ; 50 | go acc rest 51 | | exception Not_found -> 52 | Hashtbl.add tbl hash () ; 53 | go (entry :: acc) rest) in 54 | if (not quiet) && !cnt > 0 then Fmt.pr "%d duplicate entries\n%!" !cnt ; 55 | List.fold_left (fun acc entries -> go [] entries :: acc) [] entriess 56 | 57 | let explode ?tmp:temp_dir seq = 58 | let producer seq = 59 | let rec go mails seq actual = 60 | match (actual, Seq.uncons seq) with 61 | | None, Some (`From _, seq) -> 62 | let tmp = Filename.temp_file ?temp_dir "blaze-" ".eml" in 63 | let oc = open_out tmp in 64 | let tmp = Fpath.v tmp in 65 | go (tmp :: mails) seq (Some (tmp, oc)) 66 | | Some (tmp, oc), Some (`Line line, seq) -> 67 | output_string oc line ; 68 | go mails seq (Some (tmp, oc)) 69 | | None, Some (`Line line, _) -> 70 | Logs.err (fun m -> m "Unexpected line: %S" line) ; 71 | assert false 72 | | Some (_, oc), Some (`From _, seq) -> 73 | close_out oc ; 74 | let tmp = Filename.temp_file ?temp_dir "blaze-" ".eml" in 75 | let oc = open_out tmp in 76 | let tmp = Fpath.v tmp in 77 | go (tmp :: mails) seq (Some (tmp, oc)) 78 | | None, None -> mails 79 | | Some (_, oc), None -> 80 | close_out oc ; 81 | mails in 82 | go [] seq None in 83 | producer seq 84 | 85 | let bar ~total = 86 | let open Progress.Line in 87 | let style = if Fmt.utf_8 Fmt.stdout then `UTF8 else `ASCII in 88 | list [ brackets @@ bar ~style ~width:(`Fixed 30) total; count_to total ] 89 | 90 | let with_reporter ~config ?total quiet = 91 | match (quiet, total) with 92 | | true, _ | _, None -> (ignore, ignore) 93 | | false, Some total -> 94 | let display = Progress.(Display.start ~config Multi.(line (bar ~total))) in 95 | let[@warning "-8"] Progress.Reporter.[ reporter ] = 96 | Progress.Display.reporters display in 97 | let on n = 98 | reporter n ; 99 | Progress.Display.tick display in 100 | let finally () = Progress.Display.finalise display in 101 | (on, finally) 102 | 103 | let run_pack quiet progress without_progress threads mbox output = 104 | Miou_unix.run ~domains:threads @@ fun () -> 105 | let ( let* ) = Result.bind in 106 | let ic, ic_finally = 107 | match mbox with 108 | | "-" -> (stdin, ignore) 109 | | filename -> 110 | let ic = open_in filename in 111 | let finally () = close_in ic in 112 | (ic, finally) in 113 | Fun.protect ~finally:ic_finally @@ fun () -> 114 | let seq = Mbox.of_in_channel ic in 115 | let mails = explode seq in 116 | let* mails = parallel ~fn:Pack.filename_to_email mails in 117 | let* entries = parallel ~fn:Pack.email_to_entries mails in 118 | let entries = delete_duplicates ~quiet entries in 119 | let with_header = 120 | List.fold_left (fun acc entries -> acc + List.length entries) 0 entries 121 | in 122 | let entries = List.map List.to_seq entries in 123 | let entries = List.to_seq entries in 124 | let entries = Seq.concat entries in 125 | let targets = Pack.delta ~load entries in 126 | let with_signature = Digestif.SHA1.empty in 127 | let on, finally = 128 | with_reporter ~config:progress ~total:with_header (quiet || without_progress) 129 | in 130 | Fun.protect ~finally @@ fun () -> 131 | let targets = 132 | Seq.map 133 | (fun value -> 134 | on 1 ; 135 | value) 136 | targets in 137 | let pack = Pack.to_pack ~with_header ~with_signature ~load targets in 138 | let oc, oc_finally = 139 | match output with 140 | | Some filename -> 141 | let oc = open_out filename in 142 | let finally () = close_out oc in 143 | (oc, finally) 144 | | None -> (stdout, ignore) in 145 | Fun.protect ~finally:oc_finally @@ fun () -> 146 | Seq.iter (output_string oc) pack ; 147 | Ok () 148 | 149 | open Cmdliner 150 | open Blaze_cli 151 | 152 | let mbox = 153 | let doc = "The mbox file to manipulate." in 154 | let open Arg in 155 | value & pos 0 Blaze_cli.file "-" & info [] ~doc ~docv:"FILE" 156 | 157 | let output = 158 | let doc = "The output file where to save the PACK file." in 159 | let open Arg in 160 | value 161 | & opt (some non_existing_file) None 162 | & info [ "o"; "output" ] ~doc ~docv:"FILE" 163 | 164 | let pack_term = 165 | let open Term in 166 | let to_result = function 167 | | Ok () -> `Ok () 168 | | Error exn -> `Error (false, Fmt.str "%s." (Printexc.to_string exn)) in 169 | let term = 170 | const run_pack 171 | $ setup_logs 172 | $ setup_progress 173 | $ without_progress 174 | $ threads ~min:2 () 175 | $ mbox 176 | $ output in 177 | ret (const to_result $ term) 178 | 179 | let cmd = 180 | let doc = "Transform a mbox file to a PACK file." in 181 | let man = [] in 182 | let info = Cmd.info "mbox" ~doc ~man in 183 | Cmd.v info pack_term 184 | -------------------------------------------------------------------------------- /test/001.mail: -------------------------------------------------------------------------------- 1 | Return-Path: 2 | 3 | Delivered-To: romain.calascibetta@gmail.com 4 | Received: by 10.103.97.5 with SMTP id v5csp377109vsb; 5 | Wed, 9 Nov 2016 12:10:29 -0800 (PST) 6 | X-Received: by 10.107.23.132 with SMTP id 126mr2066605iox.162.1478722229144; 7 | Wed, 09 Nov 2016 12:10:29 -0800 (PST) 8 | Received: from o3.sgmail.github.com (o3.sgmail.github.com. [192.254.112.98]) 9 | by mx.google.com with ESMTPS id z2si859821pac.156.2016.11.09.12.10.28 10 | for 11 | (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); 12 | Wed, 09 Nov 2016 12:10:29 -0800 (PST) 13 | Received-SPF: pass (google.com: domain of bounces+848413-e276-romain.calascibetta=gmail.com@sgmail.github.com designates 192.254.112.98 as permitted sender) client-ip=192.254.112.98; 14 | Authentication-Results: mx.google.com; 15 | dkim=pass header.i=@github.com; 16 | dkim=pass header.i=@sendgrid.info; 17 | spf=pass (google.com: domain of bounces+848413-e276-romain.calascibetta=gmail.com@sgmail.github.com designates 192.254.112.98 as permitted sender) smtp.mailfrom=bounces+848413-e276-romain.calascibetta=gmail.com@sgmail.github.com; 18 | dmarc=pass (p=NONE dis=NONE) header.from=github.com 19 | DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=github.com; 20 | h=from:reply-to:to:in-reply-to:references:subject:mime-version:content-type:content-transfer-encoding:list-id:list-archive:list-post:list-unsubscribe; 21 | s=s20150108; bh=s6/5UvcmmcpgdLr/3NPN3KPXQkM=; b=SuEKjwfkRl80MV9g 22 | CKDfzQlCeN/DteYLBKvZ0N+5mvGS1ZhvU3dTUqULNRRYUQ3cfg27+GoAOgRI0v4K 23 | sOhiA9TJMISOM6cjgK8RGFsFtJpumQWBCGU6ar1c3aZi+BJFMXXVgojF2k4usfg6 24 | ivI84LCjaJK+JJgK65TDiedXBwg= 25 | DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=sendgrid.info; 26 | h=from:reply-to:to:in-reply-to:references:subject:mime-version:content-type:content-transfer-encoding:list-id:list-archive:list-post:list-unsubscribe:x-feedback-id; 27 | s=smtpapi; bh=s6/5UvcmmcpgdLr/3NPN3KPXQkM=; b=iIicLeoJbjxponA15g 28 | qgGQ7tAszmj/EK0V6aLVnmKeUr6ESwIWxh9X/jVmTft386dsvmcmdDaljPH3DEWG 29 | 3UlnlUHawvw6M1jXqIitaTYH6DGwcg/0G6YheGulw9oOQuMSFnyljEYU9P9WLdOq 30 | ob84IH4kfp+oGTyZWKf1QKc+g= 31 | Received: by filter0103p1las1.sendgrid.net with SMTP id filter0103p1las1-15046-582382B3-12 32 | 2016-11-09 20:10:27.258036245 +0000 UTC 33 | Received: from github-smtp2b-ext-cp1-prd.iad.github.net (github-smtp2b-ext-cp1-prd.iad.github.net [192.30.253.17]) 34 | by ismtpd0004p1iad1.sendgrid.net (SG) with ESMTP id sCMGnCRJTneGeHsvYr_ZrQ 35 | for ; Wed, 09 Nov 2016 20:10:27.367 +0000 (UTC) 36 | Date: Wed, 09 Nov 2016 12:10:27 -0800 37 | From: Thomas Gazagnaire 38 | Reply-To: mirage/irmin 39 | To: mirage/irmin 40 | Message-ID: 41 | In-Reply-To: 42 | References: 43 | Subject: Re: [mirage/irmin] use a numerical version in META (_NUM strips 44 | leading v) (#378) 45 | Mime-Version: 1.0 46 | Content-Type: multipart/alternative; 47 | boundary="--==_mimepart_582382b3482a9_41fe3fcae2335134114081"; 48 | charset=UTF-8 49 | Content-Transfer-Encoding: 7bit 50 | Precedence: list 51 | X-GitHub-Sender: samoht 52 | X-GitHub-Recipient: dinosaure 53 | List-ID: mirage/irmin 54 | List-Archive: https://github.com/mirage/irmin 55 | List-Post: 56 | List-Unsubscribe: , 57 | 58 | X-Auto-Response-Suppress: All 59 | X-GitHub-Recipient-Address: romain.calascibetta@gmail.com 60 | X-SG-EID: cmZW6+3/0nIS8wiCq3K5Gx142PtEnYtDodOm+A+XOu1I4um33tvQzCB/qgw7ttUwp5+ca0gThBkIFA 61 | QgX8ETLCAANVJiBg4fghHzmvUPXlL1piLUotS21nFGcpk2k3Y8u/frKhDf1FOUG3Vj95iEAquHo/H2 62 | +BrGZB6ljwNTFHIsjNn2scRyPuov1FkVZmyKRJMkJXPT/0gd9pywiNVVY+aJlmUnEYLdJvjd00G7Ey 63 | 9rrwfDq9T59ARt+YoGtMGZ 64 | X-Feedback-ID: 848413:6xvVEJqleZlAW7/vhv7PzD/cv5tamo2SWZDKyvugGvg=:6xvVEJqleZlAW7/vhv7PzD/cv5tamo2SWZDKyvugGvg=:SG 65 | X-getmail-retrieved-from-mailbox: INBOX 66 | X-GMAIL-THRID: =?utf-8?q?1550517059353564079?= 67 | X-GMAIL-MSGID: =?utf-8?q?1550552640229331727?= 68 | 69 | ----==_mimepart_582382b3482a9_41fe3fcae2335134114081 70 | Content-Type: text/plain; 71 | charset=UTF-8 72 | Content-Transfer-Encoding: 7bit 73 | 74 | The TravisCI error is unrelated. 75 | 76 | -- 77 | You are receiving this because you are subscribed to this thread. 78 | Reply to this email directly or view it on GitHub: 79 | https://github.com/mirage/irmin/pull/378#issuecomment-259513470 80 | ----==_mimepart_582382b3482a9_41fe3fcae2335134114081 81 | Content-Type: text/html; 82 | charset=UTF-8 83 | Content-Transfer-Encoding: 7bit 84 | 85 |

The TravisCI error is unrelated.

86 | 87 |

—
You are receiving this because you are subscribed to this thread.
Reply to this email directly, view it on GitHub, or mute the thread.

88 |
89 |
90 | 91 | 92 |
93 | 94 |
95 | 96 | 97 | ----==_mimepart_582382b3482a9_41fe3fcae2335134114081-- 98 | -------------------------------------------------------------------------------- /bin/map.ml: -------------------------------------------------------------------------------- 1 | let const x _ = x 2 | let emitter_of_queue q = function Some str -> Queue.push str q | None -> () 3 | let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt 4 | 5 | let stream_of_queue q () = 6 | match Queue.pop q with 7 | | v -> Some (v, 0, String.length v) 8 | | exception Queue.Empty -> None 9 | 10 | let blit src src_off dst dst_off len = 11 | Bstr.blit_from_string src ~src_off dst ~dst_off ~len 12 | 13 | let empty_part ~header = Mrmime.Mt.part ~header (const None) 14 | 15 | let parser ic = 16 | let uid = ref (-1) in 17 | let tbl = Hashtbl.create 0x10 in 18 | let emitters _header = 19 | incr uid ; 20 | let v = !uid in 21 | let contents = Queue.create () in 22 | Hashtbl.add tbl v contents ; 23 | (emitter_of_queue contents, v) in 24 | let parser = Mrmime.Mail.stream emitters in 25 | let rec loop ic ke = function 26 | | Angstrom.Unbuffered.Done (_, (header, mail)) -> Ok (header, mail, tbl) 27 | | Fail _ -> error_msgf "Invalid incoming email" 28 | | Partial { committed; continue } -> ( 29 | Ke.Rke.N.shift_exn ke committed ; 30 | if committed = 0 then Ke.Rke.compress ke ; 31 | match input_line ic with 32 | | line -> 33 | Ke.Rke.N.push ke ~blit ~length:String.length ~off:0 34 | ~len:(String.length line) line ; 35 | Ke.Rke.push ke '\r' ; 36 | Ke.Rke.push ke '\n' ; 37 | let[@warning "-8"] (slice :: _) = Ke.Rke.N.peek ke in 38 | loop ic ke 39 | (continue slice ~off:0 ~len:(Bstr.length slice) Incomplete) 40 | | exception End_of_file -> 41 | let buf = 42 | match Ke.Rke.length ke with 43 | | 0 -> Bstr.empty 44 | | _ -> 45 | Ke.Rke.compress ke ; 46 | List.hd (Ke.Rke.N.peek ke) in 47 | loop ic ke (continue buf ~off:0 ~len:(Bstr.length buf) Complete)) 48 | in 49 | let ke = Ke.Rke.create ~capacity:0x1000 Bigarray.char in 50 | loop ic ke (Angstrom.Unbuffered.parse parser) 51 | 52 | let encoder header mail tbl = 53 | let open Mrmime in 54 | let rec to_mail = function 55 | | header, Mail.Leaf body -> 56 | let body = stream_of_queue (Hashtbl.find tbl body) in 57 | Mt.part ~header body |> Mt.make Header.empty Mt.simple 58 | | header, Mail.Message (header', body) -> 59 | to_mail (header', body) 60 | |> Mt.to_stream 61 | |> Mt.part ~header 62 | |> Mt.make Header.empty Mt.simple 63 | | header, Mail.Multipart parts -> 64 | let f (header, body) = 65 | match body with 66 | | Some body -> to_part (header, body) 67 | | None -> empty_part ~header in 68 | let parts = List.map f parts in 69 | Mt.multipart ~header ~rng:Mt.rng parts |> Mt.make Header.empty Mt.multi 70 | and to_part = function 71 | | header, Mail.Leaf body -> 72 | let body = stream_of_queue (Hashtbl.find tbl body) in 73 | Mt.part ~header body 74 | | header, Mail.Message (header', body) -> 75 | to_mail (header', body) |> Mt.to_stream |> Mt.part ~header 76 | | header, Mail.Multipart parts -> 77 | let f (header, body) = 78 | match body with 79 | | Some body -> to_part (header, body) 80 | | None -> empty_part ~header in 81 | let parts = List.map f parts in 82 | Mt.multipart ~header ~rng:Mt.rng parts |> Mt.multipart_as_part in 83 | to_mail (header, mail) 84 | 85 | let crlf = Astring.String.Sub.v "\r\n" 86 | 87 | (* XXX(dinosaure): it's needed to sanitize the incoming stream because we composed 88 | it with unsanitized streams. So we have a mix between "line per line" streams 89 | generated by [mrmime] and non "line per line" streams. *) 90 | 91 | let rec transmit state oc stream = 92 | match stream () with 93 | | Some (_, _, 0) -> transmit state oc stream 94 | | Some (str, off, len) when state = `CR && str.[0] = '\n' -> ( 95 | output_char oc '\n' ; 96 | let lines = 97 | List.map Astring.String.Sub.to_string 98 | Astring.String.( 99 | Sub.cuts ~sep:crlf (sub_with_range ~first:(off + 1) ~len str)) in 100 | let lines = String.concat "\n" lines in 101 | match str.[off + len - 1] with 102 | | '\r' -> 103 | output_substring oc lines 0 (String.length lines - 1) ; 104 | transmit `CR oc stream 105 | | _ -> 106 | output_string oc lines ; 107 | transmit `None oc stream) 108 | | Some (str, off, len) -> ( 109 | let lines = 110 | List.map Astring.String.Sub.to_string 111 | Astring.String.( 112 | Sub.cuts ~sep:crlf (sub_with_range ~first:off ~len str)) in 113 | let lines = String.concat "\n" lines in 114 | match str.[off + len - 1] with 115 | | '\r' -> 116 | output_substring oc lines 0 (String.length lines - 1) ; 117 | transmit `CR oc stream 118 | | _ -> 119 | output_string oc lines ; 120 | transmit `None oc stream) 121 | | None -> () 122 | 123 | let mailmap _ diff input output = 124 | let ic, close_ic = 125 | match input with 126 | | Some fpath -> (open_in (Fpath.to_string fpath), close_in) 127 | | None -> (stdin, ignore) in 128 | let v = parser ic in 129 | close_ic ic ; 130 | match (v, diff) with 131 | | Ok (header, mail, tbl), false -> 132 | let mail' = encoder header mail tbl in 133 | let oc, close_oc = 134 | match output with 135 | | Some fpath -> (open_out (Fpath.to_string fpath), close_out) 136 | | None -> (stdout, ignore) in 137 | transmit `None oc (Mrmime.Mt.to_stream mail') ; 138 | close_oc oc ; 139 | `Ok () 140 | | Ok _, _ -> assert false 141 | | Error (`Msg err), _ -> `Error (false, Fmt.str "%s." err) 142 | 143 | open Cmdliner 144 | open Blaze_cli 145 | 146 | let existing_file = 147 | let parser = function 148 | | "-" -> Ok None 149 | | str -> 150 | match Fpath.of_string str with 151 | | Ok v when Sys.file_exists str -> Ok (Some v) 152 | | Ok v -> error_msgf "%a not found" Fpath.pp v 153 | | Error _ as err -> err in 154 | Arg.conv (parser, Fmt.option ~none:(Fmt.any "-") Fpath.pp) 155 | 156 | let input = 157 | let doc = "The email to decode & encode." in 158 | Arg.(value & pos 0 existing_file None & info [] ~doc) 159 | 160 | let new_file = Arg.conv (Fpath.of_string, Fpath.pp) 161 | 162 | let output = 163 | let doc = "The path of the encoded email." in 164 | Arg.(value & opt (some new_file) None & info [ "o"; "output" ] ~doc) 165 | 166 | let diff = 167 | let doc = 168 | "Instead to show the encoded email, we show the diff from the source." in 169 | Arg.(value & flag & info [ "diff" ] ~doc) 170 | 171 | let cmd = 172 | let doc = "Try to decode and encode the given message." in 173 | let man = 174 | [ 175 | `S Manpage.s_description; 176 | `P "From the given email, we try to decode and encode it."; 177 | ] in 178 | Cmd.v (Cmd.info "map" ~doc ~man) 179 | Term.(ret (const mailmap $ setup_logs $ diff $ input $ output)) 180 | -------------------------------------------------------------------------------- /lib/pack.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "blaze.pack" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | let ( % ) f g = fun x -> f (g x) 6 | 7 | let pp_kind ppf = function 8 | | `A -> Fmt.string ppf "mail" 9 | | `B -> Fmt.string ppf "blob" 10 | | `C -> Fmt.string ppf "stem" 11 | | `D -> Fmt.string ppf "deadbeef" 12 | 13 | let mail_identify = 14 | let open Digestif in 15 | let init kind (len : Carton.Size.t) = 16 | let hdr = Fmt.str "%a %d\000" pp_kind kind (len :> int) in 17 | let ctx = SHA1.empty in 18 | SHA1.feed_string ctx hdr in 19 | let feed bstr ctx = SHA1.feed_bigstring ctx bstr in 20 | let serialize = SHA1.(Carton.Uid.unsafe_of_string % to_raw_string % get) in 21 | { Carton.First_pass.init; feed; serialize } 22 | 23 | let uid_of_value value = 24 | let k = Carton.Value.kind value in 25 | let bstr = Carton.Value.bigstring value in 26 | let len = Carton.Value.length value in 27 | let open Carton.First_pass in 28 | let ctx = mail_identify.init k (Carton.Size.of_int_exn len) in 29 | let ctx = mail_identify.feed (Bigarray.Array1.sub bstr 0 len) ctx in 30 | mail_identify.Carton.First_pass.serialize ctx 31 | 32 | let filename_to_email filename = 33 | match Email.of_filename filename with 34 | | Ok t -> (filename, t) 35 | | Error `Invalid -> 36 | Log.err (fun m -> m "%a is an invalid email" Fpath.pp filename) ; 37 | Fmt.failwith "Invalid email" 38 | | Error `No_symmetry -> 39 | Log.err (fun m -> 40 | m "%a has no symmetry between skeleton and Mr.MIME semantic layout" 41 | Fpath.pp filename) ; 42 | Fmt.failwith "Invalid email: no symmetry" 43 | | Error `Not_enough -> 44 | Log.err (fun m -> m "%a is probably truncated" Fpath.pp filename) ; 45 | Fmt.failwith "Invalid email: truncated email" 46 | 47 | type src = 48 | | Mail of string 49 | | Body of Fpath.t * int * int 50 | | Stem of Carton.Uid.t * Carton.Uid.t * int * (string, int) Hashtbl.t 51 | 52 | let none_if_stop lang = 53 | match List.assoc_opt lang Stopwords.words with 54 | | Some stops -> fun stem -> if List.mem stem stops then None else Some stem 55 | | None -> Option.some 56 | 57 | let actions = Tokenizer.[ (Whitespace, Remove); (Bert, Remove) ] 58 | 59 | let freqs_of_document fd ?(off = 0) ?len lang = 60 | let len = 61 | match len with 62 | | Some len -> len 63 | | None -> (Unix.fstat fd).Unix.st_size - off in 64 | let barr = 65 | Unix.map_file fd ~pos:(Int64.of_int off) Bigarray.char Bigarray.c_layout 66 | false [| len |] in 67 | let bstr = Bigarray.array1_of_genarray barr in 68 | let words = Tokenizer.run_on_bstr actions bstr in 69 | let tbl = Hashtbl.create 0x7ff in 70 | let stemmer = Snowball.create ~encoding:UTF_8 lang in 71 | let finally () = Snowball.remove stemmer in 72 | Fun.protect ~finally @@ fun () -> 73 | let fn word = 74 | let stem = try Some (Snowball.stem stemmer word) with _ -> None in 75 | let stem = Option.bind stem (none_if_stop lang) in 76 | let count = Option.bind stem (Hashtbl.find_opt tbl) in 77 | match (stem, count) with 78 | | None, _ -> () 79 | | Some stem, None -> Hashtbl.add tbl stem 1 80 | | Some stem, Some count -> Hashtbl.replace tbl stem (count + 1) in 81 | Seq.iter fn words ; 82 | let length = Hashtbl.length tbl in 83 | (length, tbl) 84 | 85 | let email_to_entries (filename, t) = 86 | let open Cartonnage in 87 | let fd = Unix.openfile (Fpath.to_string filename) Unix.[ O_RDONLY ] 0o644 in 88 | let finally () = Unix.close fd in 89 | Fun.protect ~finally @@ fun () -> 90 | let fn (pos, pos_end) = 91 | let len = pos_end - pos in 92 | let barr = 93 | Unix.map_file fd ~pos:(Int64.of_int pos) Bigarray.char Bigarray.c_layout 94 | false [| len |] in 95 | let bstr = Bigarray.array1_of_genarray barr in 96 | let ctx = 97 | mail_identify.Carton.First_pass.init `B (Carton.Size.of_int_exn len) in 98 | let ctx = mail_identify.Carton.First_pass.feed bstr ctx in 99 | let uid = mail_identify.Carton.First_pass.serialize ctx in 100 | (pos, len, uid) in 101 | let t = Email.map fn t in 102 | let fn0 entries (pos, len, hash) = 103 | let kind = `B in 104 | let entry = Entry.make ~kind ~length:len hash (Body (filename, pos, len)) in 105 | entry :: entries in 106 | (* NOTE(dinosaure): our [skeleton] has everything and our [semantic] has few 107 | documents which must be available into our [skeleton]. To collect all 108 | parts, we prefer to [fold] on our [skeleton]. *) 109 | let entries0 = Email.Skeleton.fold fn0 [] (fst t) in 110 | let fn1 (_, _, (hash : Carton.Uid.t)) = (hash :> string) in 111 | let serialized = Email.to_string (Email.map fn1 t) in 112 | let hash = 113 | let hdr = Fmt.str "mail %d\000" (String.length serialized) in 114 | Digestif.SHA1.digest_string (hdr ^ serialized) in 115 | let hash = Digestif.SHA1.to_raw_string hash in 116 | let hash = Carton.Uid.unsafe_of_string hash in 117 | let entry = 118 | Entry.make ~kind:`A ~length:(String.length serialized) hash 119 | (Mail serialized) in 120 | let fn2 (mail : Carton.Uid.t) entries 121 | (_mime, lang, (off, len, (blob : Carton.Uid.t))) = 122 | let tbl_len, tbl = freqs_of_document fd ~off ~len lang in 123 | let length, hash = 124 | Stem.to_length_and_hash ((mail :> string), (blob :> string), tbl_len, tbl) 125 | in 126 | let hash = Carton.Uid.unsafe_of_string hash in 127 | let kind = `C in 128 | let value = Stem (mail, blob, tbl_len, tbl) in 129 | let entry = Entry.make ~kind ~length hash value in 130 | entry :: entries in 131 | let entries1 = Email.Semantic.fold (fn2 hash) [] (snd t) in 132 | entry :: List.rev_append entries1 entries0 133 | 134 | let sha1_with_ctx (ctx : Digestif.SHA1.ctx) = 135 | let module Hash = Digestif.SHA1 in 136 | let feed_bigstring bstr ctx = Hash.feed_bigstring ctx bstr in 137 | let feed_bytes buf ~off ~len ctx = Hash.feed_bytes ctx ~off ~len buf in 138 | let hash = 139 | { 140 | Carton.First_pass.feed_bytes; 141 | feed_bigstring; 142 | serialize = Hash.to_raw_string % Hash.get; 143 | length = Hash.digest_size; 144 | } in 145 | Carton.First_pass.Digest (hash, ctx) 146 | 147 | let sha1 = sha1_with_ctx Digestif.SHA1.empty 148 | 149 | let config ?pagesize ?cachesize ?threads ?on_entry ?on_object () = 150 | let ref_length = Digestif.SHA1.digest_size in 151 | Carton_miou_unix.config ?pagesize ?cachesize ?threads ?on_entry ?on_object 152 | ~ref_length (Carton.Identify mail_identify) 153 | 154 | let delta ~load entries = 155 | let ref_length = Digestif.SHA1.digest_size in 156 | Carton_miou_unix.delta ~ref_length ~load entries 157 | 158 | let to_pack ?with_header ?with_signature ~load targets = 159 | let with_signature = 160 | match with_signature with 161 | | Some ctx -> Some (sha1_with_ctx ctx) 162 | | None -> None in 163 | Carton_miou_unix.to_pack ?with_header ?with_signature ~load targets 164 | 165 | let make ?index filename = 166 | let ref_length = Digestif.SHA1.digest_size in 167 | Carton_miou_unix.make ~ref_length ?index filename 168 | 169 | let index filename = 170 | let ref_length = Digestif.SHA1.digest_size in 171 | let hash_length = ref_length in 172 | Carton_miou_unix.index ~hash_length ~ref_length filename 173 | 174 | let verify_from_pack ~cfg filename = 175 | Carton_miou_unix.verify_from_pack ~cfg ~digest:sha1 filename 176 | 177 | let verify_from_idx ~cfg filename = 178 | Carton_miou_unix.verify_from_idx ~cfg ~digest:sha1 filename 179 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Blaze, some tools to manipulate your emails 2 | 3 | `blaze` aggregates many tools to manipulate emails. The goal is to iterate 4 | between high-level usages of emails and libraries such as [`mrmime`][mrmime], 5 | [`dkim`][dkim] or [`spf`][spf]. It's an experimental repository! 6 | 7 | ## A simple example of `blaze` 8 | 9 | As we said, `blaze` has many tools which want to be used into an UNIX context. 10 | It permits to analyze, extract or stamp emails. This is an example of how to 11 | use `blaze`: 12 | ```sh 13 | $ git clone https://github.com/dinosaure/blaze 14 | $ cd blaze 15 | $ opam pin add -y . 16 | # Assume that ~/maildir/ is a Maildir directory which contains your emails 17 | $ export MSG=$(blaze mdir new -D ~/maildir/ | tail -n1) 18 | # We have the Maildir of the last message 19 | $ blaze mdir get -D ~/maildir/ --new $MSG > new.eml 20 | # We can verify DKIM signature 21 | $ blaze dkim verify new.eml 22 | [OK]: blaze.org 23 | # Or SPF results 24 | $ blaze spf analyze new.eml 25 | romain@blaze.org from 192.168.0.0: pass (expected: pass) 26 | # And extract some informations from it 27 | $ blaze addr --without-name new.eml 28 | romain@blaze.org 29 | ``` 30 | 31 | ## How to craft & send an email? 32 | 33 | `blaze` wants to be simple to send an email. First, you need to craft 34 | one with some meta-information. Then, you can attach a document to your 35 | email and then, pass it to `blaze send` with your account credentials. You 36 | may be need another tool, [conan][conan], to be able to recognize the MIME 37 | type of the attachment. 38 | ```sh 39 | $ blaze make < Hello World! 45 | > EOF 46 | ``` 47 | 48 | As you can see, you can craft and send your email along the UNIX pipe. 49 | 50 | ## How to receive an email? 51 | 52 | `blaze` provides a little server which is able to receive emails. You can 53 | receive one or some depending on arguments given to `blaze srv`. By default, it 54 | wants to listen on `*:25`. It's an implementation of a simple SMTP server and 55 | it waiting an email to save it then into your file-system: 56 | ``` 57 | $ sudo blaze srv -o new.eml & 58 | [1] PID 59 | $ blaze make < Hello World! 62 | > EOF 63 | $ cat new.eml 64 | Date: Thu, 6 Jan 2022 16:49:55 +0100 65 | Content-Transfer-Encoding: 7bit 66 | Content-Type: text/plain; charset=utf-8 67 | 68 | Hello World! 69 | ``` 70 | 71 | To receive multiple emails, you can launch `blaze srv` like this: 72 | ```sh 73 | $ sudo socat TCP-LISTEN:25,fork TCP:localhost:4242 & 74 | $ mkdir mailbox 75 | $ blaze srv -o mailbox/ --format "blaze-%s.eml" localhost:4242 & 76 | $ blaze make < Hello World! 78 | > EOF 79 | ``` 80 | 81 | ## Submit or send an email? 82 | 83 | SMTP is a bi-diretional protocol where a SMTP server can be a client for 84 | another SMTP server. When you want to send an email, you have 2 possibilities: 85 | 1) send an email to a recipient directly under my identity concretized _via_ 86 | my computer (my _hostname_, etc.) 87 | 2) send an email to a recipient **through** a _certain_ identity provided by 88 | a SMTP server (like `gmail.com`) 89 | 90 | For the first case, you want to use `blaze send` which sends an email directly 91 | to the given SMTP server (on `*:25`) or the SMTP server of the first recipient. 92 | For instance, this command send an email to `foo:25`: 93 | ```sh 94 | $ blaze send --sender romain@blaze.org -r bar@foo 95 | ``` 96 | 97 | However, you probably want some security mechanisms such as DKIM or SPF offered 98 | by a _certain_ service like `gmail.com`. In that case, you want to **submit** 99 | an email to this service which will re-send your email under **its** 100 | authority with its security mechanisms: 101 | ```sh 102 | $ blaze submit --sender romain@blaze.org --password ****** -r bar@foo 103 | ``` 104 | 105 | The second case ensure that the communication between you and the SMTP service 106 | is encrypted (_via_ `STARTTLS` or over `TLS`). Otherwise, it does not try to 107 | send an email. Then, the submission server **is not** `foo:25` like before but 108 | `blaze.org:{465,587}`. Usually, this service requires a password. 109 | 110 | In both case, `bar@foo` will receive an email but: 111 | - in the first case, it will receive the email as is 112 | - in the second case, your _serviteur_ (`blaze.org`) probably put some 113 | _metadata_ to let `bar@foo` to _verify_ the given email 114 | 115 | ## How to fetch emails? 116 | 117 | blaze also lets you download emails and store them in a folder. There are 118 | additional tools for storing these emails in ‘maildir’, ‘mbox’ or our special 119 | ‘pack’ format. 120 | 121 | You can currently download emails from your GMail account for the last 30 days 122 | in this way: 123 | ```sh 124 | $ mkdir mailbox 125 | $ blaze fetch pop3://pop.gmail.com:995 --username recent:@gmail.com \ 126 | --password ****** -f "mailbox/%s.eml" > emails.txt 127 | ``` 128 | 129 | You can then generate an archive of these emails in our PACK format: 130 | ```sh 131 | $ blaze pack make -o pack.pack emails.txt 132 | $ blaze pack index pack.pack 133 | ``` 134 | 135 | ## How to store emails? 136 | 137 | As mentioned above, blaze prefers to store emails in a special format, the PACK 138 | format. It is possible to switch from a format such as mbox to the PACK format 139 | if you wish, so that you use less disk space to store your emails. 140 | ```sh 141 | $ blaze mbox archive.mbox -o pack.pack 142 | $ blaze pack index pack.pack 143 | ``` 144 | 145 | ### Emails and isomorphism 146 | 147 | `blaze` has a unique way of storing emails: it breaks them down! An email is 148 | essentially structured in two parts: the headers and the body. However, it can 149 | (often) happen that an email contains several parts (such as attached files) 150 | which themselves contain headers and a body. `blaze` offers a tool for 151 | describing the structure of an email: 152 | ```sh 153 | $ blaze descr 001.eml 154 | ┌── alternative 155 | │ ├── text/plain 156 | │ └── text/html 157 | ``` 158 | 159 | Then, when it comes to saving the email in an archive, we serialise its 160 | structure and each node in this structure points to content that can be a 161 | headers or a body. 162 | 163 | There is therefore an isomorphism rule (so as not to break checks such as 164 | DKIM). In short, `blaze` can check whether our way of serialising/deserialising 165 | emails is isomorphic: 166 | ```sh 167 | $ blaze iso 001.eml > out.eml 168 | $ diff 001.eml out.eml 169 | $ echo $? 170 | ``` 171 | 172 | ## How to search emails? 173 | 174 | From an email archive, it is possible to search for an email based on a query. 175 | `blaze` offers the `okapi` tool (named after the [Okapi BM25 algorithm][bm25]) 176 | which allows you to "rate" emails in an archive based on a query: 177 | ```sh 178 | $ blaze okapi pack.idx "foo" | head -n5 179 | 79233664206d01e186011e35a4a5c73588667bcc: 10.709457 180 | 629fd153b511cff1948f300ff65d89de78292156: 10.004464 181 | e28b0c40ef928c05478cc830ca32cbdc0d8dda61: 9.988271 182 | 57f39c708e4e005d277a9fedc8f205ba9d163fb1: 9.695392 183 | 4d9f51478e777ae186f315692dd5ebd3536a94ef: 9.135971 184 | ``` 185 | 186 | The identifiers allow you to retrieve the email from the archive: 187 | ```sh 188 | $ blaze pack get pack.idx 79233664206d01e186011e35a4a5c73588667bcc > new.eml 189 | ``` 190 | 191 | ## Funding 192 | 193 | This project received funding through [NGI Zero Core](https://nlnet.nl/core), a 194 | fund established by [NLnet](https://nlnet.nl) with financial support from the 195 | European Commission's [Next Generation Internet](https://ngi.eu) program. Learn 196 | more at the [NLnet project page](https://nlnet.nl/project/PTT). 197 | 198 | [mrmime]: https://github.com/mirage/mrmime 199 | [dkim]: https://github.com/dinosaure/ocaml-dkim 200 | [spf]: https://github.com/dinosaure/uspf 201 | [conan]: https://github.com/mirage/conan 202 | [bm25]: https://en.wikipedia.org/wiki/Okapi_BM25 203 | -------------------------------------------------------------------------------- /bin/addr.ml: -------------------------------------------------------------------------------- 1 | open Mrmime 2 | 3 | let ( % ) f g x = f (g x) 4 | 5 | let default = 6 | let open Field_name in 7 | Map.empty 8 | |> Map.add from Field.(Witness Mailboxes) 9 | |> Map.add (v "to") Field.(Witness Addresses) 10 | |> Map.add cc Field.(Witness Addresses) 11 | |> Map.add bcc Field.(Witness Addresses) 12 | |> Map.add sender Field.(Witness Mailbox) 13 | 14 | let decode_rfc2047 = ref false 15 | 16 | let pp_encoded ~charset ppf = function 17 | | Emile.Quoted_printable (Ok v) -> 18 | let buf = Buffer.create (String.length v) in 19 | let encoder = Pecu.Inline.encoder (`Buffer buf) in 20 | let rec go idx = 21 | let[@warning "-8"] (`Ok : [ `Ok | `Partial ]) = 22 | if idx = String.length v 23 | then Pecu.Inline.encode encoder `End 24 | else Pecu.Inline.encode encoder (`Char v.[idx]) in 25 | if idx < String.length v then go (succ idx) in 26 | go 0 ; 27 | Fmt.pf ppf "=?%s?Q?%s?=" charset (Buffer.contents buf) 28 | | Emile.Base64 (Ok v) -> 29 | Fmt.pf ppf "=?%s?B?%s?=" charset (Base64.encode_exn ~pad:true v) 30 | | _ -> assert false 31 | 32 | let pp_phrase ppf phrase = 33 | let pp_elem ppf = function 34 | | `Dot -> Fmt.string ppf "." 35 | | `Word (`Atom x) -> Fmt.string ppf x 36 | | `Word (`String x) -> Fmt.(quote string) ppf x 37 | | `Encoded (charset, Emile.Quoted_printable (Ok v)) when !decode_rfc2047 -> 38 | let v' = Rosetta.to_utf_8_string ~charset v in 39 | if Option.is_none v' 40 | then 41 | Logs.warn (fun m -> 42 | m "Impossible to normalize %S (charset: %s) to UTF-8" v charset) ; 43 | let v' = Option.value ~default:v v' in 44 | Fmt.string ppf v' 45 | | `Encoded (charset, Emile.Base64 (Ok v)) when !decode_rfc2047 -> 46 | let v' = Rosetta.to_utf_8_string ~charset v in 47 | if Option.is_none v' 48 | then 49 | Logs.warn (fun m -> 50 | m "Impossible to normalize %S (charset: %s) to UTF-8" v charset) ; 51 | let v' = Option.value ~default:v v' in 52 | Fmt.string ppf v' 53 | | `Encoded (charset, v) -> pp_encoded ~charset ppf v in 54 | Fmt.(list ~sep:(any "@ ") pp_elem) ppf phrase 55 | 56 | let pp_mailbox ppf = function 57 | | { Emile.name = None; _ } as v -> Emile.pp_mailbox ppf v 58 | | { name = Some name; domain = _, []; _ } as v -> 59 | Fmt.pf ppf "@[<1>@[%a@]@ <%a>@]" pp_phrase name Emile.pp_mailbox 60 | { v with Emile.name = None } 61 | | { name = Some name; _ } as v -> 62 | (* XXX(dinosaure): with multiple domains, we know that [emile] surrounds with "<" and ">". *) 63 | Fmt.pf ppf "@[<1>@[%a@]@ %a@]" pp_phrase name Emile.pp_mailbox 64 | { v with Emile.name = None } 65 | 66 | let pp_mailbox_without_name ppf = function 67 | | { Emile.local; domain = domain, _; _ } -> 68 | Fmt.pf ppf "@[<1>%a@]" Emile.pp_mailbox 69 | { Emile.local; domain = (domain, []); name = None } 70 | 71 | let pp_mailbox ~without_name = 72 | match without_name with 73 | | true -> pp_mailbox_without_name 74 | | false -> pp_mailbox 75 | 76 | let parse_header newline p ic = 77 | let decoder = Hd.decoder p in 78 | let rec go (addresses : Emile.mailbox list) = 79 | match Hd.decode decoder with 80 | | `Malformed err -> Error (`Msg err) 81 | | `Field field -> ( 82 | match Location.prj field with 83 | | Field (_field_name, Mailboxes, vs) -> go (vs @ addresses) 84 | | Field (_field_name, Mailbox, v) -> go (v :: addresses) 85 | | Field (_field_name, Addresses, vs) -> 86 | let vs = 87 | let f = function 88 | | `Group { Emile.mailboxes; _ } -> mailboxes 89 | | `Mailbox m -> [ m ] in 90 | List.concat (List.map f vs) in 91 | go (vs @ addresses) 92 | | _ -> go addresses) 93 | | `End _prelude -> Ok (List.rev addresses) 94 | | `Await -> 95 | match input_line ic with 96 | | line -> 97 | let line = 98 | match newline with `CRLF -> line ^ "\n" | `LF -> line ^ "\r\n" in 99 | Hd.src decoder line 0 (String.length line) ; 100 | go addresses 101 | | exception End_of_file -> 102 | Hd.src decoder "" 0 0 ; 103 | go addresses in 104 | go [] 105 | 106 | let run want_to_decode_rfc2047 newline without_name margin fields input = 107 | Option.iter Format.set_margin margin ; 108 | decode_rfc2047 := want_to_decode_rfc2047 ; 109 | let ic, close = 110 | match input with 111 | | Some fpath -> (open_in (Fpath.to_string fpath), close_in) 112 | | None -> (stdin, ignore) in 113 | let finally () = close ic in 114 | Fun.protect ~finally @@ fun () -> 115 | let p = 116 | List.fold_left 117 | (fun p v -> Field_name.Map.add v Field.(Witness Addresses) p) 118 | default fields in 119 | match parse_header newline p ic with 120 | | Ok addresses -> 121 | List.iter 122 | (print_endline % Fmt.str "%a" (pp_mailbox ~without_name)) 123 | addresses ; 124 | `Ok () 125 | | Error (`Msg err) -> `Error (false, Fmt.str "%s." err) 126 | 127 | open Cmdliner 128 | open Blaze_cli 129 | 130 | let existing_file = 131 | let parser = function 132 | | "-" -> Ok None 133 | | str -> 134 | match Fpath.of_string str with 135 | | Ok v when Sys.file_exists str -> Ok (Some v) 136 | | Ok v -> error_msgf "%a not found" Fpath.pp v 137 | | Error _ as err -> err in 138 | Arg.conv (parser, Fmt.option ~none:(Fmt.any "-") Fpath.pp) 139 | 140 | let field_name = Arg.conv (Field_name.of_string, Field_name.pp) 141 | 142 | let input = 143 | let doc = "The email to analyze." in 144 | Arg.(value & pos 0 existing_file None & info [] ~doc ~docv:"EMAIL") 145 | 146 | let fields = 147 | let doc = "Extra-fields which contains email addresses." in 148 | let open Arg in 149 | value 150 | & opt (list ~sep:':' field_name) [] 151 | & info [ "f"; "fields" ] ~doc ~docv:"FIELD" 152 | 153 | let decode_rfc2047 = 154 | let doc = 155 | "Decode $(i,quoted-printable)/$(i,base64) values according to RFC 2047 and \ 156 | normalize them to UTF-8 (best-effort)." in 157 | Arg.(value & flag & info [ "d" ] ~doc) 158 | 159 | let without_name = 160 | let doc = "Show email addresses without their names." in 161 | Arg.(value & flag & info [ "without-name" ] ~doc) 162 | 163 | let margin = 164 | let doc = "Set the margin which is our limit to print email addresses." in 165 | let number = 166 | let parser str = 167 | match int_of_string_opt str with 168 | | Some n when n >= 1 -> Ok n 169 | | Some _ -> error_msgf "The margin must be greater or equal to 1" 170 | | None -> error_msgf "Invalid margin" in 171 | Arg.conv (parser, Fmt.int) in 172 | let open Arg in 173 | value & opt (some number) None & info [ "m"; "margin" ] ~doc ~docv:"MARGIN" 174 | 175 | let cmd = 176 | let doc = "Extract addresses from an email." in 177 | let man = 178 | [ 179 | `S Manpage.s_description; 180 | `P "$(tname) extracts email addresses from an email."; 181 | `P 182 | "This can be useful for automating who can be replied to from an \ 183 | email. The program may seem simple, but it allows you to display the \ 184 | email addresses collected. The program attempts to normalize the \ 185 | values (especially names) to UTF-8 and tries to respect a margin in \ 186 | the display."; 187 | `P 188 | "If an email address is larger than the margin, the program behaves \ 189 | like $(i,RFC822) and outputs a newline and a space as the \ 190 | continuation of the email address."; 191 | `P 192 | "It is possible to keep the $(i,RFC2047) representation of values (pre \ 193 | UTF-8) allowing names to be encoded securely between machines (the \ 194 | $(i,RFC2047) representation ensures that it can be transmitted via \ 195 | 7-bit encoding)."; 196 | ] in 197 | let info = Cmd.info "addr" ~doc ~man in 198 | let term = 199 | let open Term in 200 | const run 201 | $ decode_rfc2047 202 | $ newline () 203 | $ without_name 204 | $ margin 205 | $ fields 206 | $ input 207 | |> ret in 208 | Cmd.v info term 209 | -------------------------------------------------------------------------------- /bin/descr.ml: -------------------------------------------------------------------------------- 1 | open Mrmime 2 | 3 | let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt 4 | 5 | let default = 6 | let open Field_name in 7 | Map.empty 8 | |> Map.add date Field.(Witness Unstructured) 9 | |> Map.add from Field.(Witness Unstructured) 10 | |> Map.add sender Field.(Witness Unstructured) 11 | |> Map.add reply_to Field.(Witness Unstructured) 12 | |> Map.add (v "to") Field.(Witness Unstructured) 13 | |> Map.add cc Field.(Witness Unstructured) 14 | |> Map.add bcc Field.(Witness Unstructured) 15 | |> Map.add subject Field.(Witness Unstructured) 16 | |> Map.add message_id Field.(Witness Unstructured) 17 | |> Map.add comments Field.(Witness Unstructured) 18 | 19 | type t = Single of { mime : string option } | Choose of kind * t list 20 | and kind = [ `Mixed | `Alternative | `Parallel | `Message | `Other of string ] 21 | 22 | let pp_kind ppf = function 23 | | `Mixed -> Fmt.string ppf "mixed" 24 | | `Alternative -> Fmt.string ppf "alternative" 25 | | `Parallel -> Fmt.string ppf "parallel" 26 | | `Message -> Fmt.string ppf "message" 27 | | `Other v -> Fmt.string ppf v 28 | 29 | let top = 30 | Lazy.from_fun @@ fun () -> 31 | if Fmt.utf_8 Fmt.stdout then ("┌── ", "│ ") else (".-- ", "| ") 32 | 33 | let between = 34 | Lazy.from_fun @@ fun () -> 35 | if Fmt.utf_8 Fmt.stdout then ("├── ", "│ ") else ("|-- ", "| ") 36 | 37 | let last = 38 | Lazy.from_fun @@ fun () -> 39 | if Fmt.utf_8 Fmt.stdout then ("└── ", " ") else ("`-- ", " ") 40 | 41 | let rec pp ?(prefix = "") ?(is_last = false) ppf tree = 42 | let branch, next_prefix = Lazy.force (if is_last then last else between) in 43 | match tree with 44 | | Single { mime } -> 45 | let mime = Option.value ~default:"unknown" mime in 46 | Fmt.pf ppf "%s%s%s@." prefix branch mime 47 | | Choose (kind, children) -> 48 | Fmt.pf ppf "%s%s%a@." prefix branch pp_kind kind ; 49 | let prefix = prefix ^ next_prefix in 50 | let rec go = function 51 | | [] -> () 52 | | [ x ] -> pp ~prefix ~is_last:true ppf x 53 | | x :: r -> 54 | pp ~prefix ~is_last:false ppf x ; 55 | go r in 56 | go children 57 | 58 | let pp ppf = function 59 | | Single _ as v -> pp ppf v 60 | | Choose (kind, children) -> 61 | let branch, next_prefix = Lazy.force top in 62 | Fmt.pf ppf "%s%a@." branch pp_kind kind ; 63 | let prefix = next_prefix in 64 | let rec go = function 65 | | [] -> () 66 | | [ x ] -> pp ~prefix ~is_last:true ppf x 67 | | x :: r -> 68 | pp ~prefix ~is_last:false ppf x ; 69 | go r in 70 | go children 71 | 72 | let blit src src_off dst dst_off len = 73 | Bstr.blit_from_string src ~src_off dst ~dst_off ~len 74 | 75 | let parser ic = 76 | let emitters _headers = (Fun.const (), ()) in 77 | let parser = Mrmime.Mail.stream ~transfer_encoding:false ~g:default emitters in 78 | let rec loop ic ke = function 79 | | Angstrom.Unbuffered.Done (_, v) -> Ok v 80 | | Fail (_, stack, msg) -> 81 | Logs.err (fun m -> 82 | m "Invalid email (%a): %S" Fmt.(Dump.list string) stack msg) ; 83 | error_msgf "Invalid email" 84 | | Partial { committed; continue } -> begin 85 | Ke.Rke.N.shift_exn ke committed ; 86 | if committed = 0 then Ke.Rke.compress ke ; 87 | match input_line ic with 88 | | "" -> 89 | Ke.Rke.push ke '\n' ; 90 | let[@warning "-8"] (slice :: _) = Ke.Rke.N.peek ke in 91 | let off = 0 and len = Bstr.length slice in 92 | let state = continue slice ~off ~len Incomplete in 93 | loop ic ke state 94 | | line when line.[String.length line - 1] = '\r' -> 95 | Ke.Rke.N.push ke ~blit ~length:String.length ~off:0 96 | ~len:(String.length line) line ; 97 | Ke.Rke.push ke '\n' ; 98 | let[@warning "-8"] (slice :: _) = Ke.Rke.N.peek ke in 99 | let off = 0 and len = Bstr.length slice in 100 | let state = continue slice ~off ~len Incomplete in 101 | loop ic ke state 102 | | line -> 103 | Ke.Rke.N.push ke ~blit ~length:String.length ~off:0 104 | ~len:(String.length line) line ; 105 | Ke.Rke.push ke '\r' ; 106 | Ke.Rke.push ke '\n' ; 107 | let[@warning "-8"] (slice :: _) = Ke.Rke.N.peek ke in 108 | let off = 0 and len = Bstr.length slice in 109 | let state = continue slice ~off ~len Incomplete in 110 | loop ic ke state 111 | | exception End_of_file -> 112 | let buf = 113 | match Ke.Rke.length ke with 114 | | 0 -> Bstr.empty 115 | | _ -> 116 | Ke.Rke.compress ke ; 117 | List.hd (Ke.Rke.N.peek ke) in 118 | let off = 0 and len = Bstr.length buf in 119 | let state = continue buf ~off ~len Complete in 120 | loop ic ke state 121 | end in 122 | let ke = Ke.Rke.create ~capacity:0x1000 Bigarray.char in 123 | loop ic ke (Angstrom.Unbuffered.parse parser) 124 | 125 | let mime_from_headers hdrs = 126 | let open Mrmime in 127 | let content_type = Field_name.content_type in 128 | match Header.assoc content_type hdrs with 129 | | Field.Field (_, Content, v) :: _ -> 130 | let a = Content_type.Type.to_string v.Content_type.ty in 131 | let b = Content_type.Subtype.to_string v.Content_type.subty in 132 | Some (Fmt.str "%s/%s" a b) 133 | | _ -> None 134 | 135 | let to_kind v = 136 | let v = Content_type.Subtype.to_string v in 137 | let v = String.lowercase_ascii v in 138 | match v with 139 | | "mixed" -> `Mixed 140 | | "alternative" -> `Alternative 141 | | "parallel" -> `Parallel 142 | | v -> `Other v 143 | 144 | let kind_of_headers hdrs = 145 | let open Mrmime in 146 | let content_type = Field_name.content_type in 147 | match Header.assoc content_type hdrs with 148 | | Field.Field (_, Content, v) :: _ -> to_kind v.Content_type.subty 149 | | _ -> assert false 150 | 151 | let rec to_semantic ~headers = function 152 | | Mrmime.Mail.Leaf _ -> 153 | let mime = mime_from_headers headers in 154 | Single { mime } 155 | | Multipart lst -> 156 | let kind = kind_of_headers headers in 157 | let fn acc (headers, contents) = 158 | match contents with 159 | | None -> acc 160 | | Some contents -> to_semantic ~headers contents :: acc in 161 | let lst = List.fold_left fn [] lst in 162 | let lst = List.rev lst in 163 | Choose (kind, lst) 164 | | Message (headers, t) -> 165 | let t = to_semantic ~headers t in 166 | Choose (`Message, [ t ]) 167 | 168 | let to_semantic (headers, t) = to_semantic ~headers t 169 | let ( let@ ) finally fn = Fun.protect ~finally fn 170 | 171 | let run _ input = 172 | let ic, close = 173 | match input with 174 | | Some fpath -> (open_in (Fpath.to_string fpath), close_in) 175 | | None -> (stdin, ignore) in 176 | let@ () = fun () -> close ic in 177 | match parser ic with 178 | | Error (`Msg err) -> `Error (false, Fmt.str "%s." err) 179 | | Ok v -> 180 | Fmt.pr "%a%!" pp (to_semantic v) ; 181 | `Ok () 182 | 183 | open Cmdliner 184 | open Blaze_cli 185 | 186 | let existing_file = 187 | let parser = function 188 | | "-" -> Ok None 189 | | str -> 190 | match Fpath.of_string str with 191 | | Ok v when Sys.file_exists str -> Ok (Some v) 192 | | Ok v -> error_msgf "%a not found" Fpath.pp v 193 | | Error _ as err -> err in 194 | Arg.conv (parser, Fmt.option ~none:(Fmt.any "-") Fpath.pp) 195 | 196 | let field_name = Arg.conv (Field_name.of_string, Field_name.pp) 197 | 198 | let input = 199 | let doc = "The email to analyze." in 200 | Arg.(value & pos 0 existing_file None & info [] ~doc) 201 | 202 | let cmd = 203 | let doc = "Describe the structure of the given email." in 204 | let man = 205 | [ 206 | `S Manpage.s_description; 207 | `P "$(tname) describes the structure of the given email like a tree."; 208 | ] in 209 | let info = Cmd.info "descr" ~doc ~man in 210 | let term = 211 | let open Term in 212 | ret (const run $ setup_logs $ input) in 213 | Cmd.v info term 214 | -------------------------------------------------------------------------------- /bin/recv.ml: -------------------------------------------------------------------------------- 1 | let stream_of_in_channel ic () = 2 | match input_line ic with 3 | | line -> Some (line ^ "\r\n", 0, String.length line + 2) 4 | | exception End_of_file -> None 5 | 6 | let pp_protocol : Received.protocol Fmt.t = 7 | fun ppf v -> 8 | match (v :> [ `Atom of string | `ESMTP | `SMTP ]) with 9 | | `Atom v -> Fmt.string ppf v 10 | | `ESMTP -> Fmt.string ppf "ESMTP" 11 | | `SMTP -> Fmt.string ppf "SMTP" 12 | 13 | let pp_link : Received.link Fmt.t = 14 | fun ppf v -> 15 | match (v :> [ `Atom of string | `TCP ]) with 16 | | `Atom v -> Fmt.string ppf v 17 | | `TCP -> Fmt.string ppf "tcp" 18 | 19 | let show_one recv = 20 | let _by = Received.received_by recv in 21 | let _from = Received.received_from recv in 22 | let _for = Received.received_for recv in 23 | let () = 24 | match (_by, _from, _for) with 25 | | ( Some (Received.Only _by | Received.With (_by, _)), 26 | Some (Received.Only _from | Received.With (_from, _)), 27 | Some _for ) -> 28 | Fmt.pr "from:%a -> by:%a -> for:%a\n%!" Colombe.Domain.pp _from 29 | Colombe.Domain.pp _by Colombe.Path.pp _for 30 | | Some (Received.Only _by | Received.With (_by, _)), None, Some _for -> 31 | Fmt.pr "by:%a -> for:%a\n%!" Colombe.Domain.pp _by Colombe.Path.pp _for 32 | | Some (Received.Only _by | Received.With (_by, _)), None, None -> 33 | Fmt.pr "by:%a\n%!" Colombe.Domain.pp _by 34 | | _ -> () in 35 | let _with = Received.received_with recv in 36 | let via = Received.received_via recv in 37 | let () = 38 | match (_with, via) with 39 | | Some protocol, Some link -> 40 | Fmt.pr "\twith %a\n%!" pp_protocol protocol ; 41 | Fmt.pr "\tvia %a\n%!" pp_link link 42 | | Some protocol, None -> Fmt.pr "\twith %a\n%!" pp_protocol protocol 43 | | None, Some link -> Fmt.pr " vi %a\n%!" pp_link link 44 | | _ -> () in 45 | () 46 | 47 | let show recvs = List.iter show_one recvs 48 | 49 | module Gr = Graph.Imperative.Digraph.Concrete (struct 50 | include Colombe.Domain 51 | 52 | let hash = Hashtbl.hash 53 | end) 54 | 55 | module Dot = Graph.Graphviz.Dot (struct 56 | include Gr 57 | 58 | let vertex_name v = Fmt.str "%a" Fmt.(quote Colombe.Domain.pp) v 59 | let edge_attributes _ = [ `Color 0xffffff ] 60 | let default_edge_attributes _ = [] 61 | 62 | let vertex_attributes _ = 63 | [ `Color 0xffffff; `Fontcolor 0xffffff; `Shape `Box ] 64 | 65 | let default_vertex_attributes _ = [] 66 | let graph_attributes _ = [ `BgcolorWithTransparency 0x0l; `Ratio `Compress ] 67 | let get_subgraph _ = None 68 | end) 69 | 70 | let make_graph recvs = 71 | let g = Gr.create ~size:(List.length recvs) () in 72 | let add recv = 73 | match (Received.received_from recv, Received.received_by recv) with 74 | | ( Some (Received.Only from | Received.With (from, _)), 75 | Some (Received.Only _by | Received.With (_by, _)) ) -> 76 | Gr.add_edge g from _by 77 | | Some (Received.Only from | Received.With (from, _)), None -> 78 | Gr.add_vertex g from 79 | | None, Some (Received.Only _by | Received.With (_by, _)) -> 80 | Gr.add_vertex g _by 81 | | _ -> () in 82 | List.iter add recvs ; 83 | g 84 | 85 | let show_graph g = 86 | Dot.output_graph stdout g ; 87 | flush stdout 88 | 89 | let extract dot input = 90 | let ic, close = 91 | match input with 92 | | "-" -> (stdin, ignore) 93 | | filename -> (open_in filename, close_in) in 94 | let stream = stream_of_in_channel ic in 95 | let ( >>| ) x fn = Result.map fn x in 96 | match 97 | Received.of_stream stream >>| fun res -> 98 | close ic ; 99 | res 100 | with 101 | | Ok (_prelude, recvs) when dot -> 102 | let g = make_graph recvs in 103 | show_graph g ; 104 | `Ok () 105 | | Ok (_prelude, recvs) -> 106 | let recvs = List.sort Received.compare recvs in 107 | show recvs ; 108 | `Ok () 109 | | Error (`Msg err) -> `Error (false, Fmt.str "%s." err) 110 | 111 | let tmp = Bytes.create 65536 112 | 113 | let rec pipe ic oc = 114 | match input ic tmp 0 (Bytes.length tmp) with 115 | | 0 -> () 116 | | len -> 117 | output_substring oc (Bytes.unsafe_to_string tmp) 0 len ; 118 | pipe ic oc 119 | | exception End_of_file -> () 120 | 121 | let by hostname = 122 | match Colombe.Domain.of_string hostname with 123 | | Ok v -> Received.Only v 124 | | Error (`Msg _) -> Fmt.failwith "Invalid hostname: %S" hostname 125 | 126 | let stamp hostname zone from _for input = 127 | let link = Received.link "UUCP" in 128 | let by = by hostname in 129 | let protocol = 130 | match Fmt.utf_8 Fmt.stdout with 131 | | false -> Received.protocol "LMTP" 132 | | true -> Received.protocol "UTF8LMTP" in 133 | let id = 134 | None 135 | (* TODO(dinosaure): see [maildir]. *) in 136 | let stamp = 137 | Received.make ~from:(Received.Only from) ~by ~via:link ~protocol ?id 138 | (Some _for) ~zone (Ptime_clock.now ()) in 139 | Fmt.pr "%s%!" 140 | (Prettym.to_string ~new_line:"\n" Received.Encoder.as_field stamp) ; 141 | match input with 142 | | "-" -> 143 | pipe stdin stdout ; 144 | `Ok () 145 | | filename -> 146 | let ic = open_in filename in 147 | pipe ic stdout ; 148 | close_in ic ; 149 | `Ok () 150 | 151 | open Cmdliner 152 | 153 | let hostname = 154 | let parser str = 155 | match Colombe.Domain.of_string str with 156 | | Ok _ -> Ok str 157 | | Error _ as err -> err in 158 | Arg.conv (parser, Fmt.string) 159 | 160 | let zone = Arg.conv (Mrmime.Date.Zone.of_string, Mrmime.Date.Zone.pp) 161 | let domain = Arg.conv (Colombe.Domain.of_string, Colombe.Domain.pp) 162 | 163 | let path = 164 | let ( >>= ) = Result.bind in 165 | let parser str = 166 | Emile.of_string str 167 | |> Result.map_error (fun _ -> `Msg "Invalid path") 168 | >>= Colombe_emile.to_path in 169 | Arg.conv (parser, Colombe.Path.pp) 170 | 171 | let input = 172 | let doc = "The email to analyze. Use $(b,-) for $(b,stdin)." in 173 | Arg.(value & pos 1 Blaze_cli.file "-" & info [] ~doc) 174 | 175 | let dot = 176 | let doc = "Print a $(i,dot) graph." in 177 | Arg.(value & flag & info [ "d"; "dot" ] ~doc) 178 | 179 | let hostname = 180 | let doc = "Specify the hostname used to stamp the given email." in 181 | Arg.( 182 | value & opt hostname (Unix.gethostname ()) & info [ "h"; "hostname" ] ~doc) 183 | 184 | let zone = 185 | let doc = "Specify the time zone used to stamp the given email." in 186 | Arg.(value & opt zone Mrmime.Date.Zone.UT & info [ "z"; "zone" ] ~doc) 187 | 188 | let _for = 189 | let doc = "The recipient of the given email." in 190 | let cpath = path in 191 | Arg.(required & pos 0 (some cpath) None & info [] ~doc) 192 | 193 | let from = 194 | let doc = "The domain which identifies the source of the given email." in 195 | Arg.(required & opt (some domain) None & info [ "f"; "from" ] ~doc) 196 | 197 | let stamp = 198 | let doc = "Stamp the given email with a new Received field." in 199 | let man = 200 | [ 201 | `S Manpage.s_description; 202 | `P "$(tname) stamps the given $(i,msgs) with a new $(i,Received) field."; 203 | ] in 204 | let info = Cmd.info "stamp" ~doc ~man in 205 | let term = 206 | let open Term in 207 | ret (const stamp $ hostname $ zone $ from $ _for $ input) in 208 | Cmd.v info term 209 | 210 | let input = 211 | let doc = "The email to analyze. Use $(b,-) for $(b,stdin)." in 212 | Arg.(value & pos 0 Blaze_cli.file "-" & info [] ~doc) 213 | 214 | let extract = 215 | let doc = "Extract Received fields" in 216 | let man = 217 | [ 218 | `S Manpage.s_description; 219 | `P "$(tname) prints $(i,Received) fields from the specified $(i,msgs)."; 220 | ] in 221 | Cmd.v (Cmd.info "extract" ~doc ~man) Term.(ret (const extract $ dot $ input)) 222 | 223 | let default = Term.(ret (const (`Help (`Pager, None)))) 224 | 225 | let cmd = 226 | let doc = "A tool to manipulate Received fields." in 227 | let man = 228 | [ 229 | `S Manpage.s_description; 230 | `P 231 | "Use $(tname) $(i,extract) to extract $(i,Received) informations from \ 232 | the given $(i,msgs)."; 233 | `P 234 | "Use $(tname) $(i,stamp) to stamp the given $(i,msgs) with a new \ 235 | $(i,Received) field."; 236 | ] in 237 | Cmd.group ~default (Cmd.info "recv" ~doc ~man) [ extract; stamp ] 238 | -------------------------------------------------------------------------------- /bin/hdr.ml: -------------------------------------------------------------------------------- 1 | open Mrmime 2 | 3 | let identity x = x 4 | let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt 5 | 6 | let default = 7 | let open Field_name in 8 | Map.empty 9 | |> Map.add from Field.(Witness Mailboxes) 10 | |> Map.add (v "to") Field.(Witness Addresses) 11 | |> Map.add cc Field.(Witness Addresses) 12 | |> Map.add bcc Field.(Witness Addresses) 13 | |> Map.add sender Field.(Witness Mailbox) 14 | |> Map.add date Field.(Witness Date) 15 | |> Map.add subject Field.(Witness Unstructured) 16 | |> Map.add message_id Field.(Witness MessageID) 17 | |> Map.add comments Field.(Witness Unstructured) 18 | |> Map.add content_type Field.(Witness Content) 19 | |> Map.add content_encoding Field.(Witness Encoding) 20 | 21 | let decode_rfc2047 = ref false 22 | 23 | let pp_encoded ~charset ppf = function 24 | | Emile.Quoted_printable (Ok v) -> 25 | let buf = Buffer.create (String.length v) in 26 | let encoder = Pecu.Inline.encoder (`Buffer buf) in 27 | let rec go idx = 28 | let[@warning "-8"] (`Ok : [ `Ok | `Partial ]) = 29 | if idx = String.length v 30 | then Pecu.Inline.encode encoder `End 31 | else Pecu.Inline.encode encoder (`Char v.[idx]) in 32 | if idx < String.length v then go (succ idx) in 33 | go 0 ; 34 | Fmt.pf ppf "=?%s?Q?%s?=" charset (Buffer.contents buf) 35 | | Emile.Base64 (Ok v) -> 36 | Fmt.pf ppf "=?%s?B?%s?=" charset (Base64.encode_exn ~pad:true v) 37 | | _ -> assert false 38 | 39 | let pp_phrase ppf phrase = 40 | let pp_elem ppf = function 41 | | `Dot -> Fmt.string ppf "." 42 | | `Word (`Atom x) -> Fmt.string ppf x 43 | | `Word (`String x) -> Fmt.(quote string) ppf x 44 | | `Encoded (_, Emile.Quoted_printable (Ok v)) when !decode_rfc2047 -> 45 | Fmt.string ppf v 46 | | `Encoded (_, Emile.Base64 (Ok v)) when !decode_rfc2047 -> Fmt.string ppf v 47 | | `Encoded (charset, v) -> pp_encoded ~charset ppf v in 48 | Fmt.(list ~sep:(any "@ ") pp_elem) ppf phrase 49 | 50 | let pp_mailbox ppf = function 51 | | { Emile.name = None; _ } as v -> Emile.pp_mailbox ppf v 52 | | { name = Some name; domain = _, []; _ } as v -> 53 | Fmt.pf ppf "@[%a@] <%a>" pp_phrase name Emile.pp_mailbox 54 | { v with Emile.name = None } 55 | | { name = Some name; _ } as v -> 56 | (* XXX(dinosaure): with multiple domains, we know that [emile] surrounds with "<" and ">". *) 57 | Fmt.pf ppf "@[%a@] %a" pp_phrase name Emile.pp_mailbox 58 | { v with Emile.name = None } 59 | 60 | let pp_group ppf { Emile.group; mailboxes } = 61 | Fmt.pf ppf "@[%a@]: @[%a@]" pp_phrase group 62 | Fmt.(list ~sep:(any ",@ ") pp_mailbox) 63 | mailboxes 64 | 65 | let pp_address ppf = function 66 | | `Group g -> pp_group ppf g 67 | | `Mailbox m -> pp_mailbox ppf m 68 | 69 | let parse_header p ic = 70 | let decoder = Hd.decoder p in 71 | let rec go hdr = 72 | match Hd.decode decoder with 73 | | `Malformed err -> Error (`Msg err) 74 | | `Field field -> go (Location.prj field :: hdr) 75 | | `End _prelude -> Ok (List.rev hdr) 76 | | `Await -> 77 | match input_line ic with 78 | | line -> 79 | Hd.src decoder (line ^ "\r\n") 0 (String.length line + 2) ; 80 | go hdr 81 | | exception End_of_file -> 82 | Hd.src decoder "" 0 0 ; 83 | go hdr in 84 | go [] 85 | 86 | let pp_value ppf = function 87 | | `String v -> Fmt.pf ppf "%a" Fmt.(quote string) v 88 | | `Token v -> Fmt.string ppf v 89 | 90 | let pp_parameters ppf = function 91 | | [] -> () 92 | | lst -> 93 | let pp_binding ppf (k, v) = Fmt.pf ppf "%s=%a" k pp_value v in 94 | Fmt.pf ppf "; %a" Fmt.(list ~sep:(any ";@,") pp_binding) lst 95 | 96 | let pp_content_type ppf { Content_type.ty; subty; parameters } = 97 | Fmt.pf ppf "%s/%s@[%a@]" 98 | (Content_type.Type.to_string ty) 99 | (Content_type.Subtype.to_string subty) 100 | pp_parameters parameters 101 | 102 | let filter hdr fields = 103 | let rem field_name fields = 104 | let delete (a, deleted) x = 105 | if deleted 106 | then (x :: a, deleted) 107 | else if Field_name.equal x field_name 108 | then (a, true) 109 | else (x :: a, deleted) in 110 | List.fold_left delete ([], false) fields |> fst |> List.rev in 111 | let filter (acc, fields) x = 112 | let (Field.Field (field_name', _, _)) = x in 113 | if List.exists (Field_name.equal field_name') fields 114 | then (x :: acc, rem field_name' fields) 115 | else (acc, fields) in 116 | List.fold_left filter ([], fields) hdr |> fun (res, _fields) -> List.rev res 117 | 118 | let show ~prefix hdr fields = 119 | let open Field in 120 | let pp ppf = function 121 | | Field (field_name, Date, v) -> 122 | let v, tz_offset_s = Result.get_ok (Date.to_ptime v) in 123 | Fmt.pf ppf "%a: %a" Field_name.pp field_name 124 | (Ptime.pp_human ~tz_offset_s ()) 125 | v 126 | | Field (field_name, Addresses, v) -> 127 | Fmt.pf ppf "%a: @[%a@]" Field_name.pp field_name 128 | Fmt.(list ~sep:(any ",@,") pp_address) 129 | v 130 | | Field (field_name, Mailboxes, v) -> 131 | Fmt.pf ppf "%a: @[%a@]" Field_name.pp field_name 132 | Fmt.(list ~sep:(any ",@,") pp_mailbox) 133 | v 134 | | Field (field_name, Mailbox, v) -> 135 | Fmt.pf ppf "%a: %a" Field_name.pp field_name pp_mailbox v 136 | | Field (field_name, Unstructured, v) -> 137 | let v = 138 | let filter a = function #Unstrctrd.elt as elt -> elt :: a | _ -> a in 139 | List.fold_left filter [] v 140 | |> List.rev 141 | |> Unstrctrd.of_list 142 | |> Result.get_ok in 143 | let v = Unstrctrd.fold_fws v in 144 | Fmt.pf ppf "%a:%s" Field_name.pp field_name 145 | (Unstrctrd.to_utf_8_string v) 146 | | Field (field_name, MessageID, v) -> 147 | Fmt.pf ppf "%a: %a" Field_name.pp field_name MessageID.pp v 148 | | Field (field_name, Content, v) -> 149 | Fmt.pf ppf "%a: %a" Field_name.pp field_name pp_content_type v 150 | | _ -> () in 151 | let hdr = match fields with None -> hdr | Some fields -> filter hdr fields in 152 | List.iter (Fmt.pr "%s%a\n%!" prefix pp) hdr 153 | 154 | let show_parameter ~prefix contents key = 155 | let open Content_type in 156 | let show_line = function 157 | | Field.Field (_, Content, content) -> ( 158 | let ps = parameters content in 159 | match List.assoc key ps with 160 | | value -> Fmt.pr "%s%a\n%!" prefix pp_value value 161 | | exception Not_found -> ()) 162 | | _ -> () in 163 | (* XXX(dinosaure): [assert false]? *) 164 | List.iter show_line contents 165 | 166 | let run fields want_to_decode_rfc2047 prefix parameter input = 167 | let prefix = 168 | match (prefix, input) with 169 | | true, Some fpath -> Fpath.to_string fpath ^ "\t" 170 | | true, None -> ">\t" 171 | | _ -> "" in 172 | decode_rfc2047 := want_to_decode_rfc2047 ; 173 | let ic, close = 174 | match input with 175 | | Some fpath -> (open_in (Fpath.to_string fpath), close_in) 176 | | None -> (stdin, ignore) in 177 | let p = 178 | match parameter with 179 | | None -> default 180 | | Some _ -> 181 | let fields = Option.fold ~none:[] ~some:identity fields in 182 | let fields = 183 | if List.exists (Field_name.equal Field_name.content_type) fields 184 | then fields 185 | else Field_name.content_type :: fields in 186 | let open Field_name in 187 | List.fold_left 188 | (fun a x -> Map.add x Field.(Witness Content) a) 189 | Map.empty fields in 190 | let result = 191 | let ( >>| ) x fn = Result.map fn x in 192 | parse_header p ic >>| fun value -> 193 | close ic ; 194 | value in 195 | match (result, parameter) with 196 | | Ok hdr, None -> 197 | show ~prefix hdr fields ; 198 | `Ok () 199 | | Ok hdr, Some parameter -> 200 | show_parameter ~prefix hdr parameter ; 201 | `Ok () 202 | | Error (`Msg err), _ -> `Error (false, Fmt.str "%s." err) 203 | 204 | open Cmdliner 205 | 206 | let existing_file = 207 | let parser = function 208 | | "-" -> Ok None 209 | | str -> 210 | match Fpath.of_string str with 211 | | Ok v when Sys.file_exists str -> Ok (Some v) 212 | | Ok v -> error_msgf "%a not found" Fpath.pp v 213 | | Error _ as err -> err in 214 | Arg.conv (parser, Fmt.option ~none:(Fmt.any "-") Fpath.pp) 215 | 216 | let field_name = Arg.conv (Field_name.of_string, Field_name.pp) 217 | 218 | let input = 219 | let doc = "The email to analyze." in 220 | Arg.(value & pos 0 existing_file None & info [] ~doc) 221 | 222 | let fields = 223 | let doc = 224 | "Only print the values of headers in the colon-separated list $(i,hdrs)." 225 | in 226 | Arg.(value & opt (some (list ~sep:':' field_name)) None & info [ "h" ] ~doc) 227 | 228 | let parameter = 229 | let open Content_type in 230 | Arg.conv (Parameters.key, Fmt.string) 231 | 232 | let parameter = 233 | let doc = 234 | "Extract a particular $(i,parameter) from the specified $(i,hdrs)." in 235 | Arg.(value & opt (some parameter) None & info [ "p" ] ~doc) 236 | 237 | let decode_rfc2047 = 238 | let doc = "Decode the $(i,hdrs) according to RFC 2047." in 239 | Arg.(value & flag & info [ "d" ] ~doc) 240 | 241 | let prefix = 242 | let doc = 243 | "Prefix output lines with the filename of the message, followed by a tab." 244 | in 245 | Arg.(value & flag & info [ "H" ] ~doc) 246 | 247 | let cmd = 248 | let doc = "Print message headers" in 249 | let man = 250 | [ 251 | `S Manpage.s_description; 252 | `P "$(tname) prints the headers of the specified $(i,msgs)."; 253 | ] in 254 | Cmd.v (Cmd.info "hdr" ~doc ~man) 255 | Term.( 256 | ret (const run $ fields $ decode_rfc2047 $ prefix $ parameter $ input)) 257 | -------------------------------------------------------------------------------- /test/002.mail: -------------------------------------------------------------------------------- 1 | Return-Path: 2 | Delivered-To: romain.calascibetta@gmail.com 3 | Received: by 2002:a0c:8b6e:0:0:0:0:0 with SMTP id d46csp10537574qvc; 4 | Thu, 6 Dec 2018 04:45:36 -0800 (PST) 5 | X-Google-Smtp-Source: AFSGD/WUVwB34rhb7WzrddyrzlpTItS2BDRiFVF5aBgdXFnpTXq4Fet8Bfd5B7H28uJgGhFkMVdj 6 | X-Received: by 2002:a37:52d6:: with SMTP id g205mr26395616qkb.335.1544100336431; 7 | Thu, 06 Dec 2018 04:45:36 -0800 (PST) 8 | ARC-Seal: i=1; a=rsa-sha256; t=1544100336; cv=none; 9 | d=google.com; s=arc-20160816; 10 | b=yxuQpTtUGLkxXRZ1uXEgzTrmcQZJGJ7kg5vBUZsT3+naoOaznots+iPBZ58igS7hMw 11 | SzYfwm09AhQLUDW58+wMOV0jAXpqtfxGLszKYlr+TeUDhksV+VJ8tiBsnv8qCFmoxz/Z 12 | fiMdT0ODWOi4ri2MhlEMYn5z17amiwkJnW6JtFjM4FJ1rzGK5on8ACg2ebThAeVSlWId 13 | VVekE56/ZbCPU1nur+JEO2tAyRRmqdVp2HkMaK8+aCA4Pz49bGD3qW9DSVlpbsTAsCAw 14 | zDxtH8kNPqJL84lsgqKicfh8ngH+/1hDD6RgRMBnzSEYeOAIWcMathkEQF2i1x7Fxkfm 15 | H3eA== 16 | ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; 17 | h=list-unsubscribe:list-post:list-archive:list-id:precedence 18 | :content-transfer-encoding:mime-version:subject:references 19 | :in-reply-to:message-id:cc:to:reply-to:from:dkim-signature:date; 20 | bh=JC5Ppi0bIF0LjaqLBvsdmlGUddy9IBANMcZlB4r/jg0=; 21 | b=K0ZBUMibHCdKNMZdAI3TY6sJW+wtSgmE4Ju5obpsF/+oMv88bqK/EM3/LHsONgJVK1 22 | N+Ht7Z5tB3eeV0L9HBqRu9hGqfotsUwNzK3p4G+Oxi2g0LDwHZ/Luc1UXeVJ6QEv4SfD 23 | 57LQeHG00KZ6mZzkdpr8KwwjVa/pcdFV0/MjsL+It354oSkfAbmFbt3jS/3rP1IG+qRp 24 | 7j4k0sVU/u+POFgXczV3s0AssbG1cUk6T6/qc7e7ZcruPVXa7FLwPOChGHt1R7TOsTMO 25 | +6sFc2TVHUIaMcnEAYO5hT8ayFcE1I6eZp4IJTe/yRcjCKD0WZJjhQ/TPZnaRUpyTJyg 26 | XOEw== 27 | ARC-Authentication-Results: i=1; mx.google.com; 28 | dkim=pass (test mode) header.i=@github.com header.s=pf2014 header.b=1crXUDuJ; 29 | spf=pass (google.com: domain of noreply@github.com designates 192.30.252.192 as permitted sender) smtp.mailfrom=noreply@github.com; 30 | dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=github.com 31 | Received: from out-1.smtp.github.com (out-1.smtp.github.com. [192.30.252.192]) 32 | by mx.google.com with ESMTPS id 55si171645qvx.1.2018.12.06.04.45.36 33 | for 34 | (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); 35 | Thu, 06 Dec 2018 04:45:36 -0800 (PST) 36 | Received-SPF: pass (google.com: domain of noreply@github.com designates 192.30.252.192 as permitted sender) client-ip=192.30.252.192; 37 | Authentication-Results: mx.google.com; 38 | dkim=pass (test mode) header.i=@github.com header.s=pf2014 header.b=1crXUDuJ; 39 | spf=pass (google.com: domain of noreply@github.com designates 192.30.252.192 as permitted sender) smtp.mailfrom=noreply@github.com; 40 | dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=github.com 41 | Date: Thu, 06 Dec 2018 04:45:36 -0800 42 | DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=github.com; 43 | s=pf2014; t=1544100336; 44 | bh=JC5Ppi0bIF0LjaqLBvsdmlGUddy9IBANMcZlB4r/jg0=; 45 | h=Date:From:Reply-To:To:Cc:In-Reply-To:References:Subject:List-ID: 46 | List-Archive:List-Post:List-Unsubscribe:From; 47 | b=1crXUDuJO2iqzhbE/SM4v5F8MWzU2JaZmn8qvPPy0YzEfR9iXTGe9maYVC0owrHzA 48 | HH6TYsRMvWFi4PIWQ4w9mf9n3w6hsMYqyn6rTZwU02ObRNgZWgmWcrMwmDRdknvR/4 49 | EQZZOCdBtpE5Y95xJ3x6xnS5k2QwT6OXovA7pczQ= 50 | From: =?UTF-8?B?WWFubiBSw6lnaXMgR2lhbmFz?= 51 | Reply-To: mirage/decompress 52 | To: mirage/decompress 53 | Cc: Calascibetta Romain , 54 | Mention 55 | Message-ID: 56 | In-Reply-To: 57 | References: 58 | Subject: Re: [mirage/decompress] Outdated documentation (#65) 59 | Mime-Version: 1.0 60 | Content-Type: multipart/alternative; 61 | boundary="--==_mimepart_5c0919f027e25_99f3fa5ab2d45c01692e9"; 62 | charset=UTF-8 63 | Content-Transfer-Encoding: 7bit 64 | Precedence: list 65 | X-GitHub-Sender: yurug 66 | X-GitHub-Recipient: dinosaure 67 | X-GitHub-Reason: mention 68 | List-ID: mirage/decompress 69 | List-Archive: https://github.com/mirage/decompress 70 | List-Post: 71 | List-Unsubscribe: , 72 | 73 | X-Auto-Response-Suppress: All 74 | X-GitHub-Recipient-Address: romain.calascibetta@gmail.com 75 | X-getmail-retrieved-from-mailbox: INBOX 76 | X-GMAIL-THRID: =?utf-8?q?1619097479752438042?= 77 | X-GMAIL-MSGID: =?utf-8?q?1619106554327842224?= 78 | 79 | 80 | ----==_mimepart_5c0919f027e25_99f3fa5ab2d45c01692e9 81 | Content-Type: text/plain; 82 | charset=UTF-8 83 | Content-Transfer-Encoding: 7bit 84 | 85 | Thanks @dinosaure! 86 | 87 | -- 88 | You are receiving this because you were mentioned. 89 | Reply to this email directly or view it on GitHub: 90 | https://github.com/mirage/decompress/issues/65#issuecomment-444859318 91 | ----==_mimepart_5c0919f027e25_99f3fa5ab2d45c01692e9 92 | Content-Type: text/html; 93 | charset=UTF-8 94 | Content-Transfer-Encoding: quoted-printable 95 | 96 |

Thanks @dinosaure!

=0D 100 | =0D 101 |

&m= 102 | dash;
You are receiving this because you were mentioned.
Reply = 103 | to this email directly, view it on GitHub, or mute the thread.3D""

=0D 109 | = 209 | 210 | ----==_mimepart_5c0919f027e25_99f3fa5ab2d45c01692e9-- 211 | -------------------------------------------------------------------------------- /test/004.mail: -------------------------------------------------------------------------------- 1 | Return-Path: 2 | Delivered-To: romain.calascibetta@gmail.com 3 | Received: by 10.12.195.133 with SMTP id o5csp1021946qvi; 4 | Wed, 28 Mar 2018 15:01:18 -0700 (PDT) 5 | X-Google-Smtp-Source: AIpwx48v4O7s67bC8SJXN97+vP+R9+zZJgOoYig7/CbSM3HQ+2KMJRo0h4S79jjGG8sS/PBSpNIt 6 | X-Received: by 10.99.67.1 with SMTP id q1mr3686835pga.365.1522274478680; 7 | Wed, 28 Mar 2018 15:01:18 -0700 (PDT) 8 | ARC-Seal: i=1; a=rsa-sha256; t=1522274478; cv=none; 9 | d=google.com; s=arc-20160816; 10 | b=CXc64U6fkuKdWCoLGbNrMVqGSL7C3wN4Qhu0hq6y0Aw51Qkx7/kKGPHRwQAuP+zVf7 11 | llKUdev7/3CoXECRwELPnp0haFF3pYzpGMAjx0S3gDqxxOv28QHrUa6Htt0z9Bxm2t7w 12 | 53xorW3SZHpUHQos/pNX+ZOPc9p7mW/QQMG1JruHIzk0DQPHnAjsK/7BU2ymspEtwAqs 13 | 35xEaNUHJ/RTBucZS7Ds/UfhHINtfRkNpPeNx9nh01rtySjFd4QhsGOdV2ZISgDkpLZ6 14 | RHNrOYcAMTLVGW9h9uBL4CqjSrLJLj7qHxLlSGt5YXKM61Qnd6cV6oae9m4bXbh7A5nm 15 | NcHA== 16 | ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; 17 | h=list-archive:list-id:precedence:auto-submitted:list-unsubscribe 18 | :content-transfer-encoding:mime-version:subject:references 19 | :in-reply-to:message-id:to:reply-to:from:date:dkim-signature 20 | :arc-authentication-results; 21 | bh=ZdGqJdNQN89dxdSnp2OTNCT9sFs6eWJfQgJNHULMQmI=; 22 | b=ftc00BZ0+5PbzgcJN5kOwrGPeJxBXD51tvi2SOJhPlgqjUkFQcaK8snsHSeuW9CT7h 23 | QjseLh1KioTtKRiJTm9IvLgvSwM6S/lL2q5jXCdvetHZPGSnz1EXdJ+HBs+03ytbzr5p 24 | LeR1S4xLyNqEGA4zU8Uv53mwDPr2mJN929eBsqu0jLOautbiFTJoQ/duoFKAOGJQ+DpE 25 | knYrcVx/tPoSFLXXyEchVFv438AHehHU5gi3t2GgFTj2lhui5uQcmjebun7f8c38e7F6 26 | B43tHv31bR3FE/ie/hnRRmIeD4HQWevOMiHcTM4fB3b3F+rPx4IfEdSOpbCNWlKdqA79 27 | /miQ== 28 | ARC-Authentication-Results: i=1; mx.google.com; 29 | dkim=pass header.i=@discoursemail.com header.s=sjc2 header.b=VmvuZ8wM; 30 | spf=pass (google.com: domain of ocaml+verp-cdef9eaa098cd788943a4314c682b75a@discoursemail.com designates 216.218.240.121 as permitted sender) smtp.mailfrom=ocaml+verp-cdef9eaa098cd788943a4314c682b75a@discoursemail.com; 31 | dmarc=pass (p=QUARANTINE sp=QUARANTINE dis=NONE) header.from=discoursemail.com 32 | Received: from mx-out-01b.sjc2.discourse.org (mx-out-01b.sjc2.discourse.org. [216.218.240.121]) 33 | by mx.google.com with ESMTPS id bj5-v6si4246535plb.712.2018.03.28.15.01.17 34 | for 35 | (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); 36 | Wed, 28 Mar 2018 15:01:18 -0700 (PDT) 37 | Received-SPF: pass (google.com: domain of ocaml+verp-cdef9eaa098cd788943a4314c682b75a@discoursemail.com designates 216.218.240.121 as permitted sender) client-ip=216.218.240.121; 38 | Authentication-Results: mx.google.com; 39 | dkim=pass header.i=@discoursemail.com header.s=sjc2 header.b=VmvuZ8wM; 40 | spf=pass (google.com: domain of ocaml+verp-cdef9eaa098cd788943a4314c682b75a@discoursemail.com designates 216.218.240.121 as permitted sender) smtp.mailfrom=ocaml+verp-cdef9eaa098cd788943a4314c682b75a@discoursemail.com; 41 | dmarc=pass (p=QUARANTINE sp=QUARANTINE dis=NONE) header.from=discoursemail.com 42 | Received: from localhost.localdomain (unknown [IPv6:2001:470:107:1::212:8d46:a771]) 43 | by mx-out-01b.sjc2.discourse.org (Postfix) with ESMTP id 98C035E012C 44 | for ; Wed, 28 Mar 2018 22:01:17 +0000 (UTC) 45 | DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=discoursemail.com; 46 | s=sjc2; t=1522274477; 47 | bh=0KfgF1n2wDD+Fbyhl4WJ9itDLHq672fuUrX2TKL6JX0=; 48 | h=Date:From:Reply-To:To:In-Reply-To:References:Subject: 49 | List-Unsubscribe:List-ID:List-Archive; 50 | b=VmvuZ8wMp5tiiS5AT4iGiuup+K0ymLD4lkcR+GoWEy/n1dhcjBesmciwcheee+Dfw 51 | j2wRK3QtDXWNGiBg0HnNhjV3G/qgU4jS/gxFRzVP8NJlEX1AqKFo+s6+G+hSJu0X5z 52 | BTt/EUqnldTfduSd2ysewofLOyjF1Z4d0Bqib8rlDdwm6aUaQHyO6qhr6VlOmG7/MQ 53 | XbwpK1rWN5RN4CIH08xVdGOGEJb//OsNoas1J9nGYwc6rbAbPEPNH4nMlMXNt9JNaE 54 | D8Ven7fzOS7FQGIVQjFphSzRPToGMfgPWVht9LSoEq1UjBF48/u7zQZkhPx8vRA4rs 55 | LWDx9qyhXevhg== 56 | Date: Wed, 28 Mar 2018 22:01:17 +0000 57 | From: Yaron Minsky 58 | Reply-To: OCaml 59 | To: romain.calascibetta@gmail.com 60 | Message-ID: 61 | In-Reply-To: 62 | References: 63 | Subject: [OCaml] [Learning] OCaml Style guide? 64 | Mime-Version: 1.0 65 | Content-Type: multipart/alternative; 66 | boundary="--==_mimepart_5abc10ad75205_5dea3fb094a687e8622af"; 67 | charset=UTF-8 68 | Content-Transfer-Encoding: 7bit 69 | List-Unsubscribe: 70 | X-Auto-Response-Suppress: All 71 | Auto-Submitted: auto-generated 72 | Precedence: list 73 | List-ID: 74 | List-Archive: https://discuss.ocaml.org/t/ocaml-style-guide/1378 75 | X-getmail-retrieved-from-mailbox: Inbox 76 | X-GMAIL-THRID: =?utf-8?q?1588517903135480835?= 77 | X-GMAIL-MSGID: =?utf-8?q?1596220483834877081?= 78 | 79 | 80 | ----==_mimepart_5abc10ad75205_5dea3fb094a687e8622af 81 | Content-Type: text/plain; 82 | charset=UTF-8 83 | Content-Transfer-Encoding: 7bit 84 | 85 | 86 | 87 | Hardly definitive, but we just posted our style guide here: 88 | 89 | https://opensource.janestreet.com/standards/ 90 | 91 | 92 | 93 | 94 | 95 | --- 96 | [Visit Topic](https://discuss.ocaml.org/t/ocaml-style-guide/1378/6) or reply to this email to respond. 97 | 98 | You are receiving this because you enabled mailing list mode. 99 | 100 | To unsubscribe from these emails, [click here](https://discuss.ocaml.org/email/unsubscribe/2fd70e1c317382c3b71d8459a94d0b0c105212eb757d87142a0412d92d107f03). 101 | 102 | ----==_mimepart_5abc10ad75205_5dea3fb094a687e8622af 103 | Content-Type: text/html; 104 | charset=UTF-8 105 | Content-Transfer-Encoding: 7bit 106 | 107 |
108 | 109 |
110 | 111 |
112 | 113 | 114 | 117 | 123 | 124 |
115 | 116 | 118 | Yaron_Minsky 119 | Maintainer 120 |
121 | March 28 122 |
125 |
126 |

Hardly definitive, but we just posted our style guide here:

127 |
128 |
129 | 130 | Jane Street Open Source 131 |
132 |
133 |
134 | 135 |

Jane Street Open Source

136 | 137 |

A collection of Jane Street Open Source libraries

138 | 139 | 140 |
141 |
142 | 143 | 144 |
145 |
146 |
147 |
148 |
149 | 150 | 151 | 152 | 153 | 154 | 155 |
156 |
157 |

Visit Topic or reply to this email to respond.

158 |
159 |
160 |

You are receiving this because you enabled mailing list mode.

161 |

To unsubscribe from these emails, click here.

162 |
163 | 164 |
165 | 166 |
167 |
168 | 169 | 170 |
171 |
172 | 173 | ----==_mimepart_5abc10ad75205_5dea3fb094a687e8622af-- 174 | -------------------------------------------------------------------------------- /lib/protocol.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "protocol" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | module Decoder = struct 6 | type t = { buffer : bytes; mutable pos : int; mutable max : int } 7 | 8 | let make len = { buffer = Bytes.make len '\000'; pos = 0; max = 0 } 9 | 10 | let leftover { buffer; pos; max } = 11 | let len = pos - max in 12 | Bytes.sub_string buffer pos len 13 | 14 | type ('v, 'err) state = 15 | | Done of 'v 16 | | Read of { 17 | buffer : bytes; 18 | off : int; 19 | len : int; 20 | continue : ('v, 'err) continue; 21 | } 22 | | Error of 'err info 23 | 24 | and ('v, 'err) continue = [ `End | `Len of int ] -> ('v, 'err) state 25 | and 'err info = { error : 'err; buffer : bytes; committed : int } 26 | 27 | type error = 28 | [ `End_of_input | `Not_enough_space | `Expected_eol | `Invalid_pkt_line ] 29 | 30 | let pp_error ppf = function 31 | | `End_of_input -> Fmt.string ppf "End of input" 32 | | `Not_enough_space -> Fmt.string ppf "Not enough space" 33 | | `Expected_eol -> Fmt.string ppf "Expected EOL" 34 | | `Invalid_pkt_line -> Fmt.string ppf "Invalid PKT-line" 35 | 36 | exception Leave of error info 37 | 38 | let return v _ = Done v 39 | let end_of_input t = t.max 40 | 41 | let safe k decoder = 42 | try k decoder with Leave ({ error = #error; _ } as info) -> Error info 43 | 44 | let leave_with (t : t) error : 'a = 45 | let info = { error; buffer = t.buffer; committed = t.pos } in 46 | raise (Leave info) 47 | 48 | (* NOTE(dinosaure): for POP3. *) 49 | let at_least_one_line (t : t) = 50 | let pos = ref t.pos in 51 | let chr = ref '\000' in 52 | let has_cr = ref false in 53 | while 54 | !pos < t.max 55 | && 56 | (chr := Bytes.unsafe_get t.buffer !pos ; 57 | not (!chr = '\n' && !has_cr)) 58 | do 59 | has_cr := !chr = '\r' ; 60 | incr pos 61 | done ; 62 | !pos < t.max && !chr = '\n' && !has_cr 63 | 64 | let hex t str = 65 | let to_int = function 66 | | 'a' .. 'f' as chr -> 10 + Char.code chr - Char.code 'a' 67 | | 'A' .. 'F' as chr -> 10 + Char.code chr - Char.code 'A' 68 | | '0' .. '9' as chr -> Char.code chr - Char.code '0' 69 | | _ -> leave_with t `Invalid_pkt_line in 70 | let v = to_int str.[0] in 71 | let v = (16 * v) + to_int str.[1] in 72 | let v = (16 * v) + to_int str.[2] in 73 | (16 * v) + to_int str.[3] 74 | 75 | (* NOTE(dinosaure): for Git. *) 76 | let at_least_one_pkt (t : t) = 77 | let len = t.max - t.pos in 78 | if len >= 4 then hex t (Bytes.sub_string t.buffer t.pos 4) <= len else false 79 | 80 | let prompt ~at_least k decoder = 81 | if decoder.pos > 0 82 | then begin 83 | let rest = decoder.max - decoder.pos in 84 | Bytes.unsafe_blit decoder.buffer decoder.pos decoder.buffer 0 rest ; 85 | decoder.max <- rest ; 86 | decoder.pos <- 0 87 | end ; 88 | let rec go off = 89 | let at_least_something = at_least { decoder with max = off } in 90 | if (not at_least_something) && off = Bytes.length decoder.buffer 91 | then 92 | let info = 93 | { 94 | error = `Not_enough_space; 95 | buffer = decoder.buffer; 96 | committed = decoder.pos; 97 | } in 98 | Error info 99 | else if not at_least_something 100 | then 101 | let continue = function 102 | | `Len len -> go (off + len) 103 | | `End -> 104 | let info = 105 | { 106 | error = `End_of_input; 107 | buffer = decoder.buffer; 108 | committed = decoder.pos; 109 | } in 110 | Error info in 111 | Read 112 | { 113 | buffer = decoder.buffer; 114 | off; 115 | len = Bytes.length decoder.buffer - off; 116 | continue; 117 | } 118 | else begin 119 | decoder.max <- off ; 120 | safe k decoder 121 | end in 122 | go decoder.max 123 | 124 | let peek_pkt (t : t) = 125 | if t.max - t.pos < 4 then leave_with t `Invalid_pkt_line ; 126 | let len = hex t (Bytes.sub_string t.buffer t.pos 4) in 127 | if t.max - t.pos < len then leave_with t `Invalid_pkt_line ; 128 | (t.buffer, t.pos + 4, Int.max 0 (len - 4)) 129 | 130 | let peek_while_eol t = 131 | let idx = ref t.pos in 132 | let chr = ref '\000' in 133 | let has_cr = ref false in 134 | while 135 | !idx < end_of_input t 136 | && 137 | (chr := Bytes.unsafe_get t.buffer !idx ; 138 | not (!chr = '\n' && !has_cr)) 139 | do 140 | has_cr := !chr = '\r' ; 141 | incr idx 142 | done ; 143 | if !idx < end_of_input t && !chr = '\n' && !has_cr 144 | then (t.buffer, t.pos, !idx + 1 - t.pos) 145 | else leave_with t `Expected_eol 146 | 147 | let skip t len = t.pos <- t.pos + len 148 | end 149 | 150 | module Encoder = struct 151 | type t = { payload : bytes; mutable pos : int } 152 | 153 | let make len = { payload = Bytes.make len '\000'; pos = 0 } 154 | 155 | type 'err state = 156 | | Write of { 157 | buffer : string; 158 | off : int; 159 | len : int; 160 | continue : 'err continue; 161 | } 162 | | Error of 'err 163 | | Done 164 | 165 | and 'err continue = int -> 'err state 166 | 167 | type error = [ `Not_enough_space ] 168 | 169 | let pp_error ppf = function 170 | | `Not_enough_space -> Fmt.string ppf "Not enough space" 171 | 172 | exception Leave of error 173 | 174 | let leave_with _ error = raise (Leave error) 175 | let safe k encoder = try k encoder with Leave (#error as err) -> Error err 176 | 177 | let flush k0 encoder = 178 | if encoder.pos > 0 179 | then 180 | let rec k1 n = 181 | if n < encoder.pos 182 | then 183 | Write 184 | { 185 | buffer = Bytes.unsafe_to_string encoder.payload; 186 | off = n; 187 | len = encoder.pos - n; 188 | continue = (fun m -> k1 (n + m)); 189 | } 190 | else begin 191 | encoder.pos <- 0 ; 192 | k0 encoder 193 | end in 194 | k1 0 195 | else k0 encoder 196 | 197 | let write str encoder = 198 | let max = Bytes.length encoder.payload in 199 | let go j l encoder = 200 | let rem = max - encoder.pos in 201 | let len = if l > rem then rem else l in 202 | Bytes.blit_string str j encoder.payload encoder.pos len ; 203 | encoder.pos <- encoder.pos + len ; 204 | if len < l then leave_with encoder `Not_enough_space in 205 | go 0 (String.length str) encoder 206 | 207 | let blit src ~off ~len encoder = 208 | let max = Bytes.length encoder.payload in 209 | let go j l encoder = 210 | let rem = max - encoder.pos in 211 | let len = if l > rem then rem else l in 212 | Bytes.blit_string src (off + j) encoder.payload encoder.pos len ; 213 | if len < l then leave_with encoder `Not_enough_space in 214 | go 0 len encoder 215 | end 216 | 217 | type (+'a, 'err) t = 218 | | Read of { 219 | buffer : bytes; 220 | off : int; 221 | len : int; 222 | k : [ `End | `Len of int ] -> ('a, 'err) t; 223 | } 224 | | Write of { buffer : string; off : int; len : int; k : int -> ('a, 'err) t } 225 | | Return of 'a 226 | | Error of 'err 227 | 228 | let ( % ) f g = fun x -> f (g x) 229 | 230 | let rec reword_error fn = function 231 | | Error err -> Error (fn err) 232 | | Read { k; buffer; off; len } -> 233 | Read { k = reword_error fn % k; buffer; off; len } 234 | | Write { k; buffer; off; len } -> 235 | Write { k = reword_error fn % k; buffer; off; len } 236 | | Return _ as v -> v 237 | 238 | let rec go ~fn t len = 239 | match t len with 240 | | Return v -> fn v 241 | | Read { k; buffer; off; len } -> Read { k = go ~fn k; buffer; off; len } 242 | | Write { k; buffer; off; len } -> 243 | let k0 = function `End -> k 0 | `Len len -> k len in 244 | let k1 = function 0 -> go ~fn k0 `End | len -> go ~fn k0 (`Len len) in 245 | Write { k = k1; buffer; off; len } 246 | | Error err -> Error err 247 | 248 | let bind t fn = 249 | match t with 250 | | Return v -> fn v 251 | | Error err -> Error err 252 | | Read { k; buffer; off; len } -> Read { k = go ~fn k; buffer; off; len } 253 | | Write { k; buffer; off; len } -> 254 | let k0 = function `End -> k 0 | `Len len -> k len in 255 | let k1 = function 0 -> go ~fn k0 `End | len -> go ~fn k0 (`Len len) in 256 | Write { k = k1; buffer; off; len } 257 | 258 | let return v = Return v 259 | let error err = Error err 260 | 261 | type ctx = { encoder : Encoder.t; decoder : Decoder.t } 262 | type error = [ Decoder.error | Encoder.error ] 263 | 264 | let pp_error ppf = function 265 | | #Encoder.error as err -> Encoder.pp_error ppf err 266 | | #Decoder.error as err -> Decoder.pp_error ppf err 267 | 268 | let ctx () = { encoder = Encoder.make 65536; decoder = Decoder.make 65536 } 269 | let leftover ctx = Decoder.leftover ctx.decoder 270 | 271 | let encode_str ctx str = 272 | let k t = 273 | Encoder.write str t ; 274 | Encoder.flush (fun _t -> Encoder.Done) t in 275 | let k t = Encoder.safe k t in 276 | let rec go = function 277 | | Encoder.Done -> Return () 278 | | Encoder.Write { buffer; off; len; continue } -> 279 | Write { k = go % continue; buffer; off; len } 280 | | Encoder.Error err -> Error err in 281 | go (k ctx.encoder) 282 | 283 | let encode_line ctx str = encode_str ctx (str ^ "\r\n") 284 | 285 | let hex = 286 | let[@ocamlformat "disable"] to_char = 287 | [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 288 | 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; |] in 289 | fun n -> 290 | if n < 0 then invalid_arg "Protocol.hex: negative number" ; 291 | if n > 65535 then Fmt.invalid_arg "Protocol.hex: too large number (%d)" n ; 292 | let n = ref n in 293 | let buf = Bytes.create 4 in 294 | Bytes.set buf 3 to_char.(!n mod 16) ; 295 | n := !n / 16 ; 296 | Bytes.set buf 2 to_char.(!n mod 16) ; 297 | n := !n / 16 ; 298 | Bytes.set buf 1 to_char.(!n mod 16) ; 299 | n := !n / 16 ; 300 | Bytes.set buf 0 to_char.(!n) ; 301 | Bytes.unsafe_to_string buf 302 | 303 | let encode_pkt ctx str = 304 | let hdr = hex (String.length str + 4) in 305 | encode_str ctx (hdr ^ str) 306 | 307 | let encode_flush_pkt ctx = encode_str ctx "0000" 308 | let encode_delim_pkt ctx = encode_str ctx "0001" 309 | 310 | type ('r, 'err) fmt = 311 | ('r, Format.formatter, unit, (unit, ([> Encoder.error ] as 'err)) t) format4 312 | 313 | let encode_pkt ctx fmt = Fmt.kstr (encode_pkt ctx) fmt 314 | 315 | let decode_line ctx = 316 | let at_least = Decoder.at_least_one_line in 317 | let k t = 318 | let buf, off, len = Decoder.peek_while_eol t in 319 | let str = Bytes.sub_string buf off (len - 2) in 320 | Decoder.skip t len ; 321 | Decoder.Done str in 322 | let k t = 323 | if at_least t then Decoder.safe k t else Decoder.prompt ~at_least k t in 324 | let rec go = function 325 | | Decoder.Done v -> Return v 326 | | Decoder.Read { buffer; off; len; continue } -> 327 | Read { k = Fun.compose go continue; buffer; off; len } 328 | | Decoder.Error { error; _ } -> Error error in 329 | go (k ctx.decoder) 330 | 331 | let decode_pkt ctx = 332 | let at_least = Decoder.at_least_one_pkt in 333 | let k t = 334 | let buf, off, len = Decoder.peek_pkt t in 335 | let str = Bytes.sub_string buf off len in 336 | Decoder.skip t (4 + len) ; 337 | Decoder.Done str in 338 | let k t = 339 | if at_least t then Decoder.safe k t else Decoder.prompt ~at_least k t in 340 | let rec go = function 341 | | Decoder.Done v -> Return v 342 | | Decoder.Read { buffer; off; len; continue } -> 343 | Read { k = Fun.compose go continue; buffer; off; len } 344 | | Decoder.Error { error; _ } -> Error error in 345 | go (k ctx.decoder) 346 | -------------------------------------------------------------------------------- /bin/fetch.ml: -------------------------------------------------------------------------------- 1 | let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt 2 | let msgf fmt = Fmt.kstr (fun msg -> `Msg msg) fmt 3 | let reword_error fn = function Ok _ as v -> v | Error err -> Error (fn err) 4 | 5 | type uid = [ `POP3 of string ] 6 | type protocol = [ `POP3 | `Git ] 7 | 8 | type remote = 9 | | Uri of protocol * (string * string) option * string * int option * string 10 | | Git of string * string * string 11 | 12 | let decode_host_port str = 13 | match String.split_on_char ':' str with 14 | | [] -> assert false 15 | | [ host ] -> Ok (host, None) 16 | | [ host; "" ] -> Ok (host, None) 17 | | hd :: tl -> ( 18 | let port, host = 19 | match List.rev (hd :: tl) with 20 | | hd :: tl -> (hd, String.concat ":" (List.rev tl)) 21 | | _ -> assert false in 22 | try Ok (host, Some (int_of_string port)) 23 | with _ -> error_msgf "Couldn't decode port") 24 | 25 | let decode_user_pass up = 26 | match String.split_on_char ':' up with 27 | | [ _user ] -> Ok None 28 | | user :: pass -> 29 | let pass = String.concat ":" pass in 30 | Ok (Some (user, pass)) 31 | | [] -> assert false 32 | 33 | let decode_uri uri = 34 | let ( >>= ) = Result.bind in 35 | match String.split_on_char '/' uri with 36 | | proto :: "" :: user_pass_host_port :: path -> 37 | begin match proto with 38 | | "pop3:" -> Ok `POP3 39 | | "git:" -> Ok `Git 40 | | _ -> error_msgf "Unknown protocol" 41 | end 42 | >>= fun protocol -> 43 | begin match String.split_on_char '@' user_pass_host_port with 44 | | [ host_port ] -> Ok (None, host_port) 45 | | [ user_pass; host_port ] -> 46 | decode_user_pass user_pass >>= fun up -> Ok (up, host_port) 47 | | _ -> error_msgf "Couldn't decode URI" 48 | end 49 | >>= fun (user_pass, host_port) -> 50 | decode_host_port host_port >>= fun (host, port) -> 51 | let path = "/" ^ String.concat "/" path in 52 | Ok (Uri (protocol, user_pass, host, port, path)) 53 | | [ user_pass_host_port ] -> 54 | begin match String.split_on_char '@' user_pass_host_port with 55 | | [ host_port ] -> Ok (None, host_port) 56 | | [ user_pass; host_port ] -> 57 | decode_user_pass user_pass >>= fun up -> Ok (up, host_port) 58 | | _ -> error_msgf "Couldn't decode URI" 59 | end 60 | >>= fun (user_pass, host_port) -> 61 | decode_host_port host_port >>= fun (host, port) -> 62 | Ok (Uri (`POP3, user_pass, host, port, "/")) 63 | | _ -> Error (`Msg "Could't decode URI on top") 64 | 65 | let decode_ssh str = 66 | let ( >>= ) = Result.bind in 67 | let len = String.length str in 68 | Emile.of_string_raw ~off:0 ~len str |> reword_error (msgf "%a" Emile.pp_error) 69 | >>= fun (consumed, m) -> 70 | let rem = String.sub str consumed (len - consumed) in 71 | match String.split_on_char ':' rem with 72 | | "" :: path -> 73 | let local = 74 | let fn = function `Atom x -> x | `String x -> Fmt.str "%S" x in 75 | List.map fn m.Emile.local in 76 | let user = String.concat "." local in 77 | let host = 78 | match fst m.Emile.domain with 79 | | `Domain vs -> String.concat "." vs 80 | | `Literal v -> v 81 | | `Addr (Emile.IPv4 v) -> Ipaddr.V4.to_string v 82 | | `Addr (Emile.IPv6 v) -> Ipaddr.V6.to_string v 83 | | `Addr (Emile.Ext (k, v)) -> Fmt.str "%s:%s" k v in 84 | Ok (Git (user, host, String.concat ":" path)) 85 | | _ -> error_msgf "Invalid SSH endpoint" 86 | 87 | let remote_of_string str = 88 | match (decode_ssh str, decode_uri str) with 89 | | Ok v, _ | _, Ok v -> Ok v 90 | | _, (Error _ as err) -> err 91 | 92 | type cfg = { 93 | quiet : bool; 94 | uri : remote; 95 | authenticator : X509.Authenticator.t option; 96 | happy_eyeballs : Happy_eyeballs_miou_unix.t; 97 | excludes : uid list; 98 | fmt : (string -> string, Format.formatter, unit, string) format4; 99 | } 100 | 101 | let or_failwith on_err = function 102 | | Ok value -> value 103 | | Error err -> 104 | let str = on_err err in 105 | Logs.err (fun m -> m "Task failed with: %s" str) ; 106 | failwith str 107 | 108 | let split_on_char chr ?(interleave = Bstr.make 1 chr) bstr = 109 | let rec go bottom idx () = 110 | if idx >= Bstr.length bstr 111 | then 112 | let pre = Bstr.sub bstr ~off:bottom ~len:(idx - bottom) in 113 | Seq.Cons (pre, Seq.empty) 114 | else if Bstr.get bstr idx = chr 115 | then 116 | let pre = Bstr.sub bstr ~off:bottom ~len:(idx - bottom) in 117 | let seq0 = go (idx + 1) (idx + 1) in 118 | let seq1 = Seq.cons interleave seq0 in 119 | Seq.Cons (pre, seq1) 120 | else go bottom (idx + 1) () in 121 | go 0 0 122 | 123 | let crlf = Bstr.of_string "\r\n" 124 | 125 | let run cfg = 126 | let store stream () = 127 | let open Flux in 128 | let save = 129 | let init = () and merge () () = () in 130 | Sink.each ~parallel:false ~init ~merge @@ fun (uid, stream) -> 131 | let filename = Fmt.str cfg.fmt uid in 132 | Stream.file ~filename stream in 133 | let into = 134 | let open Sink.Syntax in 135 | let+ mails = Sink.list and+ _ = save in 136 | let fn (uid, _) = Fmt.str cfg.fmt uid in 137 | List.map fn mails in 138 | let mails = Stream.into into stream in 139 | if not cfg.quiet then List.iter print_endline mails in 140 | match cfg.uri with 141 | | Git _ | Uri (`Git, _, _, _, _) -> 142 | let bqueue = Flux.Bqueue.(create with_close) 0x7ff in 143 | let remote = 144 | match cfg.uri with 145 | | Git (user, server, path) -> `SSH (user, server, None, path) 146 | | Uri (_, _, server, port, path) -> `Git (server, port, path) in 147 | let fetch = 148 | Miou.async @@ fun () -> 149 | Git_miou_unix.fetch remote cfg.happy_eyeballs bqueue 150 | |> or_failwith (Fmt.str "%a" Git_miou_unix.pp_error) in 151 | let from = Flux.Source.bqueue bqueue in 152 | let from = Flux.Stream.from from in 153 | let from = 154 | let fn (uid, raw) = 155 | let uid = Fmt.str "%a" Carton.Uid.pp uid in 156 | Logs.debug (fun m -> m "[+] %s" uid) ; 157 | Logs.debug (fun m -> 158 | m "@[%a@]" (Hxd_string.pp Hxd.default) (Bstr.to_string raw)) ; 159 | let seq = split_on_char '\n' ~interleave:crlf raw in 160 | let src = Flux.Source.seq seq in 161 | let stream = Flux.Stream.from src in 162 | let stream = Flux.Stream.map Bstr.to_string stream in 163 | (uid, stream) in 164 | Flux.Stream.map fn from in 165 | let store = Miou.call (store from) in 166 | Miou.await_exn fetch ; 167 | Logs.debug (fun m -> m "public-inbox cloned, start to store emails") ; 168 | Miou.await_exn store 169 | | Uri (`POP3, authentication, server, port, _) -> 170 | let ports = Option.map (fun x -> [ x ]) port in 171 | let stream = Flux.Bqueue.(create with_close) 0x7ff in 172 | let excludes = 173 | List.filter_map (function `POP3 uid -> Some uid) cfg.excludes in 174 | let filter uids = 175 | let exists uid = List.exists (Pop3.Uid.equal_to_string uid) excludes in 176 | List.filter (Fun.negate exists) uids in 177 | let fetch = 178 | Miou.async @@ fun () -> 179 | Pop3_miou_unix.fetch ?authentication ?authenticator:cfg.authenticator 180 | ?ports ~server ~filter cfg.happy_eyeballs stream 181 | |> or_failwith (Fmt.str "%a" Pop3_miou_unix.pp_error) in 182 | let from = Flux.Source.bqueue stream in 183 | let from = Flux.Stream.from from in 184 | let from = 185 | let fn (uid, src) = 186 | let src = Flux.Source.bqueue src in 187 | let stream = Flux.Stream.from src in 188 | (Pop3.Uid.to_string uid, stream) in 189 | Flux.Stream.map fn from in 190 | let store = Miou.call (store from) in 191 | Miou.await_exn fetch ; 192 | Miou.await_exn store 193 | 194 | let now () = Some (Ptime_clock.now ()) 195 | 196 | let run quiet authenticator resolver (uri, _) excludes fmt = 197 | Miou_unix.run ~domains:2 @@ fun () -> 198 | let daemon, happy_eyeballs = resolver () in 199 | let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in 200 | let authenticator = Option.map (fun (fn, _) -> fn now) authenticator in 201 | let finally () = 202 | Happy_eyeballs_miou_unix.kill daemon ; 203 | Mirage_crypto_rng_miou_unix.kill rng in 204 | Fun.protect ~finally @@ fun () -> 205 | run { quiet; authenticator; happy_eyeballs; uri; excludes; fmt } 206 | 207 | open Cmdliner 208 | open Blaze_cli 209 | 210 | let username = 211 | let doc = "The username used to be connected to the service." in 212 | let open Arg in 213 | value 214 | & opt (some string) None 215 | & info [ "u"; "username" ] ~doc ~docv:"USERNAME" 216 | 217 | let password = 218 | let doc = "The password used to be connected to the service." in 219 | let open Arg in 220 | value 221 | & opt (some string) None 222 | & info [ "p"; "password" ] ~doc ~docv:"PASSWORD" 223 | 224 | let uri = 225 | let doc = "The server to fetch emails." in 226 | let parser str = 227 | match remote_of_string str with 228 | | Ok v -> Ok (v, str) 229 | | Error _ as err -> err in 230 | let pp ppf (_, str) = Fmt.string ppf str in 231 | let uri = Arg.conv (parser, pp) in 232 | let open Arg in 233 | required & pos 0 (some uri) None & info [] ~doc ~docv:"URI" 234 | 235 | let setup_uri (uri : remote * _) username password = 236 | let str = snd uri in 237 | match (fst uri, username, password) with 238 | | _, None, None -> uri 239 | | Uri (protocol, None, host, port, path), Some username, Some password -> 240 | let uri = Uri (protocol, Some (username, password), host, port, path) in 241 | (uri, str) 242 | | _ -> uri (* TODO(dinosaure): warn which username/password we will use. *) 243 | 244 | let setup_uri = 245 | let open Term in 246 | const setup_uri $ uri $ username $ password 247 | 248 | let authenticator = 249 | let doc = "The TLS authenticator used to verify TLS certificates." in 250 | let parser str = 251 | match X509.Authenticator.of_string str with 252 | | Ok authenticator -> Ok (authenticator, str) 253 | | Error _ as err -> err in 254 | let pp ppf (_, str) = Fmt.string ppf str in 255 | let authenticator = Arg.conv (parser, pp) in 256 | let open Arg in 257 | value 258 | & opt (some authenticator) None 259 | & info [ "a"; "auth"; "authenticator" ] ~doc ~docv:"AUTHENTICATOR" 260 | 261 | let is_graphic = function '\x21' .. '\x7e' -> true | _ -> false 262 | 263 | let uid = 264 | let parser str = 265 | match String.split_on_char ':' str with 266 | | [] -> assert false 267 | | [ "pop3"; uid ] -> 268 | (* XXX(dinosaure): See RFC1939. *) 269 | if String.for_all is_graphic uid 270 | then Ok (`POP3 uid) 271 | else error_msgf "Invalid unique email identifier: %S" uid 272 | | _ -> error_msgf "Invalid unique email identifier: %S" str in 273 | let pp ppf = function `POP3 uid -> Fmt.pf ppf "pop3:%s" uid in 274 | Arg.conv (parser, pp) 275 | 276 | let excludes = 277 | let doc = "Excludes some emails to fetch via their unique identifiers." in 278 | let open Arg in 279 | value & opt_all uid [] & info [ "exclude" ] ~doc ~docv:"UID" 280 | 281 | let default_fmt : (string -> string, Format.formatter, unit, string) format4 = 282 | "blaze-%s.eml" 283 | 284 | let fmt : (string -> string, Format.formatter, unit, string) format4 Term.t = 285 | let doc = "The format of incoming emails saved into the given directory." in 286 | let parser str = 287 | let proof = CamlinternalFormatBasics.(String_ty End_of_fmtty) in 288 | try Ok (CamlinternalFormat.format_of_string_fmtty str proof) 289 | with _ -> error_msgf "Invalid format: %S" str in 290 | let pp ppf (CamlinternalFormatBasics.Format (_, str)) = Fmt.pf ppf "%S" str in 291 | let fmt = Arg.conv (parser, pp) in 292 | let open Arg in 293 | value & opt fmt default_fmt & info [ "f"; "format" ] ~doc ~docv:"FMT" 294 | 295 | let term = 296 | let open Term in 297 | const run 298 | $ setup_logs 299 | $ authenticator 300 | $ setup_resolver 301 | $ setup_uri 302 | $ excludes 303 | $ fmt 304 | 305 | let cmd = 306 | let doc = "A program to fetch a bunch of emails from a service (like POP3)." in 307 | let man = [] in 308 | let info = Cmd.info "fetch" ~doc ~man in 309 | Cmd.v info term 310 | --------------------------------------------------------------------------------