path: root/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_parse.erl

%% ``Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
%% You may obtain a copy of the License at
%%
%%     http://www.apache.org/licenses/LICENSE-2.0
%%
%% Unless required by applicable law or agreed to in writing, software
%% distributed under the License is distributed on an "AS IS" BASIS,
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions and
%% limitations under the License.
%%
%% The Initial Developer of the Original Code is Ericsson Utvecklings AB.
%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings
%% AB. All Rights Reserved.''
%%
%%     $Id: httpd_parse.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $
%%
-module(httpd_parse).
-export([
	 request_header/1,
	 hsplit/2,
	 get_request_record/10,
	 split_lines/1,
	 tagup_header/1]).
-include("httpd.hrl").


%%----------------------------------------------------------------------
%% request_header
%%
%% Input: The request as sent from the client (list of characters)
%%        (may include part of the entity body)
%%
%% Returns:
%%   {ok, Info#mod}
%%   {not_implemented,Info#mod}
%%   {bad_request, Reason}
%%----------------------------------------------------------------------

request_header(Header)->
    [RequestLine|HeaderFields] = split_lines(Header),
    ?DEBUG("request ->"
	   "~n   RequestLine: ~p"
	   "~n   Header:      ~p",[RequestLine,Header]),
    ParsedHeader = tagup_header(HeaderFields),
    ?DEBUG("request ->"
	   "~n   ParseHeader: ~p",[ParsedHeader]),
    case verify_request(string:tokens(RequestLine," ")) of
	["HEAD", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] ->
	    {ok, ["HEAD", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N], RequestLine,
		 ParsedHeader]};
	["GET", RequestURI, "HTTP/0.9"] ->
	    {ok, ["GET", RequestURI, "HTTP/0.9", RequestLine, ParsedHeader]};
	["GET", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] ->
	    {ok, ["GET", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N], RequestLine,
		 ParsedHeader]};
	["POST", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] ->
	    {ok, ["POST", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N], RequestLine,
		 ParsedHeader]};
	%%HTTP must be 1.1 or higher
	["TRACE", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] when N>48->
	    {ok, ["TRACE", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N], RequestLine,
		 ParsedHeader]};
	[Method, RequestURI] ->
	    {not_implemented, RequestLine, Method, RequestURI,ParsedHeader,"HTTP/0.9"};
	[Method, RequestURI, HTTPVersion] ->
	    {not_implemented, RequestLine, Method, RequestURI,ParsedHeader, HTTPVersion};
	{bad_request, Reason} ->
	    {bad_request, Reason};
	Reason ->
	    {bad_request, "Unknown request method"}
    end.






%%----------------------------------------------------------------------
%% The request is passed through the server as a record of type mod get it
%% ----------------------------------------------------------------------

get_request_record(Socket,SocketType,ConfigDB,Method,RequestURI,
		 HTTPVersion,RequestLine,ParsedHeader,EntityBody,InitData)->
    PersistentConn=get_persistens(HTTPVersion,ParsedHeader,ConfigDB),
    Info=#mod{init_data=InitData,
	      data=[],
	      socket_type=SocketType,
	      socket=Socket,
	      config_db=ConfigDB,
	      method=Method,
	      absolute_uri=formatAbsoluteURI(RequestURI,ParsedHeader),
	      request_uri=formatRequestUri(RequestURI),
	      http_version=HTTPVersion,
	      request_line=RequestLine,
	      parsed_header=ParsedHeader,
	      entity_body=maybe_remove_nl(ParsedHeader,EntityBody),
	      connection=PersistentConn},
    {ok,Info}.

%%----------------------------------------------------------------------
%% Conmtrol wheater we shall maintain a persistent connection or not
%%----------------------------------------------------------------------
get_persistens(HTTPVersion,ParsedHeader,ConfigDB)->
    case httpd_util:lookup(ConfigDB,persistent_conn,true) of
	true->
	    case HTTPVersion of
		%%If it is version prio to 1.1 kill the conneciton
		[$H, $T, $T, $P, $\/, $1, $.,N] ->
		    case httpd_util:key1search(ParsedHeader,"connection","keep-alive")of
			%%if the connection isn't ordered to go down let it live
			%%The keep-alive value is the older http/1.1 might be older
			%%Clients that use it.
			"keep-alive" when N >= 49 ->
			    ?DEBUG("CONNECTION MODE: ~p",[true]),
			    true;
			"close" ->
			    ?DEBUG("CONNECTION MODE: ~p",[false]),
			    false;
			Connect ->
			    ?DEBUG("CONNECTION MODE: ~p VALUE: ~p",[false,Connect]),
			    false
		    end;
		_ ->
		    ?DEBUG("CONNECTION MODE: ~p VERSION: ~p",[false,HTTPVersion]),
		    false

	    end;
	_ ->
	    false
    end.




