Commit 069e0b79 authored by Bas Lijnse's avatar Bas Lijnse

Added a subserver wrapper option to the http library. It should however only...

Added a subserver wrapper option to the http library. It should however only be used in experimental environments, because it is based on the undocumented CleanServer API, instead of stable pure Clean libraries.

Also moved the makeResponse function in the HttpServer, HttpCGI and HttpSubServer modules to a unified http_makeResponse function in HttpUtil


git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@129 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 1265a713
module example
import Http, HttpServer, HttpCGI, HttpUtil
import Http, HttpServer, HttpCGI, HttpUtil, HttpSubServer
import StdString, StdList, StdArray, StdInt
//serverFunction = http_startServer
//serverOptions = [HTTPServerOptPort 80, HTTPServerOptStaticFallback True, HTTPServerOptParseArguments True]
serverFunction = http_startCGI
serverOptions = [HTTPCGIOptParseArguments True]
serverFunction = http_startServer
serverOptions = [HTTPServerOptPort 80, HTTPServerOptStaticFallback True, HTTPServerOptParseArguments True]
//serverFunction = http_startCGI
//serverOptions = [HTTPCGIOptParseArguments True]
//serverFunction = http_startSubServer
//serverOptions = [HTTPSubServerOptPort 80, HTTPSubServerOptStaticFallback True, HTTPSubServerOptParseArguments True]
Start :: *World -> *World
Start world = serverFunction serverOptions [ ((==) "/debug",debug)
, ((==) "/upload", upload)
......
......@@ -32,7 +32,7 @@ http_startCGI options handlers world
client_name = getClientName}
# request = if (getParseOption options) (http_parseArguments request) request
# (response,world) = makeResponse options request handlers world
# (response,world) = http_makeResponse request handlers (getStaticOption options) world
# (response,world) = http_encodeResponse response False world
# (ok,console) = freopen console FWriteData
# console = fwrites response console
......@@ -67,15 +67,6 @@ makeHeaders [(name,envname):xs]
= case value of EnvironmentVariableUndefined = makeHeaders xs
(EnvironmentVariable v) = [(name,v): makeHeaders xs]
// Calls the request handler for a request and returns the generated response
makeResponse :: [HTTPCGIOption] HTTPRequest [((String -> Bool),(HTTPRequest *World -> (HTTPResponse, *World)))] *World -> (HTTPResponse, *World)
makeResponse options request [] world //None of the request handlers matched
= if (getStaticOption options)
(http_staticResponse request world) (http_notfoundResponse request world)
makeResponse options request [(pred,handler):rest] world
| (pred request.req_path) = handler request world //Apply handler function
= makeResponse options request rest world //Search the rest of the list
getStaticOption :: [HTTPCGIOption] -> Bool
getStaticOption [] = False
getStaticOption [x:xs] = case x of (HTTPCGIOptStaticFallback b) = b
......
......@@ -70,7 +70,7 @@ loop options handlers listener rchannels schannels requests world
| method_done && headers_done && data_done
# request = if (getParseOption options) (http_parseArguments request) request
// Create a response
# (response,world) = makeResponse options request handlers world
# (response,world) = http_makeResponse request handlers (getStaticOption options)world
// Encode the response to the HTTP protocol format
# (reply, world) = http_encodeResponse response True world
// Send the encoded response to the client
......@@ -124,15 +124,6 @@ addRequestData req requestline_done headers_done data_done data
= (req,True,True,True,False) //We have all data and are done
//Data is added while we were already done
= (req,True,True,True,False)
// Calls the request handler for a request and returns the generated response
makeResponse :: [HTTPServerOption] HTTPRequest [((String -> Bool),(HTTPRequest *World -> (HTTPResponse, *World)))] *World -> (HTTPResponse, *World)
makeResponse options request [] world //None of the request handlers matched
= if (getStaticOption options)
(http_staticResponse request world) (http_notfoundResponse request world)
makeResponse options request [(pred,handler):rest] world
| (pred request.req_path) = handler request world //Apply virtual page function
= makeResponse options request rest world //Search the rest of the list
getPortOption :: [HTTPServerOption] -> Int
......
......@@ -19,6 +19,7 @@ http_parseUrlEncodedArguments :: !String -> [HTTPArgument]
http_parseMultiPartPostArguments :: !HTTPRequest -> ([HTTPArgument],[HTTPUpload])
//Construction of HTTP Response messages
http_makeResponse :: !HTTPRequest [((String -> Bool),(HTTPRequest *World -> (HTTPResponse, *World)))] !Bool !*World -> (!HTTPResponse,!*World)
http_encodeResponse :: !HTTPResponse !Bool !*World -> (!String,!*World)
//Error responses
......
......@@ -148,6 +148,16 @@ where
= s % (start, end)
//Construction of HTTP Response messages
http_makeResponse :: !HTTPRequest [((String -> Bool),(HTTPRequest *World -> (HTTPResponse, *World)))] !Bool !*World -> (!HTTPResponse,!*World)
http_makeResponse request [] fallback world //None of the request handlers matched
= if fallback
(http_staticResponse request world) //Use the static response handler
(http_notfoundResponse request world) //Raise an error
http_makeResponse request [(pred,handler):rest] fallback world
| (pred request.req_path) = handler request world //Apply handler function
= http_makeResponse request rest fallback world //Search the rest of the list
http_encodeResponse :: !HTTPResponse !Bool !*World -> (!String, !*World)
http_encodeResponse {rsp_headers = headers, rsp_data = data} withreply world //When used directly the 'Status' header should be converted to
# (date,world) = getCurrentDate world
......
KERNEL32.DLL
OpenFileMappingA@12
GetCurrentProcessId@0
RtlMoveMemory@12
CreateSemaphoreA@16
ReleaseSemaphore@12
\ No newline at end of file
USER32.DLL
FindWindowA@8
\ No newline at end of file
WSOCK32.DLL
WSACleanup@0
WSAStartup@8
send@16
recv@16
closesocket@4
select@20
shutdown@8
\ No newline at end of file
definition module HttpSubServer
import Http, SubServerUtil
// (c) 2006 Erwin Lips and Jacco van Drunen
// HIO - Breda
// Radboud University Nijmegen
// This is an Http 1.1 SubServer written in Clean
// The SubServer can be linked with a Clean function generating Html code
// It creates a subserver application which can be attached to a Http 1.1 compliant main server.
// This can e.g. be an Apache server, a Microsoft IIS server, or the Clean Http 1.1 server.
// Several SubServers can be attached, and Strings and Files can be communicated
:: HTTPSubServerOption = HTTPSubServerOptPort Int // The port on which the server listens (default is 80)
| HTTPSubServerOptStaticFallback Bool // If all request handlers fail, should the static file handler be tried (default False)
| HTTPSubServerOptParseArguments Bool // Should the query and body of the request be parsed (default True)
| HTTPSubServerOptMaxServers Int // The maximum number of subserver processes to be started (default is 100)
//Wrapper function similar to http_startServer and http_startCGI
http_startSubServer :: [HTTPSubServerOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World
//The following types and functions can be used to implement a more advanced streaming subserver.
//For simple applications, it is advisable to just use the http_startSubServer wrapper
:: Socket :== Int;
//required functions
RegisterSubProcToServer :: !Int !Int !Int !String !String -> Int // priority minimum maximum number of subservers
WaitForMessageLoop :: ([String] Int Socket *World -> (Socket,*World)) Socket !*World -> *World
//helper-functions for sending (suggested to use one of these)
SendString :: !String !String ![String] !Socket !*World -> (Socket,*World)
SendFile :: String ![String] !Socket !*World -> (Socket,*World)
//helper-functions for receiving (optional to use one of these)
ReceiveString :: !Int !Int !Socket !*World -> (Int,String,Socket,*World)
ReceiveFile :: !Int !Socket !*File !*World -> (Bool,*File,*World)
//extra functions (do not use these unless you know what you are doing, read the RFC first)
SendDataToClient :: !Socket !{#Char} !*env -> (!Socket,*env);
HTTPdisconnectGracefulC :: !Socket !*env -> *env;
DetectHttpVersionAndClose :: !String !String !Socket !*World -> (Socket,*World)
\ No newline at end of file
implementation module HttpSubServer
import StdEnv, Directory
import Http, HttpUtil, SubServerUtil, Semaphore
import code from "REGEXP.OBJ"
import code from "REGSUB.OBJ"
import code from "REGERROR.OBJ"
import code from "CFUNCLIB.OBJ"
import code from "SUBSERVER.OBJ", library "KERNEL32.TXT", library "USER32.TXT", library "WSOCK32.TXT"
// Create subserver talking to an http 1.1 server.
// One needs to create several copies of the same subserver to handle parallel request issues by an http 1.1 server.
// To prevent race conditions, calls to such a subserver copy is serialized using a semaphore.
// This wrapper function works like the http_startServer and http_startCGI functions
http_startSubServer :: [HTTPSubServerOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World
http_startSubServer options handlers world
# result = RegisterSubProcToServer 1 0 (getMaxServersOption options) ".*" ".*" //Handle all requests
| result == 1
# (console,world) = stdio world
# (_,world) = fclose (fwrites ("Error: SubServer could *NOT* be registered to an HTTP 1.1 main server\n") console) world
= world
| result == 2
# (console,world) = stdio world
# (_,world) = fclose (fwrites ("SubServer successfully registered to an HTTP 1.1 main server\n") console) world
= world
# (semaphore,world) = CreateSemaphore 0 1 1 "HttpSubServer" world
| semaphore == 0 = abort "CreateSemaphore failed"
# world = WaitForMessageLoop (callback semaphore handlers) (getPortOption options) world
# (ok,world) = CloseHandle semaphore world
| ok==0 = abort "CloseHandle failed"
= world
where
callback :: !Int [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] [String] Int Socket *World -> (Socket, *World)
callback semaphore handlers header contentlength socket world
# (alldatareceived,datafromclient,socket,world) = ReceiveString 0 contentlength socket world
# (method,path,query,version, ok) = http_parseRequestLine (hd header)
# headers = [hdr \\ (hdr, error) <- map http_parseHeader (tl header) | not error]
# request = {http_emptyRequest & req_method = method
, req_path = path
, req_query = query
, req_version = version
, req_headers = headers
, req_data = datafromclient
}
# request = if (getParseOption options) (http_parseArguments request) request
| socket==0 = (0,world) //socket closed or timed out
| alldatareceived == -1
# (response,world) = indivisable options request handlers world
# (response,world) = http_encodeResponse response True world
= SendDataToClient socket response world
| alldatareceived <> 0
= SendString "Unexpected request" "text/plain" header socket world
# (response,world) = indivisable options request handlers world
# (response,world) = http_encodeResponse response True world
= SendDataToClient socket response world
where
indivisable options request handlers world
# (_,world) = WaitForSingleObject semaphore -1 world
# (response,world) = http_makeResponse request handlers (getStaticOption options) world
# (_,world) = ReleaseSemaphore semaphore 1 0 world
= (response,world)
getPortOption :: [HTTPSubServerOption] -> Int
getPortOption [] = 80
getPortOption [x:xs] = case x of (HTTPSubServerOptPort port) = port
_ = getPortOption xs
getStaticOption :: [HTTPSubServerOption] -> Bool
getStaticOption [] = False
getStaticOption [x:xs] = case x of (HTTPSubServerOptStaticFallback b) = b
_ = getStaticOption xs
getParseOption :: [HTTPSubServerOption] -> Bool
getParseOption [] = True
getParseOption [x:xs] = case x of (HTTPSubServerOptParseArguments b) = b
_ = getParseOption xs
getMaxServersOption :: [HTTPSubServerOption] -> Int
getMaxServersOption [] = 100
getMaxServersOption [x:xs] = case x of (HTTPSubServerOptMaxServers num) = num
_ = getMaxServersOption xs
RegisterSubProcToServer :: !Int !Int !Int !String !String -> Int;
RegisterSubProcToServer _ _ _ _ _ = code{
ccall RegisterSubProcToServer "IIISS:I"
}
WaitForMessage :: (!Bool,!Socket,!String);
WaitForMessage = code{
ccall WaitForMessage ":VIIS"
}
RecvContent :: !Socket !String -> Bool;
RecvContent _ _ = code{
ccall RecvContent "IS:I"
}
HTTPrecvC :: !Socket !String -> Int;
HTTPrecvC _ _ = code{
ccall HTTPrecvC "IS:I"
}
MatchRegExpr :: !String -> Bool;
MatchRegExpr _ = code{
ccall MatchRegExpr "S:I"
}
FreeSharedMem :: !Int !*env -> *env;
FreeSharedMem _ _ = code{
ccall FreeSharedMem "I:V:A"
}
SetContentLength :: !Int !*env -> *env;
SetContentLength _ _ = code{
ccall SetContentLength "I:V:A"
}
SendDataToClient :: !Socket !{#Char} !*env -> (!Socket,*env);
SendDataToClient 0 _ world = (0,world)
SendDataToClient socket data world
# (_,world) = sendAPI socket data (size data) 0 world
= (socket,world)
where
sendAPI :: !Socket !{#Char} !Int !Int !*env -> (!Int,*env);
sendAPI _ _ _ _ _ = code{
ccall send@16 "PIsII:I:A"
}
HTTPdisconnectGracefulC :: !Socket !*env -> *env;
HTTPdisconnectGracefulC _ _ = code{
ccall HTTPdisconnectGracefulC "I:V:A"
}
makeNewString :: !Int -> {#.Char}//function to allocate memory for a new string
makeNewString _ = code inline{
create_array_ CHAR 0 1
}
ReadTotalHeaderFromSocket :: Int [String] Socket !*World -> ([String],Socket,*World)
ReadTotalHeaderFromSocket 0 header socket world//first line (example: GET / HTTP/1.0)
# (newheaderline,socket,world) = ReadHeaderFromSocket socket world
| socket==0 = ([],0,world)
# (newheaderline,socket,world) = case newheaderline of//empty line is allowed at the beginning of a request -> RFC2616 section 4.1
"\r\n" -> ReadHeaderFromSocket socket world
_ -> (newheaderline,socket,world)
| socket==0 = ([],0,world)
# newheaderline = newheaderline % (0,size newheaderline - 3)//remove '\r\n' at the end of the line
# (method,location,getDataArray,version) = GetFirstLine newheaderline
| method=="" || location=="" || version=="" || version % (0,4)<>"HTTP/"//check correctness of the first line
# (socket,world) = SendDataToClient socket "HTTP/1.1 400 Bad Request\r\nConnection: close\r\n\r\n" world
# world = HTTPdisconnectGracefulC socket world
= ([],0,world)
| MatchRegExpr location//match the new location against the regular expression, no match means sending back to mainserver
# (headerlist,socket,world) = ReadTotalHeaderFromSocket 1 (header++[newheaderline]) socket world
| socket==0 = ([],0,world)
# hostname = (GetHeaderData headerlist "HOST:")
| hostname==""
# (socket,world) = SendDataToClient socket "HTTP/1.1 400 Bad Request\r\nConnection: close\r\n\r\n" world
# world = HTTPdisconnectGracefulC socket world
= ([],0,world)
# (socket,world) = SendDataToClient socket "HTTP/1.1 302 Found\r\nConnection: close\r\nLocation: http://" world
# (socket,world) = SendDataToClient socket hostname world
# (socket,world) = SendDataToClient socket location world
# (socket,world) = SendDataToClient socket "\r\nContent-Type: text/plain\r\nContent-Length: 18\r\n\r\nSubserver Redirect" world//a little text is required when using a redirect -> RFC2616 section 10.3.2
# world = HTTPdisconnectGracefulC socket world
= ([],0,world)
= ReadTotalHeaderFromSocket 1 (header++[newheaderline]) socket world
ReadTotalHeaderFromSocket 99 header socket world//reached maximum lines, must be an evil request
= ([],0,HTTPdisconnectGracefulC socket world)
ReadTotalHeaderFromSocket linenumber header socket world
# (newheaderline,socket,world) = ReadHeaderFromSocket socket world
| newheaderline=="\r\n" || socket==0 = (header,socket,world)//stop reading header
# newheaderline = newheaderline % (0,size newheaderline - 3)//remove '\r\n' at the end of the line
= ReadTotalHeaderFromSocket (linenumber+1) (header++[newheaderline]) socket world
ReadHeaderFromSocket :: Socket !*World -> (String,Socket,*World)
ReadHeaderFromSocket socket world
# (success,world) = ReadHeaderFromSocket` world
| success = (data,socket,world)//reading header succeeded
| otherwise = ("",0,HTTPdisconnectGracefulC socket world)//reading header failed
where
data = makeNewString 4092//4092 = sizeof(a page in Windows) - sizeof(int), hope to increase some allocation speed this way
ReadHeaderFromSocket` :: !*World -> (Bool,*World)
ReadHeaderFromSocket` world
# eorl = HTTPrecvC socket data//eorl = short for End Of Read Line
| eorl==2 = (False,world)//line too long, or timeout
| eorl==1 = (True,world)//reached the '\n'
= ReadHeaderFromSocket` world//eorl=0, keep reading the line
WaitForMessageLoop :: ([String] Int Socket *World -> (Socket,*World)) Socket !*World -> *World
WaitForMessageLoop handlefunction 0 world
#! (success,socket,header) = WaitForMessage
| success
#! headerlist = SplitToStringArray header "\r\n"
#! world = FreeSharedMem 0 world//from this point, the same code as below, TODO: replace same code
#! cl = toInt(GetHeaderData headerlist "CONTENT-LENGTH:")
#! encoding = GetHeaderData headerlist "TRANSFER-ENCODING:"
| cl==0 && encoding <> "" && encoding <> "chunked"//only chunked is required, otherwise send 501 Unimplemented -> RFC2616 section 3.6
#! (socket,world) = SendDataToClient socket "HTTP/1.1 501 Unimplemented\r\nConnection: close\r\nContent-Type: text/plain\r\nContent-Length: 27\r\n\r\nOnly Chunked Is Implemented" world//a little text is required when using a 5xx error -> RFC2616 section 10.5
= WaitForMessageLoop handlefunction 0 (HTTPdisconnectGracefulC socket world)
#! cl = case encoding of
"chunked" = -1//-1 represents the chunked mode in both the ReceiveString and the functions in C
_ = cl
#! world = SetContentLength cl world//remember the contentlength in C, so later we check on it to know if there is data on the socket
#! (socket,world) = case (GetHeaderData headerlist "EXPECT:") of
"100-continue" -> SendDataToClient socket "HTTP/1.1 100 Continue\r\n\r\n" world//a client could expect a 100 reply before sending the data -> RFC2616 section 8.2.3
_ -> (socket,world)
#! (socket,world) = handlefunction headerlist cl socket world
= WaitForMessageLoop handlefunction socket world
= world
WaitForMessageLoop handlefunction socket world
#! (headerlist,socket,world) = ReadTotalHeaderFromSocket 0 [] socket world
| socket==0 = WaitForMessageLoop handlefunction 0 world
#! cl = toInt(GetHeaderData headerlist "CONTENT-LENGTH:")
#! encoding = GetHeaderData headerlist "TRANSFER-ENCODING:"
| cl==0 && encoding <> "" && encoding <> "chunked"//only chunked is required, otherwise send 501 Unimplemented -> RFC2616 section 3.6
#! (socket,world) = SendDataToClient socket "HTTP/1.1 501 Unimplemented\r\nConnection: close\r\nContent-Type: text/plain\r\nContent-Length: 27\r\n\r\nOnly Chunked Is Implemented" world//a little text is required when using a 5xx error -> RFC2616 section 10.5
= WaitForMessageLoop handlefunction 0 (HTTPdisconnectGracefulC socket world)
#! cl = case encoding of
"chunked" = -1
_ = cl
#! world = SetContentLength cl world//remember the contentlength in C, so later we check on it to know if there is data on the socket
#! (socket,world) = case (GetHeaderData headerlist "EXPECT:") of
"100-continue" -> SendDataToClient socket "HTTP/1.1 100 Continue\r\n\r\n" world//a client could expect a 100 reply before sending the data -> RFC2616 section 8.2.3
_ -> (socket,world)
#! (socket,world) = handlefunction headerlist cl socket world
= WaitForMessageLoop handlefunction socket world
//gebruikers afhandelfunctie voor het verzenden van een bestand
SendFile :: String ![String] !Socket !*World -> (Socket,*World)
SendFile directory header sock world
# (method,location,getDataArray,version) = GetFirstLine (hd header)
# location = directory +++ CheckLocation location
| location==""
# (sock,world) = SendDataToClient sock (version +++" 404 Not Found\r\nContent-Length: 0\r\n\r\n") world
= DetectHttpVersionAndClose version (GetHeaderData header "Connection:") sock world
# (ok,file,world) = fopen location FReadData world//probeer bestand te openen
| not ok
# (sock,world) = SendDataToClient sock (version +++" 404 Not Found\r\nContent-Length: 0\r\n\r\n") world
= DetectHttpVersionAndClose version (GetHeaderData header "Connection:") sock world
# ((_,path),world)= pd_StringToPath location world
# ((error,info),world)= getFileInfo path world
# {pi_fileInfo=piinfo}=info
# {fileSize=sizeFile}=piinfo
# string = GetHeaderData header "Content-Range:"
| string<>""
# first = FindIndexInString string "-" 0
# firstPoint = toInt(string % (6,first-1))
# tmp = string % (first+1,size string)
# second = FindIndexInString tmp "/" 0
# secondPoint = toInt(tmp % (0,second-1))
# thirdPoint = toInt(tmp % (second+1,size tmp))
| first==(-1) || second ==(-1) || firstPoint >= secondPoint || secondPoint > thirdPoint || secondPoint > (fst sizeFile)
# (sock,world) = SendDataToClient sock "HTTP/1.0 400 Bad Request\r\nContent-Length: 0\r\n\r\n" world
= DetectHttpVersionAndClose version (GetHeaderData header "Connection:") sock world
# (ok,file) = fseek file firstPoint FSeekSet
| not ok
# (sock,world) = SendDataToClient sock (version+++" 501 Internal Server Error\r\nContent-Length: 0\r\n\r\n") world
# (_,world) = fclose file world
= DetectHttpVersionAndClose version (GetHeaderData header "Connection:") sock world
# (sock,world) = SendDataToClient sock (version+++" 206 Partial content\r\n") world
# (sock,world) = SendDataToClient sock ("Content-Range: "+++string+++"\r\n") world
# contentType= getContentTypeGF (location % ((FindIndexInString location "." 0),size location))
# (sock,world) = SendDataToClient sock ("Content-Length: "+++toString(secondPoint-firstPoint)) world
# (sock,world) = SendDataToClient sock ("\r\nAccept-Ranges: bytes\r\n\r\n") world
| method<>"HEAD"
# (sock,file,world) = SendFile` (secondPoint-firstPoint) sock file world
# (_,world) = fclose file world
= DetectHttpVersionAndClose version (GetHeaderData header "Connection:") sock world
# (_,world) = fclose file world
= DetectHttpVersionAndClose version (GetHeaderData header "Connection:") sock world
# contentType= getContentTypeGF (location % ((FindIndexInString location "." 0),size location))
# (sock,world) = SendDataToClient sock (version+++" 200 OK\r\n") world
# (sock,world) = SendDataToClient sock ("Content-Type: "+++contentType+++"\r\n") world
# (sock,world) = SendDataToClient sock ("Content-Length: "+++(toString (fst sizeFile))+++"\r\n\r\n") world
| method<>"HEAD"
# (sock,file,world) = SendFile` (fst sizeFile) sock file world
# (_,world) = fclose file world
= DetectHttpVersionAndClose version (GetHeaderData header "Connection:") sock world
# (_,world) = fclose file world
= DetectHttpVersionAndClose version (GetHeaderData header "Connection:") sock world
SendFile` :: !Int !Socket !*File !*World-> (Socket,*File,*World)//functie die alle gegevens uit een bestand leest
SendFile` bytes sock file world
# read = case (bytes>4096) of
True = 4096
_ = bytes
# (data,file) = freads file read
# (sock,world)= SendDataToClient sock data world
| (bytes-read)==0 = (sock,file,world)
= SendFile` (bytes-read) sock file world
DetectHttpVersionAndClose :: !String !String !Socket !*World -> (Socket,*World)
DetectHttpVersionAndClose version connection sock world
| version=="HTTP/1.0" = (0,HTTPdisconnectGracefulC sock world)
| connection == "close" = (0,HTTPdisconnectGracefulC sock world)
= (sock,world)
SendString :: !String !String ![String] !Socket !*World -> (Socket,*World)
SendString _ _ _ 0 world = (0,world)//called function with a closed socket
SendString str contenttype requestheader sock world
# (method,location,getDataArray,version) = GetFirstLine (hd requestheader)
# (sock,world) = case version of//does not exist in the other SendString function
"HTTP/1.0" -> SendDataToClient sock "HTTP/1.0" world//does not exist in the other SendString function
_ -> SendDataToClient sock "HTTP/1.1" world//does not exist in the other SendString function
| method<>"GET" && method<>"HEAD" && method<>"POST"
# (sock,world) = SendDataToClient sock " 405 Method Not Allowed\r\nAllow: GET, HEAD, POST\r\nConnection: close\r\n\r\n" world//an Allow-field must be present with a 405 error -> RFC2616 section 14.7
= (0,HTTPdisconnectGracefulC sock world)//does not exist in the other SendString function
# (sock,world) = SendDataToClient sock " 200 OK\r\nContent-Type: " world
# (sock,world) = SendDataToClient sock contenttype world
# (sock,world) = SendDataToClient sock "\r\nContent-Length: " world
# strsize = (toString (size str))
# (sock,world) = SendDataToClient sock strsize world
# (sock,world) = SendDataToClient sock "\r\n\r\n" world
# (sock,world) = case method of
"HEAD" -> (sock,world)
_ -> SendDataToClient sock str world
= DetectHttpVersionAndClose version (GetHeaderData requestheader "CONNECTION:") sock world
ReadChunkSize :: !Socket !*World -> (Int,Socket,*World)
ReadChunkSize sock world
# (data,sock,world) = ReadHeaderFromSocket sock world
= (HexLineToInt (fromString (data % (0,size data - 3))),sock,world)
ReadChunkData :: !Int !Socket !*World -> (String,Socket,*World)
ReadChunkData 0 sock world = ("",sock,world)//reached the end of the chunked data
ReadChunkData _ 0 world = ("",0,world)//function called with a closed socket
ReadChunkData chunksize sock world
# world = SetContentLength chunksize world//set to the actuall size, so RecvContent (in C) won't get stuck on it
# (_,chunkdata,sock,world) = ReceiveString chunksize 1 sock world
# world = SetContentLength 0 world//set to 0, so ReadHeaderFromSocket won't get stuck on it
# (_,sock,world) = ReadHeaderFromSocket sock world//read an empty line
# (chunksize,sock,world) = ReadChunkSize sock world
# (newchunkdata,sock,world) = ReadChunkData chunksize sock world
= (chunkdata+++newchunkdata,sock,world)//WARNING: possibly creating giga-strings here
ReceiveString :: !Int !Int !Socket !*World -> (Int,String,Socket,*World)
ReceiveString _ _ 0 world = (-1,"",0,world)//function called with a closed socket
ReceiveString _ 0 sock world = (-1,"",sock,world)//contentlength was zero no data downloaded
ReceiveString _ -1 sock world//-1 means that 'Transfer-Encoding: chunked' is used, chunked is required for all 1.1 apps -> RFC2616 section 3.6.1
# world = SetContentLength 0 world//set to 0, so ReceiveString won't get stuck on it
# (chunksize,sock,world) = ReadChunkSize sock world
# (allchunkdata,sock,world) = ReadChunkData chunksize sock world
| sock==0 = (0,"",0,HTTPdisconnectGracefulC sock world)//stop reading content
# world = SetContentLength -1 world//the ReceiveString messes up the contentlength in C, so set it back
= (0,allchunkdata,sock,world)
ReceiveString expectedlength contentlength sock world
# expectedlength = case expectedlength of
0 -> contentlength//autodetect expected length
_ -> expectedlength
# data = makeNewString expectedlength
| RecvContent sock data = (0,"",0,world)//timed-out or disconnected, close was already done in the RecvContent-function
| expectedlength < contentlength = (contentlength-expectedlength,data,sock,world)
= (0,data,sock,world)
ReceiveFile :: !Int !Socket !*File !*World -> (Bool,*File,*World)
ReceiveFile _ 0 file world = (False,file,world)//called with closed socket
ReceiveFile 0 _ file world = (True,file,world)//called with a contentlength of zero or reached the end of the data
ReceiveFile contentlength socket file world
# (alldatareceived,data,socket,world) = ReceiveString 4096 contentlength socket world
# file = fwrites data file
= ReceiveFile alldatareceived socket file world
\ No newline at end of file