Skip to content

GitLab

I
iTasks-SDK
Commit 18a34db3 authored by Bas Lijnse's avatar Bas Lijnse
Browse files
Options

Added Http library. This library contains an HTTP server and CGI Wrapper which... 

Added Http library. This library contains an HTTP server and CGI Wrapper which are meant to replace the old CleanServer HTTP1.0 server and HTTP1.1 subserver.


git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@125 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent ce130e67
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 744 additions and 0 deletions
Http/Examples/example.icl 0 → 100644
View file @ 18a34db3
module example
import Http, HttpServer, HttpCGI, HttpUtil
import StdString, StdList, StdArray, StdInt
//serverFunction = http_startServer
//serverOptions = [HTTPServerOptPort 80, HTTPServerOptStaticFallback True, HTTPServerOptParseArguments True]
serverFunction = http_startCGI
serverOptions = [HTTPCGIOptParseArguments True]
Start :: *World -> *World
Start world = serverFunction serverOptions [ ((==) "/debug",debug)
, ((==) "/upload", upload)
, ((==) "/show",show)
, ( \_ -> True, http_staticResponse)
] world
welcome :: HTTPRequest *World -> (HTTPResponse, *World)
welcome req world = ({http_emptyResponse & rsp_data = body},world)
where
body = "<html><head><title>Clean HTTP Server Example</title></head><body>"
+++ "<a href=\"/upload\">Upload example</a><br />"
+++ "<a href=\"/debug\">Debug page</a><br />"
+++ "</body></html>"
debug :: HTTPRequest *World -> (HTTPResponse, *World)
debug req world = ({http_emptyResponse & rsp_data = body req},world)
where
body req = "<pre>"
+++ "Method: " +++ req.req_method +++ "\n"
+++ "Path: " +++ req.req_path +++ "\n"
+++ "Query: " +++ req.req_query +++ "\n"
+++ "Version: " +++ req.req_version +++ "\n"
+++ "Client Name: " +++ req.client_name +++ "\n"
+++ "Server Name: " +++ req.server_name +++ "\n"
+++ "Server Port: " +++ (toString req.server_port) +++ "\n"
+++ "Headers:\n" +++ (foldr (+++) "" ["\t" +++ n +++ ": " +++ v +++ "\n" \\ (n,v) <- req.req_headers]) +++ "\n"
+++ "Get arguments:\n" +++ (foldr (+++) "" [n +++ " = " +++ v +++ "\n" \\ (n,v) <- req.arg_get]) +++ "\n"
+++ "Post arguments:\n" +++ (foldr (+++) "" [n +++ " = " +++ v +++ "\n" \\ (n,v) <- req.arg_post]) +++ "\n"
+++ "Uploads: \n" +++ (foldr (+++) "" [upl.upl_name +++ " = " +++ upl.upl_filename +++ " (" +++ upl.upl_mimetype +++ ")\n" \\ upl <- req.arg_uploads]) +++ "\n"
+++ "Data:\n" +++ req.req_data +++ "\n"
+++ "</pre>"
upload :: HTTPRequest *World -> (HTTPResponse,*World)
upload req world = ({http_emptyResponse & rsp_data = body req},world)
where
body req = "<html><body><h1>Upload example page</h1> "
+++ "<form method=\"post\" action=\"/show\" enctype=\"multipart/form-data\" >"
+++ "<input name=\"bar\" type=\"file\" />"
+++ "<input type=\"submit\" value=\"Show\" />"
+++ "</form>"
+++ "</body><html>"
show :: HTTPRequest *World -> (HTTPResponse,*World)
show req world
| length req.arg_uploads == 1
# upload = hd req.arg_uploads
# mimetype = upload.upl_mimetype
# body = upload.upl_content
= ({http_emptyResponse & rsp_headers =
[("Content-Type", mimetype)
,("Content-Length",toString (size body))
]
,rsp_data = body
},world)
| otherwise = ({http_emptyResponse & rsp_data = "Something went wrong :("},world)
Http/Http.dcl 0 → 100644
View file @ 18a34db3
definition module Http
// This library defines HTTP related types and functions
import StdString
:: HTTPRequest = { req_method :: String // The HTTP request method (eg. GET, POST, HEAD)
, req_path :: String // The requested location (eg. /foo)
, req_query :: String // The query part of a location (eg. ?foo=bar&baz=42)
, req_version :: String // The http version (eg. HTTP/1.0 or HTTP/1.1)
, req_protocol :: HTTPProtocol // Protocol info, http or https
, req_headers :: [HTTPHeader] // The headers sent with the request parsed into name/value pairs
, req_data :: String // The raw data of the request (without the headers)
, arg_get :: [HTTPArgument] // The arguments passed in the url
, arg_post :: [HTTPArgument] // The arguments passed via the POST method
, arg_uploads :: [HTTPUpload] // Uploads that are sent via the POST method
, server_name :: String // Server host name or ip address
, server_port :: Int // Server port
, client_name :: String // Client host name or ip address
}
:: HTTPProtocol = HTTPProtoHTTP | HTTPProtoHTTPS // The protocol used for a request
:: HTTPHeader :== (String, String) // Headers are parsed into name/value pairs
:: HTTPArgument :== (String, String) // Arguments are parsed into name/value pairs as well
:: HTTPResponse = { rsp_headers :: [HTTPHeader] // Extra return headers that should be sent (eg. ("Content-Type","text/plain"))
, rsp_data :: String // The body of the response. (eg. html code or file data)
}
:: HTTPUpload = { upl_name :: String // The name of the file input in the form
, upl_filename :: String // The filename of the uploaded file
, upl_mimetype :: String // The MIME content type of the file
, upl_content :: String // The actual content of the file.
}
//Construction functions which create empty records
http_emptyRequest :: HTTPRequest
http_emptyResponse :: HTTPResponse
http_emptyUpload :: HTTPUpload
//Lookup a value in a list of arguments or headers. When the argument or header is not found
//return the default value.
//Eg: foo = http_getValue "foo" arguments 0
http_getValue :: String [(String, String)] a -> a | fromString a
\ No newline at end of file
Http/Http.icl 0 → 100644
View file @ 18a34db3
implementation module Http
import StdOverloaded, StdString, StdList
http_emptyRequest :: HTTPRequest
http_emptyRequest = { req_method = ""
, req_path = ""
, req_query = ""
, req_version = ""
, req_protocol = HTTPProtoHTTP
, req_headers = []
, req_data = ""
, arg_get = []
, arg_post = []
, arg_uploads = []
, server_name = ""
, server_port = 0
, client_name = ""
}
http_emptyResponse :: HTTPResponse
http_emptyResponse = { rsp_headers = []
, rsp_data = ""
}
http_emptyUpload :: HTTPUpload
http_emptyUpload = { upl_name = ""
, upl_filename = ""
, upl_mimetype = ""
, upl_content = ""
}
http_getValue :: String [(String, String)] a -> a | fromString a
http_getValue name values def = hd ([fromString v \\ (n,v) <- values | n == name] ++ [def])
Http/HttpCGI.dcl 0 → 100644
View file @ 18a34db3
definition module HttpCGI
import Http
:: HTTPCGIOption = HTTPCGIOptStaticFallback Bool // If all request handlers fail, should the static file handler be tried (default False)
| HTTPCGIOptParseArguments Bool // Should the query and body of the request be parsed (default True)
http_startCGI :: [HTTPCGIOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World
\ No newline at end of file
Http/HttpCGI.icl 0 → 100644
View file @ 18a34db3
implementation module HttpCGI
import Http, HttpUtil, HttpTextUtil
import StdFile, StdInt, StdBool, StdArray, ArgEnv
//Http headers for which should be checked if they exist in the environment
HTTP_CGI_HEADERS :==[ ("Content-Type","CONTENT_TYPE")
, ("Content-Length","CONTENT_LENGTH")
, ("Content-Encoding","HTTP_CONTENT_ENCODING")
, ("Accept","HTTP_ACCEPT")
, ("User-Agent","HTTP_USER_AGENT")
, ("Host", "HTTP_HOST")
, ("Authorization","HTTP_AUTHORIZATION")
, ("If-Modified-Since","HTTP_IF_MODIFIED_SINCE")
, ("Referer","HTTP_REFERER")
]
//Starts the CGI Wrapper
http_startCGI :: [HTTPCGIOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World
http_startCGI options handlers world
# (console, world) = stdio world
# (ok,console) = freopen console FReadData
# (data, console) = getData getDataLength console //Read post data
# request = {http_emptyRequest & req_method = getFromEnv "REQUEST_METHOD", //Create the request
req_path = getFromEnv "SCRIPT_NAME",
req_query = getFromEnv "QUERY_STRING",
req_version = getFromEnv "SERVER_PROTOCOL",
req_headers = makeHeaders HTTP_CGI_HEADERS,
req_data = data,
server_name = getFromEnv "SERVER_NAME",
server_port = toInt (getFromEnv "SERVER_PORT"),
client_name = getClientName}
# request = if (getParseOption options) (http_parseArguments request) request
# (response,world) = makeResponse options request handlers world
# (response,world) = http_encodeResponse response False world
# (ok,console) = freopen console FWriteData
# console = fwrites response console
# (ok,world) = fclose console world
= world
getDataLength :: Int
getDataLength
# len = getFromEnv "CONTENT_LENGTH"
| len == "" = 0
= toInt len
getData :: !Int !*File -> (!String, !*File)
getData len file = freads file len
getFromEnv :: String -> String
getFromEnv name
# value = getEnvironmentVariable name
= case value of EnvironmentVariableUndefined = ""
(EnvironmentVariable v) = v
getClientName :: String
getClientName
# name = getFromEnv "REMOTE_HOST"
| name == "" = getFromEnv "REMOTE_ADDR"
= name
makeHeaders :: [(String,String)] -> [HTTPHeader]
makeHeaders [] = []
makeHeaders [(name,envname):xs]
# value = getEnvironmentVariable envname
= 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
_ = getStaticOption xs
getParseOption :: [HTTPCGIOption] -> Bool
getParseOption [] = True
getParseOption [x:xs] = case x of (HTTPCGIOptParseArguments b) = b
_ = getParseOption xs
Http/HttpServer.dcl 0 → 100644
View file @ 18a34db3
definition module HttpServer
// This module provides a simple embedded HTTP server.
// It allows the creation of a single threaded server which
// is very suitable for small scale testing of web applications.
// It is not meant for use in a production environment.
//
// This module is based upon the original Clean HTTP server by Paul de Mast
import Http
:: HTTPServerOption = HTTPServerOptPort Int // The port on which the server listens (default is 80)
| HTTPServerOptStaticFallback Bool // If all request handlers fail, should the static file handler be tried (default False)
| HTTPServerOptParseArguments Bool // Should the query and body of the request be parsed (default True)
// Start the HTTP server
// The first argument is a list of server options
// The second argument is a list of pairs of predicates and request handlers
// The predicate inspects the requested path (eg. /foo), if the predicate is true the corresponding request handler is invoked
http_startServer :: [HTTPServerOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World
\ No newline at end of file
Http/HttpServer.icl 0 → 100644
View file @ 18a34db3
implementation module HttpServer
import Http, HttpUtil, HttpTextUtil
import StdList, StdTuple, StdArray, StdFile, StdBool, StdMisc
import StdTCP
//Start the HTTP server
http_startServer :: [HTTPServerOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World
http_startServer options handlers world
//Start the listener
# (listener,world) = startListener (getPortOption options) world
//Enter the endless loop
= loop options handlers listener [] [] [] world
// Try to open a listener on the given port
startListener :: Int !*World -> (TCP_Listener,!*World)
startListener port world
# (success, mbListener, world) = openTCP_Listener port world
| success = (fromJust mbListener,world)
| otherwise = abort ("Error: The server port " +++ (toString port) +++ " is currently occupied!\n" +++
"Probably a previous application is still running and you have forgotten to close it.\n" +++
"It is also possible that another web server running on your machine is using this port.\n\n\n")
//Main event loop, it is called each time a client connects or data arrives
loop :: [HTTPServerOption]
[((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))]
TCP_Listener [TCP_RChannel] [TCP_SChannel]
[(HTTPRequest,Bool,Bool,Bool)]
*World -> *World
loop options handlers listener rchannels schannels requests world
//Join the listener with the open channels
# glue = (TCP_Listeners [listener]) :^: (TCP_RChannels rchannels)
//Select the channel which has data available
# ([(who,what):_],glue,_,world) = selectChannel_MT Nothing glue Void world
//Split the listener from the open channels
# ((TCP_Listeners [listener:_]) :^: (TCP_RChannels rchannels)) = glue
//A new client attempts to connect
| who == 0
# (tReport, mbNewMember, listener, world) = receive_MT (Just 0) listener world
| tReport <> TR_Success = loop options handlers listener rchannels schannels requests world //Just continue
# (ip,{sChannel,rChannel}) = fromJust mbNewMember
# request = {http_emptyRequest & client_name = toString ip, server_port = getPortOption options}
= loop options handlers listener [rChannel:rchannels] [sChannel:schannels] [(request,False,False,False):requests] world
//A client has new data
| otherwise
// Select the offset without the listener
# who = who - 1
// Select the right read channel from the list
# (currentrchannel, rchannels) = selectFromList who rchannels
// Select the right write channel from the list
# (currentschannel, schannels) = selectFromList who schannels
// Select the right incomplete request from the list
# ((request, method_done, headers_done, data_done), requests) = selectFromList who requests
// New data is available
| what == SR_Available
// Fetch the new data from the receive channel
# (data,currentrchannel,world) = receive currentrchannel world
//Add new data to the request
# (request, method_done, headers_done, data_done, error) = addRequestData request method_done headers_done data_done (toString data)
| error
//Sent bad request response and disconnect
# (currentschannel,world) = send (toByteSeq "HTTP/1.0 400 Bad Request\r\n\r\n") currentschannel world
# world = closeRChannel currentrchannel world
# world = closeChannel currentschannel world
= loop options handlers listener rchannels schannels requests world
//Process a completed request
| method_done && headers_done && data_done
# request = if (getParseOption options) (http_parseArguments request) request
// Create a response
# (response,world) = makeResponse options request handlers world
// Encode the response to the HTTP protocol format
# (reply, world) = http_encodeResponse response True world
// Send the encoded response to the client
# (currentschannel,world) = send (toByteSeq reply) currentschannel world
# world = closeRChannel currentrchannel world
# world = closeChannel currentschannel world
= loop options handlers listener rchannels schannels requests world
//We do not have everything we need yet, so continue
| otherwise = loop options handlers listener [currentrchannel:rchannels] [currentschannel:schannels] [(request,method_done, headers_done, data_done):requests] world
//We lost the connection
| otherwise
# world = closeRChannel currentrchannel world
# world = closeChannel currentschannel world
= loop options handlers listener rchannels schannels requests world
where
selectFromList nr list
# (left,[element:right]) = splitAt nr list
= (element,left++right)
//Add new data to a request
addRequestData :: !HTTPRequest !Bool !Bool !Bool !String -> (HTTPRequest, Bool, Bool, Bool, Bool)
addRequestData req requestline_done headers_done data_done data
# req = {req & req_data = req.req_data +++ data} //Add the new data
//Parsing of the request line
| not requestline_done
# index = text_indexOf "\r\n" req.req_data
| index == -1 = (req,False,False,False,False) //The first line is not complete yet
| otherwise
# (method,path,query,version,error) = http_parseRequestLine (req.req_data % (0, index - 1))
| error = (req,False,False,False,True) //We failed to parse the request line
# req = {req & req_method = method, req_path = path, req_query = query, req_version = version, req_data = req.req_data % (index + 2, size req.req_data) }
= addRequestData req True False False "" //We are done with the request line but still need to inspect the rest of the data
//Parsing of headers
| not headers_done
# index = text_indexOf "\r\n" req.req_data
| index == -1 = (req,True,False,False,False) //We do not have a full line yet
| index == 0 //We have an empty line, this means we have received all the headers
# req = {req & req_data = req.req_data % (2, size req.req_data)}
= addRequestData req True True False "" //Headers are finished, continue with the data part
| otherwise
# (header,error) = http_parseHeader (req.req_data % (0, index - 1))
| error = (req,True,False,False,True) //We failed to parse the header
# req = {req & req_headers = [header:req.req_headers], req_data = req.req_data % (index + 2, size req.req_data)}
= addRequestData req True False False "" //We continue to look for more headers
//Addition of data
| not data_done
# datalength = toInt (http_getValue "Content-Length" req.req_headers "0")
| (size req.req_data) < datalength = (req,True,True,False,False) //We still need more 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
getPortOption [] = 80
getPortOption [x:xs] = case x of (HTTPServerOptPort port) = port
_ = getPortOption xs
getStaticOption :: [HTTPServerOption] -> Bool
getStaticOption [] = False
getStaticOption [x:xs] = case x of (HTTPServerOptStaticFallback b) = b
_ = getStaticOption xs
getParseOption :: [HTTPServerOption] -> Bool
getParseOption [] = True
getParseOption [x:xs] = case x of (HTTPServerOptParseArguments b) = b
_ = getParseOption xs
\ No newline at end of file
Http/HttpTextUtil.dcl 0 → 100644
View file @ 18a34db3
definition module HttpTextUtil
//Trim functions
text_trim :: String -> String
text_ltrim :: String -> String
text_rtrim :: String -> String
//Split and join
text_split :: String String -> [String]
text_join :: String [String] -> String
//Searching and replacement
text_indexOf :: String String -> Int
text_replace :: (String,String) String -> String
text_replaceMany :: [(String,String)] String -> String
Http/HttpTextUtil.icl 0 → 100644
View file @ 18a34db3
implementation module HttpTextUtil
import StdOverloaded, StdString, StdArray, StdChar, StdInt, StdBool, StdClass, StdList
//Trim functions
text_trim :: String -> String
text_trim s = text_ltrim (text_rtrim s)
text_ltrim :: String -> String
text_ltrim "" = ""
text_ltrim s
| isSpace s.[0] = if (size s == 1) "" (text_ltrim (s % (1, size s - 1)))
= s
text_rtrim :: String -> String
text_rtrim "" = ""
text_rtrim s
| isSpace s.[size s - 1] = if (size s == 1) "" (text_rtrim (s % (0, size s - 2)))
= s
//Split and join
text_split :: String String -> [String]
text_split sep s
# index = text_indexOf sep s
| index == -1 = [s]
= [s % (0, index - 1): text_split sep (s % (index + (size sep), size s))]
text_join :: String [String] -> String
text_join sep [] = ""
text_join sep [x:[]] = x
text_join sep [x:xs] = x +++ sep +++ (text_join sep xs)
//Searching and replacement
text_indexOf :: String String -> Int
text_indexOf "" haystack = -1
text_indexOf needle haystack = `text_indexOf needle haystack 0
where
`text_indexOf needle haystack n
| (n + size needle) > (size haystack) = -1
| and [needle.[i] == haystack.[n + i] \\ i <- [0..((size needle) - 1)]] = n
= `text_indexOf needle haystack (n + 1)
text_replace :: (String,String) String -> String
text_replace (needle, replacement) s = s
text_replaceMany :: [(String,String)] String -> String
text_replaceMany replacements s = s
Http/HttpUtil.dcl 0 → 100644
View file @ 18a34db3
definition module HttpUtil
import Http
//General utility functions
http_urlencode :: !String -> String
http_urldecode :: !String -> String
http_splitMultiPart :: !String !String -> [([HTTPHeader], String)]
//Parsing of HTTP Request messages
http_parseRequestLine :: !String -> (!String, !String, !String, !String, !Bool)
http_parseHeader :: !String -> (!HTTPHeader, !Bool)
http_parseArguments :: !HTTPRequest -> HTTPRequest
http_parseGetArguments :: !HTTPRequest -> [HTTPArgument]
http_parsePostArguments :: !HTTPRequest -> [HTTPArgument]
http_parseUrlEncodedArguments :: !String -> [HTTPArgument]
http_parseMultiPartPostArguments :: !HTTPRequest -> ([HTTPArgument],[HTTPUpload])
//Construction of HTTP Response messages
http_encodeResponse :: !HTTPResponse !Bool !*World -> (!String,!*World)
//Error responses
http_notfoundResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_forbiddenResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
//Static content
http_staticResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_staticFileContent :: !String !*World -> (!Bool, !String, !*World)
http_staticFileMimeType :: !String !*World -> (!String, !*World)
Http/HttpUtil.icl 0 → 100644
View file @ 18a34db3
This diff is collapsed.
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