The Inbox: WebClient-Core-ul.123.mcz

> Levente Uzonyi uploaded a new version of WebClient-Core to project  
> The Inbox:
> http://source.squeak.org/inbox/WebClient-Core-ul.123.mcz
>
> ==================== Summary ====================
>
> Name: WebClient-Core-ul.123
> Author: ul
> Time: 23 June 2020, 2:18:02.417391 pm
> UUID: ddad9c69-fa09-4c2e-bb38-156425f9baa0
> Ancestors: WebClient-Core-tobe.121
>
> WebMessage >> #streamDirectlyFrom:to:size:progress:
> - avoid infinite loop when there are fewer bytes available than  
> specified
> - fix progress notifications
> - avoid unnecessary buffer copying
>
> WebMessage:
> - use #contentType: and #contentLength: methods to set the  
> corresponding headers to avoid string duplication
>
> =============== Diff against WebClient-Core-tobe.121 ===============
>
> Item was changed:
>  ----- Method: WebClient>>httpPost:content:type:do: (in category  
> 'methods') -----
>  httpPost: urlString content: postData type: contentType do: aBlock
>   "POST the data to the given url"
>
>   | request |
>   self initializeFromUrl: urlString.
>   request := self requestWithUrl: urlString.
>   request method: 'POST'.
> + contentType ifNotNil:[request contentType: contentType].
> + request contentLength: postData size.
> - contentType ifNotNil:[request headerAt: 'Content-Type' put:  
> contentType].
> - request headerAt: 'Content-Length' put: postData size.
>   userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent].
>   aBlock value: request.
>   ^self sendRequest: request content: postData readStream size:  
> postData size!
>
> Item was changed:
>  ----- Method: WebClient>>httpPostChunked:content:type:do: (in  
> category 'methods') -----
>  httpPostChunked: urlString content: chunkBlock type: contentType  
> do: aBlock
>   "POST the data to the given url using chunked transfer-encoding.
>   The chunkBlock takes a request and can be fed using #nextChunkPut:
>   until all the data has been sent.
>
>   Chunked encoding can be used for long-lasting connections to a  
> server,
>   but care must be taken to ensure that the client isn't running  
> afoul of
>   the server expecting to read the full response (i.e., you should  
> use this
>   only if you have control over both ends).
>
>   However, it is a great way to send output from commands that take  
> awhile
>   and other time-consuming operations if authentication has been  
> handled."
>
>   | request |
>   self initializeFromUrl: urlString.
>   request := self requestWithUrl: urlString.
>   request method: 'POST'.
> + contentType ifNotNil:[request contentType: contentType].
> - contentType ifNotNil:[request headerAt: 'Content-Type' put:  
> contentType].
>   request headerAt: 'Transfer-Encoding' put: 'chunked'.
>   userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent].
>   aBlock value: request.
>   "Send the chunked data"
>   ^self sendRequest: request contentBlock:[:aStream|
>   "Set the stream in the request and pass it in the chunk block"
>   request stream: aStream.
>   chunkBlock value: request.
>   "send termination chunk"
>   aStream nextPutAll: '0'; crlf; crlf; flush.
>   ].
>  !
>
> Item was changed:
>  ----- Method: WebClient>>httpPut:content:type:do: (in category  
> 'methods') -----
>  httpPut: urlString content: postData type: contentType do: aBlock
>   "PUT the data to the given url"
>
>   | request |
>   self initializeFromUrl: urlString.
>   request := self requestWithUrl: urlString.
>   request method: 'PUT'.
> + contentType ifNotNil:[request contentType: contentType].
> + request contentLength: postData size.
> - contentType ifNotNil:[request headerAt: 'Content-Type' put:  
> contentType].
> - request headerAt: 'Content-Length' put: postData size.
>   userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent].
>   aBlock value: request.
>   ^self sendRequest: request content: postData readStream size:  
> postData size!
>
> Item was changed:
>  ----- Method: WebMessage>>streamDirectlyFrom:to:size:progress: (in  
> category 'streaming') -----
>  streamDirectlyFrom: srcStream to: dstStream size: sizeOrNil  
> progress: progressBlock
>   "Stream the content of srcStream to dstStream.
> + If a size is given, try to stream that many elements. It's the  
> senders responsibility to verify that enough bytes were read. If no  
> size is given, stream all available data."
> - If a size is given, stream that many elements, otherwise stream  
> up to the end."
>
> + | buffer bufferSize totalBytesRead bytesInBuffer |
> - | buffer remaining size totalRead |
>   sizeOrNil = 0 ifTrue:[^self].
> + bufferSize := 4096.
> + buffer := (srcStream isBinary ifTrue:[ByteArray] ifFalse:
> [String]) new: bufferSize.
> + totalBytesRead := 0.
> + [
> + progressBlock ifNotNil:[ progressBlock value: sizeOrNil value:  
> totalBytesRead ].
> + srcStream atEnd or: [ sizeOrNil notNil and: [ totalBytesRead >=  
> sizeOrNil ]] ]
> + whileFalse: [
> + bytesInBuffer := srcStream
> + readInto: buffer
> + startingAt: 1
> + count: (sizeOrNil
> + ifNil: [ bufferSize ]
> + ifNotNil: [ sizeOrNil - totalBytesRead min: bufferSize ]).
> + dstStream next: bytesInBuffer putAll: buffer startingAt: 1.
> + totalBytesRead := totalBytesRead + bytesInBuffer  ].
> + dstStream flush!
> -
> - buffer := (srcStream isBinary ifTrue:[ByteArray] ifFalse:
> [String]) new: 4096.
> - totalRead := 0.
> - size := sizeOrNil ifNil:[0].
> - [(sizeOrNil == nil and:[srcStream atEnd not]) or:[totalRead <  
> size]] whileTrue:[
> - progressBlock ifNotNil:[progressBlock value: sizeOrNil value:  
> totalRead].
> - remaining := sizeOrNil ifNil:[99999] ifNotNil:[sizeOrNil -  
> totalRead].
> - remaining > buffer size ifTrue:[remaining := buffer size].
> - buffer := srcStream next: remaining into: buffer startingAt: 1.
> - dstStream nextPutAll: (remaining < buffer size
> - ifTrue:[(buffer copyFrom: 1 to: remaining)]
> - ifFalse:[buffer]).
> - totalRead := totalRead + buffer size.
> - ].
> - dstStream flush.
> - progressBlock ifNotNil:[progressBlock value: sizeOrNil value:  
> totalRead].!
>
> Item was changed:
>  ----- Method: WebRequest>>send200Response:contentType:do: (in  
> category 'responses') -----
>  send200Response: aString contentType: contentType do: aBlock
>   "Send a 200 OK response"
>
>   | resp |
>   resp := self newResponse protocol: 'HTTP/1.1' code: 200.
> + resp contentType: contentType.
> - resp headerAt: 'Content-Type' put: contentType.
>   aBlock value: resp.
>   ^self sendResponse: resp content: aString.!
>
> Item was changed:
>  ----- Method: WebRequest>>send404Response: (in category  
> 'responses') -----
>  send404Response: body
>   "Send a 404 not found response"
>
>   ^self
>   send404Response: (body convertToWithConverter: UTF8TextConverter  
> new)
> + do: [ :resp | resp contentType: 'text/html; charset=utf-8' ]!
> - do: [ :resp | resp headerAt: 'Content-Type' put: 'text/html;  
> charset=utf-8' ]!
>
> Item was changed:
>  ----- Method: WebRequest>>send404Response:do: (in category  
> 'responses') -----
>  send404Response: body do: aBlock
>   "Send a 404 not found response"
>
>   | resp |
>   resp := self newResponse protocol: 'HTTP/1.1' code: 404.
> + resp contentType: 'text/html; charset=utf-8'.
> - resp headerAt: 'Content-Type' put: 'text/html; charset=utf-8'.
>   aBlock value: resp.
>   ^self sendResponse: resp content: body.
>  !
>
> Item was changed:
>  ----- Method: WebRequest>>send405Response:content: (in category  
> 'responses') -----
>  send405Response: allowed content: body
>   "Send a 405 method not allowed response"
>   | resp |
>   resp := self newResponse protocol: 'HTTP/1.1' code: 405.
> + resp contentType: 'text/html; charset=utf-8'.
> - resp headerAt: 'Content-Type' put: 'text/html; charset=utf-8'.
>   resp headerAt: 'allow' put: (String streamContents:[:s|
>   allowed do:[:m| s nextPutAll: m] separatedBy:[s nextPut: $,]
>   ]).
>   ^self sendResponse: resp content: body.!
>
> Item was changed:
>  ----- Method: WebRequest>>sendResponse:contentStream:size: (in  
> category 'sending') -----
>  sendResponse: resp contentStream: aStream size: streamSize
>   "Sends a WebResponse, streaming its contents from aStream.
>   If a size is provided, insert a Content-Length header, otherwise
>   ensure that the connection is transient."
>
>   streamSize
>   ifNil:[self headerAt: 'Connection' put: 'close'] "mark transient"
> + ifNotNil:[resp contentLength: streamSize].
> - ifNotNil:[resp headerAt: 'Content-Length' put: streamSize].
>
>   ^self sendResponse: resp contentBlock:[:sockStream|
>   resp streamFrom: aStream to: sockStream size: streamSize  
> progress: nil
>   ]!
>
> Item was changed:
>  ----- Method: WebRequest>>sendResponseCode:content:type:do: (in  
> category 'responses') -----
>  sendResponseCode: code content: aString type: contentType do: aBlock
>   "Send a 500 Internal server error response"
>
>   | resp |
>   resp := self newResponse protocol: 'HTTP/1.1' code: code.
> + contentType ifNotNil:[resp contentType: contentType].
> - contentType ifNotNil:[resp headerAt: 'Content-Type' put:  
> contentType].
>   aBlock value: resp.
>   ^self sendResponse: resp content: aString.!
>
> Item was changed:
>  ----- Method: WebRequest>>stream200Response:size:type:do: (in  
> category 'responses') -----
>  stream200Response: aStream size: streamSize type: contentType do:  
> aBlock
>   "Stream a 200 OK response"
>
>   | resp |
>   resp := self newResponse protocol: 'HTTP/1.1' code: 200.
> + resp contentType: contentType.
> - resp headerAt: 'Content-Type' put: contentType.
>   aBlock value: resp.
>   ^self sendResponse: resp contentStream: aStream size: streamSize.!
>
> Item was changed:
>  ----- Method: WebServer class>>browseFile:request: (in category  
> 'examples') -----
>  browseFile: file request: request
>   "Responds with a file back to the original request"
>
>   | fileSize mimeTypes resp |
>   file binary.
>   fileSize := file size.
>   mimeTypes := file mimeTypes ifNil:[#('application/octet-stream')].
>   resp := request newResponse protocol: 'HTTP/1.1' code: 200.
> + resp contentType: mimeTypes first.
> - resp headerAt: 'Content-Type' put: mimeTypes first.
>   request sendResponse: resp contentStream: file size: fileSize.!
>
> Item was changed:
>  ----- Method: WebServer>>authenticate:realm:methods:do: (in  
> category 'authentication') -----
>  authenticate: request realm: realm methods: accepted do: aBlock
>   "Authenticates an incoming request using one of the accepted  
> methods.
>
>   Evaluates aBlock upon successful authentication. Responds with a 401
>   (Unauthorized) if the authentication fails."
>
>   | method resp |
>   request headersAt: 'Authorization' do:[:authHeader|
>   method := authHeader copyUpTo: Character space.
>   (accepted anySatisfy:[:auth| auth sameAs: method]) ifTrue:[
>   (self authAccept: method request: request realm: realm header:  
> authHeader)
>   ifTrue:[^aBlock value].
>   ].
>   ].
>
>   "Send a 401 (unauthorized) response"
>   resp := request newResponse protocol: 'HTTP/1.1' code: 401.
> + resp contentType: 'text/html; charset=utf-8'.
> - resp headerAt: 'Content-Type' put: 'text/html; charset=utf-8'.
>   accepted do:[:auth| | hdr |
>   hdr := self authHeader: auth request: request realm: realm.
>   hdr ifNotNil:[resp addHeader: 'WWW-Authenticate' value: hdr].
>   ].
>   request sendResponse: resp content: '<html><head><title>401  
> Unauthorized</title></head><body><h1>401 Unauthorized</h1><p>You are  
> not authorized to access the requested URL</p></body></html>'.
>  !
>
>
>

>
> Process allSubInstances select: [:proc |
> proc suspendedContext
> ifNil: [ false ]
> ifNotNil: [:context |
> context closure
> ifNil: [ false ]
> ifNotNil: [:closure | | receiver |
> receiver := closure outerContext
> receiver.
> (receiver respondsTo: #outerContext)
> ifTrue: [ receiver
> outerContext receiver class == WebServer ]
> ifFalse: [ false ] ] ] ]
> " size => 4"
>
> WebServer allInstances first connections size   " => 3"

>
> (Process allSubInstances select: [:p | p isTerminated]) size " => 10"
>
> WASession allSubInstances size "=> 1"
>
> And leftover Sockets seem healthier than they did before this fix:
>
> (Socket allInstances collect: [:ea | ea statusString asSymbol])
> asBag   "=> a Dictionary(#connected->6 #destroyed->1
> #invalidSocketHandle->60 #otherEndClosedButNotThisEnd->6
> #waitingForConnection->2 )"
>
> Maybe WebServer listener sub-processes are still not getting GCed
> until I click somewhere in the image, which is strange (?), but at
> least they're /able/ to go away now.  :)
>
> Thanks,
> a Tim
>
>