%%----------------------------------------------------------------------
%% Control whether the last newline of the body is a part of the message or
%%it is a part of the multipart message.
%%----------------------------------------------------------------------
maybe_remove_nl(Header,Rest) ->
    case find_content_type(Header) of
	false ->
	    {ok,EntityBody,_}=regexp:sub(Rest,"\r\n\$",""),
	    EntityBody;
	{ok, Value} ->
	    case string:str(Value, "multipart/form-data") of
		0 ->
		    {ok,EntityBody,_}=regexp:sub(Rest,"\r\n\$",""),
		    EntityBody;
		_ ->
		    Rest
	    end
    end.

%%----------------------------------------------------------------------
%% Cet the content type of the incomming request
%%----------------------------------------------------------------------


find_content_type([]) ->
    false;
find_content_type([{Name,Value}|Tail]) ->
    case httpd_util:to_lower(Name) of
	"content-type" ->
	    {ok, Value};
	_ ->
	    find_content_type(Tail)
    end.

%%----------------------------------------------------------------------
%% Split the header to a list of strings where each string represents a
%% HTTP header-field
%%----------------------------------------------------------------------
split_lines(Request) ->
    split_lines(Request, [], []).
split_lines([], CAcc, Acc) ->
    lists:reverse([lists:reverse(CAcc)|Acc]);

%%White space in the header fields are allowed but the new line must begin with LWS se
%%rfc2616 chap 4.2. The rfc do not say what to
split_lines([$\r, $\n, $\t |Rest], CAcc, Acc) ->
    split_lines(Rest, [$\r, $\n |CAcc], Acc);

split_lines([$\r, $\n, $\s |Rest], CAcc, Acc) ->
    split_lines(Rest, [$\r, $\n |CAcc], Acc);

split_lines([$\r, $\n|Rest], CAcc, Acc) ->
    split_lines(Rest, [], [lists:reverse(CAcc)|Acc]);
split_lines([Chr|Rest], CAcc, Acc) ->
    split_lines(Rest, [Chr|CAcc], Acc).


%%----------------------------------------------------------------------
%% This is a 'hack' to stop people from trying to access directories/files
%% relative to the ServerRoot.
%%----------------------------------------------------------------------


verify_request([Request, RequestURI]) ->
    verify_request([Request, RequestURI, "HTTP/0.9"]);

verify_request([Request, RequestURI, Protocol]) ->
    NewRequestURI =
	case string:str(RequestURI, "?") of
	    0 ->
		RequestURI;
	    Ndx ->
		string:left(RequestURI, Ndx)
	end,
   case string:str(NewRequestURI, "..") of
	0 ->
	    [Request, RequestURI, Protocol];
	_ ->
	    {bad_request, {forbidden, RequestURI}}
    end;
verify_request(Request) ->
    Request.

%%----------------------------------------------------------------------
%% tagup_header
%%
%% Parses the header of a HTTP request and returns a key,value tuple
%% list containing Name and Value of each header directive as of:
%%
%% Content-Type: multipart/mixed -> {"Content-Type", "multipart/mixed"}
%%
%% But in http/1.1 the field-names are case insencitive so now it must be
%% Content-Type: multipart/mixed -> {"content-type", "multipart/mixed"}
%% The standard furthermore says that leading and traling white space
%% is not a part of the fieldvalue and shall therefore be removed.
%%----------------------------------------------------------------------

tagup_header([]) ->          [];
tagup_header([Line|Rest]) -> [tag(Line, [])|tagup_header(Rest)].

tag([], Tag) ->
    {httpd_util:to_lower(lists:reverse(Tag)), ""};
tag([$:|Rest], Tag) ->
    {httpd_util:to_lower(lists:reverse(Tag)), httpd_util:strip(Rest)};
tag([Chr|Rest], Tag) ->
    tag(Rest, [Chr|Tag]).


