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
This diff is collapsed.
definition module Semaphore
CreateSemaphore :: !Int !Int !Int !{#Char} !*World -> (!Int,!*World);
WaitForSingleObject :: !Int !Int !*World -> (!Int,!*World);
ReleaseSemaphore :: !Int !Int !Int !*World -> (!Int,!*World);
CloseHandle :: !Int !*World -> (!Int,!*World);
implementation module Semaphore;
import StdEnv;
INFINITE :== -1;
// add CreateSemaphoreA@16 and ReleaseSemaphore@12 to kernel_library for Clean 2.2 and older
CreateSemaphore :: !Int !Int !Int !{#Char} !*World -> (!Int,!*World);
CreateSemaphore semaphoreAttributes initialCount maximumCount name world = code {
ccall CreateSemaphoreA@16 "PIIIs:I:A"
}
WaitForSingleObject :: !Int !Int !*World -> (!Int,!*World);
WaitForSingleObject handle milliseconds world = code {
ccall WaitForSingleObject@8 "PII:I:A"
}
ReleaseSemaphore :: !Int !Int !Int !*World -> (!Int,!*World);
ReleaseSemaphore semaphore releaseCount previousCount_p world = code {
ccall ReleaseSemaphore@12 "PIII:I:A"
}
CloseHandle :: !Int !*World -> (!Int,!*World);
CloseHandle handle world = code {
ccall CloseHandle@4 "PI:I:A"
}
Start w
# semaphore_name = "MySemaphoreName";
# (semaphore,world) = CreateSemaphore 0 1 1 semaphore_name w;
| semaphore==0
= abort "CreateSemaphore failed";
# (r,world) = WaitForSingleObject semaphore INFINITE world;
# (stdout,world) = stdio world;
# (ok,c,stdout) = freadc stdout;
# (ok,world) = fclose stdout world;
# (ok,world) = ReleaseSemaphore semaphore 1 0 world;
# (ok,world) = CloseHandle semaphore world;
| ok==0
= abort "CloseHandle failed";
definition module SubServerUtil
// (c) 2005 Paul de Mast
// (c) 2006 Erwin Lips and Jacco van Drunen
// HIO - Breda
// Radboud University Nijmegen
// a collection of utility functions used by the http server / http subserver
import StdEnv, StdMaybe, StdLibMisc
/****************************************************************************
Set of handy http related functions for the end user
****************************************************************************/
GetHeaderData :: [String] *String -> String // Returns method, location, GET data, http version*/
GetFirstLine :: String -> (String,String,[String],String)
HexLineToInt :: [Char] -> Int
URLDecode :: [Char] -> String
CheckLocation :: String -> String
getContentTypeGF :: String -> String
/****************************************************************************
String handling utility functions
****************************************************************************/
CountStringInString :: String String -> Int
StringToUppercase :: Int *String ->*String // Converting a string to a uppercase string, int for begin place in string
TrimString :: String -> String // Removes spaces at beginning and end of a string
FindIndexInString :: String String Int -> Int // Find the index place in the string, based on the second string, int for begin place in first string
ToUniqueString :: String -> *String // Convert a string to a unique string
SplitToStringArray :: String String -> [String] // Split a string in a list of stringd, using on the second string as delimiter
// Example: SplitToStringArray "This:is:a:string" ":" = ["This","is","a","string"]
StringArrayToTupple :: [String] String -> [(String,String)] // Example: StringArrayToTupple ["Name:data","Name1: data1"] ":" = [("Name","data"),("Name1","data1")]
StringArrayCount :: [String] -> Int
CountStringInArray :: [String] String Int -> Int
StringArrayToString :: [String] String -> String
/****************************************************************************
as -- bs removes all elements in bs from as
****************************************************************************/
(--) infixl 5 :: [a] [a] -> [a] | Eq a
/**********************************************************************
General sorting and ordening of a list of elements
***********************************************************************/
sortOn :: [(t t -> Bool)] [t] -> [t]
groupOn :: [t -> a] [t] -> [[t]] | ==, < a
splitWith :: (a -> Bool) [a] -> ([a], [a])
/**********************************************************************
Some String utilities:
***********************************************************************/
/* words string = list of words in the string */
words :: !a -> [String] | toString a
wordsWith :: !.Char !String -> [String]
/* a String is split in a part until the seperator and the rest */
splitAfter :: !.Char !String -> (!String,!String)
cSplit :: !.Char !String -> (!String,!String)
sSplit :: !String !String -> (!String,!String)
/* flatWith listOfStrings seperator stringlist = concatenates strings with seperator */
flatWith :: !a ![b] -> String | toString a & toString b
/* endWith listOfStrings suffix stringlist = concatenates strings with suffix after each string*/
endWith :: !a ![b] -> String | toString a & toString b
/* unwords = flatWith ' ' */
unwords :: ![a] -> String | toString a
/* unlines = flatWith '\n' */
unlines :: ![a] -> String | toString a
trim :: String -> String // remove whitespace at start and end of a String
trimQuotes :: String -> String // ""text"" -> "text"
substring :: String String -> Bool
match :: String String -> Bool
stringToUpper :: String -> String
stringToLower :: String -> String
/**********************************************************************
Instances on Maybe:
***********************************************************************/
instance < (Maybe a) | < a
instance toString (Maybe a) | toString a
/**********************************************************************
To read all the characters from one File in one readacces
returns: a String containing all characters in a file
***********************************************************************/
readFile :: *File -> (String, *File)
/**********************************************************************
To read all the lines from one File
returns: a list of lines without the "\n"
***********************************************************************/
readStrings :: *File -> ([String], *File)
/**********************************************************************
To save a list of files: [(fileName,fileContents)]
***********************************************************************/
exportFiles :: [(String,String)] *Files -> ([String],*Files)
/**********************************************************************
Some funtion from the Haskell prelude:
***********************************************************************/
// from the Haskell prelude:
(hseq) infixr 0 :: !.a .b -> .b
($) infixr 0
($) f x :== f x
instance == (Either a b) | == a & == b
lookup :: a [(a,.b)] -> Maybe .b | == a;
foldr1 :: (.a -> .(.a -> .a)) ![.a] -> .a;
concatMap :: (.a -> [w:b]) -> u:([.a] -> v:[w:b]), [u <= v, u <= w]
fromMaybe :: a (Maybe a) -> a
This diff is collapsed.
This diff was suppressed by a .gitattributes entry.
This diff was suppressed by a .gitattributes entry.
This diff was suppressed by a .gitattributes entry.
This diff was suppressed by a .gitattributes entry.
definition module registry;
:: RegistryState :== Int;
KEY_READ:==0x20019;
KEY_SET_VALUE:==2;
KEY_ALL_ACCESS:==0xF002f;
REG_OPTION_NON_VOLATILE:==0;
REG_SZ:==1;
REG_BINARY:==3;
ERROR_SUCCESS:==0;
HKEY_CURRENT_USER :== 0x80000001;
HKEY_LOCAL_MACHINE :== 0x80000002;
RegOpenKeyEx :: !Int !{#Char} !Int !Int !RegistryState -> (!Int,!Int,!RegistryState);
RegDeleteKey :: !Int !{#Char} !RegistryState-> (!Int,!RegistryState);
RegCloseKey :: !Int !RegistryState -> (!Int,!RegistryState);
RegCreateKeyEx :: !Int !{#Char} !Int !{#Char} !Int !Int !Int !RegistryState -> (!Int,!Int,!Int,!RegistryState);
RegSetValueEx ::
!Int
!{#Char}
!Int
!Int
!{#Char}
!Int
!RegistryState -> (!Int,!RegistryState);
RegQueryValueEx ::
!Int
!{#Char}
!Int
!Int
!{#Char}
!{#Char}
!RegistryState -> (!Int,!RegistryState);
RegEnumValue :: !Int !Int !Int !Int !Int !RegistryState -> (!Int,!{#Char},!Int,!{#Char},!RegistryState);
//==> the following don't really belong here...
GetFileAttributes :: !{#Char} -> Int;
:: CStringP :== Int;
GetCommandLine :: CStringP;
read_char :: !CStringP -> Char;
implementation module registry;
import StdArray,StdInt,StdClass,StdString,StdBool,StdChar;
import code from library "registry_advapi32_library";
:: RegistryState :== Int;
KEY_READ:==0x20019;
KEY_SET_VALUE:==2;
KEY_ALL_ACCESS:==0xF002f;
REG_OPTION_NON_VOLATILE:==0;
REG_SZ:==1;
REG_BINARY:==3;
ERROR_SUCCESS:==0;
HKEY_LOCAL_MACHINE:==0x80000002;
RegOpenKeyEx :: !Int !{#Char} !Int !Int !RegistryState -> (!Int,!Int,!RegistryState);
RegOpenKeyEx hkey path n f rs = code {
ccall RegOpenKeyExA@20 "PIsII:II"
};
RegDeleteKey :: !Int !{#Char} !RegistryState-> (!Int,!RegistryState);
RegDeleteKey hkey path rs = code {
ccall RegDeleteKeyA@8 "PIs:I"
};
RegCloseKey :: !Int !RegistryState -> (!Int,!RegistryState);
RegCloseKey hkey rs = code {
ccall RegCloseKey@4 "PI:I"
};
RegCreateKeyEx :: !Int !{#Char} !Int !{#Char} !Int !Int !Int !RegistryState -> (!Int,!Int,!Int,!RegistryState);
RegCreateKeyEx hkey path i s i1 i2 i3 rs = code {
ccall RegCreateKeyExA@36 "PIsIsIII:III"
};
RegSetValueEx :: !Int !{#Char} !Int !Int !{#Char} !Int !RegistryState -> (!Int,!RegistryState);
RegSetValueEx hkey s1 i1 i2 s2 i3 rs = code {
ccall RegSetValueExA@24 "PIsIIsI:I"
};
RegQueryValueEx :: !Int !{#Char} !Int !Int !{#Char} !{#Char} !RegistryState -> (!Int,!RegistryState);
RegQueryValueEx hkey s1 i1 i2 s2 i3 rs = code {
ccall RegQueryValueExA@24 "PIsIIss:I:I"
};
/*
RegEnumValue :: !Int !Int !Int !Int !Int !RegistryState -> (!Int,!{#Char},!Int,!{#Char},!RegistryState);
RegEnumValue key index max_value_name_size reserved max_data_size rs
# value_name = createArray max_value_name_size '0';
# data = createArray max_data_size '0';
# type_s = createArray 4 '\0';
# value_name_size_s = { toChar max_value_name_size,
toChar (max_value_name_size>>8),
toChar (max_value_name_size>>16),
toChar (max_value_name_size>>24) };
# data_size_s = { toChar max_data_size,
toChar (max_data_size>>8),
toChar (max_data_size>>16),
toChar (max_data_size>>24) };
# (r,rs) = RegEnumValue_ key index value_name value_name_size_s reserved type_s data data_size_s rs;
| r<>0
= (r,"",0,"",rs);
# data_size = string4_to_int data_size_s;
# value_name_size = string4_to_int value_name_size_s;
# type = string4_to_int type_s;
| type==REG_SZ && data_size<>0
= (r,value_name % (0,value_name_size-1),type,data % (0,data_size-2),rs);
= (r,value_name % (0,value_name_size-1),type,data % (0,data_size-1),rs);
string4_to_int :: !{#Char} -> Int;
string4_to_int s
= toInt s.[0] + (toInt s.[1]<<8) + (toInt s.[2]<<16) + (toInt s.[3]<<24);
RegEnumValue_ :: !Int !Int !{#Char} !{#Char} !Int !{#Char} !{#Char} !{#Char} !RegistryState -> (!Int,!RegistryState);
RegEnumValue_ key index value_name value_name_size reserved type data data_size rs
= code {
ccall RegEnumValueA@32 "PIIssIsss:I:I"
}
*/
RegEnumValue :: !Int !Int !Int !Int !Int !RegistryState -> (!Int,!{#Char},!Int,!{#Char},!RegistryState);
RegEnumValue key index max_value_name_size reserved max_data_size rs
# value_name = createArray max_value_name_size '0';
# data = createArray max_data_size '0';
# type_s = { 0 };
# value_name_size_s = { max_value_name_size };
# data_size_s = { max_data_size };
# (r,rs) = RegEnumValue_ key index value_name value_name_size_s reserved type_s data data_size_s rs;
| r<>0
= (r,"",0,"",rs);
# data_size = data_size_s.[0];
# value_name_size = value_name_size_s.[0];
# type = type_s.[0];
| type==REG_SZ && data_size<>0
= (r,value_name % (0,value_name_size-1),type,data % (0,data_size-2),rs);
= (r,value_name % (0,value_name_size-1),type,data % (0,data_size-1),rs);
RegEnumValue_ :: !Int !Int !{#Char} !{#Int} !Int !{#Int} !{#Char} !{#Int} !RegistryState -> (!Int,!RegistryState);
RegEnumValue_ key index value_name value_name_size reserved type data data_size rs
= code {
ccall RegEnumValueA@32 "PIIsAIAsA:I:I"
}
GetFileAttributes :: !{#Char} -> Int;
GetFileAttributes file_name = code {
ccall GetFileAttributesA@4 "Ps:I"
};
:: CStringP :== Int;
GetCommandLine :: CStringP;
GetCommandLine = code {
ccall GetCommandLineA@0 "P:I"
};
read_char :: !CStringP -> Char;
read_char p = code {
instruction 15
instruction 182
instruction 0 | movzx eax,byte ptr [eax]
};
module remove_subservers_in_registry;
import StdEnv,registry;
REGLOCATION :== "SOFTWARE\\Clean HTTP\0";
ERROR_FILE_NOT_FOUND:== 2;
ERROR_ACCESS_DENIED :== 5;
Start w
# rs=0;
# (stdout,w) = stdio w;
# (r,key,rs) = RegOpenKeyEx HKEY_LOCAL_MACHINE REGLOCATION 0 KEY_ALL_ACCESS rs;
| r==ERROR_FILE_NOT_FOUND
# stdout = fwrites "No subservers are stored in the registry\n" stdout;
= snd (fclose stdout w);
| r<>0
| r==ERROR_ACCESS_DENIED
= abort ("RegOpenKeyEx failed with error code "+++toString r+++" (access denied)");
= abort ("RegOpenKeyEx failed with error code "+++toString r);
# (r,rs) = RegCloseKey key rs;
| r<>0
= abort ("RegCloseKey failed with error code "+++toString r);
# (r,rs) = RegDeleteKey HKEY_LOCAL_MACHINE REGLOCATION rs;
| r<>0
= abort ("RegDeleteKey failed with error code "+++toString r);
# stdout = fwrites "The subservers have been removed from the registry\n" stdout;
= snd (fclose stdout w);
module subservers_in_registry;
import StdEnv,registry;
REGLOCATION :== "SOFTWARE\\Clean HTTP\0";
ERROR_FILE_NOT_FOUND:== 2;
ERROR_ACCESS_DENIED :== 5;
ERROR_NO_MORE_ITEMS :== 259;
Start w
# rs=0;
# (stdout,w) = stdio w;
# (r,key,rs) = RegOpenKeyEx HKEY_LOCAL_MACHINE REGLOCATION 0 KEY_ALL_ACCESS rs;
| r==ERROR_FILE_NOT_FOUND
# stdout = fwrites "No subservers are stored in the registry\n" stdout;
= snd (fclose stdout w);
| r<>0
| r==ERROR_ACCESS_DENIED
= abort ("RegOpenKeyEx failed with error code "+++toString r+++" (access denied)");
= abort ("RegOpenKeyEx failed with error code "+++toString r);
# (data,rs) = read_key_data_strings key 0 rs;
# (r,rs) = RegCloseKey key rs;
| r<>0
= abort ("RegCloseKey failed with error code "+++toString r);
| isEmpty data
# stdout = fwrites "No subservers are stored in the registry\n" stdout;
= snd (fclose stdout w);
# stdout = fwrites "The following subservers are stored in the registry:\n" stdout;
# stdout = foldl (\f s -> fwritec '\n' (fwrites s f)) stdout data;
= snd (fclose stdout w);
read_key_data_strings key index rs
# (r,value_name,type,data,rs) = RegEnumValue key index 256 0 4096 rs;
| r==ERROR_NO_MORE_ITEMS
= ([],rs);
| r<>0
= abort ("RegEnumValue failed with error code "+++toString r);
| type==REG_SZ
# (more_data,rs) = read_key_data_strings key (index+1) rs;
= ([data:more_data],rs);
= read_key_data_strings key (index+1) rs;
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment