commit fc2128f9691fcab2651161abdd2eba0095a533f4 Author: Craig Everett Date: Thu Mar 27 20:06:34 2025 +0900 Init diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..31cc2ca --- /dev/null +++ b/.gitignore @@ -0,0 +1,16 @@ +.eunit +deps +cancer +*.o +*.beam +*.plt +*.swp +erl_crash.dump +ebin/*.beam +doc/*.html +doc/*.css +doc/edoc-info +doc/erlang.png +rel/example_project +.concrete/DEV_MODE +.rebar diff --git a/Emakefile b/Emakefile new file mode 100644 index 0000000..68c7b67 --- /dev/null +++ b/Emakefile @@ -0,0 +1 @@ +{"src/*", [debug_info, {i, "include/"}, {outdir, "ebin/"}]}. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5aeab8b --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright 2025 Craig Everett + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/ebin/qhl.app b/ebin/qhl.app new file mode 100644 index 0000000..e082c1d --- /dev/null +++ b/ebin/qhl.app @@ -0,0 +1,7 @@ +{application,qhl, + [{description,"The Quick HTTP Library"}, + {registered,[]}, + {included_applications,[]}, + {applications,[stdlib,kernel]}, + {vsn,"0.1.0"}, + {modules,[qhl]}]}. diff --git a/src/qhl.erl b/src/qhl.erl new file mode 100644 index 0000000..4a9acef --- /dev/null +++ b/src/qhl.erl @@ -0,0 +1,1094 @@ +%%% @doc +%%% The Quick HTTP Library +%%% This is not an HTTP server, but rather a library from which a fast HTTP server +%%% can be built. Building out a server with QHL requires minimum effort but maximum +%%% knowledge. Calling code needs to maintain the socket, own the process loop, etc. +%%% +%%% QHL does not help you form the return response body -- that is entirely up to you. +%%% @end + +-module(qhl). +-vsn("0.1.0"). +-author("Craig Everett "). +-copyright("Craig Everett "). +-license("GPL-3.0-or-later"). + +-export([parse/2, parse/3, + recv/2, resp/2, + percent_encode/1, percent_decode/1, join/1, + ridiculous_web_date/0, ridiculous_web_date/1, + slogan/1, + break_nl/1, unbreak_nl/1, clean/1, + bin_to_int/1]). + +-include("http.hrl"). +-include("$zx_include/zx_logger.hrl"). + + +-spec parse(Socket, Received) -> Result + when Socket :: gen_tcp:socket(), + Received :: binary(), + Result :: {ok, #request{}} | {error, Reason}, + Reason :: term(). % FIXME +%% @doc +%% @equiv parse(Socket, Received, #request{}) + +parse(Socket, Received) -> + parse(Socket, Received, #request{}). + + +-spec parse(Socket, Received, Request) -> Result + when Socket :: gen_tcp:socket(), + Received :: binary(), + Request :: #request{}, + Result :: {ok, #request{}} | {error, Reason}, + Reason :: term(). % FIXME +%5 @doc +%% Pass this function the connection socket and whatever the receive loop has acquired, +%% and receive back a parsed #request{} record. This requires that you have imported +%% the `http.hrl' and set `{mode, binary}' and `{active, once}' options on the +%% socket. + +parse(Socket, Received, M = #request{method = undefined}) -> + case read_method(Socket, Received) of + {ok, Method, Rest} -> parse(Socket, Rest, M#request{method = Method}); + Error -> Error + end; +parse(Socket, Received, M = #request{path = undefined}) -> + case read_path(Socket, Received) of + {ok, Path, Rest} -> parse(Socket, Rest, M#request{path = Path}); + Error -> Error + end; +parse(Socket, Received, M = #request{qargs = undefined}) -> + case read_qargs(Socket, Received) of + {ok, Qargs, Rest} -> parse(Socket, Rest, M#request{qargs = Qargs}); + Error -> Error + end; +parse(Socket, Received, M = #request{fragment = undefined}) -> + case read_fragment(Socket, Received) of + {ok, Fragment, Rest} -> parse(Socket, Rest, M#request{fragment = Fragment}); + Error -> Error + end; +parse(Socket, Received, M = #request{version = undefined}) -> + case read_version(Socket, Received) of + {ok, Version, Rest} -> parse(Socket, Rest, M#request{version = Version}); + Error -> Error + end; +parse(Socket, Received, M = #request{headers = undefined}) -> + case read_headers(Socket, Received) of + {ok, Headers, Rest} -> parse(Socket, Rest, M#request{headers = Headers}); + Error -> Error + end; +parse(Socket, Received, M = #request{enctype = undefined}) -> + case read_enctype(M) of + {ok, Enctype} -> parse(Socket, Received, M#request{enctype = Enctype}); + Error -> Error + end; +parse(Socket, Received, M = #request{cookies = undefined}) -> + case read_cookies(M) of + {ok, Cookies} -> parse(Socket, Received, M#request{cookies = Cookies}); + Error -> Error + end; +parse(Socket, Received, M = #request{size = undefined}) -> + case read_size(M) of + {ok, 0} -> {ok, M#request{size = 0}, none}; + {ok, Size} -> parse(Socket, Received, M#request{size = Size}); + Error -> Error + end; +parse(Socket, Received, M = #request{method = get, body = undefined, size = Size}) -> + case read_body(Received, Size) of + {ok, Body} -> {ok, M#request{body = Body}, none}; + {ok, Body, Next} -> {ok, M#request{body = Body}, Next}; + {incomplete, Body} -> accumulate(Socket, M#request{body = Body}); + Error -> Error + end; +parse(Socket, + Received, + M = #request{body = undefined, + method = post, + enctype = urlencoded, + size = Size}) -> + case read_body(Received, Size) of + {ok, Body} -> + {ok, M#request{body = parts_to_map(posted(Body))}, none}; + {ok, Body, Next} -> + {ok, M#request{body = parts_to_map(posted(Body))}, Next}; + {incomplete, Body} -> + case accumulate(Socket, M#request{body = Body}) of + {ok, NewM = #request{body = NewBody}} -> + {ok, NewM#request{body = parts_to_map(posted(NewBody))}, none}; + {ok, NewM = #request{body = NewBody}, More} -> + {ok, NewM#request{body = parts_to_map(posted(NewBody))}, More}; + Error -> + Error + end; + Error -> + Error + end; +parse(Socket, + Received, + M = #request{body = undefined, + method = post, + enctype = {multipart, Boundary}, + size = Size}) -> + case read_multipart(Socket, Received, Boundary, Size) of + {ok, Parts} -> {ok, M#request{body = parts_to_map(Parts)}, none}; + {ok, Parts, Next} -> {ok, M#request{body = parts_to_map(Parts)}, Next}; + Error -> Error + end; +parse(Socket, + Received, + M = #request{body = undefined, + method = post, + enctype = json, + size = Size}) -> + case read_body(Received, Size) of + {ok, Body} -> read_json(M#request{body = Body}, none); + {ok, Body, Next} -> read_json(M#request{body = Body}, Next); + {incomplete, Body} -> + case accumulate(Socket, M#request{body = Body}) of + {ok, NewM = #request{body = NewBody}} -> + read_json(NewM#request{body = NewBody}, none); + {ok, NewM = #request{body = NewBody}, More} -> + read_json(NewM#request{body = NewBody}, More); + Error -> + Error + end; + Error -> + Error + end. + + +read_json(R = #request{body = Text}, Next) -> + case zj:decode(Text) of + {ok, JSON} -> {ok, R#request{body = JSON}, Next}; + Error -> Error + end. + + +% FIXME: The map version of body elements is inferior to the proplist version. +% When checking input elements it is much nicer to have a general return +% over a fold that can contain errors and use this as a universal idiom +% and then build "unfuck your input please" type error pages for the user +% based on that than matching map keys and then writing exhaustive drop-through +% checks when all this could happen in a single pass more simply. +parts_to_map(Parts) -> + lists:foldl(fun parts_to_map/2, #{}, Parts). + +parts_to_map({Key, Value}, Map) -> + AddPart = fun(Values) -> [Value | Values] end, + maps:update_with(Key, AddPart, [Value], Map). + + +read_method(_, <<"GET ", Rest/binary>>) -> + {ok, get, Rest}; +read_method(_, <<"POST ", Rest/binary>>) -> + {ok, post, Rest}; +read_method(_, <<"OPTIONS ", Rest/binary>>) -> + {ok, options, Rest}; +read_method(Socket, Received) when byte_size(Received) < 7 -> + case inet:setopts(Socket, [{active, once}]) of + ok -> + receive + {tcp, Socket, Bin} -> + read_method(Socket, <>); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; + {error, Reason} -> + Message = "inet:setopts/2 failed in read_method/2 with ~tp", + ok = tell(info, Message, [Reason]), + {error, {inet, Reason}} + end; +read_method(_, _) -> + {error, method}. + + +read_path(Socket, Received) -> + read_path(Socket, Received, <<>>). + +read_path(_, <<" ", _/binary>>, <<>>) -> + {error, path}; +read_path(_, <<"\r", _/binary>>, _) -> + {error, path}; +read_path(_, <<"\n", _/binary>>, _) -> + {error, path}; +read_path(_, <<" ", Rest/binary>>, Path) -> + {ok, Path, Rest}; +read_path(_, Rest = <<"?", _/binary>>, Path) -> + {ok, Path, Rest}; +read_path(Socket, <<>>, Acc) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + read_path(Socket, Bin, Acc); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; +read_path(Socket, <>, Acc) -> + read_path(Socket, Rest, <>). + + +read_qargs(_, <<"? ", Other/binary>>) -> + {ok, #{}, Other}; +read_qargs(Socket, <<"?", QString/binary>>) -> + read_qargs(Socket, QString, #{}); +read_qargs(_, Other) -> + {ok, #{}, Other}. + +read_qargs(Socket, Bin, Qargs) -> + read_qkey(Socket, Bin, <<>>, Qargs). + +read_qkey(_, <<" ", _/binary>>, _, _) -> + {error, qargs}; +read_qkey(_, <<"\r", _/binary>>, _, _) -> + {error, qargs}; +read_qkey(_, <<"\n", _/binary>>, _, _) -> + {error, qargs}; +read_qkey(_, <<"=", _/binary>>, <<>>, _) -> + {error, qargs}; +read_qkey(Socket, <<"=", Rest/binary>>, Key, Qargs) -> + read_qval(Socket, Rest, <<>>, Key, Qargs); +read_qkey(Socket, <>, Acc, Qargs) -> + read_qkey(Socket, Rest, <>, Qargs); +read_qkey(Socket, <<>>, Acc, Qargs) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + read_qkey(Socket, Bin, Acc, Qargs); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end. + +read_qval(_, <<" ", _/binary>>, <<>>, _, _) -> + {error, qargs}; +read_qval(_, <<" ", Rest/binary>>, Val, Key, Qargs) -> + {ok, maps:put(Key, Val, Qargs), Rest}; +read_qval(_, <<"&", _/binary>>, <<>>, _, _) -> + {error, qargs}; +read_qval(Socket, <<"&", Rest/binary>>, Val, Key, Qargs) -> + read_qargs(Socket, Rest, maps:put(Key, Val, Qargs)); +read_qval(_, <<"?", _/binary>>, _, _, _) -> + {error, qargs}; +read_qval(_, <<"\r", _/binary>>, _, _, _) -> + {error, qargs}; +read_qval(_, <<"\n", _/binary>>, _, _, _) -> + {error, qargs}; +read_qval(Socket, <>, Acc, Key, Qargs) -> + read_qval(Socket, Rest, <>, Key, Qargs); +read_qval(Socket, <<>>, Acc, Key, Qargs) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + read_qval(Socket, Bin, Acc, Key, Qargs); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end. + + +read_fragment(Socket, <<"#", Rest/binary>>) -> + read_fragment(Socket, Rest, <<>>); +read_fragment(_, Rest) -> + {ok, none, Rest}. + +read_fragment(_, <<" ", Rest/binary>>, <<>>) -> + {ok, none, Rest}; +read_fragment(_, <<" ", Rest/binary>>, Fragment) -> + {ok, Fragment, Rest}; +read_fragment(_, <<"\r", _/binary>>, _) -> + {error, fragment}; +read_fragment(_, <<"\n", _/binary>>, _) -> + {error, fragment}; +read_fragment(Socket, <>, Acc) -> + read_fragment(Socket, Rest, <>); +read_fragment(Socket, <<>>, Acc) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + read_fragment(Socket, Bin, Acc); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end. + + +read_version(_, <<"HTTP/1.0\r\n", Rest/binary>>) when byte_size(Rest) > 0 -> + {ok, http10, Rest}; +read_version(_, <<"HTTP/1.1\r\n", Rest/binary>>) when byte_size(Rest) > 0 -> + {ok, http11, Rest}; +read_version(_, <<"HTTP/2.0\r\n", Rest/binary>>) when byte_size(Rest) > 0 -> + {ok, http20, Rest}; +read_version(Socket, Acc) when byte_size(Acc) =< 10 -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + read_version(Socket, <>); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; +read_version(_, _) -> + {error, version}. + + +read_headers(Socket, <<"\r">>) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + read_headers(Socket, <<"\r", Bin/binary>>); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; +read_headers(_, <<"\r\n", _/binary>>) -> + {error, headers}; +read_headers(Socket, Received) -> + read_hkey(Socket, Received, <<>>, #{}). + +read_hkey(Socket, <>, Acc, Headers) + when $A =< Char, Char =< $Z -> + read_hkey(Socket, Rest, <>, Headers); +read_hkey(Socket, <>, Acc, Headers) + when 32 =< Char, Char =< 57; + 59 =< Char, Char =< 126 -> + read_hkey(Socket, Rest, <>, Headers); +read_hkey(Socket, <<":", Rest/binary>>, Key, Headers) -> + skip_hblanks(Socket, Rest, Key, Headers); +read_hkey(_, <<"\r\n", Rest/binary>>, <<>>, Headers) -> + {ok, Headers, Rest}; +read_hkey(Socket, <<>>, Acc, Headers) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + read_hkey(Socket, Bin, Acc, Headers); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; +read_hkey(_, Received, _, _) -> + log(info, "~p Headers died at: ~p", [?LINE, Received]), + {error, headers}. + +skip_hblanks(Socket, <<" ", Rest/binary>>, Key, Headers) -> + skip_hblanks(Socket, Rest, Key, Headers); +skip_hblanks(Socket, <<>>, Key, Headers) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + skip_hblanks(Socket, Bin, Key, Headers); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; +skip_hblanks(Socket, Rest, Key, Headers) -> + read_hval(Socket, Rest, <<>>, Key, Headers). + +read_hval(Socket, <<"\r\n", Rest/binary>>, Val, Key, Headers) -> + read_hkey(Socket, Rest, <<>>, maps:put(Key, Val, Headers)); +read_hval(Socket, <>, Acc, Key, Headers) -> + read_hval(Socket, Rest, <>, Key, Headers); +read_hval(Socket, <<>>, Val, Key, Headers) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + read_hval(Socket, Bin, Val, Key, Headers); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; +read_hval(_, Received, _, _, _) -> + log(info, "~p Headers died at: ~p", [?LINE, Received]), + {error, headers}. + +read_enctype(#request{method = get}) -> + {ok, none}; +read_enctype(#request{method = post, headers = Headers}) -> + case maps:find(<<"content-type">>, Headers) of + {ok, <<"multipart/form-data;", Rest/binary>>} -> get_boundary(Rest); + {ok, <<"application/x-www-form-urlencoded">>} -> {ok, urlencoded}; + {ok, <<"application/json">>} -> {ok, json}; + {ok, WTF} -> {error, {enctype, WTF}}; + error -> {error, no_enctype} + end; +read_enctype(#request{method = options}) -> + {ok, none}. + + +get_boundary(<<"boundary=", Boundary/binary>>) -> {ok, {multipart, Boundary}}; +get_boundary(<<" ", Rest/binary>>) -> get_boundary(Rest); +get_boundary(<<>>) -> {error, no_boundary}; +get_boundary(_) -> {error, bad_enctype}. + +read_cookies(#request{headers = Headers}) -> + case maps:find(<<"cookie">>, Headers) of + {ok, Values} -> parse_cookies(Values); + error -> {ok, #{}} + end. + + +parse_cookies(Values) -> + {ok, read_ckey(Values, <<>>, #{})}. + +read_ckey(<<"=", Rest/binary>>, Acc, Cookies) -> + read_cval(Rest, <<>>, Acc, Cookies); +read_ckey(<>, Acc, Cookies) -> + read_ckey(Rest, <>, Cookies); +read_ckey(<<>>, <<>>, Cookies) -> + Cookies; +read_ckey(<<>>, Key, Cookies) -> + case maps:is_key(Key, Cookies) of + true -> Cookies; + false -> maps:put(Key, <<>>, Cookies) + end. + +read_cval(<<>>, Val, Key, Cookies) -> + maps:put(Key, Val, Cookies); +read_cval(<<";", Rest/binary>>, Val, Key, Cookies) -> + skip_cblanks(Rest, maps:put(Key, Val, Cookies)); +read_cval(<<",", Rest/binary>>, Val, Key, Cookies) -> + skip_cblanks(Rest, maps:put(Key, Val, Cookies)); +read_cval(<>, Acc, Key, Cookies) -> + read_cval(Rest, <>, Key, Cookies). + +skip_cblanks(<<" ", Rest/binary>>, Cookies) -> + skip_cblanks(Rest, Cookies); +skip_cblanks(Rest, Cookies) -> + read_ckey(Rest, <<>>, Cookies). + + +read_size(#request{method = get}) -> + {ok, 0}; +read_size(#request{method = post, enctype = {multipart, _}, headers = Headers}) -> + case maps:find(<<"content-length">>, Headers) of + error -> + {ok, none}; + {ok, Size} -> + try + {ok, binary_to_integer(Size)} + catch + error:badarg -> {error, headers} + end + end; +read_size(#request{method = post, headers = Headers}) -> + case maps:find(<<"content-length">>, Headers) of + error -> + {ok, 0}; + {ok, Size} -> + try + {ok, binary_to_integer(Size)} + catch + error:badarg -> {error, headers} + end + end; +read_size(#request{method = options}) -> + {ok, 0}. + + +read_body(Received, Size) -> + case Received of + <> -> + {ok, Bin}; + <> -> + {ok, Bin, Next}; + Bin when byte_size(Bin) < Size -> + {incomplete, Bin} + end. + + +read_multipart(Socket, Received, Boundary, none) -> + read_multipart3(Socket, Received, Boundary); +read_multipart(Socket, Received, Boundary, Size) -> + Remaining = Size - byte_size(Received), + case accumulate(Socket, Remaining, Received) of + {ok, Complete} -> read_multipart3(Socket, Complete, Boundary); + {ok, Complete, Next} -> read_multipart2(Socket, Complete, Boundary, Next); + Error -> Error + end. + +read_multipart2(Socket, Received, Boundary, Next) -> + case read_multipart3(Socket, Received, Boundary) of + {ok, Parts} -> {ok, Parts, Next}; + {ok, Parts, Cont} -> {ok, Parts, <>}; + Error -> Error + end. + +read_multipart3(Socket, Received, Boundary) -> + SEP = <<"--", Boundary/binary, "\r\n">>, + SS = byte_size(SEP), + EOF = <<"--", Boundary/binary, "--\r\n">>, + ES = byte_size(EOF), + Seps = [{{SEP, SS}, {EOF, ES}}], + case simple_multipart(Socket, Received, Seps, []) of + {ok, Parts} -> {ok, lists:reverse(Parts)}; + {ok, Parts, Next} -> {ok, lists:reverse(Parts), Next}; + Error -> Error + end. + +simple_multipart(Socket, Received, [{{SEP, SS}, {EOF, ES}} | RemSeps], Parts) + when byte_size(Received) >= ES -> + case Received of + <> -> + NewSep = + {{<<"\r\n", SEP/binary>>, SS + 2}, + {<<"\r\n", EOF/binary>>, ES + 2}}, + NewSeps = [NewSep | RemSeps], + simple_multipart2(Socket, Rest, NewSeps, Parts); + <> -> + simple_multipart2(Socket, Rest, RemSeps, Parts) + end; +simple_multipart(_, Received, [], Parts) -> + {ok, Parts, Received}; +simple_multipart(Socket, Received, Seps, Parts) -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + simple_multipart(Socket, <>, Seps, Parts); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end. + + +simple_multipart2(Socket, Received, Seps, Parts) -> + case read_headers(Socket, Received) of + {ok, Headers, Rest} -> + check_multipart_headers(Socket, Rest, Seps, Headers, Parts); + Error -> + Error + end. + + +check_multipart_headers(Socket, Received, Seps, Headers, Parts) -> + case maps:find(<<"content-disposition">>, Headers) of + {ok, StupidShit} -> + case sort_out(StupidShit) of + [<<"form-data">> | Shit] -> + read_form_data(Socket, Shit, Received, Seps, Headers, Parts); + [<<"file">> | Shit] -> + read_file_data(Socket, Shit, Received, Seps, Parts); + COVID -> + {error, {form_had, COVID}} + end; + error -> + {error, bad_disposition} + end. + + +read_form_data(Socket, Shit, Received, Seps, Headers, Parts) -> + case proplists:is_defined(<<"filename">>, Shit) of + true -> read_file_data(Socket, Shit, Received, Seps, Parts); + false -> read_form_data2(Socket, Shit, Received, Seps, Headers, Parts) + end. + +read_form_data2(Socket, Shit, Received, Seps, Headers, Parts) -> + case maps:find(<<"content-type">>, Headers) of + {ok, StupidShit} -> + case sort_out(StupidShit) of + [<<"multipart/mixed">> | Shit] -> + read_multipart_mixed(Socket, Shit, Received, Seps, Parts); + _ -> + read_form_data3(Socket, Shit, Received, Seps, Parts) + end; + error -> + read_form_data3(Socket, Shit, Received, Seps, Parts) + end. + +read_form_data3(Socket, Shit, Received, Seps, Parts) -> + case proplists:get_value(<<"name">>, Shit) of + undefined -> {error, fucked_up_form}; + Name -> read_form_data4(Socket, Received, Name, Seps, Parts) + end. + +read_form_data4(Socket, Received, Name, Seps = [CurrSep | PrevSeps], Parts) -> + case unfuck_form_data(Socket, Received, <<>>, CurrSep) of + {ok, Data, Rest} -> + NewParts = [{Name, Data} | Parts], + simple_multipart2(Socket, Rest, Seps, NewParts); + {done, Data, Rest} -> + NewParts = [{Name, Data} | Parts], + simple_multipart(Socket, Rest, PrevSeps, NewParts); + Error -> + Error + end. + + +read_multipart_mixed(Socket, Shit, Received, Seps, Parts) -> + case proplists:get_value(<<"boundary">>, Shit) of + undefined -> + {error, no_boundary}; + Boundary -> + SEP = <<"--", Boundary/binary, "\r\n">>, + SS = byte_size(SEP), + EOF = <<"--", Boundary/binary, "--\r\n">>, + ES = byte_size(EOF), + NewSeps = [{{SEP, SS}, {EOF, ES}} | Seps], + simple_multipart(Socket, Received, NewSeps, Parts) + end. + +read_file_data(Socket, Shit, Received, Seps = [CurrSep | PrevSeps], Parts) -> + case {proplists:get_value(<<"name">>, Shit), + proplists:get_value(<<"filename">>, Shit)} of + {undefined, undefined} -> + {error, fucked_up_form}; + {_, undefined} -> + {error, fucked_up_form}; + {undefined, _} -> + {error, fucked_up_form}; + {Name, Filename} -> + case unfuck_form_data(Socket, Received, <<>>, CurrSep) of + {ok, Data, Rest} -> + NewParts = [{Name, {Filename, Data}} | Parts], + simple_multipart2(Socket, Rest, Seps, NewParts); + {done, Data, Rest} -> + NewParts = [{Name, {Filename, Data}} | Parts], + simple_multipart(Socket, Rest, PrevSeps, NewParts); + Error -> + Error + end + end. + +unfuck_form_data(Socket, Received, Acc, Seps) -> + unfuck_form_data(Socket, Received, Acc, Seps, byte_size(Received)). + +unfuck_form_data(Socket, Received, Acc, Seps = {{SEP, SS}, {EOF, ES}}, Size) + when byte_size(Received) >= SS andalso Size < 52428800 -> + case Received of + <> -> + {ok, Acc, Rest}; + <> -> + {done, Acc, Rest}; + <> when byte_size(Received) >= byte_size(SEP) -> + unfuck_form_data(Socket, Rest, <>, Seps) + end; +unfuck_form_data(Socket, Received, Acc, Seps, Size) when Size < 52428800 -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + NewBin = <>, + unfuck_form_data(Socket, NewBin, Acc, Seps); + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; +unfuck_form_data(_, _, _, _, Size) -> + {error, {size, Size}}. + + +sort_out(StupidShit) -> + read_shitkey(StupidShit, <<>>, []). + + +posted(Body) -> + read_pkey(Body, <<>>, []). + +read_pkey(<<$%, A, B, Rest/binary>>, Acc, Data) -> + read_pkey(Rest, <>, Data); +read_pkey(<<"=", Rest/binary>>, Acc, Data) -> + read_pval(Rest, <<>>, Acc, Data); +read_pkey(<<"&", Rest/binary>>, Acc, Data) -> + read_pkey(Rest, <<>>, [{Acc, <<>>} | Data]); +read_pkey(<>, Acc, Data) -> + read_pkey(Rest, <>, Data); +read_pkey(<<>>, <<>>, Data) -> + Data; +read_pkey(<<>>, Acc, Data) -> + [{Acc, <<>>} | Data]. + +read_pval(<<$%, $3, $C, Rest/binary>>, Acc, Key, Data) -> + read_pval(Rest, <>, Key, Data); +read_pval(<<$%, $3, $c, Rest/binary>>, Acc, Key, Data) -> + read_pval(Rest, <>, Key, Data); +read_pval(<<$%, $3, $E, Rest/binary>>, Acc, Key, Data) -> + read_pval(Rest, <>, Key, Data); +read_pval(<<$%, $3, $e, Rest/binary>>, Acc, Key, Data) -> + read_pval(Rest, <>, Key, Data); +read_pval(<<$%, A, B, Rest/binary>>, Acc, Key, Data) -> + read_pval(Rest, <>, Key, Data); +read_pval(<<"&", Rest/binary>>, Val, Key, Data) -> + read_pkey(Rest, <<>>, [{Key, Val} | Data]); +read_pval(<<"+", Rest/binary>>, Acc, Key, Data) -> + read_pval(Rest, <>, Key, Data); +read_pval(<>, Acc, Key, Data) -> + read_pval(Rest, <>, Key, Data); +read_pval(<<>>, Val, Key, Data) -> + [{Key, Val} | Data]. + + + +read_shitkey(<<";", Rest/binary>>, Key, Values) -> + Tail = skip_blanks(Rest), + read_shitkey(Tail, <<>>, [Key | Values]); +read_shitkey(<<"=\"", Rest/binary>>, Key, Values) -> + case read_quote(Rest) of + {ok, Val, <<";", Tail/binary>>} -> + read_shitkey(skip_blanks(Tail), <<>>, [{Key, Val} | Values]); + {ok, Val, Tail} -> + read_shitkey(skip_blanks(Tail), <<>>, [{Key, Val} | Values]); + {ok, <<>>} -> + [Key | Values]; + {ok, Val} -> + [{Key, Val} | Values] + end; +read_shitkey(<<"=", Rest/binary>>, Key, Values) -> + read_shitval(Rest, <<>>, Key, Values); +read_shitkey(<>, Acc, Values) -> + read_shitkey(Rest, <>, Values); +read_shitkey(<<>>, <<>>, Values) -> + lists:reverse(Values); +read_shitkey(<<>>, Key, Values) -> + lists:reverse([Key | Values]). + +read_shitval(<<";", Rest/binary>>, <<>>, Key, Values) -> + read_shitkey(skip_blanks(Rest), <<>>, [Key | Values]); +read_shitval(<<";", Rest/binary>>, Val, Key, Values) -> + read_shitkey(skip_blanks(Rest), <<>>, [{Key, Val} | Values]); +read_shitval(<>, Acc, Key, Values) -> + read_shitval(Rest, <>, Key, Values); +read_shitval(<<>>, <<>>, Key, Values) -> + [{Key, none} | Values]; +read_shitval(<<>>, Val, Key, Values) -> + [{Key, Val} | Values]. + + +skip_blanks(<<" ", Rest/binary>>) -> <<(skip_blanks(Rest))/binary>>; +skip_blanks(<<>>) -> <<>>; +skip_blanks(<>) -> Rest. + + +read_quote(Bin) -> read_quote(Bin, <<>>). + +read_quote(<<"\"", Rest/binary>>, Acc) -> + {ok, Acc, Rest}; +read_quote(<<"\"">>, Acc) -> + {ok, Acc}; +read_quote(<<"\\\"", Rest/binary>>, Acc) -> + read_quote(Rest, <>); +read_quote(<>, Acc) -> + read_quote(Rest, <>). + + +accumulate(Socket, M = #request{size = Size, body = Body}) -> + Remaining = Size - byte_size(Body), + case accumulate(Socket, Remaining, Body) of + {ok, Received} -> {ok, M#request{body = Received}, none}; + {ok, Received, Next} -> {ok, M#request{body = Received}, Next}; + Error -> Error + end. + +accumulate(Socket, Remaining, Received) when Remaining > 0 -> + ok = inet:setopts(Socket, [{active, once}]), + receive + {tcp, Socket, Bin} -> + Size = byte_size(Bin), + if + Size == Remaining -> + {ok, <>}; + Size < Remaining -> + NewRemaining = Remaining - Size, + NewReceived = <>, + accumulate(Socket, NewRemaining, NewReceived); + Size > Remaining -> + <> = Bin, + NewReceived = <>, + {ok, NewReceived, Next} + end; + {tcp_closed, Socket} -> + exit(normal); + {tcp_error, Socket, Reason} -> + ok = tell(info, "Socket error: ~p", [Reason]), + exit(normal) + after 3000 -> + {error, timeout} + end; +accumulate(_, 0, Received) -> + {ok, Received}; +accumulate(_, Remaining, Received) when Remaining =< 0 -> + {error, {oversend, Received}}. + + + +%%% Websocket insanity + +-spec recv(Socket, Received) -> Result + when Socket :: gen_tcp:socket(), + Received :: binary(), + Result :: {ok, Message} | {error, Reason}, + Message :: binary(), + Reason :: term(). % FIXME + +recv(_, _) -> {error, nih}. + + +-spec resp(Socket, Binary) -> Result + when Socket :: gen_tcp:socket(), + Binary :: binary(), + Result :: ok | {error, Reason}, + Reason :: term(). % FIXME + +resp(_, _) -> {error, nih}. + + + + + +%%% Utility Functions + + +-spec percent_encode(RawBinary) -> EncodedBinary + when RawBinary :: binary(), + EncodedBinary :: binary(). +%% @doc +%% Percent encodes a binary string as per RFC-3986 Section 2.1 +%% https://datatracker.ietf.org/doc/html/rfc3986#section-2.1 + +percent_encode(<>) + when $0 =< C, C =< $9; + $A =< C, C =< $Z; + $a =< C, C =< $z; + C == $-; C == $.; + C == $_; C == $~ -> + <>; +percent_encode(<>) -> + case integer_to_list(C, 16) of + [A, B] -> <<$%, A, B, (percent_encode(Rest))/binary>>; + [B] -> <<$%, $0, B, (percent_encode(Rest))/binary>> + end; +percent_encode(<<>>) -> + <<>>. + + +-spec percent_decode(EncodedBinary) -> RawBinary + when EncodedBinary :: binary(), + RawBinary :: binary(). +%% @doc +%% Decodes a percent encoded binary as per RFC-3986 Section 2.1 +%% https://datatracker.ietf.org/doc/html/rfc3986#section-2.1 + +percent_decode(<<$%, A, B, Rest/binary>>) -> + <<(list_to_integer([A, B], 16)), (percent_decode(Rest))/binary>>; +percent_decode(<<$+, Rest/binary>>) -> + <<" ", (percent_decode(Rest))/binary>>; +percent_decode(<>) -> + <>; +percent_decode(<<>>) -> + <<>>. + + +-spec join(Headers) -> IOListHeaders + when Headers :: [{Key, Value}], + IOListHeaders :: iolist(), + Key :: binary(), + Value :: binary(). +%% @doc +%% Convert a header K/V tuple list to an `iolist()' of the form +%% `[Key, ": ", Value, "\r\n"]' that can be consumed by iolist +%% operations such as those in the unicode module. + +join([{K, V} | Rest]) -> + [K, ": ", V, "\r\n" | join(Rest)]; +join([]) -> + []. + + +-spec ridiculous_web_date() -> iolist(). +%% @equiv ridiculous_web_data(Date). + +ridiculous_web_date() -> + ridiculous_web_date(calendar:universal_time()). + + +-spec ridiculous_web_date(Date) -> StupifyinglyRetardedDateFormat + when Date :: calendar:datetime(), + StupifyinglyRetardedDateFormat :: iolist(). +%% @doc +%% Perform the humiliation ritual satirically known in the business as +%% web date format generation and return it as an `iolist()'. + +ridiculous_web_date({DS = {Y, M, D}, {Hr, Mn, Sc}}) -> + Day = + case calendar:day_of_the_week(DS) of + 1 -> "Mon"; + 2 -> "Tue"; + 3 -> "Wed"; + 4 -> "Thu"; + 5 -> "Fri"; + 6 -> "Sat"; + 7 -> "Sun" + end, + Year = integer_to_list(Y), + Month = + case M of + 1 -> "Jan"; + 2 -> "Feb"; + 3 -> "Mar"; + 4 -> "Apr"; + 5 -> "May"; + 6 -> "Jun"; + 7 -> "Jul"; + 8 -> "Aug"; + 9 -> "Sep"; + 10 -> "Oct"; + 11 -> "Nov"; + 12 -> "Dec" + end, + Date = ridiculous_bullshit_fixed_width_garbage(D), + Hour = ridiculous_bullshit_fixed_width_garbage(Hr), + Minute = ridiculous_bullshit_fixed_width_garbage(Mn), + Second = ridiculous_bullshit_fixed_width_garbage(Sc), + [Day, ", ", Date, " ", Month, " ", Year, " ", + Hour, ":", Minute, ":", Second, " GMT"]. + +ridiculous_bullshit_fixed_width_garbage(N) when N < 10 -> [$0, integer_to_list(N)]; +ridiculous_bullshit_fixed_width_garbage(N) -> integer_to_list(N). + + +-spec slogan(Code) -> Slogan + when Code :: pos_integer(), + Slogan :: string(). +%% @doc +%% A convenience function that returns the standard slogan of a number of well-known +%% HTTP response codes. Take note of which codes are not supported and manually +%% intervene accordingly. + +slogan(100) -> "Continue"; +slogan(101) -> "Switching Protocols"; +slogan(102) -> "Early Hints"; +slogan(200) -> "OK"; +slogan(201) -> "Created"; +slogan(202) -> "Accepted"; +slogan(203) -> "Non-Authoritative Information"; +slogan(204) -> "No Content"; +slogan(301) -> "Moved Permanently"; +slogan(302) -> "Found"; +slogan(303) -> "See Other"; +slogan(304) -> "Not Modified"; +slogan(307) -> "Temporary Redirect"; +slogan(308) -> "Permanent Redirect"; +slogan(400) -> "Bad Request"; +slogan(401) -> "Unauthorized"; +slogan(402) -> "Payment Required"; +slogan(403) -> "Forbidden"; +slogan(404) -> "Not Found"; +slogan(405) -> "Method Not Allowed"; +slogan(409) -> "Conflict"; +slogan(410) -> "Gone"; +slogan(413) -> "Content Too Large"; +slogan(414) -> "URI Too Long"; +slogan(426) -> "Upgrade Required"; +slogan(429) -> "Too Many Requests"; +slogan(451) -> "Unavailable for Legal Reasons"; +slogan(500) -> "Internal Server Error"; +slogan(501) -> "Not Implemented"; +slogan(503) -> "Service Unavailable". + + +-spec break_nl(WithOrdinaryRN_Newlines) -> WithBR_TaggedHTML + when WithOrdinaryRN_Newlines :: binary(), + WithBR_TaggedHTML :: binary(). +%% @doc +%% Substitute `<<"\\r\\n">>' with `<<"
">>' in a binary string. + +break_nl(<<"\r\n", Rest/binary>>) -> <<"
", (break_nl(Rest))/binary>>; +break_nl(<>) -> <>; +break_nl(<<>>) -> <<>>. + + + +-spec unbreak_nl(WithBR_TaggedHTML) -> WithOrdinaryRN_Newlines + when WithBR_TaggedHTML :: binary(), + WithOrdinaryRN_Newlines :: binary(). +%% @doc +%% Substitute `<<"
">>' with `<<"\\r\\n">>' in a binary string. + +unbreak_nl(<<"
", Rest/binary>>) -> <<"\r\n", (unbreak_nl(Rest))/binary>>; +unbreak_nl(<>) -> <>; +unbreak_nl(<<>>) -> <<>>. + + +-spec clean(MessyAngleBracketyHTML) -> MessierEscapedHTML + when MessyAngleBracketyHTML :: binary(), + MessierEscapedHTML :: binary(). +%% @doc +%% Receive HTML input and convert reserved characters to the comedy versions. + +clean(<<"<", Rest/binary>>) -> <<"<", (clean(Rest))/binary>>; +clean(<<">", Rest/binary>>) -> <<">", (clean(Rest))/binary>>; +clean(<<"\"", Rest/binary>>) -> <<""", (clean(Rest))/binary>>; +clean(<>) -> <>; +clean(<<>>) -> <<>>. + + +-spec bin_to_int(IntegerBinaryString) -> Result + when IntegerBinaryString :: binary(), + Result :: {ok, integer()} | error. +%% @doc +%% Convert an input to a binary string the old-fashioned non-exploding way. +%% (The caller gets to decide whether this explodes depending on how it is called, +%% without the `try .. catch' mess. + +bin_to_int(Bin) -> + case bin_to_int(Bin, <<>>) of + {ok, Clean} -> {ok, binary_to_integer(Clean)}; + error -> error + end. + +bin_to_int(<>, Acc) when $0 =< C andalso C =< $9 -> + bin_to_int(Rest, <>); +bin_to_int(<<"/">>, Acc) -> + {ok, Acc}; +bin_to_int(<<>>, Acc) -> + {ok, Acc}; +bin_to_int(_, _) -> + error. diff --git a/zomp.meta b/zomp.meta new file mode 100644 index 0000000..12c2ba4 --- /dev/null +++ b/zomp.meta @@ -0,0 +1,17 @@ +{name,"QHL"}. +{type,lib}. +{modules,[]}. +{prefix,none}. +{author,"Craig Everett"}. +{desc,"The Quick HTTP Library"}. +{package_id,{"otpr","qhl",{0,1,0}}}. +{deps,[]}. +{key_name,none}. +{a_email,"zxq9@zxq9.com"}. +{c_email,"zxq9@zxq9.com"}. +{copyright,"Craig Everett"}. +{file_exts,[]}. +{license,"MIT"}. +{repo_url,"https://git.qpq.swiss/QPQ-AG/QHL"}. +{tags,[]}. +{ws_url,"https://git.qpq.swiss/QPQ-AG/QHL"}.