Web.icl 8.95 KB
Newer Older
1
implementation module iTasks.Extensions.Web
Camil Staps's avatar
Camil Staps committed
2

3
import iTasks
4
import iTasks.UI.Editor.Controls, iTasks.UI.Editor.Modifiers
5
import Internet.HTTP, Text, Text.HTML, Text.URI, Text.Encodings.MIME, Text.Encodings.UrlEncoding, StdArray, Data.Either
6
import System.Time, System.FilePath
7

8 9
from iTasks.Internal.HttpUtil import http_addRequestData, http_parseArguments
import iTasks.Internal.HtmlUtil
10

11 12
import iTasks.Extensions.Document
import iTasks.Extensions.TextFile
13

14
import qualified Data.Map as DM
15
import Data.Map.GenJSON
16 17
import qualified Data.List as DL

18 19
gText{|URL|}	_ val	= [maybe "" toString val]

20
gEditor{|URL|} = selectByMode
21 22 23
		(comapEditorValue (\(URL s) -> ATag [HrefAttr s] [Text s]) htmlView)
		(bijectEditorValue (\(URL s) -> s) (\s -> URL s) (withDynamicHintAttributes "uniform resource locator (URL)" textField ))
		(bijectEditorValue (\(URL s) -> s) (\s -> URL s) (withDynamicHintAttributes "uniform resource locator (URL)" textField ))
24 25 26 27 28 29 30 31 32 33 34 35 36 37 38

derive JSONEncode		URL
derive JSONDecode		URL
derive gDefault			URL
derive gEq				URL

instance toString URL
where
	toString (URL url) = url

instance html URL
where
	html (URL url) = ATag [HrefAttr url] [Text url]


39
KEEPALIVE_TIME :== {tv_sec=5, tv_nsec=0}
40 41

:: HttpConnState
42
    = Idle String Timespec
43 44 45 46 47 48 49 50 51 52 53
    | ReadingRequest HttpReqState
	| AwaitingResponse String Int Bool

:: HttpReqState =
    { request       :: HTTPRequest
    , method_done   :: Bool
    , headers_done  :: Bool
    , data_done     :: Bool
    , error         :: Bool
    }

Bas Lijnse's avatar
Bas Lijnse committed
54
derive class iTask HttpConnState, HttpReqState, HTTPRequest, HTTPResponse, HTTPMethod, HTTPProtocol, HTTPUpload
55 56 57 58 59 60 61 62 63

serveWebService :: Int (HTTPRequest -> Task HTTPResponse) -> Task ()
serveWebService port handler 
	= withShared []
		\io ->
		manageConnections io -&&- handleRequests io
    @! ()
where
	manageConnections io
Haye Böhm's avatar
Haye Böhm committed
64
		= tcplisten port False (currentTimespec |*< io)
Mart Lubbers's avatar
Mart Lubbers committed
65
			{ConnectionHandlers|onConnect=onConnect,onData=onData,onShareChange=onShareChange,onDisconnect=onDisconnect,onDestroy= \s->(Ok s, [])}
66
			
67
    onConnect connId client_name (now,io)
68 69
		= (Ok (Idle client_name now), Nothing, [], False)

70
    onData data l=:(Idle client_name last) (now,io)
71 72 73 74
		# request = {newHTTPRequest & client_name = client_name, server_port = port}
	 	# (request, method_done, headers_done, data_done, error) = http_addRequestData request False False False data
		# reqs = {HttpReqState|request=request,method_done=method_done,headers_done=headers_done,data_done=data_done,error=error}
		= whileReadingRequest data reqs now io
75
	onData data l=:(ReadingRequest {HttpReqState|request, method_done, headers_done, data_done}) (now,io)
76 77 78 79
		# (request, method_done, headers_done, data_done, error) = http_addRequestData request method_done headers_done data_done (toString data)
		# reqs = {HttpReqState|request=request,method_done=method_done,headers_done=headers_done,data_done=data_done,error=error}
		= whileReadingRequest data reqs now io