%%----------------------------------------------------------------------
%% There are 3 possible forms of the reuqest URI
%%
%%  1. * When the request is not for a special assset. is is instead
%%     to the server itself
%%
%%  2. absoluteURI the whole servername port and asset is in the request
%%
%%  3. The most common form that http/1.0 used abs path that is a path
%%     to the requested asset.
%5----------------------------------------------------------------------
formatRequestUri("*")->
    "*";
formatRequestUri([$h,$t,$t,$p,$:,$\/,$\/|ServerAndPath]) ->
   removeServer(ServerAndPath);

formatRequestUri([$H,$T,$T,$P,$:,$\/,$\/|ServerAndPath]) ->
    removeServer(ServerAndPath);

formatRequestUri(ABSPath) ->
    ABSPath.

removeServer([$\/|Url])->
    case Url of
	[]->
	    "/";
        _->
	    [$\/|Url]
    end;
removeServer([N|Url]) ->
    removeServer(Url).


formatAbsoluteURI([$h,$t,$t,$p,$:,$\/,$\/|Uri],ParsedHeader)->
    [$H,$T,$T,$P,$:,$\/,$\/|Uri];

formatAbsoluteURI([$H,$T,$T,$P,$:,$\/,$\/|Uri],ParsedHeader)->
    [$H,$T,$T,$P,$:,$\/,$\/|Uri];

formatAbsoluteURI(Uri,ParsedHeader)->
    case httpd_util:key1search(ParsedHeader,"host") of
	undefined ->
	    nohost;
	Host ->
	    Host++Uri
    end.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%Code below is crap from an older version shall be removed when
%%transformation to http/1.1 is finished
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



%request(Request) ->
%    ?DEBUG("request -> entry with:"
%	   "~n   Request: ~s",[Request]),
 %   {BeforeEntityBody, Rest} = hsplit([], Request),
 %   ?DEBUG("request ->"
%	   "~n   BeforeEntityBody: ~p"
%	   "~n   Rest:             ~p",[BeforeEntityBody, Rest]),
%    [RequestLine|Header] = split_lines(BeforeEntityBody),
%    ?DEBUG("request ->"
%	   "~n   RequestLine: ~p"
%	   "~n   Header:      ~p",[RequestLine,Header]),
%    ParsedHeader = tagup_header(Header),
%    ?DEBUG("request ->"
%	   "~n   ParseHeader: ~p",[ParsedHeader]),
%    EntityBody = maybe_remove_nl(ParsedHeader,Rest),
%    ?DEBUG("request ->"
%	   "~n   EntityBody: ~p",[EntityBody]),
%    case verify_request(string:tokens(RequestLine," ")) of
%	["HEAD", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] ->
%	    {ok, ["HEAD", formatRequestUri(RequestURI), [$H,$T,$T,$P,$/,$1,$.,N], RequestLine,
%		 ParsedHeader, EntityBody]};
%	["GET", RequestURI, "HTTP/0.9"] ->
%	    {ok, ["GET", RequestURI, "HTTP/0.9", RequestLine, ParsedHeader,
%		 EntityBody]};
%	["GET", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] ->
%	    {ok, ["GET", formatRequestUri(RequestURI), [$H,$T,$T,$P,$/,$1,$.,N], RequestLine,
%		 ParsedHeader,EntityBody]};
%%	["POST", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] ->
%	    {ok, ["POST", formatRequestUri(RequestURI), [$H,$T,$T,$P,$/,$1,$.,N], RequestLine,
%		 ParsedHeader, EntityBody]};
%	[Method, RequestURI] ->
%	    {not_implemented, RequestLine, Method, RequestURI,ParsedHeader,"HTTP/0.9"};
%	[Method, RequestURI, HTTPVersion] ->
%	    {not_implemented, RequestLine, Method, RequestURI,ParsedHeader, HTTPVersion};
%	{bad_request, Reason} ->
%	    {bad_request, Reason};
%	Reason ->
%	    {bad_request, "Unknown request method"}
%    end.

hsplit(Accu,[]) ->
    {lists:reverse(Accu), []};
hsplit(Accu, [ $\r, $\n, $\r, $\n | Tail]) ->
    {lists:reverse(Accu), Tail};
hsplit(Accu, [H|T]) ->
    hsplit([H|Accu],T).