diff options
Diffstat (limited to 'portal/tcp/portal.ml')
| -rw-r--r-- | portal/tcp/portal.ml | 29 |
1 files changed, 14 insertions, 15 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 |