80
	onShareChange l=:(AwaitingResponse client_name reqId keepalive) (now,io)
81 82 83 84
		= case getResponse reqId io of
			(Nothing,_) = (Ok l, Nothing, [], False)
			(Just response,io)
				//Add keep alive header if necessary
Bas Lijnse's avatar
Bas Lijnse committed
85
				# response	= if keepalive {HTTPResponse|response & rsp_headers = [("Connection","Keep-Alive"):response.HTTPResponse.rsp_headers]} response
86 87 88
				# reply		= encodeResponse True response
				= (Ok (Idle client_name now), Just io, [reply], keepalive)

89
	onShareChange l=:(Idle client_name last) (now,_) //Close idle connections if the keepalive time passed
90 91
		= (Ok l, Nothing, [], now - last > KEEPALIVE_TIME)

92
    onShareChange l (now,io)
93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
		= (Ok l, Nothing, [], False)

	whileReadingRequest data reqs now io
		| reqs.HttpReqState.error
			//Sent bad request response and disconnect
			= (Ok (Idle reqs.HttpReqState.request.client_name now) , Nothing, ["HTTP/1.1 400 Bad Request\r\n\r\n"], True)
		| not reqs.HttpReqState.headers_done
			//Without headers we can't do anything yet
			= (Ok (ReadingRequest reqs), Nothing, [], False)
		| not reqs.HttpReqState.data_done	
			//For now only support full requests
			= (Ok (ReadingRequest reqs), Nothing, [], False)
		//Queue request to get a response
		# request	= http_parseArguments reqs.HttpReqState.request 
		//Determine if a  persistent connection was requested
		# keepalive	= isKeepAlive request
		//Add the request to be handled and wait
		# (reqId,io) = addRequest request io
		= (Ok (AwaitingResponse request.client_name reqId keepalive), Just io, [], False)

    onDisconnect l _        = (Ok l, Nothing)

Bas Lijnse's avatar
Bas Lijnse committed
115
	isKeepAlive request = maybe (request.HTTPRequest.req_version == "HTTP/1.1") (\h -> (toLowerCase h == "keep-alive")) ('DM'.get "Connection" request.HTTPRequest.req_headers)
116 117 118 119 120 121 122

    encodeResponse autoContentLength response=:{rsp_headers, rsp_data}
	    # rsp_headers = addDefault rsp_headers "Server" "iTasks HTTP Server"
	    # rsp_headers = addDefault rsp_headers "Content-Type" "text/html"
	    # rsp_headers = if autoContentLength
	    					(addDefault rsp_headers "Content-Length" (toString (size rsp_data)))
	    					rsp_headers
Bas Lijnse's avatar
Bas Lijnse committed
123
	    = toString {HTTPResponse|response & rsp_headers = rsp_headers}
124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
    where		
    	addDefault headers hdr val = if (('DL'.lookup hdr headers) =: Nothing) [(hdr,val):headers] headers

	handleRequests io
		= 	forever (
				(watch io @ listRequests) 								 //Watch for unhandled requests
			>>* [OnValue (ifValue (not o isEmpty) (createResponses io))] //Handle the new requests and store responses
			)
	
	createResponses slist requests 
		= 	allTasks [handler req \\ (_,req) <- requests]
		>>- \responses ->
			upd (addResponses [(reqId,rsp) \\ (reqId,_) <- requests & rsp <- responses]) slist
		@! ()
	where
		addResponses [] list = list
		addResponses [(reqId,rsp):rest] list = addResponses rest (addResponse reqId rsp list)
		
//The data structure shared between the management of connections and the actual processing of requests
:: ConnectionList :== [(Int,Either HTTPRequest HTTPResponse)]
:: RequestId 	:== Int

