How do I make a simple GET request in OCaml? - http

I'm trying to do something that should be simple: make a GET request to a url. However, when I search for examples of how to do this I often wind up with near-gibberish like this.
Does anyone know how to make a simple HTTP request using OCaml? I'm an OCaml newbie with some Haskell exp.
NOTE:
A solution using the lowest possible level OCaml would be ideal. I've seen the Cohttp library used, but I'm more interested in a native (?) HTTP OCaml lib or something along those lines.
In response to #antron, a solution using the lowest possible level native OCaml would be much appreciated. I'm led to believe that this will involve the Unix library. But if there is another solution that does not involve 3rd party libraries it would be just as welcome.


Use the Cohttp library. See the Client example.
The relevant line is:
Cohttp_lwt_unix.Client.get (Uri.of_string "http://www.reddit.com/")
This gives you a pair of (response, body) inside the Lwt monad. response is basically a record, and body is a stream. The rest of the example is just printing some interesting bits of those.


Perhaps the most basic way to send a GET request in OCaml is to use the Unix library and the basic input/output routines from Pervasives.
Here is a very simple example:
let ip = Unix.((gethostbyname "caml.inria.fr").h_addr_list.(0))
let addr = Unix.ADDR_INET (ip, 80)
let sock = Unix.(socket PF_INET SOCK_STREAM 0)
let _ = Unix.connect sock addr
let in_ch = Unix.in_channel_of_descr sock
let out_ch = Unix.out_channel_of_descr sock
let _ =
output_string out_ch
"GET /pub/docs/manual-ocaml/index.html HTTP/1.1\r\n\
Host: caml.inria.fr\r\n\
User-Agent: OCaml\r\n\
Connection: close\r\n\
\r\n";
flush out_ch
let _ =
try
while true do
print_string (input_line in_ch)
done
with End_of_file ->
Unix.close sock
The Unix. prefixes are not necessary if one puts open Unix at the top of the file, but I preferred to leave them in for clarity.
The program can be compiled to byte code with ocamlc unix.cma -o get get.ml.
I agree with #ChriS' suggestion to read Leroy and Rémy's Unix system programming in OCaml (I've included a link to the online version); it's a great book.


