diff options
Diffstat (limited to 'portal')
| -rw-r--r-- | portal/tcp/portal.ml | 29 | ||||
| -rw-r--r-- | portal/ws/portal.ml | 26 |
2 files changed, 26 insertions, 29 deletions
diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml index e44732d..290975c 100644 --- a/portal/tcp/portal.ml +++ b/portal/tcp/portal.ml @@ -29,22 +29,21 @@ let header ?from domain ((stream, push) : t) = If you have Github, feel free to get the word out to aantron. *) `Comment ""] - and error = Lwt.fail_with "TODO" in push (Some (of_list stanza)); - let* xml = Markup_lwt.next stream - in match xml with - | Some `Xml {version="1.0"; encoding=None; standalone=None} -> - let* stream_open = Markup_lwt.next stream in - begin - match stream_open with - | Some `Start_element ((ns, "stream"), attributes) when ns = xmlns-> - List.find_map - (fun ((_, name), value) -> if name = "id" then Some value else None) - attributes - |> Option.fold ~none:error ~some:Lwt.return - | _ -> error - end - | _ -> error + let some_id ((_, name), value) = if name = "id" then Some value else None in + let* xml = Markup_lwt.next stream in + let* id = match xml with + | Some `Xml {version="1.0"; encoding=None; standalone=None} -> + let* stream_open = Markup_lwt.next stream in + begin match stream_open with + | Some `Start_element ((ns, "stream"), attributes) when ns = xmlns-> + List.find_map some_id attributes |> Lwt.return + | _ -> Lwt.return_none + end + | _ -> Lwt.return_none + in match id with + | Some id -> Lwt.return id + | None -> Lwt.fail_with "Invalid stream opening server-side." let close (_, push) = [`End_element] |> Markup.of_list |> Option.some |> push diff --git a/portal/ws/portal.ml b/portal/ws/portal.ml index fd67ad2..5cfc88a 100644 --- a/portal/ws/portal.ml +++ b/portal/ws/portal.ml @@ -29,22 +29,20 @@ let header ?from domain (stream, push) = ((xmlns, "open"), attributes); `End_element] - and error = Lwt.fail_with "TODO" in push (Some (of_list stanza)); + let some_id ((_, name), value) = if name = "id" then Some value else None in let* stanza_open = Markup_lwt.next stream in - let some id = - let* close = Markup_lwt.next stream in - match close with - | Some `End_element -> Lwt.return id - | _ -> error - in - match stanza_open with - | Some `Start_element ((ns, "open"), attributes) when ns = xmlns -> - List.find_map - (fun ((_, name), value) -> if name = "id" then Some value else None) - attributes - |> Option.fold ~none:error ~some - | _ -> error + let* id = match stanza_open with + | Some `Start_element ((ns, "open"), attributes) when ns = xmlns -> + let* close = Markup_lwt.next stream in + begin match close with + | Some `End_element -> List.find_map some_id attributes |> Lwt.return + | _ -> Lwt.return_none + end + | _ -> Lwt.return_none + in match id with + | Some id -> Lwt.return id + | None -> Lwt.fail_with "Invalid stream opening server-side." let close (_, p) = {|<close xmlns="|} ^ xmlns ^ {|" />|} |> string |> parse_xml |> signals |> Option.some |> p |