Commit f9972415 authored by Bas Lijnse's avatar Bas Lijnse
Browse files

Updated the http server to keep IWorld state persistent between HTTP requests....

Updated the http server to keep IWorld state persistent between HTTP requests. (Making future caching possible)

IMPORTANT : Replace TCPChannels module in Libraries/TCPIP with the patched version in iTasks-SDK/Compiler/

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@2082 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent ca0d0907
definition module TCPChannels
// ********************************************************************************
// Clean Standard TCP library, version 1.2.2
//
// StdTCPChannels provides instances to use TCP.
// Author: Martin Wierich
// Modified: 7 September 2001 for Clean 2.0 (Peter Achten)
// ********************************************************************************
import StdString
import TCPDef, TCPChannelClass
from tcp_bytestreams import :: TCP_RCharStream_{..}, :: TCP_SCharStream_{..}
:: TCP_Void = TCP_Void
:: TCP_Pair a b = TCP_Pair a b
// ********************************************************************************
// Listeners
// ********************************************************************************
instance Receive TCP_Listener_
instance closeRChannel TCP_Listener_
/* Receiving on a listener will accept a TCP_DuplexChannel. eom never becomes True
for listeners.
*/
// ********************************************************************************
// TCP send channels
// ********************************************************************************
instance Send TCP_SChannel_
// ********************************************************************************
// TCP receive channels
// ********************************************************************************
instance Receive TCP_RChannel_
instance closeRChannel TCP_RChannel_
instance MaxSize TCP_RChannel_
// ********************************************************************************
// TCP char streams to receive
// ********************************************************************************
:: *TCP_RCharStream :== TCP_RCharStream_ Char
:: *TCP_RCharStreams = TCP_RCharStreams *[TCP_RCharStream]
toRCharStream :: !TCP_RChannel -> TCP_RCharStream
instance Receive TCP_RCharStream_
instance closeRChannel TCP_RCharStream_
// ********************************************************************************
// TCP char streams to send
// ********************************************************************************
:: *TCP_SCharStream :== TCP_SCharStream_ Char
:: *TCP_SCharStreams = TCP_SCharStreams *[TCP_SCharStream]
toSCharStream :: !TCP_SChannel -> TCP_SCharStream
instance Send TCP_SCharStream_
// ********************************************************************************
// establishing connections
// ********************************************************************************
lookupIPAddress :: !String !*env
-> (!Maybe IPAddress, !*env)
| ChannelEnv env
connectTCP_MT :: !(Maybe Timeout) !(!IPAddress,!Port) !*env
-> (!TimeoutReport, !Maybe TCP_DuplexChannel, !*env)
| ChannelEnv env
openTCP_Listener:: !Port !*env
-> (!Bool, !Maybe TCP_Listener, !*env)
| ChannelEnv env
tcpPossible :: !*env
-> (!Bool, !*env)
| ChannelEnv env
/* lookupIPAddress
input String can be in dotted decimal form or alphanumerical. In the latter
case the DNS is called.
connectTCP
tries to establish a TCP connection.
openTCP_Listener
to listen on a certain port.
tcpPossible
whether tcp can be started on this computer.
*/
// ********************************************************************************
// multiplexing
// ********************************************************************************
selectChannel_MT:: !(Maybe Timeout) !*r_channels !*s_channels !*env
-> (![(!Int, !SelectResult)],!*r_channels,!*s_channels,!*env)
| SelectReceive r_channels & SelectSend s_channels & ChannelEnv env
/* selectChannel_MT mbTimeout r_channels s_channels world
determines the first channel on which "something happens".
If the result is an empty list, then the timeout expired, otherwise each
(who,what) element of the result identifies one channel in r_channels or
s_channels. The what value determines whether available/eom/disconnected
on the identified channel would have returned True.
what==SR_Sendable indicates that it is possible to send non blocking on the
identified channel. If r_channels contains r channels and if s_channels
contains s channels, then the following holds:
isMember what [SR_Available,SR_EOM] => 0<=who<r
isMember what [SR_Sendable ,SR_Disconnected] => 0<=who<s
*/
instance == SelectResult
instance toString SelectResult
/* The following classes support the selectChannel_MT function:
*/
class SelectReceive channels where
accRChannels :: (PrimitiveRChannel -> (x, PrimitiveRChannel)) !*channels
-> (![x], !*channels)
getRState :: !Int !*channels !*env
-> (!Maybe SelectResult, !*channels, !*env) | ChannelEnv env
/* accRChannels f channels
applies a function on each channel in channels and returns a list which
contains the result for each application.
getRState
applies available and eom on the channel which is identified by the Int
parameter and returns SR_Available or SR_EOM or Nothing.
*/
class SelectSend channels where
accSChannels :: (TCP_SChannel -> *(.x, TCP_SChannel)) !*channels
-> (![.x], !*channels)
appDisconnected :: !Int !*channels !*env
-> (!Bool, !*channels, !*env) | ChannelEnv env
/* accSChannels
applies a function on each channel in channels and returns a list which
contains the result for each application.
appDisconnected
returns whether disconnected is True for the channel which is identified by
the Int parameter.
*/
class getNrOfChannels channels :: !*channels -> (!Int, !*channels)
/* getNrOfChannels channels
returns the number of channels in channels.
*/
instance SelectReceive TCP_RChannels,TCP_Listeners,TCP_RCharStreams,TCP_Void
instance SelectReceive (TCP_Pair *x *y) | SelectReceive, getNrOfChannels x
& SelectReceive y
instance SelectSend TCP_SChannels,TCP_SCharStreams,TCP_Void
instance SelectSend (TCP_Pair *x *y) | SelectSend, getNrOfChannels x
& SelectSend y
instance getNrOfChannels TCP_RChannels,TCP_Listeners,TCP_RCharStreams,
TCP_SChannels,TCP_SCharStreams,TCP_Void
instance getNrOfChannels (TCP_Pair *x *y) | getNrOfChannels x & getNrOfChannels y
This diff is collapsed.
......@@ -4,7 +4,8 @@ This repository holds the iTasks Software Development Kit (SDK).
= Preparation of the IDE =
- Make sure that this SDK is placed in the folder of the Clean 2.4 32-bit distribution (the one that contains "CleanIDE.exe")
and is called "iTasks-SDK".
- Copy the files "iTasks-SDK/Compiler/StdGeneric.dcl" "iTasks-SDK/Compiler/StdGeneric.icl" and to "Libraries/StdEnv/" (overwriting the existing files)
- Copy the files "iTasks-SDK/Compiler/StdGeneric.dcl" and "iTasks-SDK/Compiler/StdGeneric.icl" to "Libraries/StdEnv/" (overwriting the existing files)
- Copy the files "iTasks-SDK/Compiler/TCPChannels.dcl" and "iTasks-SDK/Compiler/TCPChannels.icl" tp "Libraries/TCPIP/" (overwriting the existing files)
- Start the CleanIDE
- Import the "iTasks" environment by choosing "Environment" -> "Import..." from the menu
and selecting the "iTasks-SDK/Server/iTasks.env" file.
......
......@@ -33,7 +33,7 @@ RELATIVE_LOCATIONS :== [".": take 5 (iterate ((</>) "..") "..")]
* @param The config record
* @param A task to execute
*/
engine :: !FilePath publish -> [(!String -> Bool,!HTTPRequest *World -> (!HTTPResponse, !*World))] | Publishable publish
engine :: publish -> [(!String -> Bool,!HTTPRequest *IWorld -> (!HTTPResponse, !*IWorld))] | Publishable publish
/**
* Wraps a task together with a url to make it publishable by the engine
......@@ -47,6 +47,16 @@ where
instance Publishable (Task a) | iTask a
instance Publishable [PublishedTask]
/**
* Inititialize the iworld
*/
initIWorld :: !FilePath !*World -> *IWorld
/**
* Finalize the iworld
*/
finalizeIWorld :: !*IWorld -> *World
/**
* Determines the server executables path
*/
......
......@@ -10,21 +10,18 @@ import WebService
CLEAN_HOME_VAR :== "CLEAN_HOME"
// The iTasks engine consist of a set of HTTP request handlers
engine :: !FilePath publish -> [(!String -> Bool,!HTTPRequest *World -> (!HTTPResponse, !*World))] | Publishable publish
engine sdkPath publishable
= taskHandlers (publishAll publishable) sdkPath ++ defaultHandlers sdkPath
engine :: publish -> [(!String -> Bool,!HTTPRequest *IWorld -> (!HTTPResponse, !*IWorld))] | Publishable publish
engine publishable
= taskHandlers (publishAll publishable) ++ defaultHandlers
where
taskHandlers published sdkPath
= [((==) url, taskDispatch sdkPath task defaultFormat) \\ {url,task=TaskWrapper task,defaultFormat} <- published]
taskHandlers published
= [((==) url, webService task defaultFormat) \\ {url,task=TaskWrapper task,defaultFormat} <- published]
taskDispatch sdkPath task defaultFormat req world
# iworld = initIWorld sdkPath world
# (response,iworld) = webService task defaultFormat req iworld
= (response, finalizeIWorld iworld)
defaultHandlers sdkPath
= [((==) "/stop", handleStopRequest),(\_ -> True, handleStaticResourceRequest sdkPath)]
defaultHandlers
= [((==) "/stop", handleStopRequest)
,(\_ -> True, handleStaticResourceRequest)
]
initIWorld :: !FilePath !*World -> *IWorld
initIWorld sdkPath world
# (appName,world) = determineAppName world
......@@ -85,17 +82,17 @@ finalizeIWorld iworld=:{IWorld|world} = world
// Request handler which serves static resources from the application directory,
// or a system wide default directory if it is not found locally.
// This request handler is used for serving system wide javascript, css, images, etc...
handleStaticResourceRequest :: !FilePath !HTTPRequest *World -> (!HTTPResponse,!*World)
handleStaticResourceRequest sdkPath req world
handleStaticResourceRequest :: !HTTPRequest *IWorld -> (!HTTPResponse,!*IWorld)
handleStaticResourceRequest req iworld=:{IWorld|sdkDirectory,world}
# (appPath,world) = determineAppPath world
# path = if (req.req_path == "/") "/index.html" req.req_path
# filename = sdkPath </> "Client" </> filePath path
# filename = sdkDirectory </> "Client" </> filePath path
# type = mimeType filename
# (mbContent, world) = readFile filename world
| isOk mbContent = ({rsp_headers = fromList [("Status","200 OK"),
("Content-Type", type),
("Content-Length", toString (size (fromOk mbContent)))]
,rsp_data = fromOk mbContent}, world)
,rsp_data = fromOk mbContent}, {IWorld|iworld & world = world})
# filename = takeDirectory appPath </> "Static" </> filePath path
# type = mimeType filename
# (mbContent, world) = readFile filename world
......@@ -103,15 +100,15 @@ handleStaticResourceRequest sdkPath req world
("Content-Type", type),
("Content-Length", toString (size (fromOk mbContent)))
]
,rsp_data = fromOk mbContent}, world)
= (notFoundResponse req,world)
,rsp_data = fromOk mbContent},{IWorld|iworld & world = world})
= (notFoundResponse req,{IWorld|iworld & world = world})
where
//Translate a URL path to a filesystem path
filePath path = ((replaceSubString "/" {pathSeparator}) o (replaceSubString ".." "")) path
mimeType path = extensionToMimeType (takeExtension path)
handleStopRequest :: HTTPRequest *World -> (!HTTPResponse,!*World)
handleStopRequest req world = ({newHTTPResponse & rsp_headers = fromList [("X-Server-Control","stop")], rsp_data = "Server stopped..."}, world) //Stop
handleStopRequest :: HTTPRequest *IWorld -> (!HTTPResponse,!*IWorld)
handleStopRequest req iworld = ({newHTTPResponse & rsp_headers = fromList [("X-Server-Control","stop")], rsp_data = "Server stopped..."}, iworld) //Stop
path2name path = last (split "/" path)
......
implementation module EngineWrapperStandalone
import StdFile, StdInt, StdList, StdChar, StdBool, StdString
import HTTP, HttpServer, CommandLine, Func
import TCPIP, tcp, HTTP, HttpServer, CommandLine, Func
import Engine
import Engine, IWorld
//Wrapper instance for TCP channels with IWorld
instance ChannelEnv IWorld
where
channelEnvKind iworld=:{IWorld|world}
# (kind,world) = channelEnvKind world
= (kind,{IWorld|iworld & world = world})
mb_close_inet_receiver_without_id b (endpoint,cat) iworld=:{IWorld|world}
= {IWorld|iworld & world = mb_close_inet_receiver_without_id b (endpoint,cat) world}
channel_env_get_current_tick iworld=:{IWorld|world}
# (tick,world) = channel_env_get_current_tick world
= (tick,{IWorld|iworld & world = world})
startEngine :: a !*World -> *World | Publishable a
startEngine publishable world
# (opts,world) = getCommandLine world
......@@ -25,8 +39,9 @@ startEngine publishable world
//Normal execution
# world = show (running port) world
# options = [HTTPServerOptPort port, HTTPServerOptDebug debug]
# world = http_startServer options (engine (fromJust mbSDKPath) publishable) world
= world
# iworld = initIWorld (fromJust mbSDKPath) world
# iworld = http_startServer options (engine publishable) iworld
= finalizeIWorld iworld
where
infoline :: !String -> [String]
infoline app = ["*** " +++ app +++ " HTTP server ***",""]
......
......@@ -7,6 +7,7 @@ from SystemTypes import :: DateTime, :: User, :: Config, :: InstanceNo, :: Task
from Time import :: Timestamp
from TaskState import :: TaskListEntry
from JSON_NG import :: JSONNode
from StdFile import class FileSystem
from SharedDataSource import class registerSDSMsg, class reportSDSChange, class reportSDSChangeFilter
:: *IWorld = { application :: !String // The name of the application
......@@ -28,6 +29,8 @@ from SharedDataSource import class registerSDSMsg, class reportSDSChange, class
, world :: !*World // The outside world
}
instance FileSystem IWorld
instance registerSDSMsg InstanceNo IWorld
instance reportSDSChange IWorld
instance reportSDSChangeFilter InstanceNo IWorld
\ No newline at end of file
......@@ -7,9 +7,29 @@ from SystemTypes import :: DateTime, :: User, :: Config, :: InstanceNo, :: Task
from Time import :: Timestamp
from TaskState import :: TaskListEntry
from JSON_NG import :: JSONNode
from StdFile import class FileSystem(..)
from StdFile import instance FileSystem World
from SharedDataSource import class registerSDSMsg, class reportSDSChange, class reportSDSChangeFilter
import TaskStore
//Wrapper instance for file access
instance FileSystem IWorld
where
fopen filename mode iworld=:{IWorld|world}
# (ok,file,world) = fopen filename mode world
= (ok,file,{IWorld|iworld & world = world})
fclose file iworld=:{IWorld|world}
# (ok,world) = fclose file world
= (ok,{IWorld|iworld & world = world})
stdio iworld=:{IWorld|world}
# (io,world) = stdio world
= (io,{IWorld|iworld & world = world})
sfopen filename mode iworld=:{IWorld|world}
# (ok,file,world) = sfopen filename mode world
= (ok,file,{IWorld|iworld & world = world})
instance registerSDSMsg InstanceNo IWorld
where
registerSDSMsg shareId instanceNo iworld = addShareRegistration shareId instanceNo iworld
......
......@@ -7,6 +7,8 @@ definition module HttpServer
// This module is based upon the original Clean HTTP server by Paul de Mast
import HTTP
from TCPIP import class ChannelEnv
from StdFile import class FileSystem
:: 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)
......@@ -17,5 +19,5 @@ import HTTP
// 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_startServer :: ![HTTPServerOption] [(!(String -> Bool),!(HTTPRequest *st-> (!HTTPResponse,!*st)))] !*st -> *st | ChannelEnv st & FileSystem st
\ No newline at end of file
......@@ -3,6 +3,7 @@ implementation module HttpServer
import StdList, StdTuple, StdArray, StdFile, StdBool, StdMisc
import StdMaybe
import Time
import TCPChannelClass,
TCPChannels,
TCPEvent,
......@@ -16,7 +17,7 @@ from HTTP import instance toString HTTPRequest, instance toString HTTPResponse
from HttpUtil import http_addRequestData, http_parseArguments, http_makeResponse, http_encodeResponse, http_serverControl
//Start the HTTP server
http_startServer :: ![HTTPServerOption] [(!(String -> Bool),!(HTTPRequest *World-> (!HTTPResponse,!*World)))] !*World -> *World
http_startServer :: ![HTTPServerOption] [(!(String -> Bool),!(HTTPRequest *st-> (!HTTPResponse,!*st)))] !*st -> *st | ChannelEnv st & FileSystem st
http_startServer options handlers world
//Start the listener
# (listener,world) = startListener (getPortOption options) world
......@@ -24,7 +25,7 @@ http_startServer options handlers world
= loop options handlers listener [] [] [] world
// Try to open a listener on the given port
startListener :: Int !*World -> (TCP_Listener,!*World)
startListener :: Int !*st -> (TCP_Listener,!*st) | ChannelEnv st
startListener port world
# (success, mbListener, world) = openTCP_Listener port world
| success = (fromJust mbListener,world)
......@@ -34,10 +35,10 @@ startListener port world
//Main event loop, it is called each time a client connects or data arrives
loop :: [HTTPServerOption]
[(!(String -> Bool),!(HTTPRequest *World-> (!HTTPResponse,!*World)))]
[(!(String -> Bool),!(HTTPRequest *st -> (!HTTPResponse,!*st)))]
TCP_Listener [TCP_RChannel] [TCP_SChannel]
[(HTTPRequest,Bool,Bool,Bool)]
*World -> *World
*st -> *st | ChannelEnv st & FileSystem st
loop options handlers listener rchannels schannels requests world
//Join the listener with the open channels
# glue = TCP_Pair (TCP_Listeners [listener]) (TCP_RChannels rchannels)
......@@ -88,7 +89,7 @@ loop options handlers listener rchannels schannels requests world
# world = debug "Generated response:" options world
# world = debug response options world
// Encode the response to the HTTP protocol format
# (reply, world) = http_encodeResponse response True world
# reply = http_encodeResponse response True
// Send the encoded response to the client
# (currentschannel,world) = send (toByteSeq reply) currentschannel world
# world = debug "Sent encoded reply:" options world
......@@ -141,7 +142,7 @@ getDebugOption [] = False
getDebugOption [x:xs] = case x of (HTTPServerOptDebug b) = b
_ = getDebugOption xs
debug:: a [HTTPServerOption] *World -> *World | toString a
debug:: a [HTTPServerOption] *st -> *st | toString a & FileSystem st
debug msg options world
| not (getDebugOption options) = world
# (sio, world) = stdio world
......
definition module HttpUtil
import HTTP
import HTTP, StdFile
//General utility functions
http_splitMultiPart :: !String !String -> [([(String,String)], String)]
......@@ -19,17 +19,18 @@ http_parseUrlEncodedArguments :: !String -> [(String,String)]
http_parseMultiPartPostArguments :: !HTTPRequest -> (Map String String, Map String 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)
http_makeResponse :: !HTTPRequest ![((String -> Bool),(HTTPRequest *st -> (HTTPResponse, *st)))] !Bool !*st -> (!HTTPResponse,!*st) | FileSystem st
http_addDateHeaders :: !HTTPResponse !*World -> (!HTTPResponse,!*World)
http_encodeResponse :: !HTTPResponse !Bool -> String
//Error responses
http_notfoundResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_forbiddenResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_notfoundResponse :: !HTTPRequest !*st -> (!HTTPResponse, !*st)
http_forbiddenResponse :: !HTTPRequest !*st -> (!HTTPResponse, !*st)
//Static content
http_staticResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_staticFileContent :: !String !*World -> (!Bool, !String, !*World)
http_staticFileMimeType :: !String !*World -> (!String, !*World)
http_staticResponse :: !HTTPRequest !*st -> (!HTTPResponse, !*st) | FileSystem st
http_staticFileContent :: !String !*st -> (!Bool, !String, !*st) | FileSystem st
http_staticFileMimeType :: !String !*st -> (!String, !*st)
//Server control
http_serverControl :: !HTTPResponse -> String
......@@ -4,12 +4,6 @@ import HTTP
import StdArray, StdOverloaded, StdString, StdFile, StdBool, StdInt, StdArray, StdList, StdFunc, StdTuple
import Time, Text, UrlEncoding, Map
mkString :: ![Char] -> *String
mkString listofchar = {c \\ c <- listofchar }
mkList :: !String -> [Char]
mkList string = [c \\ c <-: string ]
http_splitMultiPart :: !String !String -> [([(String,String)], String)]
http_splitMultiPart boundary body
# startindex = indexOf ("--" +++ boundary +++ "\r\n") body //Locate the first boundary
......@@ -145,7 +139,7 @@ where
= s % (start, end)
//Construction of HTTP Response messages
http_makeResponse :: !HTTPRequest ![((String -> Bool),(HTTPRequest *World -> (HTTPResponse, *World)))] !Bool !*World -> (!HTTPResponse,!*World)
http_makeResponse :: !HTTPRequest ![((String -> Bool),(HTTPRequest *st -> (HTTPResponse, *st)))] !Bool !*st -> (!HTTPResponse,!*st) | FileSystem st
http_makeResponse request [] fallback world //None of the request handlers matched
= if fallback
(http_staticResponse request world) //Use the static response handler
......@@ -154,28 +148,16 @@ 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
http_addDateHeaders :: !HTTPResponse !*World -> (!HTTPResponse,!*World)
http_addDateHeaders rsp=:{rsp_headers} world
# (tm,world) = gmTime world
# reply = if withreply
("HTTP/1.0 " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
("Status: " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
# reply = reply +++ ("Date: " +++ (http_getValue "Date" headers (now tm)) +++ "\r\n") //Date
# reply = reply +++ ("Server: " +++ (http_getValue "Server" headers "Clean HTTP 1.0 Server") +++ "\r\n") //Server identifier
# reply = reply +++ ("Content-Type: " +++ (http_getValue "Content-Type" headers "text/html") +++ "\r\n") //Content type header
# reply = reply +++ ("Content-Length: " +++ (toString (size data)) +++ "\r\n") //Content length header
# reply = reply +++ ("Last-Modified: " +++ (http_getValue "Last-Modified" headers (now tm)) +++ "\r\n") //Timestamp for caching
# reply = reply +++ (foldr (+++) "" [(n +++ ": " +++ v +++ "\r\n") \\ (n,v) <- toList headers | not (skipHeader n)]) //Additional headers
# reply = reply +++ "\r\n" //Separator
# reply = reply +++ data //data
= (reply, world)
# now = format tm
# rsp_headers = put "Date" now rsp_headers
# rsp_headers = put "Last-Modified" now rsp_headers
= ({rsp & rsp_headers = rsp_headers},world)
where
//Do not add these headers two times
skipHeader s = isMember s ["Status","Date","Server","Content-Type","Content-Length","Last-Modified"]
//Format the current date/time
now tm = (weekday tm.wday) +++ ", " +++ (toString tm.mday) +++ " " +++ (month tm.mon) +++ " " +++ (toString (tm.year + 1900)) +++ " "
format tm = (weekday tm.wday) +++ ", " +++ (toString tm.mday) +++ " " +++ (month tm.mon) +++ " " +++ (toString (tm.year + 1900)) +++ " "
+++ (toString tm.hour) +++ ":" +++ (toString tm.min) +++ ":" +++ (toString tm.sec) +++ " GMT"
weekday 0 = "Sun"
......@@ -198,17 +180,33 @@ where
month 9 = "Oct"
month 10 = "Nov"
month 11 = "Dec"
http_encodeResponse :: !HTTPResponse !Bool -> String
http_encodeResponse {rsp_headers = headers, rsp_data = data} withreply //When used directly the 'Status' header should be converted to
# reply = if withreply
("HTTP/1.0 " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
("Status: " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
# reply = reply +++ ("Server: " +++ (http_getValue "Server" headers "Clean HTTP 1.0 Server") +++ "\r\n") //Server identifier
# reply = reply +++ ("Content-Type: " +++ (http_getValue "Content-Type" headers "text/html") +++ "\r\n") //Content type header
# reply = reply +++ ("Content-Length: " +++ (toString (size data)) +++ "\r\n") //Content length header
# reply = reply +++ (foldr (+++) "" [(n +++ ": " +++ v +++ "\r\n") \\ (n,v) <- toList headers | not (skipHeader n)]) //Additional headers
# reply = reply +++ "\r\n" //Separator
# reply = reply +++ data //data
= reply
where
//Do not add these headers two times
skipHeader s = isMember s ["Status","Server","Content-Type","Content-Length"]
//Error responses
http_notfoundResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_notfoundResponse :: !HTTPRequest !*st -> (!HTTPResponse, !*st)
http_notfoundResponse req world = ({rsp_headers = put "Status" "404 Not Found" newMap, rsp_data = "404 - Not found"}, world)
http_forbiddenResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_forbiddenResponse :: !HTTPRequest !*st -> (!HTTPResponse, !*st)
http_forbiddenResponse req world = ({rsp_headers = put "Status" "403 Forbidden" newMap, rsp_data = "403 - Forbidden"}, world)
//Static content
http_staticResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_staticResponse :: !HTTPRequest !*st -> (!HTTPResponse, !*st) | FileSystem st
http_staticResponse req world
# filename = req.req_path % (1, size req.req_path) //Remove first slash
# (type, world) = http_staticFileMimeType filename world
......@@ -219,7 +217,7 @@ http_staticResponse req world
("Content-Length", toString (size content))]