Merge pull request #78 from Cumulus/fix-tests-and-rss2-with-curl

#77 with ocurl

.travis.yml

@@ -1,14 +1,13 @@
 language: c
 install:
   - wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh
-  - wget https://raw.githubusercontent.com/dinosaure/ocaml-travisci-skeleton/master/.travis-docgen.sh
-script: bash -ex .travis-opam.sh && bash -ex .travis-docgen.sh
+script: bash -ex .travis-opam.sh
 sudo: true
 env:
   matrix:
-  - PACKAGE="syndic" OCAML_VERSION=4.03 TESTS=true
   - PACKAGE="syndic" OCAML_VERSION=4.04 TESTS=true
   - PACKAGE="syndic" OCAML_VERSION=4.05 TESTS=true
   - PACKAGE="syndic" OCAML_VERSION=4.06 TESTS=true
+  - PACKAGE="syndic" OCAML_VERSION=4.07 TESTS=true
   global:
     secure: P2npPkd5gMklBsWxF9fG22BapaeOxvQK/W2IVcjgtv9mYqp66a3qhKNks6vEgc57AFafNV0kwlmwv+DgA0KOOiC0fQwgR7rPYsYje9J1FJ+0K+SFqJsQweTSWCscEweh0dthNtchEOXyf0A58p9du67y4yA+1la1NYAl+Je7P5s=

lib/syndic_rss2.ml

@@ -800,11 +800,10 @@ let channel_language_of_xml ~xmlbase:_ (pos, _tag, datas) =
     raise
       (Error.Error (pos, "The content of <language> MUST be a non-empty string"))
 
-let channel_copyright_of_xml ~xmlbase:_ (pos, _tag, datas) =
-  try `Copyright (get_leaf datas) with Not_found ->
-    raise
-      (Error.Error
-         (pos, "The content of <copyright> MUST be a non-empty string"))
+let channel_copyright_of_xml ~xmlbase:_ (_pos, _tag, datas) =
+  try `Copyright (get_leaf datas) with Not_found -> `Copyright ""
+
+(* XXX(dinosaure): aempty copyright is allowed. *)
 
 let channel_managingeditor_of_xml ~xmlbase:_ (pos, _tag, datas) =
   try `ManagingEditor (get_leaf datas) with Not_found ->

syndic.opam

@@ -18,15 +18,24 @@ build: [
   [ "dune" "runtest" "-p" name ] {with-test}
 ]
 
+
 depends: [
   "ocaml" {>= "4.03.0"}
   "dune"
   "ptime"
   "uri" {>= "1.9"}
   "xmlm" {>= "1.2.0"}
-  "cohttp" {with-test & >= "1.0.0"}
-  "cohttp-lwt-unix" {with-test & >= "1.0.0"}
-  "lwt" {with-test}
-  "ssl" {with-test}
-  "tls" {with-test}
+  "fmt" {with-test}
+  "ocurl" {with-test}
+  "fpath" {with-test}
+  "ocplib-json-typed" {with-test}
+  "base-unix" {with-test}
+  "jsonm" {with-test}
 ]
+
+extra-source "test/001.feed" { src: "http://16andcounting.libsyn.com/rss" }
+extra-source "test/002.feed" { src: "http://rgrinberg.com/blog/atom.xml" }
+extra-source "test/003.feed" { src: "http://ocaml.org/feed.xml" }
+extra-source "test/004.feed" { src: "http://korben.info/feed" }
+extra-source "test/005.feed" { src: "http://linuxfr.org/journaux.atom" }
+extra-source "test/006.feed" { src: "http://www.reddit.com/r/ocaml/.rss" }

test/downloader.ml

@@ -0,0 +1,56 @@
+#use "topfind" ;;
+
+#require "fmt" ;;
+#require "fpath" ;;
+#require "uri" ;;
+
+#require "curl" ;;
+
+let () = Printexc.register_printer
+    (function
+      | Curl.CurlException (code, errno, err) ->
+        Some (Fmt.strf "(CurlException (%s, %d, %s))" (Curl.strerror code) errno err)
+      | _ -> None)
+
+let curl_setup_simple h =
+  let open Curl in
+  set_useragent h "Syndic" ;
+  set_nosignal h true ;
+  set_connecttimeout h 5 ;
+  set_timeout h 10 ;
+  set_followlocation h true ;
+  set_maxredirs h 10 ;
+  set_ipresolve h IPRESOLVE_V4 ;
+  set_encoding h CURL_ENCODING_ANY
+
+let download h =
+  let b = Buffer.create 16 in
+  Curl.set_writefunction h (fun s -> Buffer.add_string b s ; String.length s) ;
+  Curl.perform h ;
+  Buffer.contents b
+
+let get url =
+  let h = Curl.init () in
+  Curl.set_url h (Uri.to_string url) ;
+  curl_setup_simple h ;
+  download h
+
+let man () = Fmt.epr "%s --uri <uri> --output <file>\n%!" Sys.argv.(0)
+let success = 0
+let failure = 1
+
+let () =
+  let uri, output = try
+      match Sys.argv with
+      | [| _; "--uri"; uri; "--output"; output |] -> Uri.of_string uri, Fpath.v output
+      | _ -> man () ; exit failure
+    with _ -> man () ; exit failure in
+  match get uri with
+  | contents ->
+    let oc = open_out (Fpath.to_string output) in
+    let ppf = Format.formatter_of_out_channel oc in
+    Fmt.pf ppf "%s%!" contents ;
+    close_out oc ;
+    exit success
+  | exception exn ->
+    Fmt.epr "Retrieve an error: %s.\n%!" (Printexc.to_string exn) ; exit failure