For low level Unix programming in OCaml (even if you don't know much about it), I recommend the excellent book Unix System Programming in OCaml. It will tell you how to write the client you want.


For those searching a quite independent solution, I found one which should at least work on any Unix* like OS.
From Rosetta Code:
let try_finalise f x finally y =
let res = try f x with e -> finally y; raise e in
finally y;
res
let rec restart_on_EINTR f x =
try f x with Unix.Unix_error (Unix.EINTR, _, _) -> restart_on_EINTR f x
let double_fork_treatment server service (client_descr, _ as client) =
let treat () =
match Unix.fork () with
| 0 ->
if Unix.fork () <> 0 then exit 0;
Unix.close server; service client; exit 0
| k ->
ignore (restart_on_EINTR (Unix.waitpid []) k)
in
try_finalise treat () Unix.close client_descr
let install_tcp_server_socket addr =
let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
try
Unix.bind s addr;
Unix.listen s 10;
s
with e -> Unix.close s; raise e
let tcp_server treat_connection addr =
ignore (Sys.signal Sys.sigpipe Sys.Signal_ignore);
let server_sock = install_tcp_server_socket addr in
while true do
let client = restart_on_EINTR Unix.accept server_sock in
treat_connection server_sock client
done
let server () =
let port = 8080 in
let host = (Unix.gethostbyname (Unix.gethostname())).Unix.h_addr_list.(0) in
let addr = Unix.ADDR_INET (host, port) in
let treat sock (client_sock, client_addr as client) =
let service (s, _) =
let response = "\
HTTP/1.1 200 OK\r\n\
Content-Type: text/html; charset=UTF-8\r\n\r\n\
<html><head><title>Goodbye, world!</title>\
<style>body { background-color: #0FF }\
h1 { font-size:3em; color: black; }</style></head>\
<body><h1>Goodbye, world!</h1></body></html>\r\n"
in
Unix.write s response 0 (String.length response);
in
double_fork_treatment sock service client
in
tcp_server treat addr
let _ =
Unix.handle_unix_error server ()
It's not a one liner but it's relative straight forward.

Related

How to make a request to an IPv6 address using the http-client package in haskell?

I've been trying to make a request to an IPv6 address using the parseRequest function from Network.HTTP.Client (https://hackage.haskell.org/package/http-client-0.7.10/docs/Network-HTTP-Client.html) package as follows:
request <- parseRequest "http://[2001:0db8:85a3:0000:0000:8a2e:0370:7334]"
Instead of parsing it as an address/addrInfo, it is parsed as a hostname and throws the error: does not exist (Name or service not known). As a next step, I tried pointing a domain to the same IPv6 address and then using the domain name in parseRequest, then it successfully resolves that into the IPv6 address and makes the request. Is there some other way I can directly use the IPv6 address to make the request using the http-client package?
PS: I also tried without square brackets around the IP address, in this case the error is Invalid URL:
request <- parseRequest "http://2001:0db8:85a3:0000:0000:8a2e:0370:7334"
More context:
For an IPv4 address, the getAddrInfo function generates the address as:
AddrInfo {addrFlags = [AI_NUMERICHOST], addrFamily = AF_INET, addrSocketType = Stream, addrProtocol = 6, addrAddress = 139.59.90.1:80, addrCanonName = Nothing}
whereas for IPv6 address(inside the square brackets format):
AddrInfo {addrFlags = [AI_ADDRCONFIG], addrFamily = AF_UNSPEC, addrSocketType = Stream, addrProtocol = 6, addrAddress = 0.0.0.0:0, addrCanonName = Nothing}
and the error prints as:
(ConnectionFailure Network.Socket.getAddrInfo (called with preferred socket type/protocol: AddrInfo {addrFlags = [AI_ADDRCONFIG], addrFamily = AF_UNSPEC, addrSocketType = Stream, addrProtocol = 6, addrAddress = 0.0.0.0:0, addrCanonName = Nothing}, host name: Just "[2001:0db8:85a3:0000:0000:8a2e:0370:7334]", service name: Just "80"): does not exist (Name or service not known))

When a literal IPv6 address is used in a URL, it should be surrounded by square brackets (as per RFC 2732) so the colons in the literal address aren't misinterpreted as some kind of port designation.
When a literal IPv6 address is resolved using the C library function getaddrinfo (or the equivalent Haskell function getAddrInfo), these functions are not required to handle these extra square brackets, and at least on Linux they don't.
Therefore, it's the responsibility of the HTTP client library to remove the square brackets from the hostname extracted from the URL before resolving the literal IPv6 address using getaddrinfo, and the http-client package doesn't do this, at least as of version 0.7.10. So, this is a bug, and I can see you've appropriately filed a bug report.
Unfortunately, I don't see an easy way to work around the issue. You can manipulate the Request after parsing to remove the square brackets from the host field, like so:
{-# LANGUAGE OverloadedStrings #-}
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Network.HTTP.Client
import Network.HTTP.Types.Status (statusCode)
main :: IO ()
main = do
manager <- newManager defaultManagerSettings
request <- parseRequest "http://[::1]"
let request' = request { host = removeBrackets (host request) }
response <- httpLbs request' manager
print response
removeBrackets :: ByteString -> ByteString
removeBrackets bs =
case BS.stripPrefix "[" bs >>= BS.stripSuffix "]" of
Just bs' -> bs'
Nothing -> bs
The problem with this is that it also removes the square brackets from the value in the Host header, so the HTTP request will contain the header:
Host: ::1
instead of the correct
Host: [::1]
which may or may not cause problems, depending on the web server at the other end.
You could try using a patched http-client package. The following patch against version 0.7.10 seems to work, but I didn't test it very extensively:
diff --git a/Network/HTTP/Client/Connection.hs b/Network/HTTP/Client/Connection.hs
index 0e329cd..719822e 100644
--- a/Network/HTTP/Client/Connection.hs
+++ b/Network/HTTP/Client/Connection.hs
## -15,6 +15,7 ## module Network.HTTP.Client.Connection
import Data.ByteString (ByteString, empty)
import Data.IORef
+import Data.List (stripPrefix, isSuffixOf)
import Control.Monad
import Network.HTTP.Client.Types
import Network.Socket (Socket, HostAddress)
## -158,8 +159,12 ## withSocket :: (Socket -> IO ())
withSocket tweakSocket hostAddress' host' port' f = do
let hints = NS.defaultHints { NS.addrSocketType = NS.Stream }
addrs <- case hostAddress' of
- Nothing ->
- NS.getAddrInfo (Just hints) (Just host') (Just $ show port')
+ Nothing -> do
+ let port'' = Just $ show port'
+ case ip6Literal host' of
+ Just lit -> NS.getAddrInfo (Just hints { NS.addrFlags = [NS.AI_NUMERICHOST] })
+ (Just lit) port''
+ Nothing -> NS.getAddrInfo (Just hints) (Just host') port''
Just ha ->
return
[NS.AddrInfo
## -173,6 +178,11 ## withSocket tweakSocket hostAddress' host' port' f = do
E.bracketOnError (firstSuccessful addrs $ openSocket tweakSocket) NS.close f
+ where
+ ip6Literal h = case stripPrefix "[" h of
+ Just rest | "]" `isSuffixOf` rest -> Just (init rest)
+ _ -> Nothing
+
openSocket tweakSocket addr =
E.bracketOnError
(NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)

Understanding module parameters in OCaml

I'm trying to understand what's the point of this connect function:
let connect netif ethif arpv4 ipv4 icmpv4 udpv4 tcpv4 =
let udpv4_listeners = Hashtbl.create 7 in
let tcpv4_listeners = Hashtbl.create 7 in
let t = { netif; ethif; arpv4; ipv4; icmpv4; tcpv4; udpv4;
udpv4_listeners; tcpv4_listeners } in
Log.info (fun f -> f "stack assembled: %a" pp t);
Lwt.async (fun () -> listen t);
Lwt.return t
My first assumption is: are the netif ethif arpv4 ipv4 icmpv4 udpv4 tcpv4 parameters being taken to be by default the 'variables' of same name enclosed in the scope of the connect function definition?
Please see the entire context here: https://github.com/mirage/mirage-tcpip/blob/master/src/stack-direct/tcpip_stack_direct.ml#L122
If this is not the case, then does it mean that I need to always pass all these 7 parameters when I call connect? What's the point of passing them if they're already created here?

Send SIGINT to a process by sending ctrl-c to stdin

I'm looking for a way to mimick a terminal for some automated testing: i.e. start a process and then interact with it via sending data to stdin and reading from stdout. E.g. sending some lines of input to stdin including ctrl-c and ctrl-\ which should result in sending signals to the process.
Using std::process::Commannd I'm able to send input to e.g. cat and I'm also seeing its output on stdout, but sending ctrl-c (as I understand that is 3) does not cause SIGINT sent to the shell. E.g. this program should terminate:
use std::process::{Command, Stdio};
use std::io::Write;
fn main() {
let mut child = Command::new("sh")
.arg("-c").arg("-i").arg("cat")
.stdin(Stdio::piped())
.spawn().unwrap();
let mut stdin = child.stdin.take().unwrap();
stdin.write(&[3]).expect("cannot send ctrl-c");
child.wait();
}
I suspect the issue is that sending ctrl-c needs the some tty and via sh -i it's only in "interactive mode".
Do I need to go full fledged and use e.g. termion or ncurses?
Update: I confused shell and terminal in the original question. I cleared this up now. Also I mentioned ssh which should have been sh.

The simplest way is to directly send the SIGINT signal to the child process. This can be done easily using nix's signal::kill function:
// add `nix = "0.15.0"` to your Cargo.toml
use std::process::{Command, Stdio};
use std::io::Write;
fn main() {
// spawn child process
let mut child = Command::new("cat")
.stdin(Stdio::piped())
.spawn().unwrap();
// send "echo\n" to child's stdin
let mut stdin = child.stdin.take().unwrap();
writeln!(stdin, "echo");
// sleep a bit so that child can process the input
std::thread::sleep(std::time::Duration::from_millis(500));
// send SIGINT to the child
nix::sys::signal::kill(
nix::unistd::Pid::from_raw(child.id() as i32),
nix::sys::signal::Signal::SIGINT
).expect("cannot send ctrl-c");
// wait for child to terminate
child.wait().unwrap();
}
You should be able to send all kinds of signals using this method. For more advanced "interactivity" (e.g. child programs like vi that query terminal size) you'd need to create a pseudoterminal like #hansaplast did in his solution.

After a lot of research I figured out it's not too much work to do the pty fork myself. There's pty-rs, but it has bugs and seems unmaintained.
The following code needs pty module of nix which is not yet on crates.io, so Cargo.toml needs this for now:
[dependencies]
nix = {git = "https://github.com/nix-rust/nix.git"}
The following code runs cat in a tty and then writes/reads from it and sends Ctrl-C (3):
extern crate nix;
use std::path::Path;
use nix::pty::{posix_openpt, grantpt, unlockpt, ptsname};
use nix::fcntl::{O_RDWR, open};
use nix::sys::stat;
use nix::unistd::{fork, ForkResult, setsid, dup2};
use nix::libc::{STDIN_FILENO, STDOUT_FILENO, STDERR_FILENO};
use std::os::unix::io::{AsRawFd, FromRawFd};
use std::io::prelude::*;
use std::io::{BufReader, LineWriter};
fn run() -> std::io::Result<()> {
// Open a new PTY master
let master_fd = posix_openpt(O_RDWR)?;
// Allow a slave to be generated for it
grantpt(&master_fd)?;
unlockpt(&master_fd)?;
// Get the name of the slave
let slave_name = ptsname(&master_fd)?;
match fork() {
Ok(ForkResult::Child) => {
setsid()?; // create new session with child as session leader
let slave_fd = open(Path::new(&slave_name), O_RDWR, stat::Mode::empty())?;
// assign stdin, stdout, stderr to the tty, just like a terminal does
dup2(slave_fd, STDIN_FILENO)?;
dup2(slave_fd, STDOUT_FILENO)?;
dup2(slave_fd, STDERR_FILENO)?;
std::process::Command::new("cat").status()?;
}
Ok(ForkResult::Parent { child: _ }) => {
let f = unsafe { std::fs::File::from_raw_fd(master_fd.as_raw_fd()) };
let mut reader = BufReader::new(&f);
let mut writer = LineWriter::new(&f);
writer.write_all(b"hello world\n")?;
let mut s = String::new();
reader.read_line(&mut s)?; // what we just wrote in
reader.read_line(&mut s)?; // what cat wrote out
writer.write(&[3])?; // send ^C
writer.flush()?;
let mut buf = [0; 2]; // needs bytewise read as ^C has no newline
reader.read(&mut buf)?;
s += &String::from_utf8_lossy(&buf).to_string();
println!("{}", s);
println!("cat exit code: {:?}", wait::wait()?); // make sure cat really exited
}
Err(_) => println!("error"),
}
Ok(())
}
fn main() {
run().expect("could not execute command");
}
Output:
hello world
hello world
^C
cat exit code: Signaled(2906, SIGINT, false)

Try adding -t option TWICE to force pseudo-tty allocation. I.e.
klar (16:14) ~>echo foo | ssh user#host.ssh.com tty
not a tty
klar (16:14) ~>echo foo | ssh -t -t user#host.ssh.com tty
/dev/pts/0
When you have a pseudo-tty, I think it should convert that to SIGINT as you wanted to do.
In your simple example, you could also just close stdin after the write, in which case the server should exit. For this particular case it would be more elegant and probably more reliable.

Solution without using a crate
Now that you are spawning a command in Rust, you might as well spawn another to send SIGINT to it. That command is kill.
So, you can do this:
use std::process::{Command, Stdio};
use std::io::{Result, Write};
fn main() -> Result<()> {
let mut child = Command::new("sh")
.arg("-c").arg("-i").arg("cat")
.stdin(Stdio::piped())
.spawn()?;
let mut stdin = child.stdin.take().unwrap();
let mut kill = Command::new("kill")
.arg(child.id().to_string())
.spawn()?;
kill.wait()
}

Ejabberd: error in simple module to handle offline messages

I have an Ejabberd 17.01 installation where I need to push a notification in case a recipient is offline. This seems the be a common task and solutions using a customized Ejabberd module can be found everywhere. However, I just don't get it running. First, here's me script:
-module(mod_offline_push).
-behaviour(gen_mod).
-export([start/2, stop/1]).
-export([push_message/3]).
-include("ejabberd.hrl").
-include("logger.hrl").
-include("jlib.hrl").
start(Host, _Opts) ->
?INFO_MSG("mod_offline_push loading", []),
ejabberd_hooks:add(offline_message_hook, Host, ?MODULE, push_message, 10),
ok.
stop(Host) ->
?INFO_MSG("mod_offline_push stopping", []),
ejabberd_hooks:add(offline_message_hook, Host, ?MODULE, push_message, 10),
ok.
push_message(From, To, Packet) ->
?INFO_MSG("mod_offline_push -> push_message", [To]),
Type = fxml:get_tag_attr_s(<<"type">>, Packet), % Supposedly since 16.04
%Type = xml:get_tag_attr_s(<<"type">>, Packet), % Supposedly since 13.XX
%Type = xml:get_tag_attr_s("type", Packet),
%Type = xml:get_tag_attr_s(list_to_binary("type"), Packet),
?INFO_MSG("mod_offline_push -> push_message", []),
ok.
The problem is the line Type = ... line in method push_message; without that line the last info message is logged (so the hook definitely works). When browsing online, I can find all kinds of function calls to extract elements from Packet. As far as I understand it changed over time with new releases. But it's not good, all variants lead in some kind of error. The current way returns:
2017-01-25 20:38:08.701 [error] <0.21678.0>#ejabberd_hooks:run1:332 {function_clause,[{fxml,get_tag_attr_s,[<<"type">>,{message,<<>>,normal,<<>>,{jid,<<"homer">>,<<"xxx.xxx.xxx.xxx">>,<<"conference">>,<<"homer">>,<<"xxx.xxx.xxx.xxx">>,<<"conference">>},{jid,<<"carl">>,<<"xxx.xxx.xxx.xxx">>,<<>>,<<"carl">>,<<"xxx.xxx.xxx.xxx">>,<<>>},[],[{text,<<>>,<<"sfsdfsdf">>}],undefined,[],#{}}],[{file,"src/fxml.erl"},{line,169}]},{mod_offline_push,push_message,3,[{file,"mod_offline_push.erl"},{line,33}]},{ejabberd_hooks,safe_apply,3,[{file,"src/ejabberd_hooks.erl"},{line,382}]},{ejabberd_hooks,run1,3,[{file,"src/ejabberd_hooks.erl"},{line,329}]},{ejabberd_sm,route,3,[{file,"src/ejabberd_sm.erl"},{line,126}]},{ejabberd_local,route,3,[{file,"src/ejabberd_local.erl"},{line,110}]},{ejabberd_router,route,3,[{file,"src/ejabberd_router.erl"},{line,87}]},{ejabberd_c2s,check_privacy_route,5,[{file,"src/ejabberd_c2s.erl"},{line,1886}]}]}
running hook: {offline_message_hook,[{jid,<<"homer">>,<<"xxx.xxx.xxx.xxx">>,<<"conference">>,<<"homer">>,<<"xxx.xxx.xxx.xxx">>,<<"conference">>},{jid,<<"carl">>,<<"xxx.xxx.xxx.xxx">>,<<>>,<<"carl">>,<<"xxx.xxx.xxx.xxx">>,<<>>},{message,<<>>,normal,<<>>,{jid,<<"homer">>,<<"xxx.xxx.xxx.xxx">>,<<"conference">>,<<"homer">>,<<"xxx.xxx.xxx.xxx">>,<<"conference">>},{jid,<<"carl">>,<<"xxx.xxx.xxx.xxx">>,<<>>,<<"carl">>,<<"xxx.xxx.xxx.xxx">>,<<>>},[],[{text,<<>>,<<"sfsdfsdf">>}],undefined,[],#{}}]}
I'm new Ejabberd and Erlang, so I cannot really interpret the error, but the Line 33 as mentioned in {mod_offline_push,push_message,3,[{file,"mod_offline_push.erl"}, {line,33}]} is definitely the line calling get_tag_attr_s.
UPDATE 2017/01/27: Since this cost me a lot of headache -- and I'm still not perfectly happy -- I post here my current working module in the hopes it might help others. My setup is Ejabberd 17.01 running on Ubuntu 16.04. Most stuff I tried and failed with seem to for older versions of Ejabberd:
-module(mod_fcm_fork).
-behaviour(gen_mod).
%% public methods for this module
-export([start/2, stop/1]).
-export([push_notification/3]).
%% included for writing to ejabberd log file
-include("ejabberd.hrl").
-include("logger.hrl").
-include("xmpp_codec.hrl").
%% Copied this record definition from jlib.hrl
%% Including "xmpp_codec.hrl" and "jlib.hrl" resulted in errors ("XYZ already defined")
-record(jid, {user = <<"">> :: binary(),
server = <<"">> :: binary(),
resource = <<"">> :: binary(),
luser = <<"">> :: binary(),
lserver = <<"">> :: binary(),
lresource = <<"">> :: binary()}).
start(Host, _Opts) ->
?INFO_MSG("mod_fcm_fork loading", []),
% Providing the most basic API to the clients and servers that are part of the Inets application
inets:start(),
% Add hook to handle message to user who are offline
ejabberd_hooks:add(offline_message_hook, Host, ?MODULE, push_notification, 10),
ok.
stop(Host) ->
?INFO_MSG("mod_fcm_fork stopping", []),
ejabberd_hooks:add(offline_message_hook, Host, ?MODULE, push_notification, 10),
ok.
push_notification(From, To, Packet) ->
% Generate JID of sender and receiver
FromJid = lists:concat([binary_to_list(From#jid.user), "#", binary_to_list(From#jid.server), "/", binary_to_list(From#jid.resource)]),
ToJid = lists:concat([binary_to_list(To#jid.user), "#", binary_to_list(To#jid.server), "/", binary_to_list(To#jid.resource)]),
% Get message body
MessageBody = Packet#message.body,
% Check of MessageBody is not empty
case MessageBody/=[] of
true ->
% Get first element (no idea when this list can have more elements)
[First | _ ] = MessageBody,
% Get message data and convert to string
MessageBodyText = binary_to_list(First#text.data),
send_post_request(FromJid, ToJid, MessageBodyText);
false ->
?INFO_MSG("mod_fcm_fork -> push_notification: MessageBody is empty",[])
end,
ok.
send_post_request(FromJid, ToJid, MessageBodyText) ->
%?INFO_MSG("mod_fcm_fork -> send_post_request -> MessageBodyText = ~p", [Demo]),
Method = post,
PostURL = gen_mod:get_module_opt(global, ?MODULE, post_url,fun(X) -> X end, all),
% Add data as query string. Not nice, query body would be preferable
% Problem: message body itself can be in a JSON string, and I couldn't figure out the correct encoding.
URL = lists:concat([binary_to_list(PostURL), "?", "fromjid=", FromJid,"&tojid=", ToJid,"&body=", edoc_lib:escape_uri(MessageBodyText)]),
Header = [],
ContentType = "application/json",
Body = [],
?INFO_MSG("mod_fcm_fork -> send_post_request -> URL = ~p", [URL]),
% ADD SSL CONFIG BELOW!
%HTTPOptions = [{ssl,[{versions, ['tlsv1.2']}]}],
HTTPOptions = [],
Options = [],
httpc:request(Method, {URL, Header, ContentType, Body}, HTTPOptions, Options),
ok.

Actually it fails with second arg Packet you pass to fxml:get_tag_attr_s in push_message function
{message,<<>>,normal,<<>>,
{jid,<<"homer">>,<<"xxx.xxx.xxx.xxx">>,<<"conference">>,
<<"homer">>,<<"xxx.xxx.xxx.xxx">>,<<"conference">>},
{jid,<<"carl">>,<<"xxx.xxx.xxx.xxx">>,<<>>,<<"carl">>,
<<"xxx.xxx.xxx.xxx">>,<<>>},
[],
[{text,<<>>,<<"sfsdfsdf">>}],
undefined,[],#{}}
because it is not xmlel
Looks like it is record "message" defined in tools/xmpp_codec.hrl
with <<>> id and type 'normal'
xmpp_codec.hrl
-record(message, {id :: binary(),
type = normal :: 'chat' | 'error' | 'groupchat' | 'headline' | 'normal',
lang :: binary(),
from :: any(),
to :: any(),
subject = [] :: [#text{}],
body = [] :: [#text{}],
thread :: binary(),
error :: #error{},
sub_els = [] :: [any()]}).
Include this file and use just
Type = Packet#message.type
or, if you expect binary value
Type = erlang:atom_to_binary(Packet#message.type, utf8)

The newest way to do that seems to be with xmpp:get_type/1:
Type = xmpp:get_type(Packet),
It returns an atom, in this case normal.

Basic `listenOn` HTTP server "Recv failure: Connection reset by peer"

While diving into Haskell's Network library, I'm making a very simple HTTP server based on info from this link.
import Control.Concurrent
import Control.Monad
import Network
import System.IO
main = withSocketsDo $ listenOn (PortNumber 8080) >>= loop
loop :: Socket -> IO ()
loop sock = do
(h,_,_) <- accept sock
forkIO $ handleRequest h
loop sock
handleRequest :: Handle -> IO ()
handleRequest h = do
hPutStr h $ httpRequest "Pong!\n"
hFlush h
hClose h
httpRequest :: String -> String
httpRequest body = "HTTP/1.0 200 OK\r\n"
++ "Content-Length: " ++ (show.length) body ++ "\r\n"
++ "\r\n" ++ body ++ "\r\n"
However, even though I manage to get some response, the handles seems to be closed unexpectedly soon (sometimes?) as curl tells me:
$ curl localhost:8080
Pong!
curl: (56) Recv failure: Connection reset by peer
NB: Sometimes I don't even get the message (Pong!) or just a part of it. Sometimes, it works... but if I run 100 curls in a row I eventually get some connection resets.
Why is the connection reset? I tried with and without forkIO without success. Have I missed some essential about IO streams in Haskell? Thanks!
OS: recent Ubuntu ; GHC: 7.8.4
--- Edit: ---
jozefg identified that the problem came from draining the request's contents! However I'd like to send this content back to the client and it hangs while using the following code:
handleRequest :: Handle -> IO ()
handleRequest h = do
contents <- getHandleContents h
hPutStr h $ httpRequest contents
hFlush h
hClose h
getHandleContents :: Handle -> IO String
getHandleContents h = do
iseof <- hIsEOF h
if iseof
then return []
else do
newLine <- hGetLine h
nextLines <- getHandleContents h
return $ newLine ++ '\n' : nextLines
Moreover I had no success draining the whole contents using hGetContents. Any idea why?

The error seems to be that you are not fully reading the data the client sends upon making a get-request as described in this answer for Rust. The solution proposed there is basically to write a small loop which drains the header from the handle before you respond. The Haskell version is
drainHeaders :: Handle -> IO ()
drainHeaders h = do
line <- hGetLine h
if line == "\r" then return () else drainHeaders h
so then your code may be written
import Control.Concurrent
import Control.Exception (bracket)
import Control.Monad
import Network
import System.IO
main = withSocketsDo $
bracket (listenOn (PortNumber 8080)) sClose loop
loop :: Socket -> IO ()
loop sock = do
(handle, _host, _port) <- accept sock
-- Handle is automatically closed now even in the face of async exns
forkFinally (handleRequest handle) (const $ hClose handle)
loop sock
drainHeaders :: Handle -> IO ()
drainHeaders h = do
line <- hGetLine h -- Strips off a trailing \n
if line == "\r" then return () else drainHeaders h
handleRequest :: Handle -> IO ()
handleRequest h = do
drainHeaders h
hPutStr h $ httpRequest "Pong!\n"
hFlush h
httpRequest :: String -> String
httpRequest body =
mconcat [ "HTTP/1.0 200 OK\r\nContent-Length: "
, (show . length) body
, "\r\n\r\n"
, body
, "\r\n" ]
I also took the liberty of tweaking the code to make it a bit more exception safe by using forkFinally and bracket to handle closing things in the face of exceptions: I doubt it's 100% perfect but it's now a little bit cleaner.

Resources