addRequest :: HTTPRequest ConnectionList -> (RequestId,ConnectionList)
addRequest req list = addRequest` 0 req list
where
	addRequest` max req [] = let max` = max + 1 in (max`,[(max`,Left req)])
	addRequest` max req [x=:(i,_):xs] = let (id,xs`) = addRequest` (if (i > max) i max) req xs in (id,[x:xs`])

listRequests :: ConnectionList -> [(RequestId,HTTPRequest)]
listRequests list = [(i,req) \\ (i,Left req) <- list]

addResponse :: RequestId HTTPResponse ConnectionList -> ConnectionList
addResponse reqId rsp [] = []
addResponse reqId rsp [x=:(i,_):xs]
	| i == reqId 	= [(i,Right rsp):xs]
	| otherwise		= [x:addResponse reqId rsp xs]

getResponse :: RequestId ConnectionList -> (Maybe HTTPResponse,ConnectionList)
getResponse reqId [] = (Nothing,[])
getResponse reqId [x=:(i,Right rsp):xs]
	| i == reqId 	     = (Just rsp,xs)
	| otherwise  		 = let (mbrsp,xs`) = getResponse reqId xs in (mbrsp,[x:xs])
getResponse reqId [x:xs] = let (mbrsp,xs`) = getResponse reqId xs in (mbrsp,[x:xs])

serveFile :: [FilePath] HTTPRequest -> Task HTTPResponse
serveFile [] req = return (notFoundResponse req)
serveFile [d:ds] req=:{HTTPRequest|req_path}
	= 	try (importTextFile (d +++ filePath) @ toResponse)
		    (\(FileException _ _) -> serveFile ds req)
where
	//Translate a URL path to a filesystem path
	filePath = ((replaceSubString "/" {pathSeparator}) o (replaceSubString ".." "")) (urlDecode req_path)
	mimeType = extensionToMimeType (takeExtension filePath)

	toResponse content
	  = {HTTPResponse|okResponse
		& rsp_headers =
			[("Content-Type", mimeType)
			,("Content-Length", toString (size content))]
		, rsp_data = content
		}
185 186 187

callHTTP :: !HTTPMethod !URI !String !(HTTPResponse -> (MaybeErrorString a)) -> Task a | iTask a
callHTTP method url=:{URI|uriScheme,uriRegName=Just uriRegName,uriPort,uriPath,uriQuery,uriFragment} data parseFun
188
    =   tcpconnect uriRegName port Nothing (constShare ()) {ConnectionHandlers|onConnect=onConnect,onData=onData,onShareChange=onShareChange,onDisconnect=onDisconnect,onDestroy= \s->(Ok s, [])}
189 190 191 192 193 194 195
    @?  taskResult
where
    port = fromMaybe 80 uriPort
    path = uriPath +++ maybe "" (\q -> ("?"+++q)) uriQuery +++ maybe "" (\f -> ("#"+++f)) uriFragment
    //VERY SIMPLE HTTP 1.1 Request
    req = toString method +++ " " +++ path +++ " HTTP/1.1\r\nHost:"+++uriRegName+++"\r\nConnection: close\r\n\r\n"+++data

196
    onConnect _ _ _
197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217
        = (Ok (Left []),Nothing,[req],False)
    onData data (Left acc) _
        = (Ok (Left (acc ++ [data])),Nothing,[],False)
    onShareChange acc _
        = (Ok acc,Nothing,[],False)
    onDisconnect (Left acc) _
        = case parseResponse (concat acc) of
			Nothing    = (Error "Invalid response",Nothing)
            (Just rsp) = case parseFun rsp of
 				               	Ok a    = (Ok (Right a),Nothing)
                				Error e = (Error e,Nothing)

    taskResult (Value (Right a) _)  = Value a True
    taskResult _                    = NoValue

callHTTP _ url _ _
    = throw ("Invalid url: " +++ toString url)

callRPCHTTP :: !HTTPMethod !URI ![(String,String)] !(HTTPResponse -> a) -> Task a | iTask a
callRPCHTTP method url params transformResult
	= callHTTP method url (urlEncodePairs params) (Ok o transformResult)