test/dune

@@ -1,15 +1,15 @@
 (executable
  (name test)
  (modules test)
- (libraries syndic cohttp-lwt-unix ssl tls))
+ (libraries syndic jsonm fpath fmt ocplib-json-typed unix))
 
-(executable
- (name test_decisions)
- (modules test_decisions)
- (libraries syndic cohttp-lwt-unix ssl tls))
+(include dune.inc)
+
+(rule
+ (targets dune.inc.gen)
+ (deps (:gen generate.ml) (:feeds feeds.json))
+ (action (run %{ocaml} %{gen} --json %{feeds} --output %{targets})))
 
 (alias
  (name runtest)
- (package syndic)
- (deps (:test test.exe))
- (action (run %{test} -q --color=always)))
+ (action (diff dune.inc dune.inc.gen)))

test/dune.inc

@@ -0,0 +1,9 @@
+(rule (targets 001.feed) (mode fallback) (deps (:gen downloader.ml)) (action (run %{ocaml} %{gen} --uri http://16andcounting.libsyn.com/rss --output %{targets})))
+(rule (targets 002.feed) (mode fallback) (deps (:gen downloader.ml)) (action (run %{ocaml} %{gen} --uri http://rgrinberg.com/blog/atom.xml --output %{targets})))
+(rule (targets 003.feed) (mode fallback) (deps (:gen downloader.ml)) (action (run %{ocaml} %{gen} --uri http://ocaml.org/feed.xml --output %{targets})))
+(rule (targets 004.feed) (mode fallback) (deps (:gen downloader.ml)) (action (run %{ocaml} %{gen} --uri http://korben.info/feed --output %{targets})))
+(rule (targets 005.feed) (mode fallback) (deps (:gen downloader.ml)) (action (run %{ocaml} %{gen} --uri http://linuxfr.org/journaux.atom --output %{targets})))
+(rule (targets 006.feed) (mode fallback) (deps (:gen downloader.ml)) (action (run %{ocaml} %{gen} --uri http://www.reddit.com/r/ocaml/.rss --output %{targets})))
+
+(alias (name runtest) (package syndic) (deps (:test test.exe) (:feeds 001.feed 002.feed 003.feed 004.feed 005.feed 006.feed) feeds.json) (action (run %{test} --color=always)))
+

test/feeds.json

@@ -0,0 +1,20 @@
+[
+    { "name": "001",
+      "uri": "http://16andcounting.libsyn.com/rss",
+      "kind": "rss2" },
+    { "name": "002",
+      "uri": "http://rgrinberg.com/blog/atom.xml",
+      "kind": "atom" },
+    { "name": "003",
+      "uri": "http://ocaml.org/feed.xml",
+      "kind": "atom" },
+    { "name": "004",
+      "uri": "http://korben.info/feed",
+      "kind": "rss2" },
+    { "name": "005",
+      "uri": "http://linuxfr.org/journaux.atom",
+      "kind": "atom" },
+    { "name": "006",
+      "uri": "http://www.reddit.com/r/ocaml/.rss",
+      "kind": "atom" }
+]

test/generate.ml

@@ -0,0 +1,146 @@
+#use "topfind" ;;
+
+#require "ocplib-json-typed" ;;
+#require "fmt" ;;
+#require "jsonm" ;;
+#require "fpath" ;;
+
+type entry =
+  { name : string
+  ; uri : Uri.t
+  ; kind : kind }
+and kind = Rss1 | Rss2 | Atom
+
+let json =
+  let open Json_encoding in
+  let name = req "name" string in
+  let uri = req "uri" (conv Uri.to_string Uri.of_string string) in
+  let kind =
+    let rss1 = case string (function Rss1 -> Some "rss1" | _ -> None) (function "rss1" -> Rss1 | _ -> assert false) in
+    let rss2 = case string (function Rss2 -> Some "rss2" | _ -> None) (function "rss2" -> Rss2 | _ -> assert false) in
+    let atom = case string (function Atom -> Some "atom" | _ -> None) (function "atom" -> Atom | _ -> assert false) in
+    req "kind" (union [ rss1; rss2; atom ]) in
+  let entry = conv (fun { name; uri; kind; } -> (name, uri, kind)) (fun (name, uri, kind) -> { name; uri; kind; }) (obj3 name uri kind) in
+  list entry
+
+type await = [ `Await ]
+type error = [ `Error of Jsonm.error ]
+type eoi = [ `End ]
+type value = [ `Null | `Bool of bool | `String of string | `Float of float ]
+
+let json_of_input ic =
+  let decoder = Jsonm.decoder (`Channel ic) in
+
+  let error (`Error err) = Fmt.invalid_arg "%a" Jsonm.pp_error err in
+  let end_of_input `End = Fmt.invalid_arg "Unexpected end of input" in
+
+  let rec arr acc k = match Jsonm.decode decoder with
+    | #await -> assert false
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme `Ae -> k (`A (List.rev acc))
+    | `Lexeme v -> base (fun v -> arr (v :: acc) k) v
+
+  and name n k = match Jsonm.decode decoder with
+    | #await -> assert false
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme v -> base (fun v -> k (n, v)) v
+
+  and obj acc k = match Jsonm.decode decoder with
+    | #await -> assert false
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme `Oe -> k (`O (List.rev acc))
+    | `Lexeme (`Name n) -> name n (fun v -> obj (v :: acc) k)
+    | `Lexeme v -> Fmt.invalid_arg "Unexpected lexeme: %a" Jsonm.pp_lexeme v
+
+  and base k = function
+    | #value as v -> k v
+    | `Os -> obj [] k
+    | `As -> arr [] k
+    | `Ae | `Oe -> Fmt.invalid_arg "Unexpected end of array/object"
+    | `Name n -> Fmt.invalid_arg "Unexpected key: %s" n in
+
+  let go k = match Jsonm.decode decoder with
+    | #await -> assert false
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme (#Jsonm.lexeme as lexeme) -> base k lexeme in
+
+  go Json_encoding.(destruct json)
+
+let flat_json json : Jsonm.lexeme list =
+  let rec arr acc k = function
+    | [] -> k (List.rev (`Ae :: acc))
+    | (#value as x) :: r -> arr (x :: acc) k r
+    | `A l :: r -> arr [ `As ] (fun l -> arr (List.rev_append l acc) k r) l
+    | `O l :: r -> obj [ `Os ] (fun l -> arr (List.rev_append l acc) k r) l
+
+  and obj acc k = function
+    | [] -> k (List.rev (`Oe :: acc))
+    | (n, x) :: r -> base (fun v -> obj (List.rev_append v (`Name n :: acc)) k r) x
+
+  and base k = function
+    | `A l -> arr [ `As ] k l
+    | `O l -> obj [ `Os ] k l
+    | #value as x -> k [ x ] in
+
+  base (fun l -> l) json
+
+external identity : 'a -> 'a = "%identity"
+
+let pp_json ppf map =
+  let json = Json_encoding.(construct json map) in
+  let raw = Bytes.create 0x800 in
+  let encoder = Jsonm.encoder `Manual in
+  let rec write k = function
+    | `Ok -> k ()
+    | `Partial ->
+      Fmt.string ppf (Bytes.sub_string raw 0 (Jsonm.Manual.dst_rem encoder)) ;
+      Jsonm.Manual.dst encoder raw 0 (Bytes.length raw) ;
+      write k (Jsonm.encode encoder `Await) in
+  let rec go k = function
+    | [] -> write k (Jsonm.encode encoder `End)
+    | lexeme :: r -> write (fun () -> go k r) (Jsonm.encode encoder (`Lexeme lexeme)) in
+  let lexemes = flat_json json in
+  go identity lexemes
+
+let pp_entry ppf entry =
+  Fmt.pf ppf "(rule (targets %s.feed) \
+              (mode fallback) \
+              (deps (:gen downloader.ml)) \
+              (action (run %%{ocaml} %%{gen} --uri %s --output %%{targets})))"
+    entry.name (Uri.to_string entry.uri)
+
+let pp_test ppf entries =
+  Fmt.pf ppf "(alias (name runtest) \
+              (package syndic) \
+              (deps (:test test.exe) (:feeds %a) feeds.json) \
+              (action (run %%{test} --color=always)))@\n"
+    Fmt.(list ~sep:(const string " ") (using (fun { name; _ } -> name ^ ".feed") string)) entries
+
+let man () = Fmt.epr "%s --json <json> --output <dune.inc>\n%!" Sys.argv.(0)
+
+let success = 0
+let failure = 1
+
+let compare_entry a b = String.compare a.name b.name
+
+let () =
+  let json, output =
+    try match Sys.argv with
+      | [| _; "--json"; json; "--output"; output |] ->
+        if Sys.file_exists json
+        then Fpath.v json, Fpath.v output
+        else ( Fmt.epr "%s does not exist.\n%!" json; exit failure )
+      | _ -> man () ; exit failure
+    with _ -> man () ; exit failure in
+  let ic = open_in (Fpath.to_string json) in
+  let data = List.sort compare_entry (json_of_input ic) in
+  let oc = open_out (Fpath.to_string output) in
+  let ppf = Format.formatter_of_out_channel oc in
+  Fmt.pf ppf "%a@\n@\n%!" Fmt.(list ~sep:(always "@\n") pp_entry) data ;
+  Fmt.pf ppf "%a@\n" pp_test data ;
+  close_out oc ;
+  exit success