Commit d4092218 authored by Rinus Plasmeijer's avatar Rinus Plasmeijer
Browse files

subserver added, although it is not bug free yet....

parent a268a08c
definition module StdHtml
// main portal for generating Clean Web applications using the iData / GEC technique
// (c) 2005 MJP
// top module for generating Clean Web applications using the iData / GEC technique
// (c) 2005 - 2006 MJP
import
......@@ -9,19 +9,18 @@ import
htmlSettings // some global settings
, htmlFormData // general iData type definitions
, htmlHandler // the kernel module for iData creation and handling
, htmlHandler // *the* kernel module for iData creation and handling
, htmlButtons // basic collections of buttons, data types for lay-out control
, htmlFormlib // collection of advanced iData creating functions
, htmlDatabase // collection for storing data, while guarding consistency and versions
, htmlExceptions // collection of global exception handling and storage
, htmlFormlib // collection of advanced iData creating functions
, htmlRefFormlib // collection of persistent idata maintaining sharing
, htmlArrow // arrow instantiations for iData forms
, htmlTask // for easy creation of workflow tasks based on iData
// html code generation:
, htmlDataDef // Clean's ADT representation of Html
......
......@@ -21,11 +21,11 @@ derive bimap Form, FormId
// doHtml main wrapper for generating & handling of a Html form
doHtmlServer :: !(*HSt -> (Html,!*HSt)) !*World -> *World // use this application with the built-in Clean server
// it will combine both into one application : http://localhost/clean;
doHtmlSubServer :: !(!Int,!Int,!Int,!String) !(*HSt -> (Html,!*HSt)) // priority (higher number = higher prio), min number, max number of subservers, location, html code
!*World -> *World // use this application as a subserver in combination with an external (Clean) server;
doHtml :: !.(*HSt -> (Html,!*HSt)) !*World -> *World // use this application with some external server using a php script;
doHtmlServer :: !(*HSt -> (Html,!*HSt)) !*World -> *World // use this application with the built-in Clean server
// it will combine both into one application : http://localhost/clean;
doHtmlSubServer :: !(!Int,!Int,!Int,!String) !(*HSt -> (Html,!*HSt)) // use this application as a subserver in combination with an external (Clean) server;
!*World -> *World // priority (higher number = higher prio), min number, max number of subservers, location, html code
doHtml :: !.(*HSt -> (Html,!*HSt)) !*World -> *World // use this application with some external server using a php script;
// mkViewForm is the *swiss army knife* function creating stateful interactive forms with a view v of data d.
// Make sure that all editors have a unique identifier!
......
......@@ -4,7 +4,7 @@ import StdArray, StdChar, StdList, StdStrictLists, StdString, StdTuple
import ArgEnv, StdMaybe
import htmlDataDef, htmlTrivial, htmlSettings, htmlStylelib, iDataState
import StdGeneric, GenParse, GenPrint
import httpServer
import httpServer, httpSubServer
import Gerda
derive gPrint (,), (,,), (,,,), UpdValue
......@@ -76,8 +76,6 @@ doHtmlServer2 args userpage world
= d_s
= ([],allhtmlcode,world)
import SUBSERVER
doHtmlSubServer :: !(!Int,!Int,!Int,!String) !(*HSt -> (Html,!*HSt)) !*World -> *World
doHtmlSubServer (prio,min,max,location) userpage world
# (console,world) = stdio world
......
definition module httpServer
// (c) 2005 Paul de Mast
// HIO - Breda - The Netherlands
// This is an Http 1.0 Server written in Clean
// The Server has to be used with (a) Clean function(s) which generates Html Code
// Together they are linked into one application !
// So this Server can only communicate with the linked in Clean functions.
// It is not a general purpose server which can communicate with other applications.
// As such this is great for testing Html / iData / iTasks Clean applications.
// StartServer takes a port number + list of virtual pages
StartServer :: Int [(String,(String String Arguments *World -> ([String],String,*World)))] *World -> *World
......
definition module httpSubServer
import httpUtil
:: Socket :== Int;
//required functions
RegisterSubProcToServer :: !Int !Int !Int !String !String -> Int
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 httpUtil
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"
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
definition module httpUtil
// (c) 2005 Paul de Mast
// (c) 2006 Erwin Lips and Jacco van Drunen
// HIO - Breda
// Radboud University Nijmegen
import StdEnv
import StdMaybe
import StdLibMisc
// 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
......@@ -19,7 +49,6 @@ sortOn :: [(t t -> Bool)] [t] -> [t]
groupOn :: [t -> a] [t] -> [[t]] | ==, < a
splitWith :: (a -> Bool) [a] -> ([a], [a])
/**********************************************************************
Some String utilities:
***********************************************************************/
......@@ -57,6 +86,7 @@ stringToLower :: String -> String
/**********************************************************************
Instances on Maybe:
***********************************************************************/
instance < (Maybe a) | < a
instance toString (Maybe a) | toString a
......@@ -64,24 +94,28 @@ 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
......@@ -89,10 +123,7 @@ exportFiles :: [(String,String)] *Files -> ([String],*Files)
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
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
implementation module httpUtil
import StdEnv, StdLib, StdMaybe
/****************************************************************************
Set of handy http related functions for the end user
****************************************************************************/
/*1e method, 2e location, 3e get data, 4e http version*/
GetFirstLine :: String -> (String,String,[String],String)
GetFirstLine firstLine
| length data <>3 = ("","",[],"")
| otherwise
# location=data!!1
# location = case location % (0,6) == "http://" of
True=location % ((FindIndexInString (location % (7,size location)) "/" 0)+7,size location)
_=location
# location = case location == "" of
True="/"
_=URLDecode (fromString location)
# nr = FindIndexInString location "?" 0
| nr==(-1) = (data!!0,location,[],data!!2)
= (data!!0,location % (0,nr-1),(SplitToStringArray (location %(nr+1,size (location)))) "&",data!!2)
where
data = SplitToStringArray firstLine " "
HexLineToInt :: [Char] -> Int
HexLineToInt [a] = toInt(hexToChar a)
HexLineToInt [a,b] = (16 * toInt(hexToChar a)) + HexLineToInt [b]
HexLineToInt [a,b,c] = (256 * toInt(hexToChar a)) + HexLineToInt [b,c]
HexLineToInt [a,b,c,d] = (4096 * toInt(hexToChar a)) + HexLineToInt [b,c,d]
HexLineToInt _ = 0
URLDecode :: [Char] -> String//URLDecode-functie (zet %?? om naar juiste characters, %20 naar spatie bijv.)
URLDecode [] = ""
URLDecode ['%',a,b:tail] = toString ((toChar (16 * toInt (hexToChar a))) + hexToChar b)+++ URLDecode tail
URLDecode ['+':tail]= " "+++URLDecode tail
URLDecode [head:tail] = toString head +++URLDecode tail
hexToChar :: Char -> Char//functie is onderdeel van removeEscapes
hexToChar a
| a >= '0' && a <= '9' = a - '0'
| a >= 'A' && a <= 'F' = a - 'A' + (toChar 10)
| a >= 'a' && a <= 'f' = a - 'a' + (toChar 10)
= toChar 0