Squeak-dev April 2023

squeak-dev@lists.squeakfoundation.org

17 participants
87 discussions

The Trunk: Tools-mt.1198.mcz
by commits＠source.squeak.org 13 Apr '23

13 Apr '23

Marcel Taeumel uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-mt.1198.mcz ==================== Summary ==================== Name: Tools-mt.1198 Author: mt Time: 13 April 2023, 3:11:13.484682 pm UUID: 28e60f5f-f151-e74e-8651-4a3dae59a4a9 Ancestors: Tools-mt.1197 Adds and enables TreeBrowser, which is a variation of the default Browser with tree widgets in 3 of 4 panes. See its class comment. For a previous discussion, see: https://lists.squeakfoundation.org/archives/list/squeak-dev@lists.squeakfou… Disable it again via the preference wizard or: SystemBrowser default: Browser. Please report remaining issues and other questions. =============== Diff against Tools-mt.1197 =============== Item was added: + Browser subclass: #TreeBrowser + instanceVariableNames: 'parentCategories lastSystemCategoryList lastClassList lastMessageCategoryList isHierarchyMode classForHierarchy lastClassListIndentForHierarchy' + classVariableNames: 'ShowAllClassesInPackage ShowBlankClassIcons ShowEmptyPackages' + poolDictionaries: '' + category: 'Tools-Browser'! + + !TreeBrowser commentStamp: 'mt 4/13/2023 14:31' prior: 0! + Like a regular Smalltalk System Browser, I am a tool that helps explore and modify source code in the system. I am able to detect and show hierarchical structure in class (or system) categories, classes, and message categories (aka. protocols). The class hierarchy is formed by Smalltalk's single inheritance (i.e., #superclass and #subclasses). A hierarchy from any list of categories is derived by splitting dashes ("-") to reveal groups. Type-in filters are expected to work as in regular lists. + + Class (or system) categories, left-most pane: + - Synthetic groups have (parentheses) and are empty + - Groups that represent modified Monticello packages have an *asterisk + - Groups that represent packages can list all classes in it, see class-side preference + - Groups (or entries) that are just categories (i.e. no packages), are set in italic + - Type-in filter searches complete hierarchy, including collapsed items + + Class tree, second-from-left pane: + - Complete hierarchy expanded when selecting a different class category, except for "-- all --" category + - Type-in filter only searches visible items, not complete hierarchy, for better performance in "-- all --" category + - Blank icons disabled by default for better overview, see class-side preference + + Message categories (or protocols), third-from-left pane: + - Synthetic groups have (parentheses) and are empty + - All extensions grouped in "-- extensions --" category, which also aggregates all extension methods + - Type-in filter searches complete hierarchy, including collapsed items + + Note that a useful metaphor for category-hierarchies is the file system with its hierarchy of directories. Directories can be empty. Selecting a parent directory does not list the files of all sub-directories. While single-child paths are condensed for clarity, they can still occur when intermediate items are valid categories with content. + + I also have built-in support for showing a class hierarchy around a specific class, just like the HierarchyBrowser does. + I also have built-in support for traits, especially when in hierarchy-mode.! Item was added: + ----- Method: TreeBrowser class>>extensionCategory (in category 'defaults') ----- + extensionCategory + + ^ #'-- extensions --'! Item was added: + ----- Method: TreeBrowser class>>fullHierarchyOnClass: (in category 'instance creation') ----- + fullHierarchyOnClass: aClass + "Provide features from HierarchyBrowser within TreeBrowser." + + ^ self fullHierarchyOnClass: aClass selector: nil! Item was added: + ----- Method: TreeBrowser class>>fullHierarchyOnClass:selector: (in category 'instance creation') ----- + fullHierarchyOnClass: aClass selector: aSelector + "Provide features from HierarchyBrowser within TreeBrowser." + + ^ self new + buildAndOpenHierarchyBrowserLabel: 'Hierarchy Browser'; + initHierarchyFor: aClass "or trait"; + setSelector: aSelector; + yourself! Item was added: + ----- Method: TreeBrowser class>>hierarchyCategory (in category 'defaults') ----- + hierarchyCategory + + ^ #'-- hierarchy --'! Item was added: + ----- Method: TreeBrowser class>>newOnCategory:label: (in category 'instance creation') ----- + newOnCategory: aClassCategoryOrPackageName label: aLabel + "Overwritten to ignore artificial categories (including package names that are not a system category but only prefix)." + + ^ self new + selectSystemCategory: aClassCategoryOrPackageName asSymbol; + buildAndOpenCategoryBrowserLabel: aLabel; + yourself! Item was added: + ----- Method: TreeBrowser class>>showAllClassesInPackage (in category 'preferences') ----- + showAllClassesInPackage + <preference: 'Show all classes in a package in Tree Browser' + categoryList: #(Morphic Tools Browsing) + description: 'When true, the entire class tree in a package will be shown in the class pane instead of the classes that belong to the respective system category, which is usually empty.' + type: #Boolean> + + ^ ShowAllClassesInPackage ifNil: [true]! Item was added: + ----- Method: TreeBrowser class>>showAllClassesInPackage: (in category 'preferences') ----- + showAllClassesInPackage: aBooleanOrNil + + ShowAllClassesInPackage == aBooleanOrNil ifTrue: [^ self]. + ShowAllClassesInPackage := aBooleanOrNil. + + self allInstancesDo: [:treeBrowser | treeBrowser updateClassTree].! Item was added: + ----- Method: TreeBrowser class>>showBlankClassIcons (in category 'preferences') ----- + showBlankClassIcons + <preference: 'Show blank class icons in Tree Browser' + categoryList: #(Morphic Tools Browsing) + description: 'When true, classes with no distinct icon will get a blank icon, which makes such labels wider and might obfuscate hierarchy indication. Note that #showClassIcons must be enabled for this to have an effect.' + type: #Boolean> + + ^ ShowBlankClassIcons ifNil: [false]! Item was added: + ----- Method: TreeBrowser class>>showBlankClassIcons: (in category 'preferences') ----- + showBlankClassIcons: booleanOrNil + + ShowBlankClassIcons == booleanOrNil ifTrue: [^ self]. + (ShowBlankClassIcons := booleanOrNil) == true + ifTrue: [self showClassIcons: true]. + + self allInstancesDo: [:treeBrowser | treeBrowser changed: #classRoots].! Item was added: + ----- Method: TreeBrowser class>>showEmptyPackages (in category 'preferences') ----- + showEmptyPackages + <preference: 'Show extensions-only packages in Tree Browser' + categoryList: #(Morphic Tools Browsing) + description: 'When true, apparently empty packages will be listed in the browser if those packages contain only extension methods in other classes. Users can still add classes to these packages or use the context menu to browse their extensions.' + type: #Boolean> + + ^ ShowEmptyPackages ifNil: [false]! Item was added: + ----- Method: TreeBrowser class>>showEmptyPackages: (in category 'preferences') ----- + showEmptyPackages: aBooleanOrNil + + ShowEmptyPackages == aBooleanOrNil ifTrue: [^ self]. + ShowEmptyPackages := aBooleanOrNil. + + self allInstancesDo: [:treeBrowser | treeBrowser updateSystemCategoryTree].! Item was added: + ----- Method: TreeBrowser>>allAncestorsOfClass: (in category 'extras - hierarchy browser - class tree') ----- + allAncestorsOfClass: class + + ^ self allAncestorsOfClass: class into: OrderedCollection new at: -1! Item was added: + ----- Method: TreeBrowser>>allAncestorsOfClass:into:at: (in category 'extras - hierarchy browser - class tree') ----- + allAncestorsOfClass: class into: collection at: depth + "See #allAncestorsOfClass:... in HierarchyBrowser." + + (class superclass ifNil: [#()] ifNotNil: [:c | {c}]), class traits + do: [:ancestor | + ancestor isTrait + ifTrue: [self allAncestorsOfTrait: ancestor into: collection at: depth - 1] + ifFalse: [self allAncestorsOfClass: ancestor into: collection at: depth - 1]. + collection add: ancestor. + lastClassListIndentForHierarchy add: depth]. + ^ collection! Item was added: + ----- Method: TreeBrowser>>allAncestorsOfTrait: (in category 'extras - hierarchy browser - class tree') ----- + allAncestorsOfTrait: trait + + ^ self allAncestorsOfTrait: trait into: OrderedCollection new at: -1! Item was added: + ----- Method: TreeBrowser>>allAncestorsOfTrait:into:at: (in category 'extras - hierarchy browser - class tree') ----- + allAncestorsOfTrait: trait into: collection at: depth + "See #allAncestorsOfTrait:... in HierarchyBrowser." + + trait traitComposition asTraitComposition traits + do: [:ancestor | + self allAncestorsOfTrait: ancestor into: collection at: depth - 1. + collection add: ancestor. + lastClassListIndentForHierarchy add: depth]. + ^ collection! Item was added: + ----- Method: TreeBrowser>>allClassCategories (in category 'system category tree - support') ----- + allClassCategories + + self isHierarchy ifTrue: [^ {} "pane should be invisible anyway"]. + + ^ self class showEmptyPackages + ifTrue: [systemOrganizer categories, PackageOrganizer default packageNames] + ifFalse: [systemOrganizer categories]! Item was added: + ----- Method: TreeBrowser>>allClassesForHierarchy (in category 'extras - hierarchy browser - class tree') ----- + allClassesForHierarchy + + | before after | + self flag: #hacky. "mt: See #updateTreeIfNeeded. Should work... hmpf..." + lastClassListIndentForHierarchy := OrderedCollection new. + + self flag: #environment. "mt: Check environment? Skip foreign classes?" + before := (classForHierarchy isTrait + ifTrue: [self allAncestorsOfTrait: classForHierarchy] + ifFalse: [self allAncestorsOfClass: classForHierarchy]). + lastClassListIndentForHierarchy add: 0. + after := (classForHierarchy isTrait + ifTrue: [self allSuccessorsOfTrait: classForHierarchy] + ifFalse: [self allSuccessorsOfClass: classForHierarchy]). + + ^ before, {classForHierarchy}, after! Item was added: + ----- Method: TreeBrowser>>allClassesInCategory (in category 'class tree - support') ----- + allClassesInCategory + "Answer a list of all class objects in the selected system category." + + self hasSystemCategorySelected ifFalse: [^ #()]. + self isHierarchy ifTrue: [^ self allClassesForHierarchy]. + + ^ self class showAllClassesInPackage + ifFalse: [self defaultClassList + collect: [:className | self environment classNamed: className] + thenSelect: [:classOrNil | classOrNil notNil "guard environment"]] + ifTrue: [PackageOrganizer default + packageNamed: selectedSystemCategory + ifPresent: [:pkg | pkg classes] + ifAbsent: [self defaultClassList + collect: [:className | self environment classNamed: className] + thenSelect: [:classOrNil | classOrNil notNil "guard environment"]]]! Item was added: + ----- Method: TreeBrowser>>allMessageCategories (in category 'message category tree - support') ----- + allMessageCategories + + ^ self hasClassSelected + ifFalse: [#()] + ifTrue: [self classOrMetaClassOrganizer categories]! Item was added: + ----- Method: TreeBrowser>>allSuccessorsOfClass: (in category 'extras - hierarchy browser - class tree') ----- + allSuccessorsOfClass: class + + ^ self allSuccessorsOfClass: class into: OrderedCollection new at: 1! Item was added: + ----- Method: TreeBrowser>>allSuccessorsOfClass:into:at: (in category 'extras - hierarchy browser - class tree') ----- + allSuccessorsOfClass: class into: collection at: depth + "See #allSuccessorsOfClass:... in HierarchyBrowser." + + (class subclasses sorted: #name ascending) + do: [:successor | + collection add: successor. + lastClassListIndentForHierarchy add: depth. + successor isTrait + ifTrue: [self allSuccessorsOfTrait: successor into: collection at: depth + 1] + ifFalse: [self allSuccessorsOfClass: successor into: collection at: depth + 1]]. + ^ collection! Item was added: + ----- Method: TreeBrowser>>allSuccessorsOfTrait: (in category 'extras - hierarchy browser - class tree') ----- + allSuccessorsOfTrait: trait + + ^ self allSuccessorsOfTrait: trait into: OrderedCollection new at: 1! Item was added: + ----- Method: TreeBrowser>>allSuccessorsOfTrait:into:at: (in category 'extras - hierarchy browser - class tree') ----- + allSuccessorsOfTrait: trait into: collection at: depth + "See #allSuccessorsOfTrait:... in HierarchyBrowser." + + (trait users "includes classes and traits" sorted: #name ascending) + do: [:successor | + collection add: successor. + lastClassListIndentForHierarchy add: depth. + successor isTrait + ifTrue: [self allSuccessorsOfTrait: successor into: collection at: depth + 1] + ifFalse: [self allSuccessorsOfClass: successor into: collection at: depth + 1]]. + ^ collection! Item was added: + ----- Method: TreeBrowser>>browseAllClasses (in category 'system category functions') ----- + browseAllClasses + + self class newOnCategory: SystemOrganizer allCategory.! Item was added: + ----- Method: TreeBrowser>>browseClassHierarchy (in category 'extras - hierarchy browser') ----- + browseClassHierarchy + + | pivot | + (pivot := self selectedClass) ifNil: [^ self]. + + self multiWindowState + ifNil: [ + self class fullHierarchyOnClass: pivot] + ifNotNil: [ + self multiWindowState addNewWindow. + self initHierarchyFor: pivot].! Item was added: + ----- Method: TreeBrowser>>buildAndOpenCategoryBrowserLabel: (in category 'toolbuilder') ----- + buildAndOpenCategoryBrowserLabel: aLabel + "Overwrite to replay certain interactive features that only work if the browser is already open." + + super buildAndOpenCategoryBrowserLabel: aLabel. + + self expandClassTree. + self changed: #classChild. + ! Item was added: + ----- Method: TreeBrowser>>buildAndOpenFullBrowser (in category 'toolbuilder') ----- + buildAndOpenFullBrowser + "Overwrite to replay certain interactive features that only work if the browser is already open." + + super buildAndOpenFullBrowser. + + self expandClassTree. + self changed: #classChild. + ! Item was added: + ----- Method: TreeBrowser>>buildAndOpenHierarchyBrowserLabel: (in category 'extras - hierarchy browser') ----- + buildAndOpenHierarchyBrowserLabel: aLabelString + + | builder windowSpec | + builder := ToolBuilder default. + + windowSpec := self buildHierarchyBrowserWith: builder. + aLabelString ifNotNil:[:str| windowSpec label: str]. + + builder open: windowSpec. + + ^self! Item was added: + ----- Method: TreeBrowser>>buildClassListWith: (in category 'toolbuilder') ----- + buildClassListWith: builder + + | tree | + tree := builder pluggableTreeSpec new. + tree + model: self; + roots: #classRoots; + label: #classLabel:; + getChildren: #classChildren:; + hasChildren: #classHasChildren:; + help: #classHelpAt:; + getSelectedPath: #classPath; + getSelected: #classChild; + setSelected: #classChild:; + icon: #classIcon:; + menu: #classListMenu:shifted:; + keyPress: #classListKey:from:; + filterMode: #visible; "not #all bc. class-tree is too deep, which makes filtering slow" + searchMode: #depthFirst. + SystemBrowser browseWithDragNDrop ifTrue: [ + tree + dragItem: #dragFromClassTree:; + dragType: #dragTypeForClassTreeAt:]. + ^ tree! Item was added: + ----- Method: TreeBrowser>>buildHierarchyBrowserWith: (in category 'extras - hierarchy browser') ----- + buildHierarchyBrowserWith: builder + + | max windowSpec | + max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4]. + + windowSpec := self buildWindowWith: builder specs: { + (self classListFrame: max fromTop: 0 fromLeft: 0 width: 0.333) -> [self buildClassListWith: builder]. + (self switchesFrame: max fromLeft: 0 width: 0.333) -> [self buildSwitchesWith: builder]. + (LayoutFrame fractions: (0.333@0 corner: 0.666@max) offsets: (0@0 corner: 0@0)) -> [self buildMessageCategoryListWith: builder]. + (LayoutFrame fractions: (0.666@0 corner: 1@max) offsets: (0@0 corner: 0@0)) -> [self buildMessageListWith: builder]. + (0@max corner: 1@1) -> [self buildCodePaneWith: builder]. + }. + self setMultiWindowFor:windowSpec. + + ^ builder build: windowSpec + ! Item was added: + ----- Method: TreeBrowser>>buildMessageCategoryListWith: (in category 'toolbuilder') ----- + buildMessageCategoryListWith: builder + + | tree | + tree := builder pluggableTreeSpec new. + tree + model: self; + roots: #messageCategoryRoots; + label: #messageCategoryLabel:; + getChildren: #messageCategoryChildren:; + hasChildren: #messageCategoryHasChildren:; + help: #messageCategoryHelpAt:; + getSelectedPath: #messageCategoryPath; + getSelected: #messageCategoryChild; + setSelected: #messageCategoryChild:; + menu: #messageCategoryMenu:; + keyPress: #messageCategoryListKey:from:; + filterMode: #all; + searchMode: #depthFirst. + SystemBrowser browseWithDragNDrop ifTrue:[ + tree + dropAccept: #wantsMessageCategoriesDrop:; + dropItem: #dropOnMessageCategories:on:]. + ^ tree! Item was added: + ----- Method: TreeBrowser>>buildSystemCategoryListWith: (in category 'toolbuilder') ----- + buildSystemCategoryListWith: builder + + | tree | + tree := builder pluggableTreeSpec new. + tree + model: self; + roots: #systemCategoryRoots; + label: #systemCategoryLabel:; + getChildren: #systemCategoryChildren:; + hasChildren: #systemCategoryHasChildren:; + help: #systemCategoryHelpAt:; + getSelectedPath: #systemCategoryPath; + getSelected: #systemCategoryChild; + setSelected: #systemCategoryChild:; + menu: #systemCategoryMenu:; + keyPress: #systemCatListKey:from:; + filterMode: #all; + searchMode: #depthFirst. + ^ tree! Item was added: + ----- Method: TreeBrowser>>changed: (in category 'updating') ----- + changed: aspect + + super changed: aspect. + + aspect == #systemCategoryList + ifTrue: [^ self updateSystemCategoryTree]. + aspect == #classList + ifTrue: [^ self updateClassTree]. + aspect == #messageCategoryList + ifTrue: [^ self updateMessageCategoryTree]. + + aspect == #systemCategoryListIndex + ifTrue: [^ self changed: #systemCategoryChild]. + aspect == #classListIndex + ifTrue: [^ self changed: #classChild]. + aspect == #messageCategoryListIndex + ifTrue: [^ self changed: #messageCategoryChild].! Item was added: + ----- Method: TreeBrowser>>classChild (in category 'class tree') ----- + classChild + + ^ self selectedClass! Item was added: + ----- Method: TreeBrowser>>classChild: (in category 'class tree') ----- + classChild: aClassNotMeta + + selectedClassName = aClassNotMeta name ifTrue: [^ self]. + self selectClass: aClassNotMeta. + self currentHand deleteBalloon.! Item was added: + ----- Method: TreeBrowser>>classChildren: (in category 'class tree') ----- + classChildren: aClass + + | all | + self selectedSystemCategory = SystemOrganizer allCategory + ifTrue: [^ aClass subclasses sortedSafely]. + self selectedSystemCategory = self class hierarchyCategory + ifTrue: [^ self classChildrenForHierarchy: aClass]. + + all := lastClassList. + + ^ all select: [:subclass | subclass superclass == aClass]! Item was added: + ----- Method: TreeBrowser>>classChildrenForHierarchy: (in category 'extras - hierarchy browser - class tree') ----- + classChildrenForHierarchy: classOrTraitOrNil + + | pos myIndent children currentIndent | + pos := lastClassList indexOf: classOrTraitOrNil ifAbsent: [0]. + pos = lastClassList size ifTrue: [^ #()]. + myIndent := lastClassListIndentForHierarchy + at: pos + ifAbsent: [lastClassListIndentForHierarchy first - 1]. + + children := OrderedCollection new. + pos := pos + 1. + [(currentIndent := lastClassListIndentForHierarchy at: pos ifAbsent: [myIndent]) <= myIndent] + whileFalse: [ + currentIndent = (myIndent+1 "direct child") + ifTrue: [children add: (lastClassList at: pos)]. + pos := pos + 1]. + ^ children! Item was added: + ----- Method: TreeBrowser>>classHasChildren: (in category 'class tree') ----- + classHasChildren: aClass + + aClass == Class "... ProtoObject class ..." + ifTrue: [^ false]. + self selectedSystemCategory = SystemOrganizer allCategory + ifTrue: [^ aClass subclasses notEmpty]. + self selectedSystemCategory = self class hierarchyCategory + ifTrue: [^ self classHasChildrenForHierarchy: aClass]. + ^ lastClassList includesAnyOf: aClass subclasses! Item was added: + ----- Method: TreeBrowser>>classHasChildrenForHierarchy: (in category 'extras - hierarchy browser - class tree') ----- + classHasChildrenForHierarchy: classOrTrait + + | pos indent | + pos := lastClassList indexOf: classOrTrait. + pos = lastClassList size ifTrue: [^ false]. + indent := lastClassListIndentForHierarchy at: pos. + ^ (lastClassListIndentForHierarchy at: pos+1 "first child?") = (indent+1)! Item was added: + ----- Method: TreeBrowser>>classHelpAt: (in category 'class tree - support') ----- + classHelpAt: aClass + "Shorten unformatted string representation to for better performance of longer comments." + + ^ aClass organization classComment + ifNotEmpty: [:comment | self messageHelpTruncated: (comment asString withNoLineLongerThan: 60) asText] + ifEmpty: [nil]! Item was added: + ----- Method: TreeBrowser>>classIcon: (in category 'class tree') ----- + classIcon: aClass + "Answer 'nil' instead of blank icon to keep the tree widget compact." + + | iconName | + self class showClassIcons + ifFalse: [^ nil]. + + ^ ((iconName := ToolIcons iconForClass: aClass name) ~~ #blank or: [ShowBlankClassIcons == true]) + ifTrue: [ToolIcons iconNamed: iconName]! Item was added: + ----- Method: TreeBrowser>>classLabel: (in category 'class tree') ----- + classLabel: aClassOrTrait + + self selectedSystemCategory = self class hierarchyCategory + ifTrue: [^ self classLabelForHierarchy: aClassOrTrait]. + + ^ aClassOrTrait isTrait + ifTrue: [aClassOrTrait name asText addAttribute: TextEmphasis italic] + ifFalse: [aClassOrTrait name]! Item was added: + ----- Method: TreeBrowser>>classLabelForHierarchy: (in category 'extras - hierarchy browser - class tree') ----- + classLabelForHierarchy: classOrTrait + "Emphasize what is different from the hierarchy's current center." + + ^ classForHierarchy == classOrTrait + ifTrue: [classOrTrait name asText addAttribute: TextEmphasis bold] + ifFalse: [classForHierarchy isTrait == classOrTrait isTrait + ifTrue: [classOrTrait name] + ifFalse: [classOrTrait name asText addAttribute: TextEmphasis italic]]! Item was added: + ----- Method: TreeBrowser>>classListKey:from: (in category 'class tree - support') ----- + classListKey: aChar from: view + "Overwritten because tree widgets do not check whether a modifier key was pressed..." + + ^ self currentEvent anyModifierKeyPressed + and: [super classListKey: aChar from: view]! Item was added: + ----- Method: TreeBrowser>>classPath (in category 'class tree') ----- + classPath + + self selectedSystemCategory = self class hierarchyCategory + ifTrue: [^ self classPathForHierarchy]. + + ^ self selectedClass ifNotNil: [:cls | + | roots shouldAdd | + roots := self classRoots asSet. + shouldAdd := true. + (Array streamContents: [:s | + cls withAllSuperclassesDo: [:ea | + shouldAdd ifTrue: [s nextPut: ea]. + (roots includes: ea) + ifTrue: [shouldAdd := false]]]) + reversed]! Item was added: + ----- Method: TreeBrowser>>classPathForHierarchy (in category 'extras - hierarchy browser - class tree') ----- + classPathForHierarchy + + ^ self selectedClass ifNotNil: [:classOrTrait | + | pos firstIndent indent path | + firstIndent := lastClassListIndentForHierarchy at: 1. + path := OrderedCollection with: classOrTrait. + + pos := lastClassList indexOf: classOrTrait. + indent := lastClassListIndentForHierarchy at: pos. + + [pos > 1 and: [indent > firstIndent]] whileTrue: [ + [(lastClassListIndentForHierarchy at: pos) < indent] + whileFalse: [pos := pos - 1]. + path addFirst: (lastClassList at: pos). + indent := lastClassListIndentForHierarchy at: pos]. + + path]! Item was added: + ----- Method: TreeBrowser>>classRoots (in category 'class tree') ----- + classRoots + + | all | + self selectedSystemCategory = SystemOrganizer allCategory ifTrue: [^ {ProtoObject}]. + self selectedSystemCategory = self class hierarchyCategory ifTrue: [^ self classRootsForHierarchy]. + + all := lastClassList. + + ^ all select: [:class | all noneSatisfy: [:ea | class inheritsFrom: ea]]! Item was added: + ----- Method: TreeBrowser>>classRootsForHierarchy (in category 'extras - hierarchy browser - class tree') ----- + classRootsForHierarchy + + ^ self classChildrenForHierarchy: nil! Item was added: + ----- Method: TreeBrowser>>contents:notifying: (in category 'accessing') ----- + contents: input notifying: aController + "Overwritten to indicate uncommitted (MC) changes in the package nodes in the system-category tree." + + ^ (super contents: input notifying: aController) + ifTrue: [self changed: #systemCategoryLabel:. true] + ifFalse: [false]! Item was added: + ----- Method: TreeBrowser>>defaultBrowserTitle (in category 'initialization') ----- + defaultBrowserTitle + + ^ self isHierarchy + ifTrue: ['Hierarchy Browser'] + ifFalse: [super defaultBrowserTitle]! Item was added: + ----- Method: TreeBrowser>>dragFromClassTree: (in category 'class tree - support') ----- + dragFromClassTree: aClass + + ^ aClass! Item was added: + ----- Method: TreeBrowser>>dragTypeForClassTreeAt: (in category 'class tree - support') ----- + dragTypeForClassTreeAt: aClass + + ^ #sourceCode! Item was added: + ----- Method: TreeBrowser>>dropOnMessageCategories:on: (in category 'message category tree - support') ----- + dropOnMessageCategories: method on: child + + ^ self + dropOnMessageCategories: method + at: (self messageCategoryList indexOf: child)! Item was added: + ----- Method: TreeBrowser>>expandClassTree (in category 'class tree - support') ----- + expandClassTree + "Expand full class hierarchy for specific categories, top-level only for the '-- all --' category." + + self selectedSystemCategory = SystemOrganizer allCategory + ifFalse: [self classRoots do: [:ea | self changed: #expandAllNodesRequested with: #classChildren:]] + ifTrue: [self changed: #expandNodeRequested with: {#classChildren:. ProtoObject}].! Item was added: + ----- Method: TreeBrowser>>findPrefix: (in category 'category to hierarchy') ----- + findPrefix: aString + + ^ self findPrefix: aString startingAt: 1! Item was added: + ----- Method: TreeBrowser>>findPrefix:startingAt: (in category 'category to hierarchy') ----- + findPrefix: aString startingAt: start + + | pos | + ^ (pos := aString findString: '-' startingAt: start+1) > 0 + ifTrue: [(aString copyFrom: 1 to: pos-1) asSymbol] + ifFalse: [nil]! Item was added: + ----- Method: TreeBrowser>>findSuffix: (in category 'category to hierarchy') ----- + findSuffix: category + + | first | + first := (parentCategories at: category ifAbsent: ['']) size. + first = 0 ifTrue: [^ category]. + ^ category copyFrom: first+2 to: category size! Item was added: + ----- Method: TreeBrowser>>findTrimmedPrefix: (in category 'category to hierarchy') ----- + findTrimmedPrefix: aString + + ^ self findTrimmedPrefix: aString startingAt: 1! Item was added: + ----- Method: TreeBrowser>>findTrimmedPrefix:startingAt: (in category 'category to hierarchy') ----- + findTrimmedPrefix: aString startingAt: start + + | pos first | + first := start. + [(aString at: first) isSeparator] whileTrue: [first := first + 1]. + ^ (pos := aString findString: '-' startingAt: first+1) > 0 + ifTrue: [(aString copyFrom: 1 to: pos-1) withBlanksTrimmed asSymbol] + ifFalse: [nil]! Item was added: + ----- Method: TreeBrowser>>findTrimmedSuffix: (in category 'category to hierarchy') ----- + findTrimmedSuffix: category + + | first | + first := (parentCategories at: category ifAbsent: ['']) size + 1. + first = 1 ifTrue: [^ category]. + [(category at: first) isSeparator] whileTrue: [first := first + 1]. + first := first + 1. + [(category at: first) isSeparator] whileTrue: [first := first + 1]. + ^ category copyFrom: first to: category size! Item was added: + ----- Method: TreeBrowser>>for:from:anyVariations: (in category 'category to hierarchy') ----- + for: category from: allCategories anyVariations: findBlock + "Answer whether there is more than one sub-category in allCategories given the prefix category." + + | variations prefixSize | + variations := Set new. + prefixSize := category size + 1. + + prefixSize > 2 ifFalse: [^ false "e-toy ..."]. + + allCategories do: [:each | + (findBlock value: each value: prefixSize) + ifNotNil: [:prefix | variations add: prefix] + ifNil: [variations add: each asSymbol]. + variations size > 1 ifTrue: [^ true]]. + + ^ false! Item was added: + ----- Method: TreeBrowser>>for:from:count: (in category 'category to hierarchy') ----- + for: category from: allCategories count: findBlock + + | variations prefixSize | + variations := Set new. + prefixSize := category size + 1. + + allCategories do: [:each | + (findBlock value: each value: prefixSize) + ifNotNil: [:prefix | variations add: prefix] + ifNil: [variations add: each asSymbol]]. + + ^ variations size! Item was added: + ----- Method: TreeBrowser>>for:from:select:thenCollect: (in category 'category to hierarchy') ----- + for: category from: allCategories select: predicateBlock thenCollect: findBlock + "For the given category looking through allCategories, find sub-categories via findBlock if predicateBlock matches that category as an actual prefix. See #findPrefix: and #findTrimmedPrefix:. Try to avoid single children." + + | frequencies prefixSize result completed matches | + frequencies := Bag new. + completed := Set new. + matches := Dictionary new. + prefixSize := category size + 1. + + allCategories do: [:each | + (predicateBlock value: category value: each) ifTrue: [ + (findBlock value: each value: prefixSize) + ifNotNil: [:prefix | + frequencies add: prefix. + (matches at: prefix ifAbsentPut: [OrderedCollection new]) add: each] + ifNil: [ + frequencies add: each asSymbol. + completed add: each asSymbol]]]. + + result := OrderedCollection new: frequencies size + completed size. + frequencies valuesAndCounts keysAndValuesDo: [:prefix :amount | + amount > 1 + ifTrue: [ + ((completed includes: prefix) or: [self for: prefix from: (matches at: prefix) anyVariations: findBlock]) + ifTrue: ["Multiple children. Best case for overview." + parentCategories at: prefix put: category. + result add: prefix] + ifFalse: ["Multiple children with single child next level. Look further." + | miniPaths | + miniPaths := self for: prefix from: (matches at: prefix) + select: predicateBlock + thenCollect: findBlock. + miniPaths do: [:each | parentCategories at: each put: category]. + result addAll: miniPaths]] + ifFalse: [ + (completed includes: prefix) + ifTrue: ["Single child. Okay, because already complete." + parentCategories at: prefix put: category. + result add: prefix] + ifFalse: ["Single child. Look further." + | miniPaths | + miniPaths := self for: prefix from: (matches at: prefix) + select: predicateBlock + thenCollect: findBlock. + miniPaths do: [:each | parentCategories at: each put: category]. + result addAll: miniPaths]]]. + + ^ result sorted! Item was added: + ----- Method: TreeBrowser>>hasMessageCategory:prefix: (in category 'category to hierarchy') ----- + hasMessageCategory: category prefix: prefix + "Like #beginsWith: but check for a trailing separator, ignoring whitespace" + + prefix ifEmpty: [^ true]. + (category beginsWith: prefix) ifFalse: [^ false]. + prefix size + 1 to: category size do: [:index | | char | + (char := category at: index) == $- ifTrue: [^ true]. + char isSeparator ifFalse: [^ false]]. + ^ false! Item was added: + ----- Method: TreeBrowser>>hasSystemCategory:prefix: (in category 'category to hierarchy') ----- + hasSystemCategory: category prefix: prefix + + ^ prefix isEmpty or: [ + (category at: prefix size + 1 ifAbsent: nil) == $- + and: [category beginsWith: prefix]]! Item was added: + ----- Method: TreeBrowser>>initHierarchyFor: (in category 'extras - hierarchy browser') ----- + initHierarchyFor: classOrTrait + + self setHierarchyMode. + classForHierarchy := classOrTrait. + + self updateSystemCategoryTree. + self selectSystemCategory: self class hierarchyCategory. + + self updateClassTree. + self selectClass: classForHierarchy. "Must not use #setClass: here."! Item was added: + ----- Method: TreeBrowser>>initialize (in category 'initialization') ----- + initialize + + super initialize. + + parentCategories := Dictionary new. + + lastSystemCategoryList := #(). + lastClassList := #(). + lastMessageCategoryList := #().! Item was added: + ----- Method: TreeBrowser>>isHierarchy (in category 'extras - hierarchy browser') ----- + isHierarchy + "Note that this hook was also introduced for multi-window support. See superclass." + + ^ isHierarchyMode == true! Item was added: + ----- Method: TreeBrowser>>messageCategoryChild (in category 'message category tree') ----- + messageCategoryChild + + ^ selectedMessageCategoryName! Item was added: + ----- Method: TreeBrowser>>messageCategoryChild: (in category 'message category tree') ----- + messageCategoryChild: aSymbol + + selectedMessageCategoryName = aSymbol ifTrue: [^ self]. + self selectMessageCategoryNamed: aSymbol. + self currentHand deleteBalloon.! Item was added: + ----- Method: TreeBrowser>>messageCategoryChildren: (in category 'message category tree') ----- + messageCategoryChildren: category + + | all | + category = ClassOrganizer allCategory ifTrue: [^ #()]. + + all := (category = self class extensionCategory or: [category notEmpty and: [category first == $*]]) + ifTrue: [lastMessageCategoryList select: [:cat | cat first == $*]] + ifFalse: [lastMessageCategoryList reject: [:cat | cat first == $*]]. + + ^ self + for: (category = self class extensionCategory + ifTrue: [''] ifFalse: [category]) + from: all + select: [:prefix :cat | self hasMessageCategory: cat prefix: prefix] + thenCollect: [:cat :start | self findTrimmedPrefix: cat startingAt: start]! Item was added: + ----- Method: TreeBrowser>>messageCategoryHasChildren: (in category 'message category tree') ----- + messageCategoryHasChildren: category + + | predicate | + category == ClassOrganizer allCategory ifTrue: [^ false]. + + predicate := category == self class extensionCategory + ifTrue: [ [:cat | cat first == $*] ] + ifFalse: [ [:cat | self hasMessageCategory: cat prefix: category] ]. + + ^ lastMessageCategoryList anySatisfy: [:cat | predicate value: cat]! Item was added: + ----- Method: TreeBrowser>>messageCategoryHelpAt: (in category 'message category tree - support') ----- + messageCategoryHelpAt: category + + ^ (self messageCategoryLabel: category) = category + ifFalse: [category]! Item was added: + ----- Method: TreeBrowser>>messageCategoryLabel: (in category 'message category tree') ----- + messageCategoryLabel: category + + | label | + category = ClassOrganizer allCategory ifTrue: [^ category]. + category = self class extensionCategory ifTrue: [^ category]. + + label := self findTrimmedSuffix: category. + + (self classOrMetaClassOrganizer categories includes: category) + ifFalse: [ + label := '(', label, ')']. + + ^ label! Item was added: + ----- Method: TreeBrowser>>messageCategoryListKey:from: (in category 'message category tree - support') ----- + messageCategoryListKey: aChar from: view + "Overwriten because tree widgets do not check whether a modifier key was pressed..." + + ^ self currentEvent anyModifierKeyPressed + and: [super messageCategoryListKey: aChar from: view]! Item was added: + ----- Method: TreeBrowser>>messageCategoryPath (in category 'message category tree') ----- + messageCategoryPath + "Answer the path represented by the category. Ensure to fill the cache." + + self hasClassSelected ifFalse: [^ #()]. + self hasMessageCategorySelected ifFalse: [^ #()]. + + selectedMessageCategoryName = ClassOrganizer allCategory ifTrue: [^ {selectedMessageCategoryName}]. + selectedMessageCategoryName = self class extensionCategory ifTrue: [^ {selectedMessageCategoryName}]. + + ^ Array streamContents: [:s | | parent | + selectedMessageCategoryName first == $* "Is extension category?" + ifTrue: [s nextPut: (parent := self class extensionCategory)] + ifFalse: [parent := '']. + [parent notNil] whileTrue: [ + (self messageCategoryChildren: parent) + detect: [:ea | selectedMessageCategoryName beginsWith: ea] + ifFound: [:ea | s nextPut: (parent := ea)] + ifNone: [parent := nil]]]! Item was added: + ----- Method: TreeBrowser>>messageCategoryRoots (in category 'message category tree') ----- + messageCategoryRoots + + | hasExtensions hasAny roots | + self hasClassSelected ifFalse: [^ Array new]. + + hasAny := self classOrMetaClassOrganizer isEmpty not. + hasExtensions := self classOrMetaClassOrganizer categories + anySatisfy: [:cat | cat first == $*]. + + roots := OrderedCollection new. + hasAny ifTrue: [roots add: ClassOrganizer allCategory]. + hasExtensions ifTrue: [roots add: self class extensionCategory]. + + roots addAll: (self messageCategoryChildren: ''). + + ^ roots! Item was added: + ----- Method: TreeBrowser>>messageList (in category 'message list') ----- + messageList + "Overwritten to show all extensions when the '-- extensions --' category is selected." + + ^ self selectedMessageCategoryName = self class extensionCategory + ifFalse: [super messageList] + ifTrue: [ + Array streamContents: [:extensionSelectors | + self classOrMetaClassOrganizer categories + select: [:cat | cat first == $*] + thenDo: [:extCat | (self classOrMetaClassOrganizer listAtCategoryNamed: extCat) + do: [:extSel | extensionSelectors nextPut: (self formattedLabel: extSel)]]]]! Item was added: + ----- Method: TreeBrowser>>newClassContents (in category 'extras - hierarchy browser') ----- + newClassContents + "Overwritten to use category of hierarchy-class for new class." + + | theClassName | + self isHierarchy ifFalse: [^ super newClassContents]. + ^ (theClassName := self selectedClassName) + ifNil: [Class template: classForHierarchy category] + ifNotNil: [Class templateForSubclassOf: theClassName asString category: classForHierarchy category]! Item was added: + ----- Method: TreeBrowser>>restoreToCategory:className:protocol:selector:mode:meta: (in category 'extras - multi-window support') ----- + restoreToCategory: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool + + lastSystemCategoryList := #(). + lastClassList := #(). + lastMessageCategoryList := #(). + + self updateTreesIfNeeded. + + super restoreToCategory: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool.! Item was added: + ----- Method: TreeBrowser>>selectEnvironment: (in category 'initialization') ----- + selectEnvironment: anEnvironment + + super selectEnvironment: anEnvironment. + + lastSystemCategoryList := self allClassCategories.! Item was added: + ----- Method: TreeBrowser>>setHierarchyMode (in category 'extras - hierarchy browser') ----- + setHierarchyMode + "Mimic what HierarchyBrowser does. Configure the receiver to only display an inheritance tree around a specific class. That is, all superclasses of that class and *all* of its specializations. From now on, there will be no class categories visible in the left-most pane even if the toolbuilder constructed a pane for that. See #newHierarchyFor:selector: for a way to open the receiver without that class-category pane." + + isHierarchyMode := true.! Item was added: + ----- Method: TreeBrowser>>spawnOrNavigateTo: (in category 'extras - hierarchy browser') ----- + spawnOrNavigateTo: aClass + + (aClass inheritsFrom: classForHierarchy) + ifTrue: [ super spawnOrNavigateTo: aClass ] + ifFalse: [ self systemNavigation browseHierarchy: aClass ].! Item was added: + ----- Method: TreeBrowser>>systemCatListKey:from: (in category 'system category tree - support') ----- + systemCatListKey: aChar from: view + "Overwriten because tree widgets do not check whether a modifier key was pressed..." + + ^ self currentEvent anyModifierKeyPressed + and: [super systemCatListKey: aChar from: view]! Item was added: + ----- Method: TreeBrowser>>systemCatSingletonKey:from: (in category 'system category tree - support') ----- + systemCatSingletonKey: aChar from: aView + + ^ super systemCatSingletonKey: aChar from: aView! Item was added: + ----- Method: TreeBrowser>>systemCategoryChild (in category 'system category tree') ----- + systemCategoryChild + + ^ selectedSystemCategory! Item was added: + ----- Method: TreeBrowser>>systemCategoryChild: (in category 'system category tree') ----- + systemCategoryChild: aSymbol + + aSymbol = selectedSystemCategory ifTrue: [^ self]. + self selectSystemCategory: aSymbol. + self currentHand deleteBalloon.! Item was added: + ----- Method: TreeBrowser>>systemCategoryChildren: (in category 'system category tree') ----- + systemCategoryChildren: category + + | all | + category == SystemOrganizer allCategory ifTrue: [^ #()]. + category == self class hierarchyCategory ifTrue: [^ #() "#systemCategoryChildrenForHierarchy:"]. + + all := lastSystemCategoryList. + + ^ self + for: category + from: all + select: [:prefix :cat | self hasSystemCategory: cat prefix: prefix] + thenCollect: [:cat :start | self findPrefix: cat startingAt: start]! Item was added: + ----- Method: TreeBrowser>>systemCategoryHasChildren: (in category 'system category tree') ----- + systemCategoryHasChildren: category + + category == SystemOrganizer allCategory ifTrue: [^ false]. + category == self class hierarchyCategory ifTrue: [^ false "#systemCategoryHasChildrenForHierarchy:"]. + + ^ lastSystemCategoryList anySatisfy: [:cat | self hasSystemCategory: cat prefix: category]! Item was added: + ----- Method: TreeBrowser>>systemCategoryHelpAt: (in category 'system category tree - support') ----- + systemCategoryHelpAt: category + "Integrate Monticello by informing users about package repositories and modifications." + + ^ PackageOrganizer default + packageNamed: category + ifPresent: [:pkg | + Text streamContents: [:packageHelp | | wc repos | + wc := pkg workingCopy. + packageHelp + nextPutAll: ('This is a{1} package:' translated + format: {wc modified ifTrue: [' <b>modified</b>'] ifFalse: ['']}) asTextFromHtml; + cr; space; nextPutAll: (wc := pkg workingCopy) description. + (repos := wc repositoryGroup repositories) size > 1 "more than cache" ifTrue: [ + packageHelp + cr; cr; nextPutAll: 'Known repositories:' translated. + 2 to: repos size do: [:index | | repo | + repo := repos at: index. + packageHelp cr; space; nextPutAll: repo description]] ]] + ifAbsent: [(SystemOrganization categories includes: category) + ifTrue: [category]] + ! Item was added: + ----- Method: TreeBrowser>>systemCategoryLabel: (in category 'system category tree') ----- + systemCategoryLabel: category + "Integrate Monticello by informing users about package modifications." + + | label | + category = SystemOrganizer allCategory ifTrue: [^ category]. + category = self class hierarchyCategory ifTrue: [^ category "#systemCategoryLabelForHierarchy:"]. + + label := self findSuffix: category. + + PackageOrganizer default + packageNamed: category + ifPresent: [:pkg | pkg workingCopy modified ifTrue: [label := '* ', label]] + ifAbsent: [ + (PackageOrganizer default + packageOfSystemCategory: category + ifNone: nil) + ifNil: [ + (SystemOrganization categories includes: category) + ifTrue: [label := label asText addAttribute: TextEmphasis italic; yourself] + ifFalse: [label := '(', label, ')'" asText addAttribute: TextColor gray; yourself"]] + ifNotNil: [ + self flag: #performance. + (SystemOrganization categories includes: category) + ifFalse: [label := '(', label, ')']. + label := label asText addAttribute: TextEmphasis italic; yourself.]] + . + + ^ label! Item was added: + ----- Method: TreeBrowser>>systemCategoryPath (in category 'system category tree') ----- + systemCategoryPath + + self hasSystemCategorySelected ifFalse: [^ #()]. + selectedSystemCategory = SystemOrganizer allCategory ifTrue: [^ {selectedSystemCategory}]. + selectedSystemCategory = self class hierarchyCategory ifTrue: [^ {selectedSystemCategory} "#systemCategoryPathForHierarchy:"]. + + ^ Array streamContents: [:s | | parent | + parent := ''. + [parent notNil] whileTrue: [ + (self systemCategoryChildren: parent) + detect: [:ea | (self hasSystemCategory: selectedSystemCategory prefix: ea) + or: [selectedSystemCategory == ea]] + ifFound: [:ea | s nextPut: (parent := ea)] + ifNone: [parent := nil]]]! Item was added: + ----- Method: TreeBrowser>>systemCategoryRoots (in category 'system category tree') ----- + systemCategoryRoots + + ^ self isHierarchy + ifTrue: [{SystemOrganizer allCategory. self class hierarchyCategory} "#systemCategoryRootsForHierarchy"] + ifFalse: [{SystemOrganizer allCategory}, (self systemCategoryChildren: '')]! Item was added: + ----- Method: TreeBrowser>>systemOrganizer: (in category 'initialization') ----- + systemOrganizer: aSystemOrganizer + + super systemOrganizer: aSystemOrganizer. + + lastSystemCategoryList := self allClassCategories.! Item was added: + ----- Method: TreeBrowser>>updateClassTree (in category 'updating') ----- + updateClassTree + + self updateClassTree: self allClassesInCategory.! Item was added: + ----- Method: TreeBrowser>>updateClassTree: (in category 'updating') ----- + updateClassTree: newList + + lastClassList := newList. + self changed: #classRoots. + self expandClassTree. + + self changed: #classChild.! Item was added: + ----- Method: TreeBrowser>>updateListsAndCodeIn: (in category 'updating') ----- + updateListsAndCodeIn: aWindow + + super updateListsAndCodeIn: aWindow. + self updateTreesIfNeeded.! Item was added: + ----- Method: TreeBrowser>>updateMessageCategoryTree (in category 'updating') ----- + updateMessageCategoryTree + + self updateMessageCategoryTree: self allMessageCategories.! Item was added: + ----- Method: TreeBrowser>>updateMessageCategoryTree: (in category 'updating') ----- + updateMessageCategoryTree: newList + + lastMessageCategoryList := newList. + self changed: #messageCategoryRoots.! Item was added: + ----- Method: TreeBrowser>>updateSystemCategoryTree (in category 'updating') ----- + updateSystemCategoryTree + + self updateSystemCategoryTree: self allClassCategories.! Item was added: + ----- Method: TreeBrowser>>updateSystemCategoryTree: (in category 'updating') ----- + updateSystemCategoryTree: newList + + lastSystemCategoryList := newList. + self changed: #systemCategoryRoots. + self changed: #systemCategoryChild. "For expanding new paths."! Item was added: + ----- Method: TreeBrowser>>updateTreesIfNeeded (in category 'updating') ----- + updateTreesIfNeeded + + | tmp | + lastSystemCategoryList = (tmp := self allClassCategories) + ifFalse: [self updateSystemCategoryTree: tmp]. + lastClassList = (tmp := self allClassesInCategory) + ifFalse: [self updateClassTree: tmp]. + lastMessageCategoryList = (tmp := self allMessageCategories) + ifFalse: [self updateMessageCategoryTree: tmp].! Item was changed: + (PackageInfo named: 'Tools') postscript: 'SystemBrowser default: TreeBrowser.'! - (PackageInfo named: 'Tools') postscript: 'ToolIcons icons removeKey: #font ifAbsent: []. - - "Update description of the preference #extraDebuggerButtons (Tools-ct.1128)" - (Preferences preferenceAt: #extraDebuggerButtons) instVarNamed: ''helpString'' put: ''If true, debugger windows will show *two* rows of buttons -- the debugger-specific row (proceed, restart, etc.) and also the conventional code-tools row. This preference overrides the "Optional buttons" preference for debuggers.''.'!

2 1

The Trunk: ReleaseBuilder-mt.244.mcz
by commits＠source.squeak.org 13 Apr '23

13 Apr '23

Marcel Taeumel uploaded a new version of ReleaseBuilder to project The Trunk: http://source.squeak.org/trunk/ReleaseBuilder-mt.244.mcz ==================== Summary ==================== Name: ReleaseBuilder-mt.244 Author: mt Time: 13 April 2023, 3:12:12.009682 pm UUID: 7108259d-d48f-6946-9b08-e440f57baeec Ancestors: ReleaseBuilder-mt.243 Complements Tools-mt.1198 =============== Diff against ReleaseBuilder-mt.243 =============== Item was changed: ----- Method: ReleaseBuilder class>>configureTools (in category 'scripts') ----- configureTools "Initialize well-known tools and other resources." FileList initialize. FileServices initialize. "register file reader services" RealEstateAgent standardSize: 650@425. SMLoaderPlus setDefaultFilters: #(filterSafelyAvailable). self beautifyEtoys. "Default applications and tools." + SystemBrowser default: TreeBrowser. - SystemBrowser default: Browser. MailSender default: nil. SoundService default: BaseSoundSystem. ToolSet default: StandardToolSet. WebBrowser default: nil. !

1 0

The Trunk: PreferenceBrowser-mt.156.mcz
by commits＠source.squeak.org 13 Apr '23

13 Apr '23

Marcel Taeumel uploaded a new version of PreferenceBrowser to project The Trunk: http://source.squeak.org/trunk/PreferenceBrowser-mt.156.mcz ==================== Summary ==================== Name: PreferenceBrowser-mt.156 Author: mt Time: 13 April 2023, 3:11:54.037682 pm UUID: b7d5542e-cd9a-b948-be26-a7132abf699b Ancestors: PreferenceBrowser-mt.155 Complements Tools-mt.1198 =============== Diff against PreferenceBrowser-mt.155 =============== Item was changed: ----- Method: PreferenceWizardMorph>>adjustSettingsForLowPerformance (in category 'support') ----- adjustSettingsForLowPerformance self updateLowPerformanceLabel: 'Please wait, optimizing performance...' translated. self refreshWorld. self stateGradients "flat look" ifFalse: [self toggleGradients]. self stateBlinkingCursor ifTrue: [self toggleBlinkingCursor]. self stateFastDrag ifFalse: [self toggleFastDrag]. self stateSoftShadows ifTrue: [self toggleSoftShadows]. self stateHardShadows ifTrue: [self toggleHardShadows]. self stateRoundedWindowLook ifTrue: [self toggleRoundedWindowLook]. self stateRoundedButtonLook ifTrue: [self toggleRoundedButtonLook]. + self stateTraditionalSystemBrowser ifFalse: [self toggleTraditionalSystemBrowser]. + self stateAttachToolsToMouse ifTrue: [self toggleAttachToolsToMouse]. self stateToolAndMenuIcons ifTrue: [self toggleToolAndMenuIcons]. self stateSmartHorizontalSplitters ifTrue: [self toggleSmartHorizontalSplitters]. self stateSmartVerticalSplitters ifTrue: [self toggleSmartVerticalSplitters]. PluggableListMorph highlightHoveredRow: false; filterableLists: false; highlightPreSelection: true; "Feedback is important!!" flashOnErrors: false. TheWorldMainDockingBar showSecondsInClock: false. Preferences disable: #balloonHelpInMessageLists. "Set simple background." self currentWorld setAsBackground: MorphicProject defaultFill. "Done." self updateLowPerformanceLabel: 'Settings were adjusted for optimal performance.' translated.! Item was changed: ----- Method: PreferenceWizardMorph>>initializePage05Tools (in category 'initialization - pages') ----- initializePage05Tools | currentPage pane | currentPage := pages add: self createPage. pane := self createScrollPane. currentPage addMorphBack: (self createLabel: 'Choose other settings' color: Color white). currentPage addMorphBack: pane. pane scroller firstSubmorph addAllMorphsBack: { + self createCheckbox: 'Traditional system browser' translated for: #TraditionalSystemBrowser help: 'Enable to use the traditional Smalltalk system browser, which has no tree views in its top panes but plain lists.' translated. self createCheckbox: 'Trace messages browser' translated for: #TraceMessages help: #(trace message). self createCheckbox: 'Browse class hierarchy' translated for: #AlternativeBrowseIt help: 'Whether to spawn a hierarchy browser or full system browser on browse-it commands.' translated. self createVerticalSpace. self createCheckbox: 'Reuse tool windows' translated for: #ReuseWindows help: #(window reuse). self createCheckbox: 'Tool and menu icons' translated for: #ToolAndMenuIcons help: 'Whether to show icons in tools and menus.' translated. self createVerticalSpace. self createCheckbox: 'Embed Transcript in Workspace' translated for: #WorkspaceEmbedTranscript help: #(workspace transcript). self createCheckbox: 'File out Workspace on accept' translated for: #WorkspaceFileOutOnAccept help: #(workspace accept). }. ! Item was added: + ----- Method: PreferenceWizardMorph>>stateTraditionalSystemBrowser (in category 'actions - buttons') ----- + stateTraditionalSystemBrowser + + ^ SystemBrowser default == Browser! Item was added: + ----- Method: PreferenceWizardMorph>>toggleTraditionalSystemBrowser (in category 'actions - buttons') ----- + toggleTraditionalSystemBrowser + + self stateTraditionalSystemBrowser + ifTrue: [SystemBrowser default: TreeBrowser] + ifFalse: [SystemBrowser default: Browser]. + self changed: #stateTraditionalSystemBrowser. + self resetWorld.!

1 0

The Trunk: ToolsTests-mt.120.mcz
by commits＠source.squeak.org 13 Apr '23

13 Apr '23

Marcel Taeumel uploaded a new version of ToolsTests to project The Trunk: http://source.squeak.org/trunk/ToolsTests-mt.120.mcz ==================== Summary ==================== Name: ToolsTests-mt.120 Author: mt Time: 13 April 2023, 3:11:38.460682 pm UUID: 00d3150e-fa34-9548-8449-8a1a2fcd404f Ancestors: ToolsTests-mt.119 Complements Tools-mt.1198 =============== Diff against ToolsTests-mt.119 =============== Item was changed: ----- Method: BrowserTest>>testSpawnHierarchy (in category 'tests') ----- testSpawnHierarchy | spawn | browser selectSystemCategory: browser class category. browser selectClass: browser class. browser selectMessageCategoryNamed: browser messageCategoryList last. browser messageListIndex: (browser messageList size). spawn := browser spawnHierarchy. + [self assert: spawn selectedClassName = browser selectedClassName. - [self assert: spawn selectedSystemCategory = browser selectedSystemCategory. - self assert: spawn selectedClassName = browser selectedClassName. self assert: spawn selectedMessageCategoryName = browser selectedMessageCategoryName. self assert: spawn messageListIndex = browser messageListIndex.] ensure: [ ToolBuilder default close: spawn topView ].! Item was added: + BrowserTest subclass: #TreeBrowserTest + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'ToolsTests-Browser'! Item was added: + ----- Method: TreeBrowserTest class>>shouldInheritSelectors (in category 'testing') ----- + shouldInheritSelectors + "We must pass all basic browser tests. And more." + + ^ true! Item was added: + ----- Method: TreeBrowserTest>>setUp (in category 'running') ----- + setUp + + browser := TreeBrowser new.! Item was added: + ----- Method: TreeBrowserTest>>testMsgNoSingleChildWithEmptyParent (in category 'tests - message list') ----- + testMsgNoSingleChildWithEmptyParent + + Smalltalk allClassesDo: [:cls | | rest parent | + browser setClass: cls. + rest := browser messageCategoryRoots asOrderedCollection. + [rest notEmpty] whileTrue: [ + parent := rest removeFirst. + (browser messageCategoryHasChildren: parent) + ifTrue: [ | children | + children := browser messageCategoryChildren: parent. + children size = 1 ifTrue: [ "Should only be possible if parent is actual category with messages" + browser selectMessageCategoryNamed: parent. + self assert: browser messageList notEmpty]. + rest addAll: children]] ]! Item was added: + ----- Method: TreeBrowserTest>>testSysNoSingleChildWithEmptyParent (in category 'tests - system category list') ----- + testSysNoSingleChildWithEmptyParent + + | rest parent | + rest := browser systemCategoryRoots asOrderedCollection. + [rest notEmpty] whileTrue: [ + parent := rest removeFirst. + (browser systemCategoryHasChildren: parent) + ifTrue: [ | children | + children := browser systemCategoryChildren: parent. + children size = 1 ifTrue: [ "Should only be possible if parent is package or category with classes" + browser selectSystemCategory: parent. + self assert: (browser classList notEmpty + or: [(PackageOrganizer default packageNamed: parent ifAbsent: nil) notNil ])]. + rest addAll: children]]! Item was added: + ----- Method: TreeBrowserTest>>testSystemCategoryPath (in category 'tests - system category list') ----- + testSystemCategoryPath + "For any class, the end of the current should end in the actual system category." + + | failedSelections | + failedSelections := Set new. + SystemOrganization categories do: [:cat | + (SystemOrganization listAtCategoryNamed: cat) ifNotEmpty: [:classes | | cls | + cls := self environment classNamed: classes first. + browser setClass: cls. + cat == browser systemCategoryPath last + ifFalse: [failedSelections add: cat]]]. + self + assert: failedSelections isEmpty + description: 'Not all system categories can be selected!!'.!

1 0

WebServer/Client and MD5 crypto authentication
by tim Rowledge 12 Apr '23

12 Apr '23

Whilst slightly updating the WebServer Help page I noticed Andreas' comment that MD5 authentication was 'pathetic'. Certainly the simple version in WebUtils might be (I couldn't honestly judge it) but we do have a fairly serious crypto package these days. Has anybody ever made WebServer/Client use the presumably much faster MD5 in that package? tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim There are only two really difficult problems in programming: -Naming -Cache invalidation -Off-by-one errors

3 4

TextAction>>#analyze: and friends need improving
by tim Rowledge 11 Apr '23

11 Apr '23

I found myself annoyed that trying to select the pasted in results of a 'copy reference' in a Browser in order to make it a 'link to method' doesn't work. Seems like something that *should*. i.e. Magnitude + can be selected and made into a link that will open a Browser on that method, but Magnitude>>#+ cannot. The issue is that the parsing used in TextAction>>#analyze: and TextLink>>#validate: is a bit naive and out of date. The first problem is that the #analyze: code relies on using <> as a variety of delimiter - and that completely fails if you have the temerity to want to make a link to a method that include either character! It was probably a bad idea ab initio to use a delimiter character that is a valid part of a method name but I guess we're stuck with it. The current comment explains that the code is intending to parse out cases such as - 3+4 <3+4> Click Here<3+4> <3+4>Click Here It can't work for Magnitude > <Magnitude >> for example. The second issue is that the #validate: method needs to see if part of the input string can be splitBy: '>>#'. *That* part I solved, if rather uglyly (yes, I invented new word for the occasion). It's hardly a major thing but improving it would be nice. Actually specifying properly all the cases we want to handle would be a good start. And one couldn't honestly claim that TextEditor>>#changeEmphasis: and SmalltalkEditor>>#handleEmphasisExtra:with: are paragons of virtuous coding. tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim Nostalgia: The good old days multiplied by a bad memory...

1 0

The Inbox: WebClient-Core-ul.131.mcz
by commits＠source.squeak.org 11 Apr '23

11 Apr '23

Levente Uzonyi uploaded a new version of WebClient-Core to project The Inbox: http://source.squeak.org/inbox/WebClient-Core-ul.131.mcz ==================== Summary ==================== Name: WebClient-Core-ul.131 Author: ul Time: 11 April 2023, 12:48:04.515814 pm UUID: c3fedba8-7684-4223-802c-e699cbfb4c84 Ancestors: WebClient-Core-mt.130 Speed up MD5 computation in WebUtils: - as suggested by Tim, #md5HashStream: returns the bytes in the output order, so #reversed can be skipped (this is a breaking change for all the senders of WebUtils class >> #md5HashStream:) - use #readInto:startingAt:count: instead of #nextInto: to read from the stream into the buffer. This avoids a few sends and potential reallocation of the buffer. - do not convert the ByteString to ByteArray in #md5Digest:. ByteArray >> #replaceFrom:to:with:startingAt: can copy from a ByteString into the buffer. Throughput increases by 28% for 16k inputs. =============== Diff against WebClient-Core-mt.130 =============== Item was added: + SystemOrganization addCategory: #'WebClient-Core'! Item was added: + Exception subclass: #WebAuthRequired + instanceVariableNames: 'client request response authParams message' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebAuthRequired commentStamp: 'ar 2/10/2012 12:39' prior: 0! + Exception signaled when authentication is required.! Item was added: + ----- Method: WebAuthRequired class>>client:request:response: (in category 'instance creation') ----- + client: aWebClient request: aWebRequest response: aWebResponse + "Creates a new exception" + + ^(self new) + client: aWebClient + request: aWebRequest + response: aWebResponse! Item was added: + ----- Method: WebAuthRequired>>client (in category 'accessing') ----- + client + "The client causing the exception" + + ^client! Item was added: + ----- Method: WebAuthRequired>>client:request:response: (in category 'initialize') ----- + client: aWebClient request: aWebRequest response: aWebResponse + "Initializes the exception" + + client := aWebClient. + request := aWebRequest. + response := aWebResponse. + ! Item was added: + ----- Method: WebAuthRequired>>defaultAction (in category 'defaults') ----- + defaultAction + + self resume: false.! Item was added: + ----- Method: WebAuthRequired>>defaultResumeValue (in category 'defaults') ----- + defaultResumeValue + "Resume with false by default" + + ^false! Item was added: + ----- Method: WebAuthRequired>>isProxyAuth (in category 'testing') ----- + isProxyAuth + "Return true if proxy authorization is required" + + ^response code = 407! Item was added: + ----- Method: WebAuthRequired>>isUnauthorized (in category 'testing') ----- + isUnauthorized + "Return true if authorization is required" + + ^response code = 401! Item was added: + ----- Method: WebAuthRequired>>message (in category 'accessing') ----- + message + "Answer a default message for the user to ask for input" + + self isProxyAuth ifTrue:[ + ^'The proxy server at "', client proxyServerName, '" requires authentication.'. + ]. + + ^'The server at "', client serverName, '" requires authentication.'.! Item was added: + ----- Method: WebAuthRequired>>request (in category 'accessing') ----- + request + "The request object causing the exception" + + ^request! Item was added: + ----- Method: WebAuthRequired>>response (in category 'accessing') ----- + response + "The response object causing the exception" + + ^response! Item was added: + ----- Method: WebAuthRequired>>token: (in category 'initialize') ----- + token: aString + "Use the given token as credentials" + + | params | + params := self isProxyAuth ifTrue:[client proxyParams] ifFalse:[client authParams]. + + (params at: #token ifAbsent: [nil]) = aString + ifFalse: + [params at: #token put: aString. + self resume: true] + ! Item was added: + ----- Method: WebAuthRequired>>username:password: (in category 'initialize') ----- + username: username password: password + "Use the given username/password as credentials" + + | params retry | + params := self isProxyAuth ifTrue:[client proxyParams] ifFalse:[client authParams]. + retry := false. + (params at: #username ifAbsent:[nil]) = username ifFalse:[ + params at: #username put: username. + retry := true. + ]. + (params at: #password ifAbsent:[nil]) = password ifFalse:[ + params at: #password put: password. + retry := true. + ]. + retry ifTrue:[self resume: true]. + ! Item was added: + ReadStream subclass: #WebChunkedStream + instanceVariableNames: 'sourceStream chunkSize' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebChunkedStream commentStamp: 'ar 1/31/2012 14:00' prior: 0! + Can process chunked data.! Item was added: + ----- Method: WebChunkedStream>>atEnd (in category 'testing') ----- + atEnd + ^chunkSize = 0 and:[super atEnd]! Item was added: + ----- Method: WebChunkedStream>>next (in category 'accessing') ----- + next + "Answer the next decompressed object in the Stream represented by the + receiver." + + <primitive: 65> + position >= readLimit + ifTrue: [^self pastEndRead] + ifFalse: [^collection at: (position := position + 1)]! Item was added: + ----- Method: WebChunkedStream>>next: (in category 'accessing') ----- + next: anInteger + "Answer the next anInteger elements of my collection. overriden for simplicity" + + [(position + anInteger > readLimit) and:[chunkSize ~= 0]] + whileTrue:[self nextChunk]. + + ^super next: anInteger + ! Item was added: + ----- Method: WebChunkedStream>>nextChunk (in category 'accessing') ----- + nextChunk + "Answer the next chunk from a message using chunked transfer encoding." + + | chunk | + chunkSize = 0 ifTrue:[^'']. "read last chunk" + chunkSize := Integer readFrom: (sourceStream upToAll: String crlf) asString base: 16. + chunkSize = 0 ifFalse:[chunk := sourceStream next: chunkSize]. + sourceStream skip: 2. "CrLf" + (chunkSize + readLimit - position) <= collection size ifTrue:[ + collection replaceFrom: 1 to: (readLimit-position) with: collection startingAt: position+1. + readLimit := readLimit - position. + position := 0. + collection replaceFrom: readLimit+1 to: readLimit + chunkSize with: chunk startingAt: 1. + readLimit := readLimit + chunkSize. + ] ifFalse:[ + position < readLimit + ifTrue: [collection := (collection copyFrom: position + 1 to: readLimit), chunk] + ifFalse: [collection := chunk]. + position := 0. + readLimit := collection size. + ]. + ^chunk + ! Item was added: + ----- Method: WebChunkedStream>>on: (in category 'initialize') ----- + on: aStream + + sourceStream := aStream. + collection := (aStream isBinary ifTrue:[ByteArray] ifFalse:[String]) new. + position := readLimit := 0.! Item was added: + ----- Method: WebChunkedStream>>pastEndRead (in category 'accessing') ----- + pastEndRead + "Need more data" + + self nextChunk. + ^self next! Item was added: + Object subclass: #WebClient + instanceVariableNames: 'flags server scheme timeout stream cookies proxyServer lastScheme lastServer lastPort maxRedirect redirections userAgent authParams proxyParams accessLog debugLog' + classVariableNames: 'DebugLog FlagAcceptCookies FlagAllowAuth FlagAllowRedirect ProxyHandler' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebClient commentStamp: 'ar 5/4/2010 13:17' prior: 0! + WebClient provides a simple yet complete HTTP client implementation. + + To view the documentation evaluate: + + HelpBrowser openOn: WebClientHelp. + ! Item was added: + ----- Method: WebClient class>>debugLog (in category 'accessing') ----- + debugLog + "The default debugLog, if any: + WebClient debugLog: Transcript. + WebClient debugLog: nil. + " + + ^DebugLog! Item was added: + ----- Method: WebClient class>>debugLog: (in category 'accessing') ----- + debugLog: aStream + "The default debugLog, if any: + WebClient debugLog: Transcript. + WebClient debugLog: nil. + " + + DebugLog := aStream.! Item was added: + ----- Method: WebClient class>>htmlSubmit:fields: (in category 'utilities') ----- + htmlSubmit: urlString fields: fieldMap + "A utility method for html submit operations. The fieldMap can be EITHER + an array of associations OR a Dictionary of key value pairs (the former is + useful for providing multiple fields and/or specifying the order of fields). + + WebClient + htmlSubmit: 'http://www.google.com/search' + fields: { + 'hl' -> 'en'. + 'q' -> 'Squeak' + } + " + ^self htmlSubmit: urlString + fields: fieldMap + method: 'GET' + ! Item was added: + ----- Method: WebClient class>>htmlSubmit:fields:method: (in category 'utilities') ----- + htmlSubmit: urlString fields: fieldMap method: method + "A utility method for html submit operations. The fieldMap can be EITHER + an array of associations OR a Dictionary of key value pairs (the former is + useful for providing multiple fields and/or specifying the order of fields). + + WebClient + htmlSubmit: 'http://www.google.com/search' + fields: { + 'hl' -> 'en'. + 'q' -> 'Squeak' + } method: 'GET' + " + ^self htmlSubmit: urlString + fields: fieldMap + method: method + encoding: 'application/x-www-form-urlencoded' + ! Item was added: + ----- Method: WebClient class>>htmlSubmit:fields:method:encoding: (in category 'utilities') ----- + htmlSubmit: urlString fields: fields method: method encoding: encoding + "A utility method for html submit operations. The fieldMap can be EITHER + an array of associations OR a Dictionary of key value pairs (the former is + useful for providing multiple fields and/or specifying the order of fields). + + WebClient + htmlSubmit: 'http://www.google.com/search' + fields: { + 'hl' -> 'en'. + 'q' -> 'Squeak' + } method: 'GET' + encoding: 'application/x-www-form-urlencoded' + " + + method = 'GET' ifTrue:[ + "GET only supports url encoded requests" + encoding = 'application/x-www-form-urlencoded' + ifFalse:[^self error: 'Unsupported encoding: ', encoding]. + ^self httpGet: urlString, '?', (WebUtils encodeUrlEncodedForm: fields). + ]. + + method = 'POST' ifTrue:[ + "Dispatch on encoding type" + encoding caseOf: { + [ 'application/x-www-form-urlencoded'] -> [ + ^self httpPost: urlString + content: (WebUtils encodeUrlEncodedForm: fields) + type: encoding. + ]. + ['multipart/form-data'] -> [ + ^self httpPost: urlString multipartFields: fields + ]. + } otherwise:[] + ]. + + self error: 'Unsupported method: ', method. + ! Item was added: + ----- Method: WebClient class>>httpDelete: (in category 'methods') ----- + httpDelete: urlString + "Sends a DELETE request" + "WebClient httpDelete: 'http://ftp.squeak.org/trunk'" + + ^self httpDo:[:client| client httpDelete: urlString]. + ! Item was added: + ----- Method: WebClient class>>httpDo: (in category 'methods') ----- + httpDo: aBlock + "Simplified wrapper for running various methods" + + | client response | + client := self new. + response := WebUtils handleAuth: [aBlock value: client]. + response content; close. + ^response! Item was added: + ----- Method: WebClient class>>httpGet: (in category 'methods') ----- + httpGet: urlString + "Get the response from the given url" + "(WebClient httpGet: 'http://www.squeak.org') content" + + ^self httpDo:[:client| client httpGet: urlString].! Item was added: + ----- Method: WebClient class>>httpHead: (in category 'methods') ----- + httpHead: urlString + "Sends a HEAD request" + "WebClient httpHead: 'http://ftp.squeak.org/trunk'" + + ^self httpDo:[:client| client httpHead: urlString]. + ! Item was added: + ----- Method: WebClient class>>httpOptions: (in category 'methods') ----- + httpOptions: urlString + "Sends an OPTIONS request" + "WebClient httpOptions: 'http://ftp.squeak.org/*'" + "WebClient httpOptions: 'http://ftp.squeak.org/4.1/Squeak4.1.zip'" + + ^self httpDo:[:client| client httpOptions: urlString] + ! Item was added: + ----- Method: WebClient class>>httpPost:content:type: (in category 'methods') ----- + httpPost: urlString content: postData type: contentType + "Fire off an HTTP post request" + + ^self httpDo:[:client| client httpPost: urlString content: postData type: contentType] + ! Item was added: + ----- Method: WebClient class>>httpPost:multipartFields: (in category 'utilities') ----- + httpPost: url multipartFields: fieldMap + "Make a form submission using multipart/form-data POST. + + The fieldMap may contain MIMEDocument instances to indicate the presence + of a file to upload to the server. If the MIMEDocument is present, its + content type and file name will be used for the upload. + + The fieldMap can be EITHER an array of associations OR a Dictionary of + key value pairs (the former is useful for providing multiple fields and/or + specifying the order of fields)." + + | boundary | + boundary := WebUtils multipartBoundary. + + ^self httpPost: url + content: (WebUtils encodeMultipartForm: fieldMap boundary: boundary) + type: 'multipart/form-data; boundary=', boundary! Item was added: + ----- Method: WebClient class>>httpPostChunked:content:type: (in category 'methods') ----- + httpPostChunked: urlString content: chunkBlock type: contentType + "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." + + ^self httpDo:[:client| + client httpPostChunked: urlString content: chunkBlock type: contentType] + ! Item was added: + ----- Method: WebClient class>>httpPut:content:type: (in category 'methods') ----- + httpPut: urlString content: postData type: contentType + "Fire off an HTTP PUT request" + + ^self httpDo:[:client| client httpPut: urlString content: postData type: contentType]! Item was added: + ----- Method: WebClient class>>httpRequest:url:headers:content:response: (in category 'httpsocket') ----- + httpRequest: method url: urlString headers: hdrs content: contentOrNil response: responseBlock + + "Sends an HTTP request to the server. Returns a MIMEDocument if successful, + a string indicating the error otherwise. If a response block is provided, the + response is fed into into so that the sender can see all the headers." + + | client request response content | + client := self new. + client initializeFromUrl: urlString. + client userAgent: HTTPSocket userAgentString. + + request := client requestWithUrl: urlString. + request method: method. + + "Set up headers for the request" + (WebUtils readHeadersFrom: hdrs readStream) + do:[:hdr| request addHeader: hdr key value: hdr value]. + + WebUtils handleAuth:[ + response := client sendRequest: request + content: (contentOrNil ifNotNil:[contentOrNil readStream]) + size: (contentOrNil ifNil:[0] ifNotNil:[contentOrNil size]). + ]. + + content := response contentWithProgress:[:total :amount| + (HTTPProgress new) total: total; amount: amount; signal: 'Downloading...'. + ]. + client close. + + responseBlock ifNotNil:[responseBlock value: response asString]. + + ^(response isSuccess) + ifTrue:[MIMEDocument contentType: response contentType + content: content url: urlString] + ifFalse:[response asString, content]. + ! Item was added: + ----- Method: WebClient class>>httpTrace: (in category 'methods') ----- + httpTrace: urlString + "Sends a TRACE request" + "(WebClient httpTrace: 'http://lists.squeakfoundation.org') content" + "(WebClient httpTrace: 'http://ftp.squeak.org/trunk') content" + + ^self httpDo:[:client| client httpTrace: urlString]! Item was added: + ----- Method: WebClient class>>initialize (in category 'class initialization') ----- + initialize + "WebClient initialize" + + FlagAcceptCookies := 1. + FlagAllowAuth := 2. + FlagAllowRedirect := 4. + + "Default proxy handler" + ProxyHandler := WebUtils. + + self registerHttpSocketRequestHandler. + ! Item was added: + ----- Method: WebClient class>>proxyHandler (in category 'accessing') ----- + proxyHandler + "The currently registered proxy handler" + + ^ProxyHandler! Item was added: + ----- Method: WebClient class>>proxyHandler: (in category 'accessing') ----- + proxyHandler: anObject + "The currently registered proxy handler" + + ProxyHandler := anObject! Item was added: + ----- Method: WebClient class>>registerHttpSocketRequestHandler (in category 'httpsocket') ----- + registerHttpSocketRequestHandler + "Register WebClient as an HTTPSocket request handler" + + (HTTPSocket respondsTo: #httpRequestHandler:) ifFalse:[^self]. + + "Be polite and only register if no other handler was registered." + HTTPSocket httpRequestHandler == HTTPSocket + ifTrue:[HTTPSocket httpRequestHandler: self]. + ! Item was added: + ----- Method: WebClient class>>requestBenchmark:persistent: (in category 'benchmark') ----- + requestBenchmark: url persistent: aBool + "Run a WebClient benchmark to measure request handling speed. + Try using a persistent connection if requested. + + 1) Launch WebServer (or Seaside, or whatever): + + (WebServer reset default) + listenOn: 8888; + addService: '/' action:[:r| r send200Response: '']. + + 2) Run the benchmark: + + MessageTally spyOn:[ + WebClient requestBenchmark: 'http://localhost:8888/' persistent: true. + ] + " + + | time resp startTime endTime count client | + count := 0. + client := WebClient new. + startTime := Time millisecondClockValue. + [endTime := Time millisecondClockValue. + (time := Time milliseconds: endTime since: startTime) < 5000] whileTrue:[ + resp := client httpGet: url. + resp isSuccess ifFalse:[self error: resp status]. + resp content. + aBool ifFalse:[resp close]. + count := count + 1. + ]. + ^(count * 1000 // time) asStringWithCommas, ' requests/sec' + ! Item was added: + ----- Method: WebClient class>>unload (in category 'class initialization') ----- + unload + "Unregister WebClient as http socket handler when unloaded" + + self unregisterHttpSocketRequestHandler. + ! Item was added: + ----- Method: WebClient class>>unregisterHttpSocketRequestHandler (in category 'httpsocket') ----- + unregisterHttpSocketRequestHandler + "Unregister WebClient as an HTTPSocket request handler" + + (HTTPSocket respondsTo: #httpRequestHandler:) ifFalse:[^self]. + + HTTPSocket httpRequestHandler == self + ifTrue:[HTTPSocket httpRequestHandler: nil]. + ! Item was added: + ----- Method: WebClient class>>webSocket00:protocol: (in category 'websockets') ----- + webSocket00: serverUrl protocol: protocol + "Attempt to connect to the given server url using the WebSocket api" + + | key1 key2 bytes hash client req resp | + "Fixed keys from spec" + key1 := 155712099. + key2 := 173347027. + bytes := ByteArray new: 8. + (1 to: bytes size) do:[:i| bytes at: i put: (256 atRandom - 1)]. + hash := WebUtils webSocketHandshake: key1 with: key2 with: bytes. + + client := self new. + client initializeFromUrl: serverUrl. + req := client requestWithUrl: serverUrl. + req method: 'GET'. + req headerAt: 'Upgrade' put: 'WebSocket'. + req headerAt: 'Connection' put: 'Upgrade'. + req headerAt: 'Origin' put: 'null'. + protocol ifNotNil:[req headerAt: 'Sec-WebSocket-Protocol' put: protocol]. + req headerAt: 'Sec-WebSocket-Key1' put: '18x 6]8vM;54 *(5: { U1]8 z [ 8'. + req headerAt: 'Sec-WebSocket-Key2' put: '1_ tx7X d < nw 334J702) 7]o}` 0'. + resp := client sendRequest: req content: bytes readStream size: bytes size. + resp code = 101 ifFalse:[client close. ^nil]. + (resp stream next: 16) asByteArray = hash ifFalse:[client close. ^nil]. + + "Close of stream is left to caller" + ^WebSocket00 on: resp stream. + ! Item was added: + ----- Method: WebClient class>>webSocket07:protocol: (in category 'websockets') ----- + webSocket07: serverUrl protocol: protocol + "Attempt to connect to the given server url using the WebSocket api" + "http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07" + + | hash client req resp nonce | + nonce := ByteArray new: 16. + (1 to: nonce size) collect:[:i| nonce at: i put: (256 atRandom - 1)]. + nonce := nonce base64Encoded. + + client := self new. + client initializeFromUrl: serverUrl. + req := client requestWithUrl: serverUrl. + req method: 'GET'. + req headerAt: 'Upgrade' put: 'WebSocket'. + req headerAt: 'Connection' put: 'Upgrade'. + req headerAt: 'Sec-WebSocket-Origin' put: 'null'. + protocol ifNotNil:[req headerAt: 'Sec-WebSocket-Protocol' put: protocol]. + req headerAt: 'Sec-WebSocket-Key' put: nonce. + req headerAt: 'Sec-WebSocket-Version' put: '7'. + + resp := client sendRequest: req. + resp code = 101 ifFalse:[client close. ^nil]. + + "Verify WebSocket hash" + hash := WebUtils webSocketHash07: nonce. + hash = (resp headerAt: 'Sec-WebSocket-Accept') ifFalse:[client close. ^nil]. + + "Close of stream is left to caller" + ^WebSocket07 on: resp stream. + ! Item was added: + ----- Method: WebClient class>>webSocket68:protocol: (in category 'websockets') ----- + webSocket68: serverUrl protocol: protocol + "Attempt to connect to the given server url using the WebSocket api" + + | client req resp | + client := self new. + client initializeFromUrl: serverUrl. + req := client requestWithUrl: serverUrl. + req method: 'GET'. + req headerAt: 'Upgrade' put: 'WebSocket'. + req headerAt: 'Connection' put: 'Upgrade'. + req headerAt: 'Origin' put: 'null'. + protocol ifNotNil:[req headerAt: 'WebSocket-Protocol' put: protocol]. + resp := client sendRequest: req. + resp code = 101 ifFalse:[client close. ^nil]. + + "Close of stream is left to caller" + ^WebSocket00 on: resp stream. + ! Item was added: + ----- Method: WebClient class>>webSocketTo: (in category 'websockets') ----- + webSocketTo: serverUrl + "Attempt to connect to the given server url using the WebSocket api" + + "Testing: + + 1) Launch WebSocket example. + 2) Run the following code: + + | ws | + ws := WebClient webSocketTo: 'http://localhost:8080/broadcast'. + ws onMessage:[:data| Transcript cr; show: data]. + ws fork. + ws send: 'This is the first message'. + ws send: 'This is the last message'. + ws close. + + " + + ^self webSocketTo: serverUrl protocol: nil! Item was added: + ----- Method: WebClient class>>webSocketTo:protocol: (in category 'websockets') ----- + webSocketTo: serverUrl protocol: protocol + "Attempt to connect to the given server url using the WebSocket api" + + ^self webSocket00: serverUrl protocol: protocol! Item was added: + ----- Method: WebClient>>acceptCookie:host:path: (in category 'cookies') ----- + acceptCookie: aCookie host: reqHost path: path + "Accept a cookie from a prior response" + + self acceptCookies ifTrue:[ + "Set the defaults per RFC 2109 section 4.3.1 " + + "Ensure the cookie domain is set" + aCookie domain ifNil:[aCookie domain: reqHost]. + + "Ensure the cookie path is set" + aCookie path ifNil:[aCookie path: path]. + + "Reject the cookie per RFC 2109 section 4.3.2" + (path beginsWith: aCookie path) ifFalse:[^false]. + + aCookie domain = reqHost ifFalse:[ | domain | + domain := aCookie domain. + "For misconfigured servers, insert the leading dot into the domain" + domain first = $. ifFalse:[aCookie domain: (domain := '.', domain)]. + ((domain count:[:ch| ch = $.]) >= 2) ifFalse:[^false]. + (reqHost endsWith: domain) ifFalse:[^false]. + ((reqHost allButLast: domain size) includes: $.) ifTrue:[^false]. + ]. + + "Remove any old cookies" + cookies := cookies reject:[:any| any = aCookie]. + + "Remember the cookie if not expired" + (aCookie expiry == nil or:[aCookie expiry > DateAndTime now]) ifTrue:[ + cookies add: aCookie. + ^true + ]. + ]. + ^false! Item was added: + ----- Method: WebClient>>acceptCookies (in category 'cookies') ----- + acceptCookies + "Whether we should accept cookies" + + ^flags anyMask: FlagAcceptCookies! Item was added: + ----- Method: WebClient>>acceptCookies: (in category 'cookies') ----- + acceptCookies: aBool + "Whether we should accept cookies" + + flags := aBool ifTrue:[flags bitOr: FlagAcceptCookies] ifFalse:[flags bitClear: FlagAcceptCookies]. + ! Item was added: + ----- Method: WebClient>>accessLog (in category 'accessing') ----- + accessLog + "The standard access log. Can be either a stream or a string; if the access log + is a string then the string is assumed to be a file name and the file will be opened + and closed for each request." + + ^accessLog! Item was added: + ----- Method: WebClient>>accessLog: (in category 'accessing') ----- + accessLog: aStreamOrFilename + "The standard access log. Can be either a stream or a string; if the access log + is a string then the string is assumed to be a file name and the file will be opened + and closed for each request." + + accessLog := aStreamOrFilename! Item was added: + ----- Method: WebClient>>allowAuth (in category 'accessing') ----- + allowAuth + "If true, WebClient will attempt to handle authorization requests" + + ^flags anyMask: FlagAllowAuth! Item was added: + ----- Method: WebClient>>allowAuth: (in category 'accessing') ----- + allowAuth: aBool + "If true, WebClient will attempt to handle authorization requests" + + flags := aBool ifTrue:[flags bitOr: FlagAllowAuth] ifFalse:[flags bitClear: FlagAllowAuth]. + ! Item was added: + ----- Method: WebClient>>allowRedirect (in category 'accessing') ----- + allowRedirect + "If true, WebClient will attempt to handle redirect responses" + + ^flags anyMask: FlagAllowRedirect! Item was added: + ----- Method: WebClient>>allowRedirect: (in category 'accessing') ----- + allowRedirect: aBool + "If true, WebClient will attempt to handle redirect responses" + + flags := aBool ifTrue:[flags bitOr: FlagAllowRedirect] ifFalse:[flags bitClear: FlagAllowRedirect]. + ! Item was added: + ----- Method: WebClient>>authDispatch:from:header:params: (in category 'authentication') ----- + authDispatch: request from: response header: authHeader params: params + "Dispatch on an authentication method. + Subclasses can extend this method to support more auth methods." + + (authHeader copyUpTo: Character space) caseOf: { + ['Basic'] -> [self basicAuth: request from: response + header: authHeader params: params]. + ['Digest'] -> [self digestAuth: request from: response + header: authHeader params: params]. + ['Bearer'] -> [self bearerAuth: request from: response + header: authHeader params: params]. + } otherwise:["ignore"]. + ! Item was added: + ----- Method: WebClient>>authParams (in category 'accessing') ----- + authParams + "The authentication parameters" + + ^authParams! Item was added: + ----- Method: WebClient>>authParams: (in category 'accessing') ----- + authParams: aDictionary + "The authentication parameters" + + authParams := aDictionary! Item was added: + ----- Method: WebClient>>authenticate:from: (in category 'sending') ----- + authenticate: request from: response + "Authenticate after having received a 401/407 response. + Returns true if we should retry, false if we fail here." + + "NOTE: The first time through we do NOT ask for credentials right away. + Some authentication mechanisms (NTLM/Negotiate) can use the credentials + of the currently logged on user. Consequently we only ask for credentials + if we're unable to do so without asking. Methods that require credentials + (basic, digest) test for their existence explicitly." + + | headers authHeader params | + + "Pick the right set of parameters" + response code = 401 ifTrue:[ + params := authParams. + headers := response headersAt: 'WWW-Authenticate'. + "If the connection was closed, we need to flush the + proxy params or we won't pick up prior credentials." + self isConnected + ifFalse:[self flushAuthState: proxyParams]. + ] ifFalse:[ + params := proxyParams. + headers := response headersAt: 'Proxy-Authenticate'. + ]. + + "Remove any old response" + params removeKey: #authResponse ifAbsent:[]. + + "Process the authentication header(s)" + 1 to: headers size do:[:i| + authHeader := headers at: i. + self authDispatch: request from: response header: authHeader params: params. + "If we generated an authentication response for the header use it" + params at: #authResponse ifPresent:[:resp| + request headerAt: (response code = 401 + ifTrue:['Authorization'] + ifFalse:['Proxy-Authorization']) + put: (params at: #authMethod), ' ', resp. + ^true]. + ]. + + "If we fall through here this can have two reasons: One is that we don't have + a suitable authentication method. Check for that first." + params at: #authMethod ifAbsent:[^false]. + + "The other possibility is that the credentials are wrong. + Clean out the previous auth state and go ask for credentials." + self flushAuthState: params. + + "Clean out old authentication headers" + response code = 401 + ifTrue:[request removeHeader: 'Authorization']. + "Always clean out the proxy auth header since we don't support pre-authentication" + request removeHeader: 'Proxy-Authorization'. + + "Signal WebAuthRequired" + (WebAuthRequired client: self request: request response: response) + signal == true ifFalse:[^false]. + + "And retry with the new credentials" + ^self authenticate: request from: response! Item was added: + ----- Method: WebClient>>basicAuth:from:header:params: (in category 'authentication') ----- + basicAuth: request from: response header: header params: params + "Provide basic authentication for the request" + + | user pass args | + authParams at: #authMethod ifPresent:[:method| ^self]. "do not retry repeatedly" + authParams at: #authMethod put: 'Basic'. + + args := WebUtils parseAuthParams: header. + args at: 'realm' ifPresent:[:realm| authParams at: #authRealm put: realm]. + + user := (params at: #username ifAbsent:[nil]) ifNil:[^self]. + pass := (params at: #password ifAbsent:[nil]) ifNil:[^self]. + authParams at: #authResponse put: (user, ':', pass value) base64Encoded. + ! Item was added: + ----- Method: WebClient>>bearerAuth:from:header:params: (in category 'authentication') ----- + bearerAuth: request from: response header: header params: params + "Provide token-based OAuth2 authentication for the request" + + | token args | + authParams at: #authMethod ifPresent:[:method| ^self]. "do not retry repeatedly" + authParams at: #authMethod put: 'Bearer'. + + args := WebUtils parseAuthParams: header. + args at: 'realm' ifPresent:[:realm| authParams at: #authRealm put: realm]. + + token := (params at: #token ifAbsent:[nil]) ifNil:[^self]. + authParams at: #authResponse put: token. + ! Item was added: + ----- Method: WebClient>>canVerify (in category 'testing') ----- + canVerify + + ^ (stream respondsTo: #canVerify) + ifTrue: [stream canVerify] + ifFalse: [WebUtils platformName ~= 'Mac OS']! Item was added: + ----- Method: WebClient>>close (in category 'initialize') ----- + close + "Close the client's stream" + + stream ifNotNil:[ + stream isConnected ifTrue: [stream close]. + stream := nil]. + ! Item was added: + ----- Method: WebClient>>connect (in category 'initialize') ----- + connect + "Connect the client to a web server. Returns nil if successful, + a WebResponse if a proxy CONNECT request fails." + + | actualServer actualPort | + + "Determine which server to connect to (proxy or real)" + proxyServer ifNil:[ + actualServer := self serverName. + actualPort := self serverPort. + ] ifNotNil:[ + actualServer := self proxyServerName. + actualPort := self proxyServerPort. + ]. + + "Check if we can use the same stream or if we need to reconnect" + (stream notNil + and:[stream isConnected + and:[lastServer = actualServer + and:[lastPort = actualPort + and:[lastScheme = scheme]]]]) ifTrue:[^nil]. + + self close. + lastServer := actualServer. + lastPort := actualPort. + lastScheme := scheme. + stream := SocketStream openConnectionToHostNamed: lastServer port: lastPort. + stream timeout: timeout. + "Perform ssl initialization if necessary" + scheme = 'https' ifTrue:[^self sslConnect]. + ^nil! Item was added: + ----- Method: WebClient>>contentDecoders (in category 'initialize') ----- + contentDecoders + + | result | + result := nil. + (self class environment hasBindingOf: #GZipReadStream) + ifTrue: [result := 'gzip']. + (self class environment hasBindingOf: #BrotliReadStream) + ifTrue: [ result := result ifNil: ['br'] ifNotNil: [:r | r, ', br']]. + ^ result! Item was added: + ----- Method: WebClient>>cookies (in category 'accessing') ----- + cookies + "The cookies that have been set for this session" + + ^cookies! Item was added: + ----- Method: WebClient>>cookies: (in category 'accessing') ----- + cookies: aCollection + "The cookies that have been set for this session" + + cookies := aCollection.! Item was added: + ----- Method: WebClient>>debugLog (in category 'accessing') ----- + debugLog + "If provided, WebClient will print all requests and responses to the debugLog, + except from the content of the message. The debug log must be a stream of + some sort; file names (like for the accessLog are not supported)." + + ^debugLog! Item was added: + ----- Method: WebClient>>debugLog: (in category 'accessing') ----- + debugLog: aStream + "If provided, WebClient will print all requests and responses to the debugLog, + except from the content of the message. The debug log must be a stream of + some sort; file names (like for the accessLog are not supported)." + + debugLog := aStream! Item was added: + ----- Method: WebClient>>defaultPort (in category 'initialize') ----- + defaultPort + "Return the default port to use if no port was specified. + Since we only support https and http, default to port 80 unless https." + + ^scheme = 'https' + ifTrue:[443] + ifFalse:[80]! Item was added: + ----- Method: WebClient>>defaultUserAgent (in category 'initialize') ----- + defaultUserAgent + "Answer the default User-Agent string to use for WebClient" + + ^'WebClient/1.5 (', + WebUtils mcVersion, '; ', + SystemVersion current version,'-', + SystemVersion current highestUpdate printString, '; ', + WebUtils platformName,')'. + ! Item was added: + ----- Method: WebClient>>destroy (in category 'initialize') ----- + destroy + "Destroys the client" + + stream ifNotNil:[ + stream destroy. + stream := nil. + ]. + ! Item was added: + ----- Method: WebClient>>detectProxyServer (in category 'initialize') ----- + detectProxyServer + "Automatically detect the proxy server to use" + + proxyServer := ProxyHandler proxyServerFor: self server. + ! Item was added: + ----- Method: WebClient>>digestAuth:from:header:params: (in category 'authentication') ----- + digestAuth: request from: response header: authHeader params: params + "Perform digest authentication" + + | realm nonce ha1 ha2 nc cnonce qop header uri md5 key args user pass | + params at: #authMethod ifPresent:[:method| ^self]. "do not retry repeatedly" + params at: #authMethod put: 'Digest'. + + args := WebUtils parseAuthParams: authHeader. + realm := args at: 'realm'. + authParams at: #authRealm put: realm. + + user := (params at: #username ifAbsent:[nil]) ifNil:[^self]. + pass := (params at: #password ifAbsent:[nil]) ifNil:[^self]. + + nonce := args at: 'nonce'. + uri := request rawUrl. + + "VERY IMPORTANT NOTE: Some servers fail horribly if the nonce count + isn't precisely eight digits and without quotes." + nc := args at: 'nc' put: (args at: 'nc' ifAbsent:[0]) + 1. + nc := nc asString padded: #left to: 8 with: $0. + + key := user, ':', realm, ':', pass value. + ha1 := WebUtils md5Digest: key. + ha2 := WebUtils md5Digest: request method, ':', uri. + cnonce := UUID new hex. + + (args includesKey: 'qop') ifTrue:["use qop" + qop := 'auth'. "the only qop we support" + md5 := WebUtils md5Digest: ha1, ':', nonce, ':', nc, ':', cnonce, ':', qop, ':', ha2. + header := + 'username="', user, '"', + ', realm="', realm, '"', + ', nonce="', nonce, '"', + ', uri="', uri, '"', + ', response="', md5, '"', + ', qop="', qop,'"', + ', nc="', nc, '"', + ', cnonce="', cnonce, '"'. + ] ifFalse:["ignore qop" + md5 := WebUtils md5Digest: ha1, ':', nonce, ':', ha2. + header := + 'username="', user, '"', + ', realm="', realm, '"', + ', nonce="', nonce, '"', + ', uri="', uri, '"', + ', response="', md5, '"'. + ]. + args at: 'opaque' ifPresent: [:opaque | + header := header, ', opaque="', opaque, '"' + ]. + params at: #authResponse put: header.! Item was added: + ----- Method: WebClient>>flushAuthState (in category 'initialize') ----- + flushAuthState + "Flush all the auth state" + + self flushAuthState: authParams. + self flushAuthState: proxyParams.! Item was added: + ----- Method: WebClient>>flushAuthState: (in category 'authentication') ----- + flushAuthState: params + "Fliush authentication state that should not been preserved + inbetween failed attempts to authenticate. + Subclasses can extend this method to support more auth methods." + + params removeKey: #authMethod ifAbsent:[]. + ! Item was added: + ----- Method: WebClient>>httpDelete: (in category 'methods') ----- + httpDelete: urlString + "Sends an DELETE request" + + ^self httpDelete: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpDelete:do: (in category 'methods') ----- + httpDelete: urlString do: aBlock + "Sends a DELETE request" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'DELETE'. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request.! Item was added: + ----- Method: WebClient>>httpGet: (in category 'methods') ----- + httpGet: urlString + "GET the response from the given url" + "(WebClient httpGet: 'http://www.squeak.org') content" + + ^self httpGet: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpGet:do: (in category 'methods') ----- + httpGet: urlString do: aBlock + "GET the response from the given url" + "(WebClient httpGet: 'http://www.squeak.org') content" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'GET'. + userAgent ifNotNil:[:ua | request headerAt: 'User-Agent' put: ua]. + self contentDecoders ifNotNil: [:decoders | request headerAt: 'Accept-Encoding' put: decoders]. + aBlock value: request. + ^self sendRequest: request + ! Item was added: + ----- Method: WebClient>>httpHead: (in category 'methods') ----- + httpHead: urlString + "Sends a HEAD request" + + ^self httpHead: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpHead:do: (in category 'methods') ----- + httpHead: urlString do: aBlock + "Sends a HEAD request" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'HEAD'. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request.! Item was added: + ----- Method: WebClient>>httpOptions: (in category 'methods') ----- + httpOptions: urlString + "Sends an OPTIONS request" + + ^self httpOptions: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpOptions:do: (in category 'methods') ----- + httpOptions: urlString do: aBlock + "Sends an OPTIONS request" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'OPTIONS'. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request + ! Item was added: + ----- Method: WebClient>>httpPost:content:type: (in category 'methods') ----- + httpPost: urlString content: postData type: contentType + "POST the data to the given url" + + ^self httpPost: urlString content: postData type: contentType do:[:req|]! Item was added: + ----- 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. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request content: postData readStream size: postData size! Item was added: + ----- Method: WebClient>>httpPostChunked:content:type: (in category 'methods') ----- + httpPostChunked: urlString content: chunkBlock type: contentType + "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." + + ^self httpPostChunked: urlString content: chunkBlock type: contentType do: [:req|]! Item was added: + ----- 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]. + 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 added: + ----- Method: WebClient>>httpPut:content:type: (in category 'methods') ----- + httpPut: urlString content: postData type: contentType + "PUT the data to the given url" + + ^self httpPut: urlString content: postData type: contentType do:[:req|]! Item was added: + ----- 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. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request content: postData readStream size: postData size! Item was added: + ----- Method: WebClient>>httpTrace: (in category 'methods') ----- + httpTrace: urlString + "Sends a TRACE request" + + ^self httpTrace: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpTrace:do: (in category 'methods') ----- + httpTrace: urlString do: aBlock + "Sends a TRACE request" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'TRACE'. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request + ! Item was added: + ----- Method: WebClient>>initialize (in category 'initialize') ----- + initialize + "Initializes the receiver" + flags := 0. + super initialize. + + self allowAuth: true. + self allowRedirect: true. + self acceptCookies: true. + + timeout := Socket standardTimeout. + cookies := OrderedCollection new. + redirections := Dictionary new. + maxRedirect := 10. + userAgent := self defaultUserAgent. + authParams := IdentityDictionary new. + proxyParams := IdentityDictionary new. + + "Use the default debug log" + debugLog := DebugLog. + ! Item was added: + ----- Method: WebClient>>initializeFromUrl: (in category 'initialize') ----- + initializeFromUrl: urlString + "Initialize the client from a url string" + + | urlStream serverAndPort userAndPass | + urlStream := urlString readStream. + scheme := (urlStream upToAll: '://') asLowercase. + (scheme = 'http' or:[scheme = 'https']) + ifFalse:[self error: 'Unsupported scheme: ', scheme]. + serverAndPort := urlStream upTo: $/. + + userAndPass := serverAndPort copyUpTo: $@. + userAndPass = serverAndPort ifFalse:[ + serverAndPort := serverAndPort copyAfter: $@. + self username: (userAndPass copyUpTo: $:). + self password: (userAndPass copyAfter: $:). + ]. + + self server: serverAndPort. + self detectProxyServer.! Item was added: + ----- Method: WebClient>>isConnected (in category 'testing') ----- + isConnected + "Returns true if the client is still connected" + + ^stream notNil and:[stream isConnected]! Item was added: + ----- Method: WebClient>>maxRedirect (in category 'accessing') ----- + maxRedirect + "The max. number of redirects we allow for the SAME SITE before giving up. + Redirects can happen for any number of reasons between any number of sites + and we give up if we have seen the SAME SITE maxRedirect number of times." + + ^maxRedirect! Item was added: + ----- Method: WebClient>>maxRedirect: (in category 'accessing') ----- + maxRedirect: aNumber + "The max. number of redirects we allow for the SAME SITE before giving up. + Redirects can happen for any number of reasons between any number of sites + and we give up if we have seen the SAME SITE maxRedirect number of times." + + maxRedirect := aNumber! Item was added: + ----- Method: WebClient>>newRequest (in category 'initialize') ----- + newRequest + "Create an return a new WebRequest. + Subclasses can use this method to override the default request class." + + ^WebRequest new! Item was added: + ----- Method: WebClient>>password (in category 'accessing') ----- + password + "The password for remote authentication. + The password should generally not be a plain-text + version but rather a block that can retrieve the password + when required." + + ^authParams at: #password ifAbsent:[nil]! Item was added: + ----- Method: WebClient>>password: (in category 'accessing') ----- + password: aStringOrValuable + "The password for remote authentication. + The password should generally not be a plain-text + version but rather a block that can retrieve the password + when required." + + ^authParams at: #password put: aStringOrValuable! Item was added: + ----- Method: WebClient>>printOn: (in category 'printing') ----- + printOn: aStream + "Print the receiver on aStream" + + aStream nextPutAll: self class name. + aStream nextPut: $(. + (stream notNil and:[stream isConnected]) ifTrue:[ + aStream nextPutAll: 'Connected: '. + ]. + scheme ifNotNil:[aStream nextPutAll: scheme, '://']. + server ifNotNil:[aStream nextPutAll: server]. + aStream nextPut:$). + ! Item was added: + ----- Method: WebClient>>proxyConnect (in category 'initialize') ----- + proxyConnect + "Send a proxy CONNECT request to connect to a remote host via the chosen proxy server" + + | uri request repeatAuth response | + uri := self serverUrlName,':', self serverPort. + request := self newRequest. + request method: 'CONNECT'. + request rawUrl: uri. + + [repeatAuth := false. + + "The proxy response may use Connection: Close; reconnect when that happens" + self isConnected ifFalse:[ + stream := SocketStream openConnectionToHostNamed: lastServer port: lastPort. + stream timeout: timeout. + ]. + + debugLog ifNotNil:[ + request writeOn: debugLog. + debugLog flush. + ]. + + "Don't use 'self writeRequestOn:' since this will insert both cookies + as well as modify the url target when a proxy is present" + request writeOn: stream. + stream flush. + + response := request newResponse readFrom: stream. + + debugLog ifNotNil:[ + response writeOn: debugLog. + debugLog flush. + ]. + + "Handle authentication if needed" + (self allowAuth and:[response code = 407]) ifTrue:[ + "Eat up the content of the previous response" + response content. + repeatAuth := self authenticate: request from: response. + ]. + repeatAuth] whileTrue. + + ^response! Item was added: + ----- Method: WebClient>>proxyParams (in category 'proxy') ----- + proxyParams + "The proxy authentication parameters" + + ^proxyParams! Item was added: + ----- Method: WebClient>>proxyParams: (in category 'proxy') ----- + proxyParams: aDictionary + "The proxy authentication parameters" + + proxyParams := aDictionary! Item was added: + ----- Method: WebClient>>proxyPass (in category 'proxy') ----- + proxyPass + "The password for an authenticating proxy. + The password should generally not be a plain-text + version but rather a block that can retrieve the password + when required." + + ^proxyParams at: #password! Item was added: + ----- Method: WebClient>>proxyPass: (in category 'proxy') ----- + proxyPass: aStringOrValuable + "The password for an authenticating proxy. + The password should generally not be a plain-text + version but rather a block that can retrieve the password + when required." + + proxyParams at: #password put: aStringOrValuable! Item was added: + ----- Method: WebClient>>proxyServer (in category 'proxy') ----- + proxyServer + "The proxy server to use for connections. + The server should be specified as server:port if the proxy + port to be used is different from the desitation port." + + ^proxyServer! Item was added: + ----- Method: WebClient>>proxyServer: (in category 'proxy') ----- + proxyServer: aString + "The proxy server to use for connections. + The server should be specified as server:port if the proxy + port to be used is different from the desitation port." + + proxyServer := aString! Item was added: + ----- Method: WebClient>>proxyServerName (in category 'proxy') ----- + proxyServerName + "Returns the name part of the server:port description" + + ^proxyServer copyUpTo: $:! Item was added: + ----- Method: WebClient>>proxyServerPort (in category 'proxy') ----- + proxyServerPort + "Returns the port of the proxyServer:port description" + + ^(proxyServer copyAfter: $:) + ifEmpty:[self serverPort] + ifNotEmpty:[:portString| portString asInteger]. + ! Item was added: + ----- Method: WebClient>>proxyUser (in category 'proxy') ----- + proxyUser + "The user name for an authenticating proxy" + + ^proxyParams at: #username ifAbsent:[nil]! Item was added: + ----- Method: WebClient>>proxyUser: (in category 'proxy') ----- + proxyUser: aString + "The user name for an authenticating proxy" + + proxyParams at: #username put: aString! Item was added: + ----- Method: WebClient>>redirect:from: (in category 'sending') ----- + redirect: request from: response + "Handle a 3xx redirect response" + + | location max | + + "Check if we handle the specific type of redirect here" + (#( 301 + 302 "Found" + 303 "See Other" + 307 "Temporary Redirect") + includes: response code) ifFalse:[^false]. + + "RFC 2616 states that requests other than HEAD and GET MUST NOT be auto + redirected for 302 and 307 responses" + (request method = 'GET' or:[request method = 'HEAD']) ifFalse:[ + (response code = 302 or:[response code = 307]) ifTrue:[^false]. + ]. + + "Find the new location" + location := response headerAt: 'location'. + + "Check if we've exceeded max redirections" + max := redirections at: location ifAbsent:[0]. + max > self maxRedirect ifTrue:[^false]. + redirections at: location put: max+1. + + "Do the actual redirect, i.e., set us up for the new url" + (location findString: '://') > 0 "do we have a scheme:// url?" + ifTrue:[self initializeFromUrl: location]. + + request initializeFromUrl: location. + + ^true! Item was added: + ----- Method: WebClient>>requestWithUrl: (in category 'initialize') ----- + requestWithUrl: urlString + "Create and return a new WebRequest initialized with the given url." + + ^self newRequest initializeFromUrl: urlString! Item was added: + ----- Method: WebClient>>scheme (in category 'accessing') ----- + scheme + "The scheme used for the request (usually http or https)" + + ^scheme! Item was added: + ----- Method: WebClient>>scheme: (in category 'accessing') ----- + scheme: aString + "The scheme used for the request (usually http or https)" + + scheme := aString! Item was added: + ----- Method: WebClient>>sendRequest: (in category 'sending') ----- + sendRequest: request + "Send an http request" + + ^self sendRequest: request content: nil size: 0! Item was added: + ----- Method: WebClient>>sendRequest:content:size: (in category 'sending') ----- + sendRequest: request content: contentStream size: streamSize + "Send an http request" + + ^self sendRequest: request contentBlock:[:aStream| + contentStream ifNotNil:[ + "Upload content if provided" + contentStream position: 0. + request streamFrom: contentStream to: aStream size: streamSize + progress:[:total :amount| + (HTTPProgress new) + total: total; + amount: amount; + signal: 'Uploading...']]]. + ! Item was added: + ----- Method: WebClient>>sendRequest:contentBlock: (in category 'sending') ----- + sendRequest: request contentBlock: contentBlock + "Send an http request" + + | response repeatRedirect repeatAuth | + + "XXXX: Fixme. Pre-authenticate the request if we have valid auth credentials" + + redirections := Dictionary new. + + ["The outer loop handles redirections" + repeatRedirect := false. + + "Always update the host header due to redirect" + request headerAt: 'Host' put: server. + + ["The inner loop handles authentication" + repeatAuth := false. + + "Connect can fail if SSL proxy CONNECT is involved" + self connect ifNotNil:[:resp| ^resp]. + + "Write the request to the debugLog if present" + debugLog ifNotNil:[self writeRequest: request on: debugLog]. + + "Send the request itself" + self writeRequest: request on: stream. + contentBlock value: stream. + + response := request newResponse readFrom: stream. + response url: (scheme, '://', server, request rawUrl). + + debugLog ifNotNil:[ + response writeOn: debugLog. + debugLog flush. + ]. + response setCookiesDo:[:cookie| + self acceptCookie: cookie host: self serverUrlName path: request url. + ]. + accessLog ifNotNil:[ + WebUtils logRequest: request response: response on: accessLog + ]. + "Handle authentication if needed" + (self allowAuth and:[response code = 401 or:[response code = 407]]) ifTrue:[ + "Eat up the content of the previous response" + response content. + repeatAuth := self authenticate: request from: response. + ]. + + repeatAuth] whileTrue. + + "Flush previous authState. + XXXX: Fixme. authState must be preserved for pre-authentication of requests." + self flushAuthState. + + "Handle redirect if needed" + (self allowRedirect and:[response isRedirect]) ifTrue:[ + "Eat up the content of the previous response" + response content. + repeatRedirect := self redirect: request from: response. + ]. + repeatRedirect] whileTrue:[ + "When redirecting, remove authentication headers" + request removeHeader: 'Authorization'. + request removeHeader: 'Proxy-Authorization'. + ]. + + "If the response is not a success, eat up its content" + (response isSuccess or:[response isInformational]) ifFalse:[response content]. + + ^response! Item was added: + ----- Method: WebClient>>server (in category 'accessing') ----- + server + "The server to use for connections. + The server is specified as server:port if needed" + + ^server! Item was added: + ----- Method: WebClient>>server: (in category 'accessing') ----- + server: aString + "The server to use for connections. + The server should be specified as server:port if needed" + + server := aString + ! Item was added: + ----- Method: WebClient>>serverName (in category 'accessing') ----- + serverName + "Returns the name part of the server:port description" + + | serverUrlName | + serverUrlName := self serverUrlName. + ^ (serverUrlName includes: $[) + ifTrue: [serverUrlName copyFrom: 2 to: serverUrlName size - 1] + ifFalse: [serverUrlName]! Item was added: + ----- Method: WebClient>>serverPort (in category 'accessing') ----- + serverPort + "Returns the port of the server:port description" + + (self server copyAfterLast: $:) + ifNotEmpty:[:portString| + portString isAllDigits + ifTrue: [^ portString asInteger]]. + ^ self defaultPort! Item was added: + ----- Method: WebClient>>serverUrlName (in category 'accessing') ----- + serverUrlName + "Returns the name part of the server:port description in the way it would appear in an Url" + + ^ (self server includes: $[) + ifTrue: [self server copyUpThrough: $] ] + ifFalse: [self server copyUpToLast: $:]! Item was added: + ----- Method: WebClient>>sslConnect (in category 'initialize') ----- + sslConnect + "Do the SSL handshake" + "Connect the client to a web server" + + | sqSSL | + proxyServer ifNotNil:[ | resp | + "If we have a proxy server, do the proxy connect" + resp := self proxyConnect. + resp isSuccess ifFalse:[^resp]. + ]. + + sqSSL := Smalltalk at: #SqueakSSL ifAbsent:[self error: 'SqueakSSL is missing']. + "Convert the stream to a secure stream" + stream := sqSSL secureSocketStream on: stream socket. + stream timeout: timeout. + self sslConnect: stream to: self serverName. + "And cert verification" + self canVerify + ifTrue: [stream verifyCert: self serverName]. + ^ nil"indicating success" + ! Item was added: + ----- Method: WebClient>>sslConnect:to: (in category 'initialize') ----- + sslConnect: stream to: lastServer + "Do the SSL handshake, use SNI if available" + (stream respondsTo: #sslConnectTo:) + ifTrue: [stream sslConnectTo: lastServer] + ifFalse: [stream sslConnect].! Item was added: + ----- Method: WebClient>>timeout (in category 'accessing') ----- + timeout + "Timeout for the http operations" + + ^timeout! Item was added: + ----- Method: WebClient>>timeout: (in category 'accessing') ----- + timeout: aNumber + "Timeout for the http operations" + + timeout := aNumber! Item was added: + ----- Method: WebClient>>token (in category 'accessing') ----- + token + "The token for remote OAuth2 authentication" + + ^authParams at: #token ifAbsent:[nil]! Item was added: + ----- Method: WebClient>>token: (in category 'accessing') ----- + token: aString + "The token for remote OAuth2 authentication" + + authParams at: #token put: aString! Item was added: + ----- Method: WebClient>>userAgent (in category 'accessing') ----- + userAgent + "The User-Agent string sent to the server" + + ^userAgent! Item was added: + ----- Method: WebClient>>userAgent: (in category 'accessing') ----- + userAgent: aString + "The User-Agent string sent to the server. + If no user agent should be sent, this value can be set to nil" + + userAgent := aString! Item was added: + ----- Method: WebClient>>username (in category 'accessing') ----- + username + "The username for remote authentication" + + ^authParams at: #username ifAbsent:[nil]! Item was added: + ----- Method: WebClient>>username: (in category 'accessing') ----- + username: aString + "The username for remote authentication" + + authParams at: #username put: aString! Item was added: + ----- Method: WebClient>>writeCookiesFor:on: (in category 'sending') ----- + writeCookiesFor: request on: stream + "Write the cookies for a particular request" + + (cookies select:[:ck| (request acceptsCookie: ck from: self )]) ifNotEmpty:[:ckset| + stream nextPutAll: 'Cookie: '. + ckset + do:[:ck| stream nextPutAll: ck name,'=', ck value] + separatedBy:[stream nextPutAll:'; ']. + stream crlf. + ]. + ! Item was added: + ----- Method: WebClient>>writeHeadersFor:on: (in category 'sending') ----- + writeHeadersFor: request on: aStream + "Write all the headers for the given request on aStream" + + request headersDo:[:key :value| aStream nextPutAll: key, ': ', value asString; crlf]. + ! Item was added: + ----- Method: WebClient>>writeRequest:on: (in category 'sending') ----- + writeRequest: request on: aStream + "Write all the request headers on the given stream" + + self writeRequestLine: request on: aStream. + self writeHeadersFor: request on: aStream. + self writeCookiesFor: request on: aStream. + aStream crlf. + aStream flush.! Item was added: + ----- Method: WebClient>>writeRequestLine:on: (in category 'sending') ----- + writeRequestLine: request on: aStream + "Write the HTTP request line on the given stream" + + aStream nextPutAll: request method; space. + + "https proxy support is transparent via CONNECT" + (proxyServer notNil and:[scheme ~= 'https']) ifTrue:[ + "http://www.ietf.org/rfc/rfc2616.txt + 5.1.2 Request-URI: + ... + The absoluteURI form is REQUIRED when the request is being made to a + proxy. The proxy is requested to forward the request or service it + from a valid cache, and return the response. Note that the proxy MAY + forward the request on to another proxy or directly to the server" + aStream nextPutAll: scheme, '://', self server. + + "XXXX: This is a hack. Indicate that we want the proxy connection + to be persistent. This should NOT be necessary; the proxy should + know that from the HTTP/1.1 request but apparently, squid will fail + NTLM and Negotiate authentication unless explicitly instructed to + keep the proxy connection alive." + request headerAt: 'Proxy-Connection' put: 'keep-alive'. + ]. + + aStream nextPutAll: request rawUrl; space; nextPutAll: request protocol; crlf.! Item was added: + Object subclass: #WebCookie + instanceVariableNames: 'name value path domain expiry version secure httpOnly comment sameSite' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebCookie commentStamp: 'ar 2/22/2010 05:28' prior: 0! + WebCookie represents an http cookie for use by WebClient.! Item was added: + ----- Method: WebCookie>>= (in category 'comparing') ----- + = aCookie + "Compare the receiver with aCookie" + + ^aCookie class == self class + and:[aCookie name = self name + and:[aCookie domain = self domain + and:[aCookie path = self path]]].! Item was added: + ----- Method: WebCookie>>asString (in category 'converting') ----- + asString + "Create the string representation for this cookie" + + ^String streamContents:[:s| self printOn: s].! Item was added: + ----- Method: WebCookie>>comment (in category 'accessing') ----- + comment + "Cookie comment" + + ^comment! Item was added: + ----- Method: WebCookie>>comment: (in category 'accessing') ----- + comment: aString + "Cookie comment" + + comment := aString! Item was added: + ----- Method: WebCookie>>domain (in category 'accessing') ----- + domain + "Cookie domain" + + ^domain! Item was added: + ----- Method: WebCookie>>domain: (in category 'accessing') ----- + domain: aString + "Cookie domain" + + domain := aString.! Item was added: + ----- Method: WebCookie>>expiry (in category 'accessing') ----- + expiry + "The expiry DateAndTime" + + ^expiry! Item was added: + ----- Method: WebCookie>>expiry: (in category 'accessing') ----- + expiry: aDateAndTime + "The expiry DateAndTime" + + expiry := aDateAndTime ifNotNil:[:dt| dt asUTC].! Item was added: + ----- Method: WebCookie>>expirySeconds: (in category 'accessing') ----- + expirySeconds: maxAge + "Compute the cookie's expiry age from the given number of seconds" + + maxAge = 0 ifTrue:[self expiry: DateAndTime new]. + self expiry: DateAndTime now + maxAge seconds.! Item was added: + ----- Method: WebCookie>>hash (in category 'comparing') ----- + hash + "Hash is re-implemented because #= is re-implemented" + + ^name hash + domain hash + path hash.! Item was added: + ----- Method: WebCookie>>httpOnly (in category 'accessing') ----- + httpOnly + "If the cookie should be httpOnly (not scriptable). + See http://msdn2.microsoft.com/en-us/library/ms533046.aspx" + + ^httpOnly! Item was added: + ----- Method: WebCookie>>httpOnly: (in category 'accessing') ----- + httpOnly: aBool + "If the cookie should be httpOnly (not scriptable). + See http://msdn2.microsoft.com/en-us/library/ms533046.aspx" + + httpOnly := aBool! Item was added: + ----- Method: WebCookie>>initialize (in category 'initialize') ----- + initialize + "Initializes the receiver" + super initialize. + secure := false. + httpOnly := false. + ! Item was added: + ----- Method: WebCookie>>isExpired (in category 'testing') ----- + isExpired + "Return true if this cookie is expired" + + expiry ifNil:[^false]. + ^expiry asUTC < DateAndTime now asUTC! Item was added: + ----- Method: WebCookie>>name (in category 'accessing') ----- + name + "The name of the cookie" + + ^name! Item was added: + ----- Method: WebCookie>>name: (in category 'accessing') ----- + name: aString + "The name of the cookie" + + name := aString! Item was added: + ----- Method: WebCookie>>path (in category 'accessing') ----- + path + "Cookie path" + + ^path! Item was added: + ----- Method: WebCookie>>path: (in category 'accessing') ----- + path: aString + "Cookie path" + + path := aString! Item was added: + ----- Method: WebCookie>>printOn: (in category 'printing') ----- + printOn: aStream + "Creates the string representation for this cookie" + + aStream nextPutAll: name, '=', value asString. + expiry ifNotNil:[ + aStream nextPutAll:'; expires='. + aStream nextPutAll: expiry asDate weekday, ', '. + expiry asDate printOn: aStream format: #(1 2 3 $- 2 2 2 ). + aStream nextPutAll: ' ', expiry asTime print24,' GMT'. + ]. + path ifNotNil:[ + aStream nextPutAll:'; path=', (WebUtils quote: path). + ]. + domain ifNotNil:[ + aStream nextPutAll:'; domain=', (WebUtils quote: domain). + ]. + version ifNotNil:[ + aStream nextPutAll:'; version=', version asString. + ]. + secure ifTrue:[ + aStream nextPutAll: '; secure'. + ]. + httpOnly ifTrue:[ + aStream nextPutAll: '; HttpOnly'. + ]. + ! Item was added: + ----- Method: WebCookie>>readExpiryFrom: (in category 'initialize') ----- + readExpiryFrom: aString + "Read a cookie expiry date from the given string. + The expiration date is specified in the 'Wdy, DD-Mon-YYYY HH:MM:SS GMT' format." + + | tokens | + ^[ + tokens := aString withBlanksTrimmed. + (tokens copyAfterLast: Character space) = 'GMT' + ifFalse:[^DateAndTime new]. + tokens := (tokens copyAfter: Character space) copyUpToLast: Character space. + (DateAndTime readFrom: tokens readStream) offset: Duration zero. + ] on: Error do:[:ex| ex return: DateAndTime new].! Item was added: + ----- Method: WebCookie>>readFrom: (in category 'initialize') ----- + readFrom: aStream + "Read a cookie from the given stream" + + | keyval key val | + aStream skipSeparators. + name := (aStream upTo: $=) withBlanksTrimmed. + value := (aStream upTo: $;) withBlanksTrimmed. + [aStream atEnd] whileFalse:[ + keyval := aStream upTo: $;. + key := (keyval copyUpTo: $=) withBlanksTrimmed. + val := (keyval copyAfter: $=) withBlanksTrimmed. + key asLowercase caseOf: { + ['expires'] -> [self expiry: (self readExpiryFrom: val)]. + ['path'] -> [self path: (WebUtils unquote: val)]. + ['domain'] -> [self domain: (WebUtils unquote: val)]. + ['secure'] -> [self secure: true]. + ['version'] -> [self version: val]. + ['httponly'] -> [self httpOnly: true]. + ['comment'] ->[self comment: val]. + ['max-age'] ->[self expirySeconds: val asNumber]. + ['samesite'] -> [self sameSite: val]. + } otherwise:[Transcript showln: 'Unknown cookie field: ', key, ' = ', val]. + ].! Item was added: + ----- Method: WebCookie>>sameSite (in category 'accessing') ----- + sameSite + "https://datatracker.ietf.org/doc/html/draft-west-cookie-samesite-firstparty…" + + ^ sameSite! Item was added: + ----- Method: WebCookie>>sameSite: (in category 'accessing') ----- + sameSite: value + + sameSite := value.! Item was added: + ----- Method: WebCookie>>secure (in category 'accessing') ----- + secure + "Secure cookie flag" + + ^secure! Item was added: + ----- Method: WebCookie>>secure: (in category 'accessing') ----- + secure: aBool + "Secure cookie flag" + + secure := aBool! Item was added: + ----- Method: WebCookie>>value (in category 'accessing') ----- + value + "The value of the cookie" + + ^value! Item was added: + ----- Method: WebCookie>>value: (in category 'accessing') ----- + value: aString + "The value of the cookie" + + value := aString! Item was added: + ----- Method: WebCookie>>version (in category 'accessing') ----- + version + "Cookie version" + + ^version! Item was added: + ----- Method: WebCookie>>version: (in category 'accessing') ----- + version: aString + "Cookie version" + + version := aString! Item was added: + Object subclass: #WebMessage + instanceVariableNames: 'stream protocol headers content' + classVariableNames: 'StatusCodes' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebMessage commentStamp: 'ar 2/23/2010 10:37' prior: 0! + A common base class for WebRequest and WebResponse.! Item was added: + ----- Method: WebMessage class>>initialize (in category 'class initialization') ----- + initialize + "self initialize" + + StatusCodes := Dictionary newFromPairs:{ + "1xx: Meta status codes" + 100. 'Continue'. + 101. 'Switching Protocols'. + 102. 'Processing'. + "2xx: Success status codes" + 200. 'OK'. + 201. 'Created'. + 202. 'Accepted'. + 203. 'Non-Authoritative Information'. + 204. 'No Content'. + 205. 'Reset Content'. + 206. 'Partial Content'. + 207. 'Multi-Status'. "WebDav RFC: 2518" + "3xx: Redirection status codes" + 300. 'Multiple Choices'. + 301. 'Moved Permanently'. + 302. 'Moved Temporarily'. + 303. 'See Other'. + 304. 'Not Modified'. + 305. 'Use Proxy'. + 307. 'Temporary Redirect'. + "4xx: Client-Side Error status code" + 400. 'Bad Request'. + 401. 'Unauthorized'. + 402. 'Payment Required'. + 403. 'Forbidden'. + 404. 'Not Found'. + 405. 'Method Not Allowed'. + 406. 'Not Acceptable'. + 407. 'Proxy Authentication Required'. + 408. 'Request Timeout'. + 409. 'Conflict'. + 410. 'Gone'. + 411. 'Lenght Required'. + 412. 'Precondition Failed'. + 413. 'Request Entity Too Large'. + 414. 'Request-URI Too Long'. + 415. 'Unsupported Media Type'. + 416. 'Requested Range Not Satisfiable'. + 417. 'Expectation Failed'. + 422. 'Unprocessable Entity'. "WebDav RFC: 2518" + 423. 'Locked'. "WebDav RFC: 2518" + 424. 'Failed Dependency'. "WebDav RFC: 2518" + "5xx: Server-Side Error status codes" + 500. 'Internal Server Error'. + 501. 'Not Implemented'. + 502. 'Bad Gateway'. + 503. 'Service Unavailable'. + 504. 'Gateway Timeout'. + 505. 'HTTP Version Not Supported'. + 507. 'Insufficient Storage'. "WebDav RFC: 2518" + }.! Item was added: + ----- Method: WebMessage class>>statusCodeAt: (in category 'utilities') ----- + statusCodeAt: code + "Return the textual description of a status code" + + ^StatusCodes at: code ifAbsent: [ 'Unknown error' ]! Item was added: + ----- Method: WebMessage>>addHeader:value: (in category 'headers') ----- + addHeader: key value: value + "Adds an ADDITIONAL header for the given key" + + headers add: key -> value.! Item was added: + ----- Method: WebMessage>>asString (in category 'converting') ----- + asString + "Prints the receiver" + + ^String streamContents:[:s| self writeOn: s].! Item was added: + ----- Method: WebMessage>>chunkFrom:to:progress: (in category 'streaming') ----- + chunkFrom: srcStream to: dstStream progress: progressBlock + "Stream the content of srcStream to dstStream. + Use chunked transfer-encoding." + + | chunkSize firstLine buffer totalRead | + totalRead := 0. + buffer := (srcStream isBinary ifTrue:[ByteArray] ifFalse:[String]) new. + [firstLine := srcStream nextLine asString. + chunkSize := ('16r',firstLine asUppercase) asNumber. + chunkSize = 0] whileFalse:[ + progressBlock ifNotNil:[progressBlock value: nil value: totalRead]. + buffer size = chunkSize ifFalse:[buffer := buffer class new: chunkSize]. + buffer := srcStream next: chunkSize into: buffer startingAt: 1. + dstStream nextPutAll: buffer. + srcStream skip: 2. "CRLF" + totalRead := totalRead + chunkSize. + ]. + srcStream skip: 2. "CRLF" + dstStream flush. + progressBlock ifNotNil:[progressBlock value: nil value: totalRead].! Item was added: + ----- Method: WebMessage>>close (in category 'initialize') ----- + close + "Always closes regardless of connection header" + + stream ifNotNil:[stream close].! Item was added: + ----- Method: WebMessage>>closeIfTransient (in category 'initialize') ----- + closeIfTransient + "Close the underlying connection if it's not persistent" + + self isPersistent ifFalse:[self close]. + ! Item was added: + ----- Method: WebMessage>>content (in category 'accessing') ----- + content + "Reads and caches available content and returns it." + + ^content ifNil:[content := self getContent]. + ! Item was added: + ----- Method: WebMessage>>content: (in category 'accessing') ----- + content: aString + "Sets content for a response" + + content := aString.! Item was added: + ----- Method: WebMessage>>contentLength (in category 'accessing') ----- + contentLength + "Answers the numeric value of the Content-Length header, or nil if no header exist" + + ^(self headerAt: 'Content-Length' ifAbsent:[^nil]) asInteger! Item was added: + ----- Method: WebMessage>>contentLength: (in category 'accessing') ----- + contentLength: aNumber + "Sets the numeric value of the Content-Length header" + + ^self headerAt: 'Content-Length' put: aNumber! Item was added: + ----- Method: WebMessage>>contentStream (in category 'accessing') ----- + contentStream + "Answers a stream for the conent." + + ^stream! Item was added: + ----- Method: WebMessage>>contentType (in category 'accessing') ----- + contentType + "Answer the content type for the receiver" + + ^self headerAt: 'Content-Type' ifAbsent:['application/octet-stream'] + ! Item was added: + ----- Method: WebMessage>>contentType: (in category 'accessing') ----- + contentType: aString + "Sets the content type for the receiver" + + ^self headerAt: 'Content-Type' put: aString! Item was added: + ----- Method: WebMessage>>contentWithProgress: (in category 'accessing') ----- + contentWithProgress: progressBlock + "Reads and caches available content and returns it." + + ^content ifNil: [ content := self getContentWithProgress: progressBlock ]! Item was added: + ----- Method: WebMessage>>decoderForContentEncoding (in category 'private') ----- + decoderForContentEncoding + + (self headerAt: 'content-encoding') = 'gzip' + ifTrue: [^ self class environment + at: #GZipReadStream ifAbsent: [self error: 'GZip encoded responses not supported']]. + (self headerAt: 'content-encoding') = 'br' + ifTrue: [^ self class environment + at: #BrotliReadStream ifAbsent: [self error: 'Brotli encoded responses not supported']]. + ^ nil! Item was added: + ----- Method: WebMessage>>destroy (in category 'initialize') ----- + destroy + "Destroys the underlying stream" + + stream ifNotNil:[stream destroy].! Item was added: + ----- Method: WebMessage>>getContent (in category 'private') ----- + getContent + "Reads available content and returns it." + + ^self getContentWithProgress: nil! Item was added: + ----- Method: WebMessage>>getContentWithProgress: (in category 'private') ----- + getContentWithProgress: progressBlockOrNil + "Reads available content and returns it." + + | length result | + length := self contentLength. + result := (stream isBinary ifTrue:[ ByteArray ] ifFalse: [ ByteString ]) + new: (length ifNil: [ 1000 ]) + streamContents: [ :outputStream | + self + streamFrom: stream + to: outputStream + size: length + progress: progressBlockOrNil ]. + self decoderForContentEncoding ifNotNil: [:decoder | + result := (decoder on: result) upToEnd]. + self textConverterForContentType ifNotNil: [:converter | + [result := result convertFromWithConverter: converter] + on: InvalidUTF8 "some servers lie" + do: [^ result]]. + ^ result + ! Item was added: + ----- Method: WebMessage>>headerAt: (in category 'headers') ----- + headerAt: key + "Answers a single value for the given http header. + Do not use for headers that may appear multiple times, such at www-authenticate." + + ^self headerAt: key ifAbsent:[''].! Item was added: + ----- Method: WebMessage>>headerAt:ifAbsent: (in category 'headers') ----- + headerAt: key ifAbsent: aBlock + "Answers a single value for the given http header. + Do not use for headers that may appear multiple times, such at www-authenticate." + + self headersAt: key do:[:value| ^value]. + ^aBlock value! Item was added: + ----- Method: WebMessage>>headerAt:put: (in category 'headers') ----- + headerAt: key put: value + "Sets the value of a header, adding if necessary" + + headers do:[:assoc| + (assoc key sameAs: key) ifTrue:[ + assoc value: value. + ^self + ]. + ]. + self addHeader: key value: value.! Item was added: + ----- Method: WebMessage>>headersAt: (in category 'headers') ----- + headersAt: key + "Answers a collection of values for the given http header. + Use for headers that may appear multiple times, such at www-authenticate." + + ^self headersAt: key ifAbsent:[#()].! Item was added: + ----- Method: WebMessage>>headersAt:do: (in category 'headers') ----- + headersAt: aKey do: aBlock + "Evaluate aBlock with all the headers matching aKey" + + self headersDo:[:key :value| + (aKey sameAs: key) ifTrue:[ aBlock value: value]. + ].! Item was added: + ----- Method: WebMessage>>headersAt:ifAbsent: (in category 'headers') ----- + headersAt: key ifAbsent: aBlock + "Answers a collection of values for the given http header. + Use for headers that may appear multiple times, such at www-authenticate." + + | hdrs | + hdrs := OrderedCollection new. + self headersAt: key do:[:value| hdrs add: value]. + ^hdrs asArray ifEmpty:[aBlock value] + ! Item was added: + ----- Method: WebMessage>>headersDo: (in category 'headers') ----- + headersDo: aBlock + "Evaluate aBlock with all of the headers key-value pairs" + + headers do:[:assoc| + aBlock value: assoc key value: assoc value. + ].! Item was added: + ----- Method: WebMessage>>isPersistent (in category 'testing') ----- + isPersistent + "Return true if this is a persistent connection" + + "Check for explicit connection headers" + ((self headerAt:'Connection') sameAs: 'close') ifTrue:[^false]. + ((self headerAt:'Connection') sameAs: 'keep-alive') ifTrue:[^true]. + + "Defaults for various versions" + (self protocol = 'HTTP/1.0') ifTrue:[^false]. + (self protocol = 'HTTP/1.1') ifTrue:[^true]. + + "Assume that later HTTP versions are compatible with 1.1" + ^true! Item was added: + ----- Method: WebMessage>>multipartBoundary (in category 'accessing') ----- + multipartBoundary + "Answer the boundary of a multipart/form-data message" + + | header | + header := self headerAt: 'Content-Type' ifAbsent:[^nil]. + (header beginsWith: 'multipart/form-data') ifFalse:[^nil]. + ^(header copyFrom: (header findString: 'boundary=') + 9 to: header size)! Item was added: + ----- Method: WebMessage>>nextChunk (in category 'streaming') ----- + nextChunk + "Answer the next chunk from a message using chunked transfer encoding." + + | chunkSize chunk | + chunkSize := Integer readFrom: (stream upToAll: String crlf) asString base: 16. + chunkSize = 0 ifFalse:[chunk := stream next: chunkSize]. + stream skip: 2. "CrLf" + ^chunk! Item was added: + ----- Method: WebMessage>>nextChunkPut: (in category 'streaming') ----- + nextChunkPut: chunk + "Send the next chunk of a message using chunked transfer encoding. + + Note: This method does not allow to send empty chunks to avoid accidentally + terminating the chunked transfer. Ending the transfer is part of the chunked + request/response protocol (see #httpPostChunked:encoded:content:type:do: + as well as #sendResponse:chunked:do:)" + + chunk ifNotEmpty:[ + stream nextPutAll: (chunk size printStringBase: 16); crlf. + stream nextPutAll: chunk; crlf; flush. + ].! Item was added: + ----- Method: WebMessage>>printOn: (in category 'printing') ----- + printOn: aStream + "Prints the receiver" + + aStream nextPutAll: self class name. + aStream nextPut: $(. + self writeOn: aStream. + aStream nextPut: $).! Item was added: + ----- Method: WebMessage>>protocol (in category 'accessing') ----- + protocol + "Returns the requested protocol" + + ^protocol! Item was added: + ----- Method: WebMessage>>protocol: (in category 'accessing') ----- + protocol: aString + "Returns the requested protocol" + + protocol := aString! Item was added: + ----- Method: WebMessage>>remoteHost (in category 'accessing') ----- + remoteHost + "Return the name of the remote host" + + | remote | + (stream isKindOf: SocketStream) ifFalse:[^nil]. "don't have it" + remote := stream socket remoteAddress. + ^ NetNameResolver stringFromAddress: remote. + ! Item was added: + ----- Method: WebMessage>>removeHeader: (in category 'headers') ----- + removeHeader: key + "Removes ALL headers with the given key" + + headers := headers reject:[:assoc| assoc key sameAs: key]. + ! Item was added: + ----- Method: WebMessage>>stream (in category 'accessing') ----- + stream + "Answers the underlying TCP stream" + + ^stream! Item was added: + ----- Method: WebMessage>>stream: (in category 'accessing') ----- + stream: aStream + "Sets the underlying TCP stream" + + stream := aStream! Item was added: + ----- 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." + + | buffer bufferSize totalBytesRead bytesInBuffer | + 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! Item was added: + ----- Method: WebMessage>>streamFrom:size:progress: (in category 'streaming') ----- + streamFrom: srcStream size: size progress: aBlock + "Stream the given source stream to the message's socket stream. + Outbound. Can be used on both request/response depending on + whether it is utilized by WebClient or WebServer." + + ^self streamFrom: srcStream to: stream size: size progress: aBlock! Item was added: + ----- Method: WebMessage>>streamFrom:to:size:progress: (in category 'streaming') ----- + streamFrom: srcStream to: dstStream size: sizeOrNil progress: progressBlock + "Stream the content of srcStream to dstStream applying any conversations necessary." + + (self headerAt: 'transfer-encoding') ifNotEmpty:[:encoding| + encoding = 'chunked' + ifTrue:[ + self flag: #todo. " Ideally this would use the WebChunkedStream --pre" + ^self chunkFrom: srcStream to: dstStream progress: progressBlock] + ifFalse:[self error: 'Unknown transfer-encoding: ', encoding]]. + + ^ self streamDirectlyFrom: srcStream to: dstStream size: sizeOrNil progress: progressBlock.! Item was added: + ----- Method: WebMessage>>streamTo:size:progress: (in category 'streaming') ----- + streamTo: dstStream size: size progress: aBlock + "Stream from the receiver's socket stream to the given destination stream. + Inbound. Can be used on both request/response depending on + whether it is utilized by WebClient or WebServer." + content ifNil:[ + self streamFrom: stream to: dstStream size: size progress: aBlock + ] ifNotNil:[ + self streamDirectlyFrom: content readStream to: dstStream size: size progress: aBlock + ].! Item was added: + ----- Method: WebMessage>>textConverterForContentType (in category 'accessing') ----- + textConverterForContentType + + | index contentType | + contentType := self contentType. + contentType size < 8 ifTrue: [ ^nil ]. + index := contentType findString: 'charset=' startingAt: 1 caseSensitive: false. + index = 0 ifTrue: [ ^nil ]. + contentType := contentType allButFirst: index + 7. "'charset=' size - 1". + (contentType beginsWith: '"') ifTrue: [ + "quoted content-type parameter. see rfc2068 section 3.7" + contentType := contentType + copyFrom: 2 + to: (contentType indexOf: $" startingAt: 2) ]. + ^[ TextConverter newForEncoding: contentType ] + on: NoConverterFound + do: [ nil ]! Item was added: + ----- Method: WebMessage>>writeHeadersOn: (in category 'printing') ----- + writeHeadersOn: aStream + "Write the request" + + self headersDo:[:key :value| aStream nextPutAll: key, ': ', value asString; crlf]. + ! Item was added: + ----- Method: WebMessage>>writeOn: (in category 'printing') ----- + writeOn: aStream + "Write the request" + + self writeHeadersOn: aStream. + aStream crlf. + ! Item was added: + WebMessage subclass: #WebRequest + instanceVariableNames: 'method request rawUrl server' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebRequest commentStamp: 'ar 2/23/2010 10:38' prior: 0! + Represents an HTTP request for WebClient/WebServer.! Item was added: + ----- Method: WebRequest class>>readFrom: (in category 'instance creation') ----- + readFrom: aStream + "Create a WebRequest from a given stream" + + ^self new readFrom: aStream! Item was added: + ----- Method: WebRequest>>acceptsCookie:from: (in category 'testing') ----- + acceptsCookie: aCookie from: webClient + "Returns true if this cookie is applicable to this request" + + aCookie domain ifNotNil:[:domain| + (webClient serverName endsWith: domain) ifFalse:[^false]. + ]. + aCookie path ifNotNil:[:path| + (self url beginsWith: path) ifFalse:[^false]. + ]. + aCookie secure ifNotNil:[:secure| + secure ifTrue:[webClient scheme = 'https' ifFalse:[^false]]. + ]. + aCookie expiry ifNotNil:[:expiry| + aCookie isExpired ifTrue:[^false]. + ]. + ^true! Item was added: + ----- Method: WebRequest>>asWebSocket (in category 'converting') ----- + asWebSocket + "Convert this request into a WebSocket" + + "Figure out the version of the protocol" + | field version | + version := self headerAt: 'Sec-WebSocket-Version' ifAbsent:[nil]. + version ifNil:[ + field := self headerAt: 'Sec-WebSocket-Key1' ifAbsent:[nil]. + field + ifNil:[^self asWebSocket68] + ifNotNil:[^self asWebSocket00]. + ]. + + "Attempt WebSocket07 conversion" + ^self asWebSocket07 + ! Item was added: + ----- Method: WebRequest>>asWebSocket00 (in category 'converting') ----- + asWebSocket00 + "Convert this request into a WebSocket" + + | field key1 key2 bytes resp | + resp := self newResponse protocol: 'HTTP/1.1' code: 101. + resp status: 'HTTP/1.1 101 Web Socket Protocol Handshake'. + + "Chrome 4/5 is *VERY* sensitive to the order of the fields" + resp headerAt: 'Upgrade' put: 'WebSocket'. + resp headerAt: 'Connection' put: 'Upgrade'. + + field := self headerAt: 'Sec-WebSocket-Key1'. + key1 := WebUtils extractWebSocketKey: field. + field := self headerAt: 'Sec-WebSocket-Key2'. + key2 := WebUtils extractWebSocketKey: field. + bytes := WebUtils webSocketHandshake: key1 with: key2 with: (stream next: 8). + + resp headerAt: 'Sec-WebSocket-Origin' put: (self headerAt: 'Origin'). + resp headerAt: 'Sec-WebSocket-Location' put: ('ws://', (self headerAt: 'host'), self rawUrl). + (self headerAt: 'Sec-WebSocket-Protocol' ifAbsent:[nil]) ifNotNil:[:hdr| + resp headerAt: 'Sec-WebSocket-Protocol' put: hdr. + ]. + + resp writeOn: stream. + bytes ifNotNil:[stream nextPutAll: bytes]. + stream flush. + ^WebSocket00 on: stream. + ! Item was added: + ----- Method: WebRequest>>asWebSocket07 (in category 'converting') ----- + asWebSocket07 + "Convert this request into a WebSocket" + + | resp hash nonce | + resp := self newResponse protocol: 'HTTP/1.1' code: 101. + resp status: 'HTTP/1.1 101 Web Socket Protocol Handshake'. + + "Chrome 4/5 is *VERY* sensitive to the order of the fields" + resp headerAt: 'Upgrade' put: 'WebSocket'. + resp headerAt: 'Connection' put: 'Upgrade'. + + nonce := self headerAt: 'Sec-WebSocket-Key'. + hash := WebUtils webSocketHash07: nonce. + + resp headerAt: 'Sec-WebSocket-Accept' put: hash. + (self headerAt: 'Sec-WebSocket-Origin' ifAbsent: [self headerAt: 'Origin']) + ifNotNil: [ :origin | resp headerAt: 'Sec-WebSocket-Origin' put: origin ]. + resp headerAt: 'Sec-WebSocket-Location' put: ('ws://', (self headerAt: 'host'), self rawUrl). + (self headerAt: 'Sec-WebSocket-Protocol' ifAbsent:[nil]) ifNotNil:[:hdr| + resp headerAt: 'Sec-WebSocket-Protocol' put: hdr. + ]. + + resp writeOn: stream. + stream flush. + ^(WebSocket07 on: stream) + masking: false; + yourself. + "http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07#section-… says: + ''Frames sent from the server to the client are not masked.'' + http://tools.ietf.org/html/rfc6455#section-5.1 says: + ''A client MUST close a connection if it detects a masked + frame.'' + So not using masking is compatible with the 07 protocol and is required by RFC 6455."! Item was added: + ----- Method: WebRequest>>asWebSocket68 (in category 'converting') ----- + asWebSocket68 + "Convert this request into a WebSocket" + + | resp | + resp := self newResponse protocol: 'HTTP/1.1' code: 101. + resp status: 'HTTP/1.1 101 Web Socket Protocol Handshake'. + + "Chrome 4/5 is *VERY* sensitive to the order of the fields" + resp headerAt: 'Upgrade' put: 'WebSocket'. + resp headerAt: 'Connection' put: 'Upgrade'. + + resp headerAt: 'WebSocket-Origin' put: (self headerAt: 'Origin'). + resp headerAt: 'WebSocket-Location' put: ('ws://', (self headerAt: 'host'), self rawUrl). + (self headerAt: 'WebSocket-Protocol' ifAbsent:[nil]) ifNotNil:[:hdr| + resp headerAt: 'WebSocket-Protocol' put: hdr. + ]. + resp writeOn: stream. + stream flush. + ^WebSocket00 on: stream.! Item was added: + ----- Method: WebRequest>>closeIfTransient:after: (in category 'sending') ----- + closeIfTransient: resp after: aBlock + "Evaluate aBlock. Close the connection if it is transient. + Inserts Connection: close header if needed." + + | close | + close := self isPersistent not. + close + ifTrue: [ + "Always be explicit and insert the Connection: close header" + resp headerAt: 'Connection' put: 'close' ] + ifFalse: [ + "We should tell the client that we keep this connection alive." + resp headerAt: 'Connection' put: 'Keep-Alive' ]. + aBlock value. + stream flush. + close ifTrue:[self close]. + ! Item was added: + ----- Method: WebRequest>>cookieAt: (in category 'cookies') ----- + cookieAt: aString + "Answer the value for a cookie with the given name" + + ^self cookieAt: aString ifAbsent:['']! Item was added: + ----- Method: WebRequest>>cookieAt:ifAbsent: (in category 'cookies') ----- + cookieAt: aString ifAbsent: aBlock + "Answer the value for a cookie with the given name" + + self cookiesDo:[:name :value| name = aString ifTrue:[^value]]. + ^aBlock value! Item was added: + ----- Method: WebRequest>>cookies (in category 'cookies') ----- + cookies + "Answer all the cookies defined in the request" + + | cookies | + cookies := Dictionary new. + self cookiesDo:[:name :value| cookies at: name put: value]. + ^cookies! Item was added: + ----- Method: WebRequest>>cookiesDo: (in category 'cookies') ----- + cookiesDo: aBlock + "Parse the cookie headers and evaluate aBlock with name / value pairs" + + self headersAt: 'Cookie' do:[:hdr| + (hdr findTokens: ';,') do:[:token| + aBlock + value: (token copyUpTo: $=) withBlanksTrimmed + value: (token copyAfter: $=) withBlanksTrimmed]].! Item was added: + ----- Method: WebRequest>>fields (in category 'fields') ----- + fields + "Answer the fields for the given request." + + | fields | + fields := Dictionary new. + self getFields associationsDo:[:a| fields add: a]. + self postFields associationsDo:[:a| fields add: a]. + self multipartFields associationsDo:[:a| fields add: a]. + ^fields + ! Item was added: + ----- Method: WebRequest>>getFields (in category 'fields') ----- + getFields + "Decodes the fields embedded in the url ?var1=val1&var2=val2" + + | args | + args := (rawUrl copyAfter: $?) ifEmpty:[^Dictionary new]. + ^WebUtils decodeUrlEncodedForm: args multipleValues: false + ! Item was added: + ----- Method: WebRequest>>initialize (in category 'initialize') ----- + initialize + "Initialize the receiver" + + super initialize. + method := 'GET'. + protocol := 'HTTP/1.1'. + headers := OrderedCollection new.! Item was added: + ----- Method: WebRequest>>initializeFromUrl: (in category 'initialize') ----- + initializeFromUrl: urlString + "Initialize the client from a http url or string" + + | urlStream | + urlStream := urlString readStream. + "Skip past scheme if present" + urlStream upToAll: '://'. + urlStream atEnd + ifTrue:[rawUrl := urlString] + ifFalse:[rawUrl := urlStream upTo: $/; upToEnd]. + (rawUrl beginsWith: '/') ifFalse:[rawUrl := '/', rawUrl]. + ! Item was added: + ----- Method: WebRequest>>isDeleteRequest (in category 'testing') ----- + isDeleteRequest + "Returns true if this is an HTTP DELETE request" + + ^self method = 'DELETE'! Item was added: + ----- Method: WebRequest>>isGetRequest (in category 'testing') ----- + isGetRequest + "Returns true if this is an HTTP GET request" + + ^self method = 'GET'! Item was added: + ----- Method: WebRequest>>isHeadRequest (in category 'testing') ----- + isHeadRequest + "Returns true if this is an HTTP HEAD request" + + ^self method = 'HEAD'! Item was added: + ----- Method: WebRequest>>isOptionsRequest (in category 'testing') ----- + isOptionsRequest + "Returns true if this is an HTTP OPTIONS request" + + ^self method = 'OPTIONS'! Item was added: + ----- Method: WebRequest>>isPostRequest (in category 'testing') ----- + isPostRequest + "Returns true if this is an HTTP POST request" + + ^self method = 'POST'! Item was added: + ----- Method: WebRequest>>isPutRequest (in category 'testing') ----- + isPutRequest + "Returns true if this is an HTTP PUT request" + + ^self method = 'PUT'! Item was added: + ----- Method: WebRequest>>isTraceRequest (in category 'testing') ----- + isTraceRequest + "Returns true if this is an HTTP TRACE request" + + ^self method = 'TRACE'! Item was added: + ----- Method: WebRequest>>method (in category 'accessing') ----- + method + "The request method (GET, POST etc)" + + ^method! Item was added: + ----- Method: WebRequest>>method: (in category 'accessing') ----- + method: aString + "The request method (GET, POST etc)" + + method := aString! Item was added: + ----- Method: WebRequest>>multipartFields (in category 'fields') ----- + multipartFields + "Answers the multipart fields of a post request" + + | fields | + fields := Dictionary new. + self multipartFieldsDo:[:hdrs :params :cntnt| + params at: 'name' ifPresent:[:fieldName| fields at: fieldName put: cntnt]. + ]. + ^fields! Item was added: + ----- Method: WebRequest>>multipartFieldsDo: (in category 'fields') ----- + multipartFieldsDo: aBlock + "Evaluate aBlock with the multipart fields of a post request. + The block is expected to take three arguments: + * The headers from the part being processed + * The parameters from the content-disposition header + * The content from the part being processed + " + + ^(self isPostRequest and: [ + self contentType beginsWith: 'multipart/form-data']) + ifTrue: [WebUtils decodeMultipartForm: self content readStream boundary: self multipartBoundary do: aBlock] + ifFalse: [Dictionary new]! Item was added: + ----- Method: WebRequest>>newResponse (in category 'initialize') ----- + newResponse + "Create a new response entitiy. + Subclasses can override this method to provide a different response class" + + ^(WebResponse new) + request: self; + yourself! Item was added: + ----- Method: WebRequest>>newWebSocketOn: (in category 'initialize') ----- + newWebSocketOn: aStream + "Create a new socket entitiy. + Subclasses can override this method to provide a different response class" + + ^WebSocket on: aStream! Item was added: + ----- Method: WebRequest>>postFields (in category 'fields') ----- + postFields + "Answers the multipart fields of a post request" + + ^(self isPostRequest and: [ + self contentType beginsWith: 'application/x-www-form-urlencoded']) + ifTrue: [ + WebUtils + decodeUrlEncodedForm: self content + multipleValues: true + withConverter: self textConverterForContentType ] + ifFalse: [Dictionary new]! Item was added: + ----- Method: WebRequest>>rawUrl (in category 'accessing') ----- + rawUrl + "The raw (unparsed) url" + + ^rawUrl! Item was added: + ----- Method: WebRequest>>rawUrl: (in category 'accessing') ----- + rawUrl: aString + "The raw (unparsed) url" + + rawUrl := aString + ! Item was added: + ----- Method: WebRequest>>readFrom: (in category 'initialize') ----- + readFrom: aStream + "Initialize the receiver initialized from an existing socket stream + This method will block until the headers have been parsed." + + | tokens | + stream := aStream. + stream isBinary ifTrue:[stream ascii]. + "Parse request header" + request := stream upToAll: String crlf. + tokens := request findTokens: ' '. + tokens size < 2 ifTrue:[^self error: 'Invalid HTTP request: ', request]. + method := tokens first. + rawUrl := tokens second. + tokens size > 2 + ifTrue:[protocol := tokens third] + ifFalse:[protocol := 'HTTP/1.0']. + + "Parse HTTP header" + headers := WebUtils readHeadersFrom: stream. + ! Item was added: + ----- Method: WebRequest>>requestLine (in category 'accessing') ----- + requestLine + "The actual request line as sent by the client" + + ^request ifNil:[self method, ' ', self rawUrl, ' ', self protocol]! Item was added: + ----- Method: WebRequest>>send200Response: (in category 'responses') ----- + send200Response: aString + "Send a 200 OK response" + + ^self + send200Response: (aString convertToWithConverter: UTF8TextConverter new) + contentType: 'text/plain; charset=utf-8'.! Item was added: + ----- Method: WebRequest>>send200Response:contentType: (in category 'responses') ----- + send200Response: aString contentType: contentType + "Send a 200 OK response" + + ^self send200Response: aString contentType: contentType do:[:resp|]! Item was added: + ----- 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. + aBlock value: resp. + ^self sendResponse: resp content: aString.! Item was added: + ----- Method: WebRequest>>send301Response: (in category 'responses') ----- + send301Response: location + "Send a 301 permanent redirect response" + + ^self send301Response: location do:[:resp|].! Item was added: + ----- Method: WebRequest>>send301Response:do: (in category 'responses') ----- + send301Response: location do: aBlock + "Send a 301 permanent redirect response" + + ^self send3xxResponse: location code: 301 do: aBlock! Item was added: + ----- Method: WebRequest>>send302Response: (in category 'responses') ----- + send302Response: location + "Send a 302 temporary redirect response" + + ^self send302Response: location do:[:resp|].! Item was added: + ----- Method: WebRequest>>send302Response:do: (in category 'responses') ----- + send302Response: location do: aBlock + "Send a 302 temporary redirect response" + + ^self send3xxResponse: location code: 302 do: aBlock! Item was added: + ----- Method: WebRequest>>send3xxResponse:code: (in category 'responses') ----- + send3xxResponse: location code: statusCode + "Send a 3xx redirect response" + + ^self send3xxResponse: location code: statusCode do:[:resp|].! Item was added: + ----- Method: WebRequest>>send3xxResponse:code:do: (in category 'responses') ----- + send3xxResponse: location code: statusCode do: aBlock + "Send a 3xx redirect response" + + | resp url | + "If the redirect is not to an absolute url, prefix it with the host if we have one" + url := location. + (location findString: '://') > 0 ifFalse:[ + (self headerAt: 'host') ifNotEmpty:[:host| url := 'http://', host, location]]. + + resp := self newResponse protocol: 'HTTP/1.1' code: statusCode. + resp headerAt: 'Location' put: url. + aBlock value: resp. + ^self sendResponse: resp content: ''. + ! Item was added: + ----- Method: WebRequest>>send400Response (in category 'responses') ----- + send400Response + "Send a 400 bad request response" + + | message | + message := '<html><head><title>400 Bad Request</title></head><body>', + '<h1>Bad Request</h1> + <p>The server encountered a request it did not understand. + </body></html>'. + + self sendResponseCode: 400 + content: message squeakToUtf8 + type: 'text/plain; charset=utf-8' + close: true! Item was added: + ----- Method: WebRequest>>send404Response (in category 'responses') ----- + send404Response + "Send a 404 not found response" + + ^self send404Response: '<html><head><title>404 Not Found</title></head><body><h1>404 Not Found</h1><p>The requested URL ',self rawUrl,' was not found on this server.</p></body></html>'. + ! Item was added: + ----- 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' ]! Item was added: + ----- 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'. + aBlock value: resp. + ^self sendResponse: resp content: body. + ! Item was added: + ----- Method: WebRequest>>send405Response: (in category 'responses') ----- + send405Response: allowed + "Send a 405 method not allowed response" + + ^self send405Response: allowed content: '<html><head><title>405 Method Not Allowed</title></head><body><h1>405 Method Not Allowed</h1><p>The requested method ',self method,' is not allowed for the URL', self rawUrl, '</p></body></html>'.! Item was added: + ----- 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: 'allow' put: (String streamContents:[:s| + allowed do:[:m| s nextPutAll: m] separatedBy:[s nextPut: $,] + ]). + ^self sendResponse: resp content: body.! Item was added: + ----- Method: WebRequest>>send500Response: (in category 'responses') ----- + send500Response: errReport + "Send a 500 internal server error response" + + | errLog | + errLog := '<html><head><title>500 Internal Server Error</title></head><body>', + '<h1>Internal Server Error</h1><pre>', + (errReport copyReplaceAll: String cr with: String crlf), + '</pre></body></html>'. + + self sendResponseCode: 500 + content: errLog squeakToUtf8 + type: 'text/html; charset=utf-8' + close: true. + ! Item was added: + ----- Method: WebRequest>>sendOptionsResponse: (in category 'responses') ----- + sendOptionsResponse: allowed + "Send a 200 OK response for an OPTIONS request" + + ^self send200Response: '' contentType: 'application/octet-stream' do:[:resp| + resp headerAt: 'allow' put: (String streamContents:[:s| + allowed do:[:m| s nextPutAll: m] separatedBy:[s nextPut: $,] + ]). + ].! Item was added: + ----- Method: WebRequest>>sendResponse:chunked: (in category 'responses') ----- + sendResponse: code chunked: chunkBlock + "Send a chunked response" + + ^self sendResponse: code chunked: chunkBlock do:[:resp|]! Item was added: + ----- Method: WebRequest>>sendResponse:chunked:do: (in category 'responses') ----- + sendResponse: code chunked: chunkBlock do: hdrBlock + "Send a chunked response" + + | resp | + resp := self newResponse protocol: 'HTTP/1.1' code: code. + resp headerAt: 'Transfer-Encoding' put: 'chunked'. + hdrBlock value: resp. + ^self sendResponse: resp contentBlock:[:aStream| + "Set the stream in the request and pass it in the chunk block" + resp stream: aStream. + chunkBlock value: resp. + "send termination chunk" + aStream nextPutAll: '0'; crlf; crlf; flush. + ]. + ! Item was added: + ----- Method: WebRequest>>sendResponse:content: (in category 'sending') ----- + sendResponse: resp content: aString + "Send a WebResponse with content." + + ^self sendResponse: resp contentStream: aString readStream size: aString size! Item was added: + ----- Method: WebRequest>>sendResponse:contentBlock: (in category 'sending') ----- + sendResponse: resp contentBlock: contentBlock + "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." + + "Add Date and Server headers" + resp headerAt: 'Date' put: (server ifNil:[WebServer]) serverDate. + resp headerAt: 'Server' put: (server ifNil:[WebServer]) serverString. + + self closeIfTransient: resp after:[ + "Ignore all network errors while sending the response" + [resp writeOn: stream. + stream flush. + self isHeadRequest ifFalse:[contentBlock value: stream]. + ] on: NetworkError do:["ignore"]. + + "Make sure we log before closing the connection" + server ifNotNil:[server logRequest: self response: resp]. + ].! Item was added: + ----- 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]. + + ^self sendResponse: resp contentBlock:[:sockStream| + resp streamFrom: aStream to: sockStream size: streamSize progress: nil + ]! Item was added: + ----- Method: WebRequest>>sendResponseCode:content:type:close: (in category 'responses') ----- + sendResponseCode: code content: aString type: contentType close: aBool + "Send a 500 Internal server error response" + + ^self sendResponseCode: code content: aString type: contentType do:[:hdr| + aBool ifTrue:[hdr headerAt: 'Connection' put: 'close']. + ].! Item was added: + ----- 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]. + aBlock value: resp. + ^self sendResponse: resp content: aString.! Item was added: + ----- Method: WebRequest>>sendXmlResponse: (in category 'responses') ----- + sendXmlResponse: xmlString + "Send an a-ok 200 xml-ish response" + + ^self send200Response: xmlString contentType: 'application/xml'! Item was added: + ----- Method: WebRequest>>server (in category 'accessing') ----- + server + "If non-nil, the WebServer instance associated with the request." + + ^server! Item was added: + ----- Method: WebRequest>>server: (in category 'accessing') ----- + server: aWebServer + "If non-nil, the WebServer instance associated with the request." + + server := aWebServer! Item was added: + ----- Method: WebRequest>>stream200Response: (in category 'responses') ----- + stream200Response: aStream + "Stream a 200 OK response" + + ^self stream200Response: aStream size: aStream size! Item was added: + ----- Method: WebRequest>>stream200Response:size: (in category 'responses') ----- + stream200Response: aStream size: streamSize + "Stream a 200 OK response" + + ^self stream200Response: aStream size: streamSize type: 'application/octet-stream'! Item was added: + ----- Method: WebRequest>>stream200Response:size:type: (in category 'responses') ----- + stream200Response: aStream size: streamSize type: contentType + "Stream a 200 OK response" + + ^self stream200Response: aStream size: streamSize type: contentType do:[:resp|].! Item was added: + ----- 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. + aBlock value: resp. + ^self sendResponse: resp contentStream: aStream size: streamSize.! Item was added: + ----- Method: WebRequest>>url (in category 'accessing') ----- + url + "The url without fragment or arguments" + + ^((rawUrl copyUpTo: $#) copyUpTo: $?) unescapePercentsWithTextEncoding: nil! Item was added: + ----- Method: WebRequest>>writeOn: (in category 'printing') ----- + writeOn: aStream + "Write the request" + + self writeRequestOn: aStream. + super writeOn: aStream! Item was added: + ----- Method: WebRequest>>writeRequestOn: (in category 'printing') ----- + writeRequestOn: aStream + "Write the request" + + aStream nextPutAll: method; space; nextPutAll: rawUrl; space; nextPutAll: protocol; crlf. + ! Item was added: + WebMessage subclass: #WebResponse + instanceVariableNames: 'request status code url' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebResponse commentStamp: 'ar 2/23/2010 10:39' prior: 0! + Represents an HTTP response for WebClient/WebServer.! Item was added: + ----- Method: WebResponse class>>protocol:code: (in category 'instance creation') ----- + protocol: protocol code: code + "Create a response using the given protocol / code" + + ^self new protocol: protocol code: code! Item was added: + ----- Method: WebResponse>>code (in category 'accessing') ----- + code + "The HTTP response code" + + ^code! Item was added: + ----- Method: WebResponse>>contentStream (in category 'accessing') ----- + contentStream + "Answers a stream for the conent." + + (self headerAt: 'transfer-encoding') = 'chunked' ifTrue:[ + ^WebChunkedStream on: stream. + ]. + ^super contentStream! Item was added: + ----- Method: WebResponse>>getContentWithProgress: (in category 'private') ----- + getContentWithProgress: progressBlockOrNil + "Any response to a HEAD request and any response with a 1xx (Informational), 204 (No Content), or 304 (Not Modified) status code is always terminated by the first empty line after the header fields, regardless of the header fields present in the message, and thus cannot contain a message body. See https://tools.ietf.org/html/rfc7230#section-3.3.3 " + + [ + (request method = 'HEAD' + or: [(code between: 100 and: 199) + or: [code = 204 + or: [code = 304]]]) ifTrue: [^ '']. + + ^ super getContentWithProgress: progressBlockOrNil + + ] ensure: [self closeIfTransient]! Item was added: + ----- Method: WebResponse>>isInformational (in category 'testing') ----- + isInformational + "Is this a 1xx response?" + + ^self code between: 100 and: 199 + ! Item was added: + ----- Method: WebResponse>>isRedirect (in category 'testing') ----- + isRedirect + "Is this a redirect response?" + + ^self code between: 300 and: 399 + ! Item was added: + ----- Method: WebResponse>>isSuccess (in category 'testing') ----- + isSuccess + "Is this a successful response?" + + ^self code between: 200 and: 299 + ! Item was added: + ----- Method: WebResponse>>protocol:code: (in category 'initialize') ----- + protocol: respProtocol code: respCode + "Initialize a response from protocol and code" + + code := respCode. + protocol := respProtocol. + status := protocol, ' ', code asString, ' ', (self class statusCodeAt: code). + headers := OrderedCollection new.! Item was added: + ----- Method: WebResponse>>readFrom: (in category 'initialize') ----- + readFrom: aStream + "Parse an HTTP response from the given stream" + + | tokens | + stream := aStream. + status := stream upToAll: String crlf. + tokens := status findTokens: ' '. + tokens size < 2 ifTrue:[^self error:'Invalid response: ', status]. + protocol := tokens first. + code := tokens second asNumber. + headers := WebUtils readHeadersFrom: stream. + ! Item was added: + ----- Method: WebResponse>>request (in category 'accessing') ----- + request + "The original request for this response" + + ^request! Item was added: + ----- Method: WebResponse>>request: (in category 'accessing') ----- + request: aRequest + "The original request for this response" + + request := aRequest! Item was added: + ----- Method: WebResponse>>setCookie: (in category 'cookies') ----- + setCookie: aCookie + "Adds a Set-Cookie header" + + ^self addHeader: 'Set-Cookie' value: aCookie asString! Item was added: + ----- Method: WebResponse>>setCookie:value:path: (in category 'cookies') ----- + setCookie: name value: value path: path + "Adds a Set-Cookie header" + + ^self setCookie: ((WebCookie new) + name: name; + value: value; + path: path; + yourself)! Item was added: + ----- Method: WebResponse>>setCookie:value:path:expires:domain:secure: (in category 'cookies') ----- + setCookie: name value: value path: path expires: date domain: domain secure: aBool + "Adds a Set-Cookie header" + + ^self setCookie: ((WebCookie new) + name: name; + value: value; + path: path; + expiry: date; + domain: domain; + secure: aBool; + yourself)! Item was added: + ----- Method: WebResponse>>setCookieAt: (in category 'cookies') ----- + setCookieAt: key + "Evaluate aBlock with all the cookies deined in the request" + + self setCookiesDo:[:cookie| + cookie name = key ifTrue:[^cookie]. + ]. + ^nil! Item was added: + ----- Method: WebResponse>>setCookiesDo: (in category 'cookies') ----- + setCookiesDo: aBlock + "Evaluate aBlock with all the cookies deined in the request" + + self headersAt: 'Set-Cookie' do:[:hdr| + aBlock value: (WebCookie new readFrom: hdr readStream) + ]. + ! Item was added: + ----- Method: WebResponse>>status (in category 'accessing') ----- + status + "The status line from the response" + + ^status! Item was added: + ----- Method: WebResponse>>status: (in category 'accessing') ----- + status: aString + "The status line from the response" + + status := aString! Item was added: + ----- Method: WebResponse>>url (in category 'accessing') ----- + url + "The url of the resource at which a request was terminated after a series + of redirects. Without redirects, this will be the same as the request url." + + ^url! Item was added: + ----- Method: WebResponse>>url: (in category 'accessing') ----- + url: urlString + "The url of the resource at which a request was terminated after a series + of redirects. Without redirects, this will be the same as the request url." + + url := urlString! Item was added: + ----- Method: WebResponse>>writeOn: (in category 'printing') ----- + writeOn: aStream + "Store this response on aStream" + + self writeStatusOn: aStream. + super writeOn: aStream. + ! Item was added: + ----- Method: WebResponse>>writeStatusOn: (in category 'printing') ----- + writeStatusOn: aStream + "Store this response on aStream" + + aStream nextPutAll: status; crlf. + ! Item was added: + Object subclass: #WebServer + instanceVariableNames: 'listenerSocket listenerProcess interface port mutex connections entryPoints vault logAction nonceCache sessions serverString errorHandler accessLog certName siteUrl' + classVariableNames: 'Default Registry' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebServer commentStamp: 'ar 5/4/2010 13:17' prior: 0! + WebClient provides a simple yet complete HTTP server implementation. + + To view the documentation evaluate: + + HelpBrowser openOn: WebServerHelp. + ! Item was added: + ----- Method: WebServer class>>benchmark (in category 'benchmarks') ----- + benchmark + "Runs a WebClient/WebServer streaming benchmark to measure throughput" + + " + WebServer benchmark + MessageTally spyOn:[WebServer benchmark] + " + + | amount time resp port | + port := 8888. + amount := 128 * 1024 * 1024. + WebServer reset default listenOn: port. + WebServer default addService: '/streaming' action:[:req| + req stream200Response: NullStream new size: amount. + ]. + time := [ + resp := WebClient httpGet: 'http://localhost:', port, '/streaming'. + resp isSuccess ifFalse:[self error: resp status]. + resp streamTo: NullStream new size: resp contentLength progress: nil. + resp close. + ] timeToRun. + WebServer reset. + ^(amount * 1000 // time) asStringWithCommas, ' bytes/sec' + ! Item was added: + ----- Method: WebServer class>>browseDir:request: (in category 'examples') ----- + browseDir: directory request: request + "Responds with a directory listing back to the original request" + + | entries listing url | + url := request url. + (url endsWith: '/') ifTrue:[url := url allButLast]. + + entries := directory entries sort:[:e1 :e2| + e1 isDirectory = e2 isDirectory + ifTrue:[e1 name <= e2 name] + ifFalse:[e2 isDirectory]]. + + listing := String streamContents:[:s| + s nextPutAll:'<html><head><title>Index of ', request url,'</title></head><body>'. + s nextPutAll:'<h1>Index of ', request url,'</h1>'. + s nextPutAll:'<pre> Name Last modified Size Description<hr>'. + s nextPutAll: '[up] <a href="', (url copyUpToLast: $/),'">parent</a>'; crlf. + entries do:[:e| + s nextPutAll:(e isDirectory ifTrue:['[dir] '] ifFalse:[' ']). + s nextPutAll: '<a href="', url, '/', e name, '">'. + s nextPutAll: (e name truncateTo: 30). + s nextPutAll: '</a>'. + e name size < 30 ifTrue:[s nextPutAll: (String new: 30 - e name size withAll: $ )]. + s nextPutAll: (e modificationDateAndTime asString padded: #right to: 20 with: $ ). + s nextPutAll: (e fileSize asString padded: #right to: 20 with: $ ). + s crlf. + ]. + ]. + + request + send200Response: (listing convertToWithConverter: UTF8TextConverter new) + contentType: 'text/html; charset=utf-8'. + + ! Item was added: + ----- 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. + request sendResponse: resp contentStream: file size: fileSize.! Item was added: + ----- Method: WebServer class>>browseRequest: (in category 'examples') ----- + browseRequest: request + "Handle an HTTP request for browsing some resource" + + | path fd entry file | + + "Extract the file path from the request" + path := request url findTokens: '/'. + path ifEmpty:[^self browseDir: FileDirectory default request: request.]. + + "Find the directory entry for the resource" + fd := path allButLast inject: FileDirectory default into:[:dir :part| dir directoryNamed: part]. + entry := fd entryAt: path last ifAbsent:[^request send404Response]. + + "Reply with the proper resource" + entry isDirectory ifTrue:[ + "Send file listing. We handle this synchronously for simplicity." + self browseDir: (fd directoryNamed: entry name) request: request. + ] ifFalse:[ + "Send file content. Since files can be large, we fork this off. + However, since we forked it, we need to handle two different + possible conditions: + - closing the file in case of error + - handling errors when sending it + This makes the code below a bit ugly" + [[ + file := fd readOnlyFileNamed: entry name. + [self browseFile: file request: request.] + ensure:[file close] "close file even in case of error" + ] on: Error do:[] "ignore errors altogether" + ] fork. "fork it" + ]. + ! Item was added: + ----- Method: WebServer class>>default (in category 'accessing') ----- + default + "A default WebServer instance. Mostly for the examples." + + ^Default ifNil:[Default := self new].! Item was added: + ----- Method: WebServer class>>exampleAuth (in category 'examples') ----- + exampleAuth "WebServer exampleAuth" + "Simple example requiring basic auth" + + | server port realm | + port := 9999. + server := WebServer reset default. + + "The realm to use for the server" + realm := 'Example Realm'. + + "Add a sample user (note: password is hashed, not stored verbatim)" + server passwordAt: 'squeak' realm: realm put: 'squeak'. + + server listenOn: port. + server addService: '/' action:[:req| + server + authenticate: req + realm: realm + methods: #(digest basic) + do:[self browseRequest: req]]. + ! Item was added: + ----- Method: WebServer class>>exampleBrowse (in category 'examples') ----- + exampleBrowse "WebServer exampleBrowse" + "This example implements a simple http server allowing to view + and download files (like browsing ftp sites etc)." + + | server port | + port := 9999. + server := WebServer reset default. + server listenOn: port. + server addService: '/' action:[:req| self browseRequest: req]. + ! Item was added: + ----- Method: WebServer class>>exampleDoIt (in category 'examples') ----- + exampleDoIt "WebServer exampleDoIt" + "This example executes doIts from a POST request. + It's the simplest possible RPC interface to Squeak." + + | server port | + port := 9999. + server := WebServer reset default. + server listenOn: port. + server addService: '/' action:[:req| + | data result | + req isPostRequest ifTrue:[ + "We fetch all of the data instead of streaming it" + data := req content. + "Compute the result" + result := [Compiler evaluate: data] on: Error do:[:ex| ex return: ex asString]. + req send200Response: result asString + ] ifFalse:[req send404Response]. + ]. + ! Item was added: + ----- Method: WebServer class>>exampleSSL: (in category 'examples') ----- + exampleSSL: certName + + "This example implements a simple https server allowing to view + and download files (like browsing ftp sites etc): + + WebServer exampleSSL: 'Internet Widgits Pty'. + WebServer exampleSSL: '/home/andreas/certs/testcert.pem'. + + " + + | server port | + port := 8443. + server := WebServer reset default. + server accessLog: Transcript. + server certName: certName. + server listenOn: port. + server addService: '/' action:[:req| self browseRequest: req]. + ! Item was added: + ----- Method: WebServer class>>exampleSession (in category 'examples') ----- + exampleSession "WebServer exampleSession" + "This example uses a simple session cookie to avoid + authentication for every request." + + | server port realm | + realm := 'Example Realm'. "authentication realm" + port := 9999. + server := WebServer reset default. + server listenOn: port. + + "Add a sample user (note: password is hashed, not stored verbatim)" + server passwordAt: 'squeak' realm: realm put: 'squeak'. + + "Register the login service (sets cookie when successful)" + server addService: '/login' action:[:req| + server authenticate: req realm: realm methods: #(digest) do:[ | id | + "Set the cookie and redirect back to /" + server sessionAt: (id := UUID new hex) put: ''. + req send302Response: (req fields at: 'url' ifAbsent:['/']) + do:[:resp| resp setCookie: 'session' value: id path: '/']]]. + + "Register the normal browse service" + server addService: '/' action:[:req| + "Check if we have a valid session cookie. If not redirect to login." + (server sessionAt: (req cookieAt: 'session')) notNil + ifTrue:[self browseRequest: req] + ifFalse:[req send302Response: '/login?url=', req url encodeForHTTP]]. + ! Item was added: + ----- Method: WebServer class>>forUrl: (in category 'registry') ----- + forUrl: urlString + "Answer the WebServer registered for a given URL string." + + ^self forUrl: urlString ifAbsent:[self newForUrl: urlString]! Item was added: + ----- Method: WebServer class>>forUrl:ifAbsent: (in category 'registry') ----- + forUrl: urlString ifAbsent: aBlock + "Answer the WebServer registered for a given URL string. + If no WebServer is registered, evaluate aBlock." + + ^self registry at: urlString ifAbsent: aBlock! Item was added: + ----- Method: WebServer class>>newForUrl: (in category 'registry') ----- + newForUrl: urlString + "Create a new WebServer instance registered for a given URL string." + + | server | + "Out with the old ...." + server := self removeUrl: urlString. + server ifNotNil:[server destroy]. + + "... and in with the new." + server := self new. + server siteUrl: urlString. + self registry at: urlString put: server. + ^server + ! Item was added: + ----- Method: WebServer class>>registry (in category 'registry') ----- + registry + "Answer the WebServer site registry" + + ^Registry ifNil:[Registry := Dictionary new]! Item was added: + ----- Method: WebServer class>>removeUrl: (in category 'registry') ----- + removeUrl: urlString + "Remove and answer the WebServer registered for a given URL string. + If no WebServer was registered, return nil." + + ^self removeUrl: urlString ifAbsent:[nil]! Item was added: + ----- Method: WebServer class>>removeUrl:ifAbsent: (in category 'registry') ----- + removeUrl: urlString ifAbsent: aBlock + "Remove and answer the WebServer registered for a given URL string." + + ^self registry removeKey: urlString ifAbsent: aBlock! Item was added: + ----- Method: WebServer class>>requestBenchmark: (in category 'benchmarks') ----- + requestBenchmark: persistent + "Runs a WebClient/WebServer benchmark to measure request handling speed. + Uses a persistent connection if requested." + + " + WebServer requestBenchmark: false. + WebServer requestBenchmark: true. + MessageTally spyOn:[WebServer requestBenchmark: true] + " + + | port | + port := 8888. + WebServer reset default listenOn: port. + WebServer default addService: '/benchmark' action:[:req| + req send200Response: ''. + ]. + ^[WebClient + requestBenchmark: 'http://localhost:', port, '/benchmark' + persistent: persistent] ensure:[WebServer reset]. + ! Item was added: + ----- Method: WebServer class>>reset (in category 'accessing') ----- + reset "WebServer reset" + "Reset the default WebServer instance." + + Default ifNotNil:[ + Default destroy. + Default := nil. + ].! Item was added: + ----- Method: WebServer class>>serverDate (in category 'accessing') ----- + serverDate + "Returns the date string to be used in responses" + + | date | + ^String streamContents:[:s| + date := DateAndTime now asUTC. + s nextPutAll: date dayOfWeekAbbreviation, ', '. + date asDate printOn: s format: #(1 2 3 $ 2 1 2 ). + s space; nextPutAll: (Time seconds: date asSeconds) print24. + s nextPutAll: ' GMT'. + ].! Item was added: + ----- Method: WebServer class>>serverString (in category 'accessing') ----- + serverString + "Returns the server string to be used in responses" + + ^'WebServer/1.5 (', + WebUtils mcVersion, '; ', + SystemVersion current version,'-', + SystemVersion current highestUpdate printString, '; ', + WebUtils platformName,')'. + ! Item was added: + ----- Method: WebServer>>accessLog (in category 'logging') ----- + accessLog + "The standard access log. Can be either a stream or a string; if the access log + is a string then the string is assumed to be a file name and the file will be opened + and closed for each request." + + ^accessLog! Item was added: + ----- Method: WebServer>>accessLog: (in category 'logging') ----- + accessLog: aStreamOrFilename + "The standard access log. Can be either a stream or a string; if the access log + is a string then the string is assumed to be a file name and the file will be opened + and closed for each request." + + accessLog := aStreamOrFilename! Item was added: + ----- Method: WebServer>>addService:action: (in category 'services') ----- + addService: entryPoint action: aBlockOrMessage + "Add a service to the web server. The service is specified by an entryPoint, + denoting the url under which the service can be requested + (such as /my/great/service) and an action which is a message + send taking a single argument, the WebRequest." + + ^self addService: entryPoint + action: aBlockOrMessage + methods: self defaultHttpMethods.! Item was added: + ----- Method: WebServer>>addService:action:methods: (in category 'services') ----- + addService: entryPoint action: aBlockOrMessage methods: methods + "Add a service to the web server. The service is specified by an entryPoint, + denoting the url under which the service can be requested + (such as /my/great/service) and an action which is a message + send taking a single argument, the WebRequest. + + The list of methods describes what HTTP methods the given url supports." + + mutex critical:[ + entryPoints at: entryPoint asLowercase put: {methods. aBlockOrMessage}. + ].! Item was added: + ----- Method: WebServer>>addToken:toRealm: (in category 'authentication') ----- + addToken: aString toRealm: realm + | hash | + hash := WebUtils md5Digest: aString, ':', realm. + self passwordHashAt: (aString,':',realm) put: hash! Item was added: + ----- Method: WebServer>>asyncHandleConnectionFrom: (in category 'handling') ----- + asyncHandleConnectionFrom: aSocket + "Handle an incoming connection asynchronously to avoid blocking the listener." + + | handlerProcess | + handlerProcess := [ + [ [ self handleConnectionFrom: aSocket ] + on: Error do: [ :ex | aSocket destroy ] ] + ensure: [ + aSocket destroy. + mutex critical: [ + "At this point handlerProcess is initialized, so it is safe to use that variable. Using Processor activeProcess is not possible, because this unwind block may be evaluated by another process. Doing this outside the #ensure: block is not safe." + connections remove: handlerProcess ifAbsent: nil ] ] ] newProcess. + + mutex critical:[connections add: handlerProcess]. + "Process priority has to be set to a lower level here, else it'll have lowIOPriority (60), and will block many important processes (UI, WeakArrayFinalization, etc.)" + handlerProcess + priority: Processor userBackgroundPriority; + resume! Item was added: + ----- Method: WebServer>>authAccept:request:realm:header: (in category 'authentication') ----- + authAccept: method request: request realm: realm header: authHeader + "Performs the requested authentication method. + Returns true if successfully authenticated. + Subclasses can extend this method to support more auth methods." + + ^method asLowercase caseOf: { + ['basic'] -> [self basicAuth: request realm: realm header: authHeader]. + ['digest'] -> [self digestAuth: request realm: realm header: authHeader]. + ['bearer'] -> [self bearerAuth: request realm: realm header: authHeader]. + } otherwise:[false]. + ! Item was added: + ----- Method: WebServer>>authHeader:request:realm: (in category 'authentication') ----- + authHeader: method request: request realm: realm + "Answer the authentication header for the given method. + Subclasses can extend this method to support more auth methods." + + ^method asLowercase caseOf: { + ['basic'] -> ['Basic realm="', realm,'"']. + ['digest'] -> ['Digest realm="', realm,'", nonce="', self newNonce,'", qop="auth"']. + ['bearer'] -> ['Bearer realm="', realm,'"']. + } otherwise:[nil]. + + ! Item was added: + ----- 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'. + 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>'. + ! Item was added: + ----- Method: WebServer>>basicAuth:realm:header: (in category 'authentication') ----- + basicAuth: request realm: realm header: authHeader + "Perform Basic auth for the given request" + + | data user pass hash | + data := (authHeader copyAfter: $ ) base64Decoded. + user := data copyUpTo: $:. + pass := data copyAfter: $:. + data atAllPut: $*. data := nil. + + hash := self hashUser: user password: pass realm: realm. + pass atAllPut: $*. pass := nil. + + ^(self passwordHashAt: user, ':', realm) = hash + ! Item was added: + ----- Method: WebServer>>bearerAuth:realm:header: (in category 'authentication') ----- + bearerAuth: request realm: realm header: authHeader + "Perform Bearer-based OAuth2 auth for the given request" + + | data hash | + data := authHeader copyAfter: $ . + hash := WebUtils md5Digest: data, ':', realm. + ^(self passwordHashAt: data, ':', realm) = hash + ! Item was added: + ----- Method: WebServer>>builtinHttpMethods (in category 'initialize') ----- + builtinHttpMethods + "Returns the list of HTTP methods that the server handles built-in, + i.e., without passing them to the registered service." + + ^#('HEAD' 'TRACE' 'OPTIONS')! Item was added: + ----- Method: WebServer>>certName (in category 'accessing') ----- + certName + "The cert name to use for a secure (SSL/TLS) web server." + + ^certName! Item was added: + ----- Method: WebServer>>certName: (in category 'accessing') ----- + certName: aString + "The cert name to use for a secure (SSL/TLS) web server." + + certName := aString.! Item was added: + ----- Method: WebServer>>connections (in category 'accessing') ----- + connections + "The active connection processes. Can only be examined after aquiring + the WebServer's mutex." + + ^connections! Item was added: + ----- Method: WebServer>>critical: (in category 'initialize') ----- + critical: aBlock + "Evaluate aBlock protected byt the server's mutex. + Necessary if code needs to manipulate internal server state." + + ^mutex critical: aBlock + ! Item was added: + ----- Method: WebServer>>defaultHttpMethods (in category 'initialize') ----- + defaultHttpMethods + "Answer the list of HTTP methods that should be be supported by default. + The methods must be implemented by the request handler." + + ^#('GET' 'POST')! Item was added: + ----- Method: WebServer>>destroy (in category 'initialize') ----- + destroy + "Destroys the receiver" + + self stopListener. + self destroyConnections. + listenerSocket ifNotNil:[listenerSocket destroy]. + + "De-register the WebServer" + (self class forUrl: self siteUrl ifAbsent:[self]) == self + ifTrue:[self class removeUrl: siteUrl] + ! Item was added: + ----- Method: WebServer>>destroyConnections (in category 'initialize') ----- + destroyConnections + "Destroy all current connections." + + | copy | + copy := mutex critical: [ connections copy ]. + " #terminate will trigger the #ensure: block in #asyncHandleConnectionFrom:, which will block if we don't release the mutex " + copy do: [ :p | p terminate ]. + " make sure all of them were really removed " + mutex critical: [ connections removeAll ] + ! Item was added: + ----- Method: WebServer>>digestAuth:realm:header: (in category 'authentication') ----- + digestAuth: request realm: realm header: authHeader + "Authenticates an incoming request using Digest auth." + + | user nonce uri response ha1 ha2 md5 qop nc cnonce + nonceData nonceCounter nonceTimeout params | + + params := WebUtils parseAuthParams: authHeader. + + "Flush the nonce cache randomly about every 100 auth attempts" + 100 atRandom = 42 ifTrue:[self flushNonceCache]. + + user := params at: 'username' ifAbsent:['']. + nonce := params at: 'nonce' ifAbsent:['']. + uri := params at: 'uri' ifAbsent:[request url]. + response := params at: 'response' ifAbsent:['']. + + qop := params at: 'qop' ifAbsent:['']. + qop = 'auth' ifFalse:[^false]. "we require qop=auth" + + nc := params at: 'nc' ifAbsent:['']. + cnonce := params at: 'cnonce' ifAbsent:['']. + + "Verify that this is a nonce that we have handed out, that it isn't expired + and that the nc counter has increased from the last use." + mutex critical:[ + nonceData := nonceCache at: nonce ifAbsent:[^false]. + ]. + nonceCounter := nonceData first. "last used nc" + nonceTimeout := nonceData second. "timeout for nonce" + nc <= nonceCounter ifTrue:[^false]. "nc must increase" + Time totalSeconds > nonceTimeout ifTrue:[^false]. "nonce expired" + nonceData at: 1 put: nc. + + ha1 := self passwordHashAt: user, ':', realm. + ha2 := WebUtils md5Digest: request method, ':', uri. + md5 := WebUtils md5Digest: ha1, ':', nonce, ':', nc, ':', cnonce, ':', qop, ':', ha2. + ^md5 = response + ! Item was added: + ----- Method: WebServer>>dispatchRequest: (in category 'handling') ----- + dispatchRequest: request + "Look up the handler for a given request and dispatch to it" + + ^self dispatchRequest: request url: request url! Item was added: + ----- Method: WebServer>>dispatchRequest:url: (in category 'handling') ----- + dispatchRequest: request url: dispatchUrl + "Look up the handler for a given url and dispatch to it" + + | entryUrl action | + "Handle TRACE requests right away" + request method = 'TRACE' ifTrue:[ + ^request send200Response: request asString contentType: 'message/http'. + ]. + + "Look up the entry point for the request" + action := nil. + entryUrl := dispatchUrl asLowercase. + (entryUrl beginsWith: '/') ifFalse:[entryUrl := '/', entryUrl]. + mutex critical:[ + [entryUrl notEmpty and:[action == nil]] whileTrue: [ + action := entryPoints at: entryUrl ifAbsent:[nil]. + entryUrl := entryUrl copyUpToLast: $/. + ]. + action ifNil:[action := entryPoints at: '/' ifAbsent:[nil]]. + ]. + + "Handle OPTIONS requests" + request method = 'OPTIONS' ifTrue:[ + "HEAD, TRACE, and OPTIONS are always supported" + request sendOptionsResponse: self builtinHttpMethods, + (action ifNil:[self defaultHttpMethods] ifNotNil:[action first]) + ]. + + "Handle 404 not found" + action ifNil:[^request send404Response]. + + "Handle 405 method not allowed" + (request method = 'HEAD' "builtin" + or:[(action at: 1) includes: request method]) ifFalse:[ + ^request send405Response: self builtinHttpMethods, action first. + ]. + + ^[self invokeAction: (action at: 2) request: request] + on: Error do:[:ex| + errorHandler + ifNil:[self handleError: ex request: request] + ifNotNil:[errorHandler value: ex value: request] + ]. + ! Item was added: + ----- Method: WebServer>>errorHandler (in category 'accessing') ----- + errorHandler + "The user-supplied error handler. If present the handler takes two arguments: + * The error being caught by WebServer + * The request the error occurred in. + The user-supplied error handler can do whatever it wants, including calling + WebServer's #handleError:request: method which is the default." + + ^errorHandler! Item was added: + ----- Method: WebServer>>errorHandler: (in category 'accessing') ----- + errorHandler: aBlock + "The user-supplied error handler. If present the handler takes two arguments: + * The error being caught by WebServer + * The request the error occurred in. + The user-supplied error handler can do whatever it wants, including calling + WebServer's #handleError:request: method which is the default." + + errorHandler := aBlock.! Item was added: + ----- Method: WebServer>>errorReportFor: (in category 'errors') ----- + errorReportFor: anError + "Provide a report for an error that's been caught during processing" + + ^[ + String streamContents:[:s| + self errorReportFor: anError + stack: ([anError signalerContext stackOfSize: 2000] + on: Error do:[:ex| ex return: #()]) + on: s + ]. + ] on: Error do: [:ex| ex pass. 'error reporting failed'].! Item was added: + ----- Method: WebServer>>errorReportFor:stack:on: (in category 'errors') ----- + errorReportFor: anError stack: preStack on: strm + "Provide a report for an error that's been caught during processing" + + self errorStackFor: anError stack: preStack on: strm. + strm cr; nextPutAll: '-----------------------------------------------------------------'; cr; cr. + self systemInfoOn: strm. + ! Item was added: + ----- Method: WebServer>>errorStackFor:stack:on: (in category 'errors') ----- + errorStackFor: anError stack: preStack on: strm + "Provide a report for an error that's been caught during processing" + + | cnt | + cnt := 0. + (preStack copyFrom: 1 to: (5 min: preStack size)) do:[:ctx| + ctx printDetails: strm. "variable values" + strm cr. + ]. + + strm cr; nextPutAll: '--- The full stack ---'; cr. + cnt := 0. + + preStack do:[:ctx| + cnt := cnt + 1. + cnt = 5 ifTrue: [ + strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. + strm print: ctx; cr. "just class>>selector" + ]. + ! Item was added: + ----- Method: WebServer>>flushNonceCache (in category 'authentication') ----- + flushNonceCache + "Flushes expired nonces from the cache" + + | deadline | + deadline := Time totalSeconds. + mutex critical:[ + nonceCache := nonceCache reject:[:nonceData| deadline > nonceData second] + ]. + ! Item was added: + ----- Method: WebServer>>handleConnectionFrom: (in category 'handling') ----- + handleConnectionFrom: aSocket + "Synchronously handle an incoming socket connection." + + | stream request | + + "Give the process a pretty name" + Processor activeProcess name: (String streamContents:[:s| + aSocket remoteAddress do:[:b| s print: b] separatedBy:[s nextPut: $.]. + s nextPut: $:; print: aSocket remotePort. + s nextPutAll: ' - ', self class name, ' request handler'. + ]). + + "Read the request from the socket, and dispatch it. + Since we've been forked already it's okay to block." + [ + certName ifNil:["Regular request" + stream := SocketStream on: aSocket. + ] ifNotNil:["SSL/TLS" + | ssl | + ssl := Smalltalk at: #SqueakSSL ifAbsent:[self error: 'SqueakSSL not installed']. + stream := ssl secureSocketStream on: aSocket. + [stream sslAccept: certName] on: Error do:[^stream destroy]. + ]. + + [aSocket isConnected] whileTrue:[ + + "Read the next request from the connection. If the connection is closed, + or if a network error occurs, or the read times out, just close the connection + without further ado (rather than logging an error). Any other error resulting + from parsing the input is treated as a 400 bad request." + + stream peek ifNil:[^aSocket destroy]. + request := self newRequest. + [request readFrom: stream] on: Error do:[:ex| + (ex isKindOf: NetworkError) ifFalse:[ + [request send400Response] on: Error do:[:ignore|]. + ]. + ^aSocket destroy]. + + self dispatchRequest: request. + ]. + ] on: Error do:[:ex| + (ex isKindOf: NetworkError) ifFalse:[ + self log: 'Error in request handling: ', ex description. + self log: (self errorReportFor: ex). + ]. + ].! Item was added: + ----- Method: WebServer>>handleError:request: (in category 'errors') ----- + handleError: ex request: aRequest + "The default error handling during processing. Sends a 500 response." + + | errLabel errReport | + errLabel := [ex description] on: Error do:[:ex2| + ex2 return: ex class name + ]. + errReport := [self errorReportFor: ex] on: Error do:[:ex2| + ex2 return: '<error report failed>'. + ]. + [self log: errLabel] on: Error do:[:ex2| ex return]. + [self log: String cr, errReport] on: Error do:[:ex2| ex return]. + aRequest send500Response: errReport. ! Item was added: + ----- Method: WebServer>>hashUser:password:realm: (in category 'authentication') ----- + hashUser: user password: pass realm: realm + "Creates a hash for the given username password pair. + This method is the ha1 part of digest auth and can be used for both digest + as well as basic auth." + + ^WebUtils md5Digest: user, ':', realm, ':', pass! Item was added: + ----- Method: WebServer>>initialize (in category 'initialize') ----- + initialize + "Initialize the receiver" + + mutex := Mutex new. + entryPoints := Dictionary new. + connections := IdentitySet new. + vault := Dictionary new. + nonceCache := Dictionary new. + sessions := Dictionary new. + self logAction:[:aString| Transcript cr; show: aString]. + ! Item was added: + ----- Method: WebServer>>invokeAction:request: (in category 'handling') ----- + invokeAction: action request: request + "Invokes the given action. Subclasses can override this method to serialize + actions if necessary. At this point, the request header has been read from + the network, but not its content." + + ^action valueWithArguments: {request} + ! Item was added: + ----- Method: WebServer>>isRunning (in category 'testing') ----- + isRunning + "Is the server still running?" + + ^self isStopped not! Item was added: + ----- Method: WebServer>>isStopped (in category 'testing') ----- + isStopped + "Is the server still running?" + + ^listenerProcess == nil or:[listenerProcess isTerminated]! Item was added: + ----- Method: WebServer>>listenOn: (in category 'listening') ----- + listenOn: aPort + "Starts the server listening on the given port" + + ^self listenOn: aPort interface: nil! Item was added: + ----- Method: WebServer>>listenOn:interface: (in category 'listening') ----- + listenOn: aPort interface: anInterface + "Starts the server listening on the given port / network interface" + + ^self listenOn: aPort interface: anInterface backlogSize: 8! Item was added: + ----- Method: WebServer>>listenOn:interface:backlogSize: (in category 'listening') ----- + listenOn: aPort interface: anInterface backlogSize: backlog + "Starts the server listening on the given port / network interface" + + | ipString | + interface := anInterface. + port := aPort. + ipString := interface ifNil:['*'] ifNotNil:[ + String streamContents:[:s| interface do:[:b| s print: b] separatedBy:[s nextPut:$.]]]. + self log: 'listener starting (interface: ', ipString, ' port: ', port asString, ')'. + listenerSocket := Socket newTCP. + interface + ifNil:[listenerSocket listenOn: port backlogSize: backlog] + ifNotNil:[listenerSocket listenOn: port backlogSize: backlog interface: interface]. + listenerSocket isWaitingForConnection ifFalse:[ + self error: 'Failed to listen(interface: ', interface printString, ' port: ', aPort printString,' )'. + ]. + self startListener.! Item was added: + ----- Method: WebServer>>listenerInterface (in category 'accessing') ----- + listenerInterface + "Returns the listener interface for the server" + + ^interface! Item was added: + ----- Method: WebServer>>listenerPort (in category 'accessing') ----- + listenerPort + "Returns the listener port for the server" + + ^port! Item was added: + ----- Method: WebServer>>listenerProcess (in category 'accessing') ----- + listenerProcess + "Returns the socket listener process for the server." + + ^listenerProcess! Item was added: + ----- Method: WebServer>>listenerProcessPriority (in category 'listening') ----- + listenerProcessPriority + "The priority at which the listener process should run" + + ^Processor lowIOPriority! Item was added: + ----- Method: WebServer>>listenerSocket (in category 'accessing') ----- + listenerSocket + "Returns the listener socket for the server." + + ^listenerSocket! Item was added: + ----- Method: WebServer>>log: (in category 'initialize') ----- + log: aString + "Log the given information." + + logAction ifNotNil:[logAction valueWithArguments: {aString}]. + ! Item was added: + ----- Method: WebServer>>logAction (in category 'accessing') ----- + logAction + "The current log action (a block or message)" + + ^logAction! Item was added: + ----- Method: WebServer>>logAction: (in category 'accessing') ----- + logAction: aBlockOrMessage + "The current log action (a block or message). + Example: + WebServer new logAction: [:aString| Transcript show: aString]. + WebServer new logAction: (MessageSend receiver: Transcript selector: #show). + " + + logAction := aBlockOrMessage! Item was added: + ----- Method: WebServer>>logRequest:response: (in category 'logging') ----- + logRequest: request response: response + "Log a request after it has been successfully processed" + + accessLog ifNil:[^self]. + + "Do not use the standard exception handler for errors logging; + it would possibly send a 500 response. Really this should be handled + by a different process with its own error handler." + + [WebUtils logRequest: request response: response on: accessLog] + on: Error do:[:ex| self log: 'Error in logging: ', ex description]. + ! Item was added: + ----- Method: WebServer>>newNonce (in category 'authentication') ----- + newNonce + "Create a new nonce to be used for a client authentication session" + + | nonce | + nonce := UUID new hex. + mutex critical:[ + nonceCache at: nonce put: {''. Time totalSeconds + self nonceDeadline}. + ]. + ^nonce! Item was added: + ----- Method: WebServer>>newRequest (in category 'handling') ----- + newRequest + "Answer a new request. + Subclasses should override this method to use a different request class." + + ^(WebRequest new) + server: self; + yourself! Item was added: + ----- Method: WebServer>>nonceDeadline (in category 'authentication') ----- + nonceDeadline + "Answer the number of seconds a nonce is considered valid for digest auth + by the server. After this period, the client will have to reauthenticate. + The default is 30 minutes." + + ^30*60 ! Item was added: + ----- Method: WebServer>>passwordAt:realm:put: (in category 'authentication') ----- + passwordAt: username realm: realm put: password + "Store the password hash for the key." + + | hash | + hash := self hashUser: username password: password realm: realm. + self passwordHashAt: (username,':',realm) put: hash! Item was added: + ----- Method: WebServer>>passwordHashAt: (in category 'authentication') ----- + passwordHashAt: key + "Answer the password hash for the given key" + + ^vault at: key ifAbsent:['']! Item was added: + ----- Method: WebServer>>passwordHashAt:put: (in category 'authentication') ----- + passwordHashAt: key put: hash + "Store the password hash for the key." + + ^vault at: key put: hash! Item was added: + ----- Method: WebServer>>removeService: (in category 'services') ----- + removeService: entryPoint + "Remove a service from the HTTP service provider. See #addService:action:" + + mutex critical:[ + entryPoints removeKey: entryPoint asLowercase ifAbsent: []. + ].! Item was added: + ----- Method: WebServer>>runListener (in category 'listening') ----- + runListener + "Runs the server's listener loop. + Accepts incoming connections and handles them asynchronously" + + | connectionSocket | + [[[listenerSocket notNil and:[listenerSocket isValid]] whileTrue:[ + "Waiting for five seconds means that WebServer will be + back up after roughly five seconds when the system restarts." + connectionSocket := listenerSocket waitForAcceptFor: 5. + "Fork this off since or else errors in acceptClient: kill the listener" + connectionSocket ifNotNil:[self asyncHandleConnectionFrom: connectionSocket]. + ]] ensure:[ + "Logging here is only for the purpose of catching sockets going randomly bad" + self log: 'listener terminating, socket: ', (listenerSocket ifNotNil:[:s| s statusString]). + + "Try to restart the listener" + (listenerSocket notNil and:[listenerSocket isValid not]) ifTrue:[ + listenerSocket destroy. + listenerProcess := nil. + "Wait a little before retrying" + (Delay forSeconds: 2) wait. + ^self listenOn: port interface: interface + ]. + ]] on: Error do:[:ex| self log: ex]. + ! Item was added: + ----- Method: WebServer>>serverDate (in category 'accessing') ----- + serverDate + "Returns the date string to be used in responses" + + ^self class serverDate! Item was added: + ----- Method: WebServer>>serverString (in category 'accessing') ----- + serverString + "Returns the server string to be used in responses. + The response is cached for efficiency." + + ^serverString ifNil:[serverString := self class serverString].! Item was added: + ----- Method: WebServer>>serverString: (in category 'accessing') ----- + serverString: aString + "Set the server string to be used in responses" + + ^serverString := aString! Item was added: + ----- Method: WebServer>>sessionAt: (in category 'sessions') ----- + sessionAt: key + "Answer the session associated with the given key" + + ^mutex critical:[sessions at: key ifAbsent:[nil]].! Item was added: + ----- Method: WebServer>>sessionAt:ifAbsentPut: (in category 'sessions') ----- + sessionAt: key ifAbsentPut: session + "Answer the session associated with the given key" + + ^mutex critical:[sessions at: key ifAbsentPut:[session]].! Item was added: + ----- Method: WebServer>>sessionAt:put: (in category 'sessions') ----- + sessionAt: key put: session + "Store the session associated with the given key" + + ^mutex critical:[sessions at: key put: session].! Item was added: + ----- Method: WebServer>>sessions (in category 'sessions') ----- + sessions + "The sessions associated with the WebServer. These are not used by the server + directly but rather provided so that client code has a convenient place to store + session data." + + ^sessions! Item was added: + ----- Method: WebServer>>sessions: (in category 'sessions') ----- + sessions: aDictionary + "The sessions associated with the WebServer. These are not used by the server + directly but rather provided so that client code has a convenient place to store + session data." + + sessions := aDictionary! Item was added: + ----- Method: WebServer>>siteUrl (in category 'accessing') ----- + siteUrl + "The site URL for WebServer, i.e., http://www.mysite.com or http://www.mysite.com/server (when used in a proxied environment) or https://www.mysite.com (when using SSL). Used to allow a client to derive the 'correct' full URL for a running server instance." + + ^siteUrl! Item was added: + ----- Method: WebServer>>siteUrl: (in category 'accessing') ----- + siteUrl: aString + "The site URL for WebServer, i.e., http://www.mysite.com or http://www.mysite.com/server (when used in a proxied environment) or https://www.mysite.com (when using SSL). Used to allow a client to derive the 'correct' full URL for a running server instance." + + siteUrl := aString! Item was added: + ----- Method: WebServer>>startListener (in category 'listening') ----- + startListener + "Starts the server's listener process" + + self stopListener. + listenerProcess := [self runListener] newProcess. + listenerProcess priority: self listenerProcessPriority. + listenerProcess name: self class name, '''s listener process'. + listenerProcess resume. + ! Item was added: + ----- Method: WebServer>>stopListener (in category 'listening') ----- + stopListener + "Stops the server's listener process" + + listenerProcess ifNotNil:[listenerProcess terminate]. + listenerProcess := nil.! Item was added: + ----- Method: WebServer>>systemInfoOn: (in category 'errors') ----- + systemInfoOn: strm + "Provides system information for a server error report" + + strm nextPutAll: 'VM: '; + nextPutAll: WebUtils platformName; + nextPutAll: ' - '; + nextPutAll: WebUtils vmVersion; + cr. + + strm nextPutAll: 'Image: '; + nextPutAll: SystemVersion current version asString; + nextPutAll: ' ['; + nextPutAll: SmalltalkImage current lastUpdateString asString; + nextPutAll: ']'; + cr. + + strm cr. + + SecurityManager default printStateOn: strm. + + "Additional info available from the windows VM" + WebUtils platformName = 'Win32' ifTrue:[ + 10001 to: 10003 do:[:i| | info | + info := (SmalltalkImage current getSystemAttribute: i) ifNil:['']. + info := info copyReplaceAll: String lf with: String cr. + info isEmpty ifFalse:[strm cr; nextPutAll: info]]]. + ! Item was added: + ----- Method: WebServer>>vault (in category 'accessing') ----- + vault + "The vault used for storing password hashes." + + ^vault! Item was added: + ----- Method: WebServer>>vault: (in category 'accessing') ----- + vault: anObject + "The vault used for storing password hashes. + + Clients can provide their own storage mechanism. + Subclasses can also override the lookup and authentication mechanism." + + vault := anObject! Item was added: + Object subclass: #WebSocket + instanceVariableNames: 'name process stream handlers' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebSocket commentStamp: '<historical>' prior: 0! + A wrapper object for the WebSocket API.! Item was added: + ----- Method: WebSocket class>>example (in category 'example') ----- + example "WebSocket example" + + "This is a very simple WebSocket example implementing a basic chat system. + Each message sent by a client connection is broadcast to everyone." + + | mutex sockets | + mutex := Mutex new. + sockets := OrderedCollection new. + WebServer reset default listenOn: 8080. + + WebServer default addService: '/' action:[:req| + "Serves the main html chat page" + req send200Response: self examplePage contentType: 'text/html'. + ]. + + WebServer default addService: '/broadcast' action:[:req| | ws | + "Implements the WebSocket broadcaster" + ws := req asWebSocket. + ws timeout: 300. "5 minutes timeout" + + Transcript cr; show: 'New ', ws. + + ws onMessage:[:data| + mutex critical:[sockets do:[:s| s send: data]]. + ]. + ws onClose:[ + Transcript cr; show: 'Closing ', ws. + mutex critical:[sockets remove: ws ifAbsent:[]]. + ]. + ws onError:[:ex| + Transcript cr; show: ws. + Transcript cr; show: ex description. + Transcript cr; show: ex signalerContext longStack. + ]. + mutex critical:[sockets add: ws]. + + "We don't need to #fork here, in fact we shouldn't since it ensures + that shutting down WebServer shuts down any WebSockets, too." + ws run. + ].! Item was added: + ----- Method: WebSocket class>>examplePage (in category 'example') ----- + examplePage + "The example HTML page for WebServer" + + ^'<html> + <p id="status">WebSocket: Not connected</p> + <form> + <input type="text" id="chat" placeholder="type and press enter to chat" /> + </form> + <p>To test, open two windows with Web Socket support, type a message above and press return.</p> + <ul id="log"></ul> + + <script> + + var conn = {}; + var log = document.getElementById("log"); + var chat = document.getElementById("chat"); + var form = chat.form; + var state = document.getElementById("status"); + + if (window.WebSocket === undefined) { + state.innerHTML = "(WebSockets not supported)"; + } else { + conn = new WebSocket("ws://localhost:8080/broadcast"); + conn.onopen = function () { + state.innerHTML = "WebSocket: Connected"; + }; + + conn.onmessage = function (event) { + log.innerHTML = "<li>" + event.data + "</li>" + log.innerHTML; + }; + + conn.onclose = function (event) { + state.innerHTML = "WebSocket: Closed"; + }; + + form.addEventListener("submit", function (event) { + event.preventDefault(); + if (conn.readyState === 1) { + conn.send(chat.value); + chat.value = ""; + } + }, false); + }; + + </script> + + </body> + </html>'! Item was added: + ----- Method: WebSocket class>>on: (in category 'instance creation') ----- + on: aStream + "Create a new WebSocket instance using the given SocketStream" + + ^self new on: aStream! Item was added: + ----- Method: WebSocket>>close (in category 'initialize') ----- + close + "Request graceful close" + + ^self subclassResponsibility! Item was added: + ----- Method: WebSocket>>fork (in category 'running') ----- + fork + "Fork the WebSocket's input process." + + process := [self run] newProcess. + process resume. + ! Item was added: + ----- Method: WebSocket>>handle:arguments: (in category 'private') ----- + handle: selector arguments: argList + + ^self handle: selector arguments: argList ifAbsent:[nil]! Item was added: + ----- Method: WebSocket>>handle:arguments:ifAbsent: (in category 'private') ----- + handle: selector arguments: argList ifAbsent: aBlock + + ^(handlers at: selector ifAbsent:[^aBlock value]) + valueWithPossibleArgs: argList.! Item was added: + ----- Method: WebSocket>>handleClose (in category 'private') ----- + handleClose + "Handle a connection close" + + ^self handle: 'close' arguments: (Array with: self) + ! Item was added: + ----- Method: WebSocket>>handleError: (in category 'private') ----- + handleError: exception + "Handle an error" + + ^self handle: 'error' arguments: (Array with: exception with: self)! Item was added: + ----- Method: WebSocket>>handleMessage:type: (in category 'private') ----- + handleMessage: msgData type: msgType + "Handle an incoming message of the given type" + + self handle: 'message' arguments: (Array with: msgData with: msgType with: self)! Item was added: + ----- Method: WebSocket>>initialize (in category 'initialize') ----- + initialize + super initialize. + handlers := Dictionary new.! Item was added: + ----- Method: WebSocket>>on: (in category 'initialize') ----- + on: aStream + "Create a new WebSocket instance using the given SocketStream" + + stream := aStream. + name := String streamContents:[:s| + stream socket remoteAddress + do:[:b| s print: b] + separatedBy:[s nextPut: $.]]. + name := name, ':', stream socket remotePort. + ! Item was added: + ----- Method: WebSocket>>onClose: (in category 'running') ----- + onClose: aBlock + "Set the handler block to invoke when the socket is closed" + + handlers at: 'close' put: aBlock.! Item was added: + ----- Method: WebSocket>>onError: (in category 'running') ----- + onError: aBlock + "Set the handler block to invoke when an error occurs" + + handlers at: 'error' put: aBlock.! Item was added: + ----- Method: WebSocket>>onMessage: (in category 'running') ----- + onMessage: aBlock + "Set the handler block to invoke when a message is received" + + handlers at: 'message' put: aBlock. + ! Item was added: + ----- Method: WebSocket>>printOn: (in category 'private') ----- + printOn: aStream + "Print the receiver" + + aStream nextPutAll: self class name. + aStream nextPutAll: '(', name, ')'.! Item was added: + ----- Method: WebSocket>>run (in category 'running') ----- + run + "Run the WebSocket's input process." + + ^self subclassResponsibility! Item was added: + ----- Method: WebSocket>>send: (in category 'read/write') ----- + send: aString + "Writes one frame worth of data" + + ^self subclassResponsibility! Item was added: + ----- Method: WebSocket>>timeout (in category 'accessing') ----- + timeout + "The underlying stream timeout" + + ^stream timeout! Item was added: + ----- Method: WebSocket>>timeout: (in category 'accessing') ----- + timeout: seconds + "Sets the underlying stream timeout" + + ^stream timeout: seconds! Item was added: + WebSocket subclass: #WebSocket00 + instanceVariableNames: 'frameType frameData' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebSocket00 commentStamp: 'ar 7/8/2010 18:21' prior: 0! + A wrapper object for the WebSocket API.! Item was added: + ----- Method: WebSocket00>>close (in category 'running') ----- + close + "Request graceful close" + + stream isConnected ifFalse: [ ^self ]. + stream + nextPut: (Character value: 255); + nextPut: (Character value: 0); + flush + ! Item was added: + ----- Method: WebSocket00>>readMessage (in category 'read/write') ----- + readMessage + "Reads one frame worth of data" + + | byte length | + byte := stream next ifNil:[ + frameType := 255. + ^nil]. + frameType := byte asInteger. + frameType < 128 ifTrue:[ + "Frame type < 128: UTF-8 encoded text with 0xFF frame delimiter" + frameData := (stream upTo: 255 asCharacter) utf8ToSqueak. + ] ifFalse:[ + "Frame type >= 128: Binary data with length prefix" + length := 0. + [byte := stream next asInteger. + length := (length * 128) + (byte bitClear: 128). + byte >= 128] whileTrue. + frameData := ByteArray new: length. + stream nextInto: frameData. + ]. + ! Item was added: + ----- Method: WebSocket00>>run (in category 'running') ----- + run + "Run the WebSocket's input process." + + [[[stream isConnected] whileTrue:[ + self readMessage. + "XXXX: Should this be moved into handleMessage:type: ???" + frameType = 255 ifTrue:[stream close. ^self]. + self handleMessage: frameData type: frameType. + ]] on: Error do:[:ex| self handleError: ex]] ensure:[ + [stream socket destroy] on: Error do:[:ex|]. + self handleClose. + ]. + ! Item was added: + ----- Method: WebSocket00>>send: (in category 'read/write') ----- + send: aString + "Writes one frame worth of data" + + ^self send: aString type: 0! Item was added: + ----- Method: WebSocket00>>send:type: (in category 'read/write') ----- + send: data type: type + "Writes one frame worth of data using the given frame type" + + "Frame type" + stream nextPut: (Character value: type). + type < 128 ifTrue:[ + "Frame type < 128: UTF-8 encoded text with 0xFF frame delimiter" + stream nextPutAll: data squeakToUtf8. + stream nextPutAll: (Character value: 255). + ] ifFalse:[ | prefix length | + "Frame type >= 128: Binary data with length prefix" + prefix := ByteArray new. + length := data size. + [length > 127] whileTrue:[ + prefix := prefix copyWith: prefix \\ 128. + length := length // 128. + ]. + prefix := prefix copyWith: length. + stream nextPutAll: prefix reversed. + stream nextPutAll: data. + stream flush. + ]. + stream flush. + ! Item was added: + WebSocket subclass: #WebSocket07 + instanceVariableNames: 'frameType frameData closing masking' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebSocket07 commentStamp: '<historical>' prior: 0! + A wrapper object for the WebSocket API.! Item was added: + ----- Method: WebSocket07>>close (in category 'control requests') ----- + close + "Send a close control request" + + closing ifFalse:[ + closing := true. + self send: #[] code: 8. + ].! Item was added: + ----- Method: WebSocket07>>firstFragment: (in category 'read/write') ----- + firstFragment: aStringOrBytes + "Writes the first fragment of data" + + aStringOrBytes isString + ifTrue:[^self send: aStringOrBytes squeakToUtf8 code: 1 final: false] + ifFalse:[^self send: aStringOrBytes code: 2 final: false].! Item was added: + ----- Method: WebSocket07>>handleClose: (in category 'control requests') ----- + handleClose: payload + "Close is being sent by remote in process of shutting down connection" + + closing ifFalse:[^self close]. + + "We're done. We've received the close and responded to it" + stream close. + + ! Item was added: + ----- Method: WebSocket07>>handleControl:type: (in category 'control requests') ----- + handleControl: payload type: opcode + "Handle a control opcode" + + opcode caseOf: { + [8] -> [self handleClose: payload]. + [9] -> [self handlePing: payload]. + [10] -> [self handlePong: payload]. + } otherwise:[self error: 'Unknown control request: ', opcode]. + + ! Item was added: + ----- Method: WebSocket07>>handlePing: (in category 'control requests') ----- + handlePing: payload + + self handle: 'ping' + arguments: (Array with: payload with: self) + ifAbsent:[self pong: payload]. + ! Item was added: + ----- Method: WebSocket07>>handlePong: (in category 'control requests') ----- + handlePong: payload + + self handle: 'pong' arguments: (Array with: payload with: self).! Item was added: + ----- Method: WebSocket07>>initialize (in category 'initialize') ----- + initialize + + super initialize. + closing := false. + masking := true. " http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07#section-… says: + ''Frames sent from the client to the server are masked to + avoid confusing network intermediaries, such as intercepting proxies.''"! Item was added: + ----- Method: WebSocket07>>lastFragment: (in category 'read/write') ----- + lastFragment: aStringOrBytes + "Writes the last fragment of data. + Note: Spec says that code is ZERO for final fragment." + + aStringOrBytes isString + ifTrue:[^self send: aStringOrBytes squeakToUtf8 code: 0 final: true] + ifFalse:[^self send: aStringOrBytes code: 0 final: true].! Item was added: + ----- Method: WebSocket07>>masking (in category 'accessing') ----- + masking + "If true, outgoing frames are masked." + + ^masking! Item was added: + ----- Method: WebSocket07>>masking: (in category 'accessing') ----- + masking: aBool + "If true, outgoing frames are masked." + + masking := aBool! Item was added: + ----- Method: WebSocket07>>nextFragment: (in category 'read/write') ----- + nextFragment: aStringOrBytes + "Writes the first fragment of data + Note: Spec says that code is ZERO for intermediate fragments." + + aStringOrBytes isString + ifTrue:[^self send: aStringOrBytes squeakToUtf8 code: 0 final: false] + ifFalse:[^self send: aStringOrBytes code: 0 final: false].! Item was added: + ----- Method: WebSocket07>>nextNumber:from: (in category 'private') ----- + nextNumber: n from: aStream + "Answer the next n bytes as a positive Integer or LargePositiveInteger." + | s | + s := 0. + 1 to: n do: + [:i | s := (s bitShift: 8) bitOr: aStream next asInteger]. + ^ s normalize! Item was added: + ----- Method: WebSocket07>>onPing: (in category 'control requests') ----- + onPing: aBlock + "Set the handler block to invoke when a ping is received" + + handlers at: 'ping' put: aBlock.! Item was added: + ----- Method: WebSocket07>>onPong: (in category 'control requests') ----- + onPong: aBlock + "Set the handler block to invoke when a pong is received" + + handlers at: 'pong' put: aBlock.! Item was added: + ----- Method: WebSocket07>>ping: (in category 'control requests') ----- + ping: data + "Send a ping control request" + + self send: data code: 9.! Item was added: + ----- Method: WebSocket07>>pong: (in category 'control requests') ----- + pong: data + "Send a pong control request" + + self send: data code: 10.! Item was added: + ----- Method: WebSocket07>>readFrame (in category 'read/write') ----- + readFrame + "Reads one frame worth of data" + + ^self readFrameFrom: stream! Item was added: + ----- Method: WebSocket07>>readFrameFrom: (in category 'read/write') ----- + readFrameFrom: aStream + "Reads one frame worth of data" + + | byte length final mask opcode payload | + byte := (aStream next ifNil:[^nil]) asInteger. + + final := byte anyMask: 128. + opcode := byte bitAnd: 15. + + byte := (aStream next ifNil:[^nil]) asInteger. + mask := byte anyMask: 128. + length := byte bitAnd: 127. + + length = 126 ifTrue:[ + length := self nextNumber: 2 from: aStream. + ] ifFalse:[ + length = 127 ifTrue:[length := self nextNumber: 8 from: aStream]. + ]. + + mask + ifTrue:[mask := aStream next: 4] + ifFalse:[mask := nil]. + + payload := ByteArray new: length. + aStream next: length into: payload. + + "Unmask payload" + mask ifNotNil:[self xor: payload with: mask]. + + "First see if this is a control frame which can be inserted into fragmented messages." + opcode >= 8 ifTrue:[^self handleControl: payload type: opcode]. + + "Now see if this is a fragmented message" + frameType ifNil:[ + frameType := opcode. + frameData := Array with: payload. + ] ifNotNil:[ + frameData := frameData copyWith: payload. + ]. + + final ifTrue:[ + "This was the final fragment" + frameData size = 1 ifTrue:[ + payload := frameData first + ] ifFalse:[ + payload := frameData allButFirst + inject: frameData first + into:[:each :next| each, next]. + ]. + frameType = 1 ifTrue:[payload := payload asString utf8ToSqueak]. + self handleMessage: payload type: frameType. + frameType := frameData := nil. + ]. + ! Item was added: + ----- Method: WebSocket07>>run (in category 'running') ----- + run + "Run the WebSocket's input process." + + [[[stream isConnected] whileTrue:[ + self readFrame. + ]] on: Error do:[:ex| self handleError: ex]] ensure:[ + [stream socket destroy] on: Error do:[:ex|]. + self handleClose. + ]. + ! Item was added: + ----- Method: WebSocket07>>send: (in category 'read/write') ----- + send: aStringOrBytes + "Writes one frame worth of data" + + aStringOrBytes isString + ifTrue:[^self send: aStringOrBytes squeakToUtf8 code: 1] + ifFalse:[^self send: aStringOrBytes code: 2].! Item was added: + ----- Method: WebSocket07>>send:code: (in category 'read/write') ----- + send: data code: opcode + "Sends unfragmented data using the given opcode" + + ^self send: data code: opcode final: true! Item was added: + ----- Method: WebSocket07>>send:code:final: (in category 'read/write') ----- + send: data code: opcode final: isFinal + "Sends unfragmented data using the given opcode" + + ^self send: data code: opcode final: isFinal mask: self masking! Item was added: + ----- Method: WebSocket07>>send:code:final:mask: (in category 'read/write') ----- + send: data code: opcode final: isFinal mask: doMask + "Sends unfragmented data using the given opcode" + + | byte1 byte2 mask xLength copy | + byte1 := opcode. "FIN = 1, RSV1=RSV2=RSV3=0" + isFinal ifTrue:[byte1 := byte1 bitOr: 128]. + data size > 125 ifTrue:[ + data size > 16rFFFF ifTrue:[ + byte2 := 127. + xLength := ByteArray new: 8. + (WriteStream on: xLength) nextNumber: 8 put: data size. + ] ifFalse:[ + byte2 := 126. + xLength := ByteArray new: 2. + (WriteStream on: xLength) nextNumber: 2 put: data size. + ]. + ] ifFalse:[ + byte2 := data size. + xLength := #[]. + ]. + doMask ifTrue:[ + byte2 := byte2 bitOr: 128. "Mask = 1" + mask := ByteArray new: 4. + 1 to: 4 do:[:i| mask at: i put: 256 atRandom-1]. + copy := data copy. + self xor: copy with: mask. + ] ifFalse:[ + copy := data. + ]. + stream nextPut: byte1. + stream nextPut: byte2. + stream nextPutAll: xLength. + mask ifNotNil:[stream nextPutAll: mask]. + stream nextPutAll: copy. + stream flush.! Item was added: + ----- Method: WebSocket07>>xor:with: (in category 'read/write') ----- + xor: data with: mask + "XOR all the data using the given mask bytes. + + WARNING: Does inplace reversal; do not call with literal data." + + "This would be much faster w/ BitBlt but data may not be + 4-byte aligned and so BB will barf." + 1 to: data size do:[:i| + data byteAt: i put: ((data byteAt: i) bitXor: (mask byteAt: i-1 \\ 4 + 1)). + ]. + ! Item was added: + Object subclass: #WebUtils + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebUtils commentStamp: 'ar 2/23/2010 10:39' prior: 0! + WebUtils contains a number of utility methods used by WebClient/WebServer.! Item was added: + ----- Method: WebUtils class>>decodeMultipartForm:boundary:do: (in category 'decoding') ----- + decodeMultipartForm: aStream boundary: boundary do: aBlock + "Parse the contents of a multipart/form-data submission. + + Evaluate aBlock with three parts: The headers, the (parsed) form-data + arguments and the (undecoded) contents of the part. The sender is + expected to take care of other issues such as content-transfer-encoding + and similar headers." + + | skip headers content disposition index params | + aStream upToAll: '--', boundary. + [aStream atEnd or:[(skip := aStream next: 2) = '--']] whileFalse:[ + skip = String crlf ifFalse:[self error: 'Error decoding multipart/form-data fields']. + headers := Dictionary new. + (WebUtils readHeadersFrom: aStream) do:[:hdr| headers add: hdr]. + content := aStream upToAll: String crlf, '--', boundary. + params := Dictionary new. + disposition := headers at: 'content-disposition' ifAbsent:['']. + #(name filename) do:[:arg| | len val | + len := arg size + 2. + index := disposition findString: arg,'='. + index > 0 ifTrue:[ + val := disposition copyFrom: index + len to: (disposition indexOf: $" startingAt: index+len) - 1. + params at: arg put: val. + ]. + ]. + aBlock value: headers value: params value: content. + ].! Item was added: + ----- Method: WebUtils class>>decodeUrlEncodedForm: (in category 'decoding') ----- + decodeUrlEncodedForm: aString + "Decodes the fields embedded in the url ?var1=val1&var2=val2" + + ^self decodeUrlEncodedForm: aString multipleValues: false! Item was added: + ----- Method: WebUtils class>>decodeUrlEncodedForm:do: (in category 'decoding') ----- + decodeUrlEncodedForm: aString do: aBlock + "Decodes the fields embedded in the url ?var1=val1&var2=val2. + Evaluates aBlock with the key/value pairs defined in the fields." + + | args keyval index key value | + args := aString readStream. + [args atEnd] whileFalse:[ + keyval := args upTo: $&. + (index := keyval indexOf: $=) = 0 ifTrue:[ + key := keyval. + value := ''. + ] ifFalse:[ + key := keyval copyFrom: 1 to: index-1. + value := keyval copyFrom: index +1 to: keyval size. + ]. + key := key unescapePercentsWithTextEncoding: nil. + value := value unescapePercentsWithTextEncoding: nil. + aBlock value: key value: value. + ]. + ! Item was added: + ----- Method: WebUtils class>>decodeUrlEncodedForm:multipleValues: (in category 'decoding') ----- + decodeUrlEncodedForm: aString multipleValues: aBool + "Decodes the fields embedded in the url ?var1=val1&var2=val2" + + | fields | + fields := Dictionary new. + self decodeUrlEncodedForm: aString do:[:key :value| + aBool + ifTrue:[fields at: key put: (fields at: key ifAbsent:['']), value] + ifFalse:[fields at: key put: value]. + ]. + ^fields! Item was added: + ----- Method: WebUtils class>>decodeUrlEncodedForm:multipleValues:withConverter: (in category 'decoding') ----- + decodeUrlEncodedForm: aString multipleValues: aBool withConverter: aTextConverter + "Decodes the fields embedded in the url ?var1=val1&var2=val2" + + | fields | + fields := Dictionary new. + self decodeUrlEncodedForm: aString do:[:key :value| + aBool + ifTrue:[ + fields + at: key + put: (fields at: key ifAbsent:['']), (value convertFromWithConverter: aTextConverter) ] + ifFalse:[ + fields + at: key + put: (value convertFromWithConverter: aTextConverter) ]. + ]. + ^fields! Item was added: + ----- Method: WebUtils class>>defaultProxyServer (in category 'proxy') ----- + defaultProxyServer + "Answer the default proxy server to use." + + HTTPSocket httpProxyServer isEmptyOrNil ifTrue:[^'']. + + "Note: This is a hack since HTTPSocket is too specific for our use here." + HTTPSocket httpProxyPort = 80 ifTrue:[ + "Assumes that port 80 means 'use default'" + ^HTTPSocket httpProxyServer ifNil:[''] + ] ifFalse:[ + ^HTTPSocket httpProxyServer, ':', HTTPSocket httpProxyPort + ].! Item was added: + ----- Method: WebUtils class>>encodeMultipartForm:boundary: (in category 'decoding') ----- + encodeMultipartForm: fieldMap boundary: boundary + "Encodes the fieldMap as multipart/form-data. + + The fieldMap may contain MIMEDocument instances to indicate the presence + of a file to upload to the server. If the MIMEDocument is present, its + content type and file name will be used for the upload. + + The fieldMap can be EITHER an array of associations OR a Dictionary of + key value pairs (the former is useful for providing multiple fields and/or + specifying the order of fields)." + + ^String streamContents:[:stream| + (fieldMap as: Dictionary) keysAndValuesDo:[:fieldName :fieldValue | | fieldContent | + "Write multipart boundary and common headers" + stream nextPutAll: '--', boundary; crlf. + stream nextPutAll: 'Content-Disposition: form-data; name="', fieldName, '"'. + "Figure out if this is a file upload" + (fieldValue isKindOf: MIMEDocument) ifTrue:[ + stream nextPutAll: '; filename="', fieldValue url pathForFile, '"'; crlf. + stream nextPutAll: 'Content-Type: ', fieldValue contentType. + fieldContent := (fieldValue content ifNil:[ + (FileStream readOnlyFileNamed: fieldValue url pathForFile) contentsOfEntireFile. + ]) asString. + ] ifFalse: [fieldContent := fieldValue]. + stream crlf; crlf. + stream nextPutAll: fieldContent asString. + stream crlf. + ]. + stream nextPutAll: '--', boundary, '--', String crlf. + ]. + ! Item was added: + ----- Method: WebUtils class>>encodeUrlEncodedForm: (in category 'decoding') ----- + encodeUrlEncodedForm: fieldMap + "Encodes the fieldsMap in the form of var1=val1&var2=val2. + The fieldMap can be EITHER an array of associations OR a Dictionary of + key value pairs (the former is useful for providing multiple fields and/or + specifying the order of fields)." + + | associations | + associations := fieldMap isDictionary ifTrue:[fieldMap associations] ifFalse:[fieldMap]. + ^String streamContents:[:s| + associations do:[:assoc| + s nextPutAll: assoc key encodeForHTTP. + assoc value ifNotNil:[ + s nextPutAll: '='. + s nextPutAll: assoc value asString encodeForHTTP + ]. + ] separatedBy:[s nextPutAll:'&']. + ].! Item was added: + ----- Method: WebUtils class>>extractWebSocketKey: (in category 'websockets') ----- + extractWebSocketKey: field + "Decodes a WebSocket key: + + Sec-WebSocket-Key1: 18x 6]8vM;54 *(5: { U1]8 z [ 8 + Sec-WebSocket-Key2: 1_ tx7X d < nw 334J702) 7]o}` 0 + + For each of these fields, the server has to take the digits from the + value to obtain a number (in this case 1868545188 and 1733470270 + respectively), then divide that number by the number of spaces + characters in the value (in this case 12 and 10) to obtain a 32-bit + number (155712099 and 173347027). These two resulting numbers are + then used in the server handshake, as described below. + " + + | digits spaces | + digits := spaces := 0. + field do:[:ch| + ch isDigit ifTrue:[digits := digits * 10 + ch digitValue]. + ch = $ ifTrue:[spaces := spaces + 1]. + ]. + ^digits // spaces. + ! Item was added: + ----- Method: WebUtils class>>handleAuth: (in category 'auth') ----- + handleAuth: aBlock + "Utility method to handle web authentication requests interactively. + + Use like here: + | wc | + wc := WebClient new. + WebUtils handleAuth:[wc httpGet: 'http://some.auth.required']. + " + + | user pass | + ^[aBlock value] on: WebAuthRequired do:[:ex| + "Allow outer handlers to take over authentication" + ex isNested ifFalse:[ + user := UIManager default request: ex message, + '\Please enter your user name:' withCRs initialAnswer:''. + user ifNotEmpty:[ + "Just a little obfuscation to avoid completely plain passwords" + pass := (UIManager default requestPassword: + 'Please enter the password for "', user,'":') base64Encoded. + ex username: user password: [pass base64Decoded]]]. + ex pass].! Item was added: + ----- Method: WebUtils class>>hmacSha1:key: (in category 'oauth') ----- + hmacSha1: message key: signKey + "Compute the SHA1 HMAC for the given message" + + | blockSize key | + blockSize := 64. "SHA1 block size" + key := signKey asByteArray. + key size > blockSize ifTrue:[key := self sha1Hash: key]. + key size < blockSize ifTrue:[key := key grownBy: blockSize - key size ]. + ^self sha1Hash: + (key collect: [ :byte | byte bitXor: 16r5c "opad byte" ]), + (self sha1Hash: (key collect: [ :byte | byte bitXor: 16r36 "ipad byte" ]), message)! Item was added: + ----- Method: WebUtils class>>jsonArray:on: (in category 'json-encode') ----- + jsonArray: anArray on: stream + "Encodes an array" + + stream nextPut: $[. + anArray + do:[:each| self jsonObj: each on: stream] + separatedBy:[stream nextPutAll:', ']. + stream nextPut:$]. + ! Item was added: + ----- Method: WebUtils class>>jsonArrayFrom: (in category 'json-decode') ----- + jsonArrayFrom: stream + "Decodes a JSON [value, *] array from the stream" + + | ch result | + (ch := stream next) = $[ ifFalse:[^self error: 'JSON Array expected']. + stream skipSeparators. + stream peek = $] ifTrue:[stream next. ^#()]. + result := WriteStream on: (Array new: 10). + ["Decode the next value" + stream skipSeparators. + result nextPut: (self jsonDecode: stream). + stream skipSeparators. + (ch := stream next) = $]] whileFalse:[ + ch = $, ifFalse:[^self error: 'Comma expected']. + ]. + + ^result contents! Item was added: + ----- Method: WebUtils class>>jsonChar:on: (in category 'json-encode') ----- + jsonChar: aCharacter on: stream + "Writes a single encoded character" + + | ascii | + ascii := aCharacter asciiValue. + + ascii < 32 ifTrue:["Control character" + ascii caseOf: { + [13] -> [^stream nextPutAll: '\r']. + [12] -> [^stream nextPutAll: '\f']. + [10] -> [^stream nextPutAll: '\n']. + [9] -> [^stream nextPutAll: '\t']. + [8] -> [^stream nextPutAll: '\b']. + } otherwise:[ + ^stream nextPutAll: '\u'; nextPutAll: + ((ascii printStringBase: 16) padded: #left to: 4 with: $0) + ]. + ]. + + (ascii >= 32 and:[ascii <=127]) ifTrue:["Ascii character" + (ascii = 34 or:[ascii = 92 or:[ascii = 47]]) ifTrue:[stream nextPut: $\]. + ^stream nextPut: aCharacter + ]. + + "Encode other characters (control chars, accents, umlauts, unicode)" + stream nextPutAll: + '\u', (((ascii bitAnd: 16rFFFF) printStringBase: 16) padded: #left to: 4 with: $0). + ! Item was added: + ----- Method: WebUtils class>>jsonCharFrom: (in category 'json-decode') ----- + jsonCharFrom: stream + "Decodes a backslash-escaped character" + + | ch | + ^(ch := stream next) caseOf: { + [$u] -> [Unicode value: + (Integer readFrom: (stream next: 4) readStream base: 16)]. + [$r] -> [Character cr]. + [$n] -> [Character lf]. + [$t] -> [Character tab]. + [$b] -> [Character backspace]. + [$f] -> [Character newPage]. + } otherwise:[ch]. + ! Item was added: + ----- Method: WebUtils class>>jsonDecode: (in category 'json-decode') ----- + jsonDecode: stream + "Decodes an arbitrary JSON encoded value from the given stream" + + stream skipSeparators. + ^stream peek caseOf: { + [$"] -> [self jsonStringFrom: stream]. + [$t] -> [self jsonTrueFrom: stream]. + [$f] -> [self jsonFalseFrom: stream]. + [$n] -> [self jsonNullFrom: stream]. + [${] -> [self jsonMapFrom: stream]. + [$[] -> [self jsonArrayFrom: stream]. + } otherwise:[self jsonNumberFrom: stream]. + ! Item was added: + ----- Method: WebUtils class>>jsonEncode: (in category 'json-encode') ----- + jsonEncode: anObject + "Encode the given object as JSON" + + ^String streamContents:[:s| self jsonObj: anObject on: s]! Item was added: + ----- Method: WebUtils class>>jsonFalseFrom: (in category 'json-decode') ----- + jsonFalseFrom: stream + "Decodes 'false' from aStream" + + ((stream next: 5) = 'false' + and:[stream atEnd or:[stream peek isAlphaNumeric not]]) + ifFalse:[^self error: 'Expected ''false''']. + ^false! Item was added: + ----- Method: WebUtils class>>jsonFloatSignificand:exp10: (in category 'json-decode') ----- + jsonFloatSignificand: value exp10: exponent + "Take care to convert to nearest Float" + ^self jsonFloatSignificand: value exp10: exponent scale: (10 raisedTo: exponent abs)! Item was added: + ----- Method: WebUtils class>>jsonFloatSignificand:exp10:scale: (in category 'json-decode') ----- + jsonFloatSignificand: value exp10: exponent scale: scale + "Take care to convert to nearest Float" + "self assert: scale = (10 raisedTo: exponent abs)." + ^(value isAnExactFloat and: ["scale isAnExactFloat" + exponent between: -22 and: 22 + "(1 to: 100) detect: [:i | (10 raisedTo: i) isAnExactFloat not]"]) + ifTrue: [exponent >= 0 + ifTrue: [value asExactFloat * scale asExactFloat] + ifFalse: [value asExactFloat / scale asExactFloat]] + ifFalse: [exponent >= 0 + ifTrue: [(value * scale) asFloat] + ifFalse: [(Fraction numerator: value denominator: scale) asFloat]]! Item was added: + ----- Method: WebUtils class>>jsonFromString: (in category 'json-decode') ----- + jsonFromString: aString + + ^ self jsonDecode: aString readStream! Item was added: + ----- Method: WebUtils class>>jsonMap:on: (in category 'json-encode') ----- + jsonMap: aDictionary on: stream + "Encodes a dictionary" + + stream nextPut: ${. + "Sorting keys ensures deterministic order" + aDictionary keys asArray sort do:[:key| + self jsonString: key on: stream. + stream nextPutAll:': '. + self jsonObj: (aDictionary at: key) on: stream. + ] separatedBy:[stream nextPutAll: ', ']. + stream nextPut: $}.! Item was added: + ----- Method: WebUtils class>>jsonMapFrom: (in category 'json-decode') ----- + jsonMapFrom: stream + "Decodes a JSON {key:value, *} object from the stream" + + | map ch key value | + map := Dictionary new. + (ch := stream next) = ${ ifFalse:[^self error: 'JSON Object expected']. + stream skipSeparators. + stream peek = $} ifTrue:[^map]. + + ["Decode the next key:value pair" + stream skipSeparators. + key := self jsonStringFrom: stream. + stream skipSeparators. + stream next = $: ifFalse:[^self error: 'Key-value pair expected']. + value := self jsonDecode: stream. + map at: key put: value. + stream skipSeparators. + (ch := stream next) = $}] whileFalse:[ + ch = $, ifFalse:[^self error: 'Comma expected']. + ]. + + ^map! Item was added: + ----- Method: WebUtils class>>jsonNullFrom: (in category 'json-decode') ----- + jsonNullFrom: stream + "Decodes 'null' from aStream" + + ((stream next: 4) = 'null' + and:[stream atEnd or:[stream peek isAlphaNumeric not]]) + ifFalse:[^self error: 'Expected ''null''']. + ^nil! Item was added: + ----- Method: WebUtils class>>jsonNumber:on: (in category 'json-encode') ----- + jsonNumber: aNumber on: stream + "Encodes a number" + + | value | + value := aNumber. + value isInteger ifFalse:[value := aNumber asFloat]. + stream print: aNumber. + ! Item was added: + ----- Method: WebUtils class>>jsonNumberFrom: (in category 'json-decode') ----- + jsonNumberFrom: stream + "Decodes a JSON number from the stream" + + | ascii ch integer fraction scale sign expSign exponent exp value beFloat | + integer := fraction := exponent := exp := 0. sign := scale := expSign := 1. + ascii := stream next asciiValue. + ascii = 45 "$- asciiValue" ifTrue:[ + sign := -1. + ascii := stream next asciiValue. + ]. + "JSON requires at least one digit" + (ascii >= 48 and:[ascii <= 57]) ifFalse:[^self error: 'Digit expected']. + + "Read the integer part" + integer := ascii - 48. + [ch := stream next ifNil:[^integer * sign]. + ascii := ch asciiValue. + ascii >= 48 and:[ascii <= 57]] whileTrue:[ + integer := (integer * 10) + (ascii - 48). + ]. + + (beFloat := ascii = 46) "$. asciiValue" ifTrue:[ + "Read the fraction part" + [ch := stream next ifNil: + [value := integer * scale + fraction * sign. + ^self jsonFloatSignificand: value exp10: exponent scale: scale]. + ascii := ch asciiValue. + ascii >= 48 and:[ascii <= 57]] whileTrue:[ + fraction := (fraction * 10) + (ascii - 48). + exponent := exponent - 1. + scale := scale * 10. + ]. + value := integer * scale + fraction * sign. + ] ifFalse:[value := integer * sign]. + (ascii = 69 "$E asciiValue" or:[ascii = 101 "$e asciiValue"]) ifTrue:[ + "Read exponent" + ascii := stream next asciiValue. + ascii = 45 "$- asciiValue" ifTrue:[ + expSign := -1. + ascii := stream next asciiValue. + ] ifFalse:[ascii = 43 "$+ asciiValue" ifTrue:[ascii := stream next asciiValue]]. + exp := ascii - 48. + [ch := stream next ifNil: + [exponent := exp * expSign + exponent. + (beFloat or: [expSign = -1]) ifTrue: [^self jsonFloatSignificand: value exp10: exponent]. + ^value * (10 raisedTo: exponent)]. + ascii := ch asciiValue. + ascii >= 48 and:[ascii <= 57]] whileTrue:[ + exp := (exp * 10) + (ascii - 48). + ]. + exponent := exp * expSign + exponent + ]. + + "Skip back before last character since number might be part of a sequence + like 1, 2, 3, 4, etc (which would eat the trailing comma)" + ch isAlphaNumeric ifTrue:[^self error: 'Delimiter expected']. + stream skip: -1. + + (beFloat or: [expSign = -1]) ifTrue: [^self jsonFloatSignificand: value exp10: exponent]. + ^value * (10 raisedTo: exponent)! Item was added: + ----- Method: WebUtils class>>jsonObj:on: (in category 'json-encode') ----- + jsonObj: anObject on: stream + "Encode a generic object" + + anObject isString ifTrue:[^self jsonString: anObject on: stream]. + anObject isNumber ifTrue:[^self jsonNumber: anObject on: stream]. + anObject == nil ifTrue:[^stream nextPutAll: 'null']. + anObject == true ifTrue:[^stream nextPutAll: 'true']. + anObject == false ifTrue:[^stream nextPutAll: 'false']. + anObject isArray ifTrue:[^self jsonArray: anObject on: stream]. + anObject isDictionary ifTrue:[^self jsonMap: anObject on: stream]. + + self error: 'Cannot encode: ', anObject! Item was added: + ----- Method: WebUtils class>>jsonString:on: (in category 'json-encode') ----- + jsonString: aString on: stream + "Encodes a string" + + stream nextPut: $". + aString do:[:ch| self jsonChar: ch on: stream]. + stream nextPut: $". + ! Item was added: + ----- Method: WebUtils class>>jsonStringFrom: (in category 'json-decode') ----- + jsonStringFrom: stream + "Decodes a JSON encoded string" + + | ch result | + (ch := stream next) = $" + ifFalse:[^self error: 'String expected']. + result := WriteStream on: (String new: 20). + [(ch := stream next) == nil] whileFalse:[ + ch = $" ifTrue:[^result contents]. + ch = $\ ifTrue:[ch := self jsonCharFrom: stream]. + result nextPut: ch. + ]. + ^self error: 'Unterminated string'! Item was added: + ----- Method: WebUtils class>>jsonTrueFrom: (in category 'json-decode') ----- + jsonTrueFrom: stream + "Decodes 'true' from aStream" + + ((stream next: 4) = 'true' + and:[stream atEnd or:[stream peek isAlphaNumeric not]]) + ifFalse:[^self error: 'Expected ''true''']. + ^true! Item was added: + ----- Method: WebUtils class>>logEntryFor:response: (in category 'misc') ----- + logEntryFor: request response: response + "Create a log entry in common log format from the given request / response" + + | entry logdate logsize | + + "CLF prints date as [day/month/year:hour:min:sec zone]" + logdate := String streamContents:[:s| | date | + date := DateAndTime fromSeconds: Time totalSeconds. + s nextPut: $[. + date asDate printOn: s format: #( 1 2 3 $/ 2 1 2). + s nextPut: $:. + date asTime print24: true on: s. + s nextPutAll:(' ', + (date offset hours >= 0 ifTrue:['+'] ifFalse:['-']), + (date offset hours abs asString padded: #left to: 2 with: $0), + (date offset minutes abs asString padded: #left to: 2 with: $0) + ). + s nextPut: $]. + ]. + + "CLF prints zero length as - " + logsize := response contentLength ifNil:[0]. + logsize = 0 ifTrue:[logsize := '-']. + + entry := String streamContents:[:s| + s + nextPutAll: (request remoteHost ifNil:[ + "Substitute with the host header" + (request headerAt: 'host') copyUpTo: $: + ]); + nextPutAll: ' -'; "RFC 1413 identity of client" + nextPutAll: ' -'; "TODO: userid of authenticated user" + nextPutAll: ' ', logdate; + nextPutAll: ' "', request requestLine, '"'; + nextPutAll: ' ', response code; + nextPutAll: ' ', logsize. + ]. + ^entry + ! Item was added: + ----- Method: WebUtils class>>logRequest:response:on: (in category 'misc') ----- + logRequest: request response: response on: streamOrFilename + "Log a request in common log format on the given stream / file." + + | entry stream | + + "Create the log entry for the request/response pair" + entry := self logEntryFor: request response: response. + + "If the argument is a string, it represents the file name to log to" + streamOrFilename isString ifTrue:[ + stream := [FileStream oldFileNamed: streamOrFilename] + on: FileDoesNotExistException + do:[FileStream newFileNamed: streamOrFilename]. + stream wantsLineEndConversion: true; setToEnd. + ] ifFalse:[stream := streamOrFilename]. + + stream nextPutAll: entry; cr. + + stream == streamOrFilename + ifTrue:[stream flush] + ifFalse:[stream close]. + ! Item was added: + ----- Method: WebUtils class>>mcVersion (in category 'misc') ----- + mcVersion + "Answers the Monticello version of WebServer's MC package" + + | version | + Smalltalk at: #MCWorkingCopy ifPresent:[:mc| + mc managersForClass: self do:[:wc| + wc ancestors ifNotEmpty:[:ancestry| version := ancestry first name]]]. + ^version ifNil:[''].! Item was added: + ----- Method: WebUtils class>>md5Digest: (in category 'md5') ----- + md5Digest: aStringOrByteArray + "This creates a little endian hex string to be used with various auth methods + This is the same as htdigest (apache) uses for its md5 digest auth db" + + ^(self md5HashStream: aStringOrByteArray readStream) hex! Item was added: + ----- Method: WebUtils class>>md5HashStream: (in category 'md5') ----- + md5HashStream: aStream + "self md5HashStream: (ReadStream on: 'foo')" + + | start buffer chunkSize n words hash | + hash := WordArray + with: 16r67452301 + with: 16rEFCDAB89 + with: 16r98BADCFE + with: 16r10325476. + words := WordArray new: 16. + buffer := ByteArray new: 64. + start := aStream position. + [ + chunkSize := aStream readInto: buffer startingAt: 1 count: 64. + chunkSize < 64 or: [ aStream atEnd ] ] + whileFalse: [ + 1 to: 16 do:[:i| words at: i put: (buffer unsignedLongAt: i*4-3 bigEndian: false)]. + self md5Transform: words hash: hash ]. + buffer from: chunkSize +1 to: buffer size put: 0. + chunkSize < 56 ifTrue: [ + buffer at: chunkSize + 1 put: 128. "trailing bit" + ] ifFalse:[ + "not enough room for the length, so just pad this one, then..." + chunkSize < 64 ifTrue:[buffer at: chunkSize + 1 put: 128]. + 1 to: 16 do:[:i| words at: i put: (buffer unsignedLongAt: i*4-3 bigEndian: false)]. + self md5Transform: words hash: hash. + "process one additional block of padding ending with the length" + buffer atAllPut: 0. + chunkSize = 64 ifTrue: [buffer at: 1 put: 128]. + ]. + "Fill in the final 8 bytes with the 64-bit length in bits." + n := (aStream position - start) * 8. + 7 to: 0 by: -1 do:[:i| buffer at: (buffer size - i) put: ((n bitShift: 7 - i * -8) bitAnd: 255)]. + "Final round" + 1 to: 16 do:[:i| words at: i put: (buffer unsignedLongAt: i*4-3 bigEndian: false)]. + self md5Transform: words hash: hash. + + ^(ByteArray new: 16) + unsignedLongAt: 1 put: (hash at: 1) bigEndian: false; + unsignedLongAt: 5 put: (hash at: 2) bigEndian: false; + unsignedLongAt: 9 put: (hash at: 3) bigEndian: false; + unsignedLongAt: 13 put: (hash at: 4) bigEndian: false; + yourself! Item was added: + ----- Method: WebUtils class>>md5Transform:hash: (in category 'md5') ----- + md5Transform: in hash: hash + "This adds the incoming words to the existing hash" + + | a b c d | + <primitive: 'primitiveMD5Transform' module: 'CroquetPlugin'> + a := hash at: 1. + b := hash at: 2. + c := hash at: 3. + d := hash at: 4. + + a := self step1: a x: b y: c z: d data: (in at: 1) add: 16rD76AA478 shift: 7. + d := self step1: d x: a y: b z: c data: (in at: 2) add: 16rE8C7B756 shift: 12. + c := self step1: c x: d y: a z: b data: (in at: 3) add: 16r242070DB shift: 17. + b := self step1: b x: c y: d z: a data: (in at: 4) add: 16rC1BDCEEE shift: 22. + a := self step1: a x: b y: c z: d data: (in at: 5) add: 16rF57C0FAF shift: 7. + d := self step1: d x: a y: b z: c data: (in at: 6) add: 16r4787C62A shift: 12. + c := self step1: c x: d y: a z: b data: (in at: 7) add: 16rA8304613 shift: 17. + b := self step1: b x: c y: d z: a data: (in at: 8) add: 16rFD469501 shift: 22. + a := self step1: a x: b y: c z: d data: (in at: 9) add: 16r698098D8 shift: 7. + d := self step1: d x: a y: b z: c data: (in at: 10) add: 16r8B44F7AF shift: 12. + c := self step1: c x: d y: a z: b data: (in at: 11) add: 16rFFFF5BB1 shift: 17. + b := self step1: b x: c y: d z: a data: (in at: 12) add: 16r895CD7BE shift: 22. + a := self step1: a x: b y: c z: d data: (in at: 13) add: 16r6B901122 shift: 7. + d := self step1: d x: a y: b z: c data: (in at: 14) add: 16rFD987193 shift: 12. + c := self step1: c x: d y: a z: b data: (in at: 15) add: 16rA679438E shift: 17. + b := self step1: b x: c y: d z: a data: (in at: 16) add: 16r49B40821 shift: 22. + + a := self step2: a x: b y: c z: d data: (in at: 2) add: 16rF61E2562 shift: 5. + d := self step2: d x: a y: b z: c data: (in at: 7) add: 16rC040B340 shift: 9. + c := self step2: c x: d y: a z: b data: (in at: 12) add: 16r265E5A51 shift: 14. + b := self step2: b x: c y: d z: a data: (in at: 1) add: 16rE9B6C7AA shift: 20. + a := self step2: a x: b y: c z: d data: (in at: 6) add: 16rD62F105D shift: 5. + d := self step2: d x: a y: b z: c data: (in at: 11) add: 16r02441453 shift: 9. + c := self step2: c x: d y: a z: b data: (in at: 16) add: 16rD8A1E681 shift: 14. + b := self step2: b x: c y: d z: a data: (in at: 5) add: 16rE7D3FBC8 shift: 20. + a := self step2: a x: b y: c z: d data: (in at: 10) add: 16r21E1CDE6 shift: 5. + d := self step2: d x: a y: b z: c data: (in at: 15) add: 16rC33707D6 shift: 9. + c := self step2: c x: d y: a z: b data: (in at: 4) add: 16rF4D50D87 shift: 14. + b := self step2: b x: c y: d z: a data: (in at: 9) add: 16r455A14ED shift: 20. + a := self step2: a x: b y: c z: d data: (in at: 14) add: 16rA9E3E905 shift: 5. + d := self step2: d x: a y: b z: c data: (in at: 3) add: 16rFCEFA3F8 shift: 9. + c := self step2: c x: d y: a z: b data: (in at: 8) add: 16r676F02D9 shift: 14. + b := self step2: b x: c y: d z: a data: (in at: 13) add: 16r8D2A4C8A shift: 20. + + a := self step3: a x: b y: c z: d data: (in at: 6) add: 16rFFFA3942 shift: 4. + d := self step3: d x: a y: b z: c data: (in at: 9) add: 16r8771F681 shift: 11. + c := self step3: c x: d y: a z: b data: (in at: 12) add: 16r6D9D6122 shift: 16. + b := self step3: b x: c y: d z: a data: (in at: 15) add: 16rFDE5380C shift: 23. + a := self step3: a x: b y: c z: d data: (in at: 2) add: 16rA4BEEA44 shift: 4. + d := self step3: d x: a y: b z: c data: (in at: 5) add: 16r4BDECFA9 shift: 11. + c := self step3: c x: d y: a z: b data: (in at: 8) add: 16rF6BB4B60 shift: 16. + b := self step3: b x: c y: d z: a data: (in at: 11) add: 16rBEBFBC70 shift: 23. + a := self step3: a x: b y: c z: d data: (in at: 14) add: 16r289B7EC6 shift: 4. + d := self step3: d x: a y: b z: c data: (in at: 1) add: 16rEAA127FA shift: 11. + c := self step3: c x: d y: a z: b data: (in at: 4) add: 16rD4EF3085 shift: 16. + b := self step3: b x: c y: d z: a data: (in at: 7) add: 16r04881D05 shift: 23. + a := self step3: a x: b y: c z: d data: (in at: 10) add: 16rD9D4D039 shift: 4. + d := self step3: d x: a y: b z: c data: (in at: 13) add: 16rE6DB99E5 shift: 11. + c := self step3: c x: d y: a z: b data: (in at: 16) add: 16r1FA27CF8 shift: 16. + b := self step3: b x: c y: d z: a data: (in at: 3) add: 16rC4AC5665 shift: 23. + + a := self step4: a x: b y: c z: d data: (in at: 1) add: 16rF4292244 shift: 6. + d := self step4: d x: a y: b z: c data: (in at: 8) add: 16r432AFF97 shift: 10. + c := self step4: c x: d y: a z: b data: (in at: 15) add: 16rAB9423A7 shift: 15. + b := self step4: b x: c y: d z: a data: (in at: 6) add: 16rFC93A039 shift: 21. + a := self step4: a x: b y: c z: d data: (in at: 13) add: 16r655B59C3 shift: 6. + d := self step4: d x: a y: b z: c data: (in at: 4) add: 16r8F0CCC92 shift: 10. + c := self step4: c x: d y: a z: b data: (in at: 11) add: 16rFFEFF47D shift: 15. + b := self step4: b x: c y: d z: a data: (in at: 2) add: 16r85845DD1 shift: 21. + a := self step4: a x: b y: c z: d data: (in at: 9) add: 16r6FA87E4F shift: 6. + d := self step4: d x: a y: b z: c data: (in at: 16) add: 16rFE2CE6E0 shift: 10. + c := self step4: c x: d y: a z: b data: (in at: 7) add: 16rA3014314 shift: 15. + b := self step4: b x: c y: d z: a data: (in at: 14) add: 16r4E0811A1 shift: 21. + a := self step4: a x: b y: c z: d data: (in at: 5) add: 16rF7537E82 shift: 6. + d := self step4: d x: a y: b z: c data: (in at: 12) add: 16rBD3AF235 shift: 10. + c := self step4: c x: d y: a z: b data: (in at: 3) add: 16r2AD7D2BB shift: 15. + b := self step4: b x: c y: d z: a data: (in at: 10) add: 16rEB86D391 shift: 21. + + a := (a + (hash at: 1)) bitAnd: 16rFFFFFFFF. hash at: 1 put: a. + b := (b + (hash at: 2)) bitAnd: 16rFFFFFFFF. hash at: 2 put: b. + c := (c + (hash at: 3)) bitAnd: 16rFFFFFFFF. hash at: 3 put: c. + d := (d + (hash at: 4)) bitAnd: 16rFFFFFFFF. hash at: 4 put: d. + + ^hash! Item was added: + ----- Method: WebUtils class>>multipartBoundary (in category 'decoding') ----- + multipartBoundary + "Answer a string to be used as multpart boundary in posts" + + ^'----squeak-', Date today,'-', Time millisecondClockValue, '-webclient-----'.! Item was added: + ----- Method: WebUtils class>>oAuthSign:url:extra:using: (in category 'oauth') ----- + oAuthSign: webRequest url: requestUrl extra: postFields using: params + "Sign the given webRequest using the set of oauth parameters provided" + + | epoch timestamp nonce normalized baseString query signature key header extraKeys baseUrl | + + "Allow providing an oauth_timestamp; HOWEVER this is only useful for + tests etc. For actual API calls the timestamp *must* match real-time closely + or else the request will be rejected". + + timestamp := params at: 'oauth_timestamp' ifAbsent:[ + "Timestamp is relative to Jan. 1st 1970 GMT" + epoch := DateAndTime year: 1970 day: 1 hour: 0 minute: 0 second: 0 + offset: (Duration seconds: 0). + (DateAndTime now asUTC - epoch) asSeconds. + ]. + + "Same for nonces (although nonces can be reused)" + nonce := params at: 'oauth_nonce' ifAbsent:[UUID new hex]. + + "Assemble the required parameters. Start with the (POST) body fields." + normalized := (postFields as: Dictionary) associations asOrderedCollection. + + "If present, extract any (GET) fields from the URL" + (requestUrl copyAfter: $?) ifNotEmpty:[:fields| + self decodeUrlEncodedForm: fields do:[:fkey :fval| normalized add: fkey -> fval]]. + + "Keep the extra argument keys so we can exclude them below" + extraKeys := normalized collect:[:assoc| assoc key] as: Set. + normalized add:('oauth_nonce' -> nonce). + normalized add: ('oauth_timestamp' -> timestamp asString). + + normalized add: (params associationAt: 'oauth_consumer_key'). + normalized add: (params associationAt: 'oauth_signature_method'). + normalized add: (params associationAt: 'oauth_version'). + + (params includesKey: 'oauth_callback') ifTrue:[ + normalized add: (params associationAt: 'oauth_callback'). + ]. + (params includesKey: 'oauth_token') ifTrue:[ + normalized add: (params associationAt: 'oauth_token'). + ]. + (params includesKey: 'oauth_verifier') ifTrue:[ + normalized add: (params associationAt: 'oauth_verifier'). + ]. + + normalized := normalized sort:[:a1 :a2| + a1 key = a2 key + ifTrue:[a1 value <= a2 value] + ifFalse:[a1 key <= a2 key]]. + + query := String streamContents:[:s| + normalized do:[:assoc| + s nextPutAll: assoc key. + s nextPutAll: '='. + s nextPutAll: assoc value encodeForHTTP. + ] separatedBy:[s nextPutAll: '&']. + ]. + + baseUrl := (requestUrl copyUpTo: $?) copyUpTo: $#. + baseString := webRequest method, + '&', baseUrl encodeForHTTP, + '&', query encodeForHTTP. + + key := (params at: 'oauth_consumer_secret'), + '&', (params at: 'oauth_token_secret' ifAbsent:['']). + (params at: 'oauth_signature_method') caseOf: { + ['HMAC-SHA1'] -> [ + signature := (WebUtils hmacSha1: baseString key: key) base64Encoded + ]. + } otherwise:[self error: 'Unsupported signature method']. + + header := String streamContents:[:s| + s nextPutAll: 'OAuth '. + "Even though we need to include the extra args in the computation, + they do NOT go into the OAuth header field." + normalized do:[:assoc| + (extraKeys includes: assoc key) + ifFalse:[ s nextPutAll: assoc key, '="', assoc value encodeForHTTP, '",']]. + s nextPutAll: 'oauth_signature="', signature encodeForHTTP, '"'. + ]. + + webRequest headerAt: 'Authorization' put: header.! Item was added: + ----- Method: WebUtils class>>oAuthSign:url:using: (in category 'oauth') ----- + oAuthSign: webRequest url: requestUrl using: params + "Sign the given webRequest using the set of oauth parameters provided" + + ^self oAuthSign: webRequest url: requestUrl extra: #() using: params! Item was added: + ----- Method: WebUtils class>>parseAuthParams: (in category 'auth utils') ----- + parseAuthParams: authHeader + "Parse the auth header to find authentication parameters" + + | authParams stream key value| + authParams := Dictionary new. + stream := ReadStream on: authHeader. + authParams at: 'method' put: (stream upTo: Character space) asLowercase. + [stream skipSeparators. + stream atEnd] whileFalse:[ + key := stream upTo: $=. + stream skipSeparators. + stream peek = $" + ifTrue:[value := stream next; upTo: $". stream upTo: $,] + ifFalse:[value := stream upToAnyOf: ' ,' asCharacterSet]. + authParams at: key asLowercase put: value. + ]. + ^authParams! Item was added: + ----- Method: WebUtils class>>platformName (in category 'misc') ----- + platformName + "Return the name of the platform we're running on." + + ^Smalltalk getSystemAttribute: 1001! Item was added: + ----- Method: WebUtils class>>proxyExceptionsDo: (in category 'proxy') ----- + proxyExceptionsDo: aBlock + "Evaluate aBlock with all registered proxy exceptions. + Uses the information from HTTPSocket." + + HTTPSocket httpProxyExceptions do: aBlock.! Item was added: + ----- Method: WebUtils class>>proxyServerFor: (in category 'proxy') ----- + proxyServerFor: serverName + "Answer the proxy server to use for the given server:port + Returns the proxy server:port to use or nil if no proxy is required." + + | domain | + domain := serverName copyUpTo: $:. + self proxyExceptionsDo:[:pattern| (pattern match: domain) ifTrue:[^nil]]. + ^self defaultProxyServer ifEmpty:[nil]! Item was added: + ----- Method: WebUtils class>>quote: (in category 'quoting') ----- + quote: aString + "Quote the given string, escaping as necessary any embedded quotes" + + ^'"', (aString copyReplaceAll: '"' with: '\"'), '"' + ! Item was added: + ----- Method: WebUtils class>>readHeadersFrom: (in category 'headers') ----- + readHeadersFrom: aStream + "Parse http headers and answer a collection of key -> value pairs." + + | headers nextLine existing | + headers := OrderedCollection new. + [nextLine := aStream upToAll: String crlf. + nextLine isEmpty] whileFalse:[ + nextLine first isSeparator ifTrue:["Continuation as per HTTP 1.1 spec" + existing := headers last. + existing value: (existing value, String space, nextLine withBlanksTrimmed). + ] ifFalse:["Regular header" + headers add: + (nextLine copyUpTo: $:) asLowercase -> + (nextLine copyAfter: $:) withBlanksTrimmed. + ]. + ]. + ^headers! Item was added: + ----- Method: WebUtils class>>rotate:by: (in category 'md5') ----- + rotate: value by: amount + "Rotate value left by amount" + + | lowMask highMask | + lowMask := (1 bitShift: 32-amount) - 1. + highMask := 16rFFFFFFFF - lowMask. + ^((value bitAnd: lowMask) bitShift: amount) + + ((value bitAnd: highMask) bitShift: amount-32)! Item was added: + ----- Method: WebUtils class>>sha1Hash: (in category 'oauth') ----- + sha1Hash: message + "Compute the SHA1 hash for the given message. Slightly different from + SecureHashAlgorithm to produce fixed-length byte arrays." + + | sha hash | + sha := SecureHashAlgorithm new hashMessage: message. + hash := ByteArray new: 20. + 1 to: 20 do:[:i| hash at: i put: (sha digitAt: 21-i)]. + ^hash + ! Item was added: + ----- Method: WebUtils class>>step1:x:y:z:data:add:shift: (in category 'md5') ----- + step1: w x: x y: y z: z data: data add: add shift: s + "Step 1 in MD5 transformation" + + | f result | + f := z bitXor: (x bitAnd: (y bitXor: z)). + result := w + f + data + add. + result := self rotate: result by: s. + ^result + x bitAnd: 16rFFFFFFFF! Item was added: + ----- Method: WebUtils class>>step2:x:y:z:data:add:shift: (in category 'md5') ----- + step2: w x: x y: y z: z data: data add: add shift: s + "Step 2 in MD5 transformation" + + | f result | + f := y bitXor: (z bitAnd: (x bitXor: y)). + result := w + f + data + add. + result := self rotate: result by: s. + ^result + x bitAnd: 16rFFFFFFFF! Item was added: + ----- Method: WebUtils class>>step3:x:y:z:data:add:shift: (in category 'md5') ----- + step3: w x: x y: y z: z data: data add: add shift: s + "Step 3 in MD5 transformation" + + | f result | + f := (x bitXor: y) bitXor: z. + result := w + f + data + add. + result := self rotate: result by: s. + ^result + x bitAnd: 16rFFFFFFFF! Item was added: + ----- Method: WebUtils class>>step4:x:y:z:data:add:shift: (in category 'md5') ----- + step4: w x: x y: y z: z data: data add: add shift: s + "Step 4 in MD5 transformation" + + | f result | + f := y bitXor: (x bitOr: (z bitXor: 16rFFFFFFFF)). + result := w + f + data + add. + result := self rotate: result by: s. + ^result + x bitAnd: 16rFFFFFFFF! Item was added: + ----- Method: WebUtils class>>unquote: (in category 'quoting') ----- + unquote: aString + "Unquote the given string, unescaping as necessary any embedded quotes" + + (aString beginsWith: '"') ifFalse:[^aString]. + (aString endsWith: '"') ifFalse:[^aString]. + ^(aString copyReplaceAll: '\"' with: '"') allButFirst allButLast! Item was added: + ----- Method: WebUtils class>>urlEncode: (in category 'misc') ----- + urlEncode: urlString + "For backwards compatibility only. Use 'urlString urlEncoded' if you can." + + ^urlString asUrl asString! Item was added: + ----- Method: WebUtils class>>vmVersion (in category 'misc') ----- + vmVersion + "Return a string identifying the interpreter version" + + ^Smalltalk getSystemAttribute: 1004! Item was added: + ----- Method: WebUtils class>>webSocketHandshake:with:with: (in category 'websockets') ----- + webSocketHandshake: key1 with: key2 with: data + "Do the actual WebSocket handshake computation" + + | bytes | + bytes := ByteArray new: 16. + bytes longAt: 1 put: key1 bigEndian: true. + bytes longAt: 5 put: key2 bigEndian: true. + bytes replaceFrom: 9 to: 16 with: data. + ^self md5HashStream: bytes readStream! Item was added: + ----- Method: WebUtils class>>webSocketHash07: (in category 'websockets') ----- + webSocketHash07: key + "Do the actual WebSocket hash computation" + + | uid | + uid := '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'. + ^(ByteArray newFrom: (SecureHashAlgorithm new hashMessage: key, uid)) reversed base64Encoded!

4 4

The Inbox: WebClient-Core-ul.132.mcz
by commits＠source.squeak.org 11 Apr '23

11 Apr '23

Levente Uzonyi uploaded a new version of WebClient-Core to project The Inbox: http://source.squeak.org/inbox/WebClient-Core-ul.132.mcz ==================== Summary ==================== Name: WebClient-Core-ul.132 Author: ul Time: 11 April 2023, 6:05:30.414442 pm UUID: 7d14b070-76e7-47d2-a31d-9a2b283cefc6 Ancestors: WebClient-Core-mt.130 Speed up MD5 computation in WebUtils: - deprecated #md5HashStream: in favor of #md5HashStreamAsBytes:, which does the same, but returns the bytes in the correct order (not reversed). - avoid reading and writing words from and to ByteArrays (buffer) by changing the class of buffer between WordArray and ByteArray as needed. Hopefully endianness will be fine on all platforms (tests will fail if not). - use #readInto:startingAt:count: instead of #nextInto: to read from the stream into the buffer. This avoids a few sends and potential reallocation of the buffer. - do not convert the ByteString to ByteArray in #md5Digest:. ByteArray >> #replaceFrom:to:with:startingAt: can copy from a ByteString into the buffer. Throughput increases by ~6x for 16k inputs. =============== Diff against WebClient-Core-mt.130 =============== Item was added: + SystemOrganization addCategory: #'WebClient-Core'! Item was added: + Exception subclass: #WebAuthRequired + instanceVariableNames: 'client request response authParams message' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebAuthRequired commentStamp: 'ar 2/10/2012 12:39' prior: 0! + Exception signaled when authentication is required.! Item was added: + ----- Method: WebAuthRequired class>>client:request:response: (in category 'instance creation') ----- + client: aWebClient request: aWebRequest response: aWebResponse + "Creates a new exception" + + ^(self new) + client: aWebClient + request: aWebRequest + response: aWebResponse! Item was added: + ----- Method: WebAuthRequired>>client (in category 'accessing') ----- + client + "The client causing the exception" + + ^client! Item was added: + ----- Method: WebAuthRequired>>client:request:response: (in category 'initialize') ----- + client: aWebClient request: aWebRequest response: aWebResponse + "Initializes the exception" + + client := aWebClient. + request := aWebRequest. + response := aWebResponse. + ! Item was added: + ----- Method: WebAuthRequired>>defaultAction (in category 'defaults') ----- + defaultAction + + self resume: false.! Item was added: + ----- Method: WebAuthRequired>>defaultResumeValue (in category 'defaults') ----- + defaultResumeValue + "Resume with false by default" + + ^false! Item was added: + ----- Method: WebAuthRequired>>isProxyAuth (in category 'testing') ----- + isProxyAuth + "Return true if proxy authorization is required" + + ^response code = 407! Item was added: + ----- Method: WebAuthRequired>>isUnauthorized (in category 'testing') ----- + isUnauthorized + "Return true if authorization is required" + + ^response code = 401! Item was added: + ----- Method: WebAuthRequired>>message (in category 'accessing') ----- + message + "Answer a default message for the user to ask for input" + + self isProxyAuth ifTrue:[ + ^'The proxy server at "', client proxyServerName, '" requires authentication.'. + ]. + + ^'The server at "', client serverName, '" requires authentication.'.! Item was added: + ----- Method: WebAuthRequired>>request (in category 'accessing') ----- + request + "The request object causing the exception" + + ^request! Item was added: + ----- Method: WebAuthRequired>>response (in category 'accessing') ----- + response + "The response object causing the exception" + + ^response! Item was added: + ----- Method: WebAuthRequired>>token: (in category 'initialize') ----- + token: aString + "Use the given token as credentials" + + | params | + params := self isProxyAuth ifTrue:[client proxyParams] ifFalse:[client authParams]. + + (params at: #token ifAbsent: [nil]) = aString + ifFalse: + [params at: #token put: aString. + self resume: true] + ! Item was added: + ----- Method: WebAuthRequired>>username:password: (in category 'initialize') ----- + username: username password: password + "Use the given username/password as credentials" + + | params retry | + params := self isProxyAuth ifTrue:[client proxyParams] ifFalse:[client authParams]. + retry := false. + (params at: #username ifAbsent:[nil]) = username ifFalse:[ + params at: #username put: username. + retry := true. + ]. + (params at: #password ifAbsent:[nil]) = password ifFalse:[ + params at: #password put: password. + retry := true. + ]. + retry ifTrue:[self resume: true]. + ! Item was added: + ReadStream subclass: #WebChunkedStream + instanceVariableNames: 'sourceStream chunkSize' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebChunkedStream commentStamp: 'ar 1/31/2012 14:00' prior: 0! + Can process chunked data.! Item was added: + ----- Method: WebChunkedStream>>atEnd (in category 'testing') ----- + atEnd + ^chunkSize = 0 and:[super atEnd]! Item was added: + ----- Method: WebChunkedStream>>next (in category 'accessing') ----- + next + "Answer the next decompressed object in the Stream represented by the + receiver." + + <primitive: 65> + position >= readLimit + ifTrue: [^self pastEndRead] + ifFalse: [^collection at: (position := position + 1)]! Item was added: + ----- Method: WebChunkedStream>>next: (in category 'accessing') ----- + next: anInteger + "Answer the next anInteger elements of my collection. overriden for simplicity" + + [(position + anInteger > readLimit) and:[chunkSize ~= 0]] + whileTrue:[self nextChunk]. + + ^super next: anInteger + ! Item was added: + ----- Method: WebChunkedStream>>nextChunk (in category 'accessing') ----- + nextChunk + "Answer the next chunk from a message using chunked transfer encoding." + + | chunk | + chunkSize = 0 ifTrue:[^'']. "read last chunk" + chunkSize := Integer readFrom: (sourceStream upToAll: String crlf) asString base: 16. + chunkSize = 0 ifFalse:[chunk := sourceStream next: chunkSize]. + sourceStream skip: 2. "CrLf" + (chunkSize + readLimit - position) <= collection size ifTrue:[ + collection replaceFrom: 1 to: (readLimit-position) with: collection startingAt: position+1. + readLimit := readLimit - position. + position := 0. + collection replaceFrom: readLimit+1 to: readLimit + chunkSize with: chunk startingAt: 1. + readLimit := readLimit + chunkSize. + ] ifFalse:[ + position < readLimit + ifTrue: [collection := (collection copyFrom: position + 1 to: readLimit), chunk] + ifFalse: [collection := chunk]. + position := 0. + readLimit := collection size. + ]. + ^chunk + ! Item was added: + ----- Method: WebChunkedStream>>on: (in category 'initialize') ----- + on: aStream + + sourceStream := aStream. + collection := (aStream isBinary ifTrue:[ByteArray] ifFalse:[String]) new. + position := readLimit := 0.! Item was added: + ----- Method: WebChunkedStream>>pastEndRead (in category 'accessing') ----- + pastEndRead + "Need more data" + + self nextChunk. + ^self next! Item was added: + Object subclass: #WebClient + instanceVariableNames: 'flags server scheme timeout stream cookies proxyServer lastScheme lastServer lastPort maxRedirect redirections userAgent authParams proxyParams accessLog debugLog' + classVariableNames: 'DebugLog FlagAcceptCookies FlagAllowAuth FlagAllowRedirect ProxyHandler' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebClient commentStamp: 'ar 5/4/2010 13:17' prior: 0! + WebClient provides a simple yet complete HTTP client implementation. + + To view the documentation evaluate: + + HelpBrowser openOn: WebClientHelp. + ! Item was added: + ----- Method: WebClient class>>debugLog (in category 'accessing') ----- + debugLog + "The default debugLog, if any: + WebClient debugLog: Transcript. + WebClient debugLog: nil. + " + + ^DebugLog! Item was added: + ----- Method: WebClient class>>debugLog: (in category 'accessing') ----- + debugLog: aStream + "The default debugLog, if any: + WebClient debugLog: Transcript. + WebClient debugLog: nil. + " + + DebugLog := aStream.! Item was added: + ----- Method: WebClient class>>htmlSubmit:fields: (in category 'utilities') ----- + htmlSubmit: urlString fields: fieldMap + "A utility method for html submit operations. The fieldMap can be EITHER + an array of associations OR a Dictionary of key value pairs (the former is + useful for providing multiple fields and/or specifying the order of fields). + + WebClient + htmlSubmit: 'http://www.google.com/search' + fields: { + 'hl' -> 'en'. + 'q' -> 'Squeak' + } + " + ^self htmlSubmit: urlString + fields: fieldMap + method: 'GET' + ! Item was added: + ----- Method: WebClient class>>htmlSubmit:fields:method: (in category 'utilities') ----- + htmlSubmit: urlString fields: fieldMap method: method + "A utility method for html submit operations. The fieldMap can be EITHER + an array of associations OR a Dictionary of key value pairs (the former is + useful for providing multiple fields and/or specifying the order of fields). + + WebClient + htmlSubmit: 'http://www.google.com/search' + fields: { + 'hl' -> 'en'. + 'q' -> 'Squeak' + } method: 'GET' + " + ^self htmlSubmit: urlString + fields: fieldMap + method: method + encoding: 'application/x-www-form-urlencoded' + ! Item was added: + ----- Method: WebClient class>>htmlSubmit:fields:method:encoding: (in category 'utilities') ----- + htmlSubmit: urlString fields: fields method: method encoding: encoding + "A utility method for html submit operations. The fieldMap can be EITHER + an array of associations OR a Dictionary of key value pairs (the former is + useful for providing multiple fields and/or specifying the order of fields). + + WebClient + htmlSubmit: 'http://www.google.com/search' + fields: { + 'hl' -> 'en'. + 'q' -> 'Squeak' + } method: 'GET' + encoding: 'application/x-www-form-urlencoded' + " + + method = 'GET' ifTrue:[ + "GET only supports url encoded requests" + encoding = 'application/x-www-form-urlencoded' + ifFalse:[^self error: 'Unsupported encoding: ', encoding]. + ^self httpGet: urlString, '?', (WebUtils encodeUrlEncodedForm: fields). + ]. + + method = 'POST' ifTrue:[ + "Dispatch on encoding type" + encoding caseOf: { + [ 'application/x-www-form-urlencoded'] -> [ + ^self httpPost: urlString + content: (WebUtils encodeUrlEncodedForm: fields) + type: encoding. + ]. + ['multipart/form-data'] -> [ + ^self httpPost: urlString multipartFields: fields + ]. + } otherwise:[] + ]. + + self error: 'Unsupported method: ', method. + ! Item was added: + ----- Method: WebClient class>>httpDelete: (in category 'methods') ----- + httpDelete: urlString + "Sends a DELETE request" + "WebClient httpDelete: 'http://ftp.squeak.org/trunk'" + + ^self httpDo:[:client| client httpDelete: urlString]. + ! Item was added: + ----- Method: WebClient class>>httpDo: (in category 'methods') ----- + httpDo: aBlock + "Simplified wrapper for running various methods" + + | client response | + client := self new. + response := WebUtils handleAuth: [aBlock value: client]. + response content; close. + ^response! Item was added: + ----- Method: WebClient class>>httpGet: (in category 'methods') ----- + httpGet: urlString + "Get the response from the given url" + "(WebClient httpGet: 'http://www.squeak.org') content" + + ^self httpDo:[:client| client httpGet: urlString].! Item was added: + ----- Method: WebClient class>>httpHead: (in category 'methods') ----- + httpHead: urlString + "Sends a HEAD request" + "WebClient httpHead: 'http://ftp.squeak.org/trunk'" + + ^self httpDo:[:client| client httpHead: urlString]. + ! Item was added: + ----- Method: WebClient class>>httpOptions: (in category 'methods') ----- + httpOptions: urlString + "Sends an OPTIONS request" + "WebClient httpOptions: 'http://ftp.squeak.org/*'" + "WebClient httpOptions: 'http://ftp.squeak.org/4.1/Squeak4.1.zip'" + + ^self httpDo:[:client| client httpOptions: urlString] + ! Item was added: + ----- Method: WebClient class>>httpPost:content:type: (in category 'methods') ----- + httpPost: urlString content: postData type: contentType + "Fire off an HTTP post request" + + ^self httpDo:[:client| client httpPost: urlString content: postData type: contentType] + ! Item was added: + ----- Method: WebClient class>>httpPost:multipartFields: (in category 'utilities') ----- + httpPost: url multipartFields: fieldMap + "Make a form submission using multipart/form-data POST. + + The fieldMap may contain MIMEDocument instances to indicate the presence + of a file to upload to the server. If the MIMEDocument is present, its + content type and file name will be used for the upload. + + The fieldMap can be EITHER an array of associations OR a Dictionary of + key value pairs (the former is useful for providing multiple fields and/or + specifying the order of fields)." + + | boundary | + boundary := WebUtils multipartBoundary. + + ^self httpPost: url + content: (WebUtils encodeMultipartForm: fieldMap boundary: boundary) + type: 'multipart/form-data; boundary=', boundary! Item was added: + ----- Method: WebClient class>>httpPostChunked:content:type: (in category 'methods') ----- + httpPostChunked: urlString content: chunkBlock type: contentType + "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." + + ^self httpDo:[:client| + client httpPostChunked: urlString content: chunkBlock type: contentType] + ! Item was added: + ----- Method: WebClient class>>httpPut:content:type: (in category 'methods') ----- + httpPut: urlString content: postData type: contentType + "Fire off an HTTP PUT request" + + ^self httpDo:[:client| client httpPut: urlString content: postData type: contentType]! Item was added: + ----- Method: WebClient class>>httpRequest:url:headers:content:response: (in category 'httpsocket') ----- + httpRequest: method url: urlString headers: hdrs content: contentOrNil response: responseBlock + + "Sends an HTTP request to the server. Returns a MIMEDocument if successful, + a string indicating the error otherwise. If a response block is provided, the + response is fed into into so that the sender can see all the headers." + + | client request response content | + client := self new. + client initializeFromUrl: urlString. + client userAgent: HTTPSocket userAgentString. + + request := client requestWithUrl: urlString. + request method: method. + + "Set up headers for the request" + (WebUtils readHeadersFrom: hdrs readStream) + do:[:hdr| request addHeader: hdr key value: hdr value]. + + WebUtils handleAuth:[ + response := client sendRequest: request + content: (contentOrNil ifNotNil:[contentOrNil readStream]) + size: (contentOrNil ifNil:[0] ifNotNil:[contentOrNil size]). + ]. + + content := response contentWithProgress:[:total :amount| + (HTTPProgress new) total: total; amount: amount; signal: 'Downloading...'. + ]. + client close. + + responseBlock ifNotNil:[responseBlock value: response asString]. + + ^(response isSuccess) + ifTrue:[MIMEDocument contentType: response contentType + content: content url: urlString] + ifFalse:[response asString, content]. + ! Item was added: + ----- Method: WebClient class>>httpTrace: (in category 'methods') ----- + httpTrace: urlString + "Sends a TRACE request" + "(WebClient httpTrace: 'http://lists.squeakfoundation.org') content" + "(WebClient httpTrace: 'http://ftp.squeak.org/trunk') content" + + ^self httpDo:[:client| client httpTrace: urlString]! Item was added: + ----- Method: WebClient class>>initialize (in category 'class initialization') ----- + initialize + "WebClient initialize" + + FlagAcceptCookies := 1. + FlagAllowAuth := 2. + FlagAllowRedirect := 4. + + "Default proxy handler" + ProxyHandler := WebUtils. + + self registerHttpSocketRequestHandler. + ! Item was added: + ----- Method: WebClient class>>proxyHandler (in category 'accessing') ----- + proxyHandler + "The currently registered proxy handler" + + ^ProxyHandler! Item was added: + ----- Method: WebClient class>>proxyHandler: (in category 'accessing') ----- + proxyHandler: anObject + "The currently registered proxy handler" + + ProxyHandler := anObject! Item was added: + ----- Method: WebClient class>>registerHttpSocketRequestHandler (in category 'httpsocket') ----- + registerHttpSocketRequestHandler + "Register WebClient as an HTTPSocket request handler" + + (HTTPSocket respondsTo: #httpRequestHandler:) ifFalse:[^self]. + + "Be polite and only register if no other handler was registered." + HTTPSocket httpRequestHandler == HTTPSocket + ifTrue:[HTTPSocket httpRequestHandler: self]. + ! Item was added: + ----- Method: WebClient class>>requestBenchmark:persistent: (in category 'benchmark') ----- + requestBenchmark: url persistent: aBool + "Run a WebClient benchmark to measure request handling speed. + Try using a persistent connection if requested. + + 1) Launch WebServer (or Seaside, or whatever): + + (WebServer reset default) + listenOn: 8888; + addService: '/' action:[:r| r send200Response: '']. + + 2) Run the benchmark: + + MessageTally spyOn:[ + WebClient requestBenchmark: 'http://localhost:8888/' persistent: true. + ] + " + + | time resp startTime endTime count client | + count := 0. + client := WebClient new. + startTime := Time millisecondClockValue. + [endTime := Time millisecondClockValue. + (time := Time milliseconds: endTime since: startTime) < 5000] whileTrue:[ + resp := client httpGet: url. + resp isSuccess ifFalse:[self error: resp status]. + resp content. + aBool ifFalse:[resp close]. + count := count + 1. + ]. + ^(count * 1000 // time) asStringWithCommas, ' requests/sec' + ! Item was added: + ----- Method: WebClient class>>unload (in category 'class initialization') ----- + unload + "Unregister WebClient as http socket handler when unloaded" + + self unregisterHttpSocketRequestHandler. + ! Item was added: + ----- Method: WebClient class>>unregisterHttpSocketRequestHandler (in category 'httpsocket') ----- + unregisterHttpSocketRequestHandler + "Unregister WebClient as an HTTPSocket request handler" + + (HTTPSocket respondsTo: #httpRequestHandler:) ifFalse:[^self]. + + HTTPSocket httpRequestHandler == self + ifTrue:[HTTPSocket httpRequestHandler: nil]. + ! Item was added: + ----- Method: WebClient class>>webSocket00:protocol: (in category 'websockets') ----- + webSocket00: serverUrl protocol: protocol + "Attempt to connect to the given server url using the WebSocket api" + + | key1 key2 bytes hash client req resp | + "Fixed keys from spec" + key1 := 155712099. + key2 := 173347027. + bytes := ByteArray new: 8. + (1 to: bytes size) do:[:i| bytes at: i put: (256 atRandom - 1)]. + hash := WebUtils webSocketHandshake: key1 with: key2 with: bytes. + + client := self new. + client initializeFromUrl: serverUrl. + req := client requestWithUrl: serverUrl. + req method: 'GET'. + req headerAt: 'Upgrade' put: 'WebSocket'. + req headerAt: 'Connection' put: 'Upgrade'. + req headerAt: 'Origin' put: 'null'. + protocol ifNotNil:[req headerAt: 'Sec-WebSocket-Protocol' put: protocol]. + req headerAt: 'Sec-WebSocket-Key1' put: '18x 6]8vM;54 *(5: { U1]8 z [ 8'. + req headerAt: 'Sec-WebSocket-Key2' put: '1_ tx7X d < nw 334J702) 7]o}` 0'. + resp := client sendRequest: req content: bytes readStream size: bytes size. + resp code = 101 ifFalse:[client close. ^nil]. + (resp stream next: 16) asByteArray = hash ifFalse:[client close. ^nil]. + + "Close of stream is left to caller" + ^WebSocket00 on: resp stream. + ! Item was added: + ----- Method: WebClient class>>webSocket07:protocol: (in category 'websockets') ----- + webSocket07: serverUrl protocol: protocol + "Attempt to connect to the given server url using the WebSocket api" + "http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07" + + | hash client req resp nonce | + nonce := ByteArray new: 16. + (1 to: nonce size) collect:[:i| nonce at: i put: (256 atRandom - 1)]. + nonce := nonce base64Encoded. + + client := self new. + client initializeFromUrl: serverUrl. + req := client requestWithUrl: serverUrl. + req method: 'GET'. + req headerAt: 'Upgrade' put: 'WebSocket'. + req headerAt: 'Connection' put: 'Upgrade'. + req headerAt: 'Sec-WebSocket-Origin' put: 'null'. + protocol ifNotNil:[req headerAt: 'Sec-WebSocket-Protocol' put: protocol]. + req headerAt: 'Sec-WebSocket-Key' put: nonce. + req headerAt: 'Sec-WebSocket-Version' put: '7'. + + resp := client sendRequest: req. + resp code = 101 ifFalse:[client close. ^nil]. + + "Verify WebSocket hash" + hash := WebUtils webSocketHash07: nonce. + hash = (resp headerAt: 'Sec-WebSocket-Accept') ifFalse:[client close. ^nil]. + + "Close of stream is left to caller" + ^WebSocket07 on: resp stream. + ! Item was added: + ----- Method: WebClient class>>webSocket68:protocol: (in category 'websockets') ----- + webSocket68: serverUrl protocol: protocol + "Attempt to connect to the given server url using the WebSocket api" + + | client req resp | + client := self new. + client initializeFromUrl: serverUrl. + req := client requestWithUrl: serverUrl. + req method: 'GET'. + req headerAt: 'Upgrade' put: 'WebSocket'. + req headerAt: 'Connection' put: 'Upgrade'. + req headerAt: 'Origin' put: 'null'. + protocol ifNotNil:[req headerAt: 'WebSocket-Protocol' put: protocol]. + resp := client sendRequest: req. + resp code = 101 ifFalse:[client close. ^nil]. + + "Close of stream is left to caller" + ^WebSocket00 on: resp stream. + ! Item was added: + ----- Method: WebClient class>>webSocketTo: (in category 'websockets') ----- + webSocketTo: serverUrl + "Attempt to connect to the given server url using the WebSocket api" + + "Testing: + + 1) Launch WebSocket example. + 2) Run the following code: + + | ws | + ws := WebClient webSocketTo: 'http://localhost:8080/broadcast'. + ws onMessage:[:data| Transcript cr; show: data]. + ws fork. + ws send: 'This is the first message'. + ws send: 'This is the last message'. + ws close. + + " + + ^self webSocketTo: serverUrl protocol: nil! Item was added: + ----- Method: WebClient class>>webSocketTo:protocol: (in category 'websockets') ----- + webSocketTo: serverUrl protocol: protocol + "Attempt to connect to the given server url using the WebSocket api" + + ^self webSocket00: serverUrl protocol: protocol! Item was added: + ----- Method: WebClient>>acceptCookie:host:path: (in category 'cookies') ----- + acceptCookie: aCookie host: reqHost path: path + "Accept a cookie from a prior response" + + self acceptCookies ifTrue:[ + "Set the defaults per RFC 2109 section 4.3.1 " + + "Ensure the cookie domain is set" + aCookie domain ifNil:[aCookie domain: reqHost]. + + "Ensure the cookie path is set" + aCookie path ifNil:[aCookie path: path]. + + "Reject the cookie per RFC 2109 section 4.3.2" + (path beginsWith: aCookie path) ifFalse:[^false]. + + aCookie domain = reqHost ifFalse:[ | domain | + domain := aCookie domain. + "For misconfigured servers, insert the leading dot into the domain" + domain first = $. ifFalse:[aCookie domain: (domain := '.', domain)]. + ((domain count:[:ch| ch = $.]) >= 2) ifFalse:[^false]. + (reqHost endsWith: domain) ifFalse:[^false]. + ((reqHost allButLast: domain size) includes: $.) ifTrue:[^false]. + ]. + + "Remove any old cookies" + cookies := cookies reject:[:any| any = aCookie]. + + "Remember the cookie if not expired" + (aCookie expiry == nil or:[aCookie expiry > DateAndTime now]) ifTrue:[ + cookies add: aCookie. + ^true + ]. + ]. + ^false! Item was added: + ----- Method: WebClient>>acceptCookies (in category 'cookies') ----- + acceptCookies + "Whether we should accept cookies" + + ^flags anyMask: FlagAcceptCookies! Item was added: + ----- Method: WebClient>>acceptCookies: (in category 'cookies') ----- + acceptCookies: aBool + "Whether we should accept cookies" + + flags := aBool ifTrue:[flags bitOr: FlagAcceptCookies] ifFalse:[flags bitClear: FlagAcceptCookies]. + ! Item was added: + ----- Method: WebClient>>accessLog (in category 'accessing') ----- + accessLog + "The standard access log. Can be either a stream or a string; if the access log + is a string then the string is assumed to be a file name and the file will be opened + and closed for each request." + + ^accessLog! Item was added: + ----- Method: WebClient>>accessLog: (in category 'accessing') ----- + accessLog: aStreamOrFilename + "The standard access log. Can be either a stream or a string; if the access log + is a string then the string is assumed to be a file name and the file will be opened + and closed for each request." + + accessLog := aStreamOrFilename! Item was added: + ----- Method: WebClient>>allowAuth (in category 'accessing') ----- + allowAuth + "If true, WebClient will attempt to handle authorization requests" + + ^flags anyMask: FlagAllowAuth! Item was added: + ----- Method: WebClient>>allowAuth: (in category 'accessing') ----- + allowAuth: aBool + "If true, WebClient will attempt to handle authorization requests" + + flags := aBool ifTrue:[flags bitOr: FlagAllowAuth] ifFalse:[flags bitClear: FlagAllowAuth]. + ! Item was added: + ----- Method: WebClient>>allowRedirect (in category 'accessing') ----- + allowRedirect + "If true, WebClient will attempt to handle redirect responses" + + ^flags anyMask: FlagAllowRedirect! Item was added: + ----- Method: WebClient>>allowRedirect: (in category 'accessing') ----- + allowRedirect: aBool + "If true, WebClient will attempt to handle redirect responses" + + flags := aBool ifTrue:[flags bitOr: FlagAllowRedirect] ifFalse:[flags bitClear: FlagAllowRedirect]. + ! Item was added: + ----- Method: WebClient>>authDispatch:from:header:params: (in category 'authentication') ----- + authDispatch: request from: response header: authHeader params: params + "Dispatch on an authentication method. + Subclasses can extend this method to support more auth methods." + + (authHeader copyUpTo: Character space) caseOf: { + ['Basic'] -> [self basicAuth: request from: response + header: authHeader params: params]. + ['Digest'] -> [self digestAuth: request from: response + header: authHeader params: params]. + ['Bearer'] -> [self bearerAuth: request from: response + header: authHeader params: params]. + } otherwise:["ignore"]. + ! Item was added: + ----- Method: WebClient>>authParams (in category 'accessing') ----- + authParams + "The authentication parameters" + + ^authParams! Item was added: + ----- Method: WebClient>>authParams: (in category 'accessing') ----- + authParams: aDictionary + "The authentication parameters" + + authParams := aDictionary! Item was added: + ----- Method: WebClient>>authenticate:from: (in category 'sending') ----- + authenticate: request from: response + "Authenticate after having received a 401/407 response. + Returns true if we should retry, false if we fail here." + + "NOTE: The first time through we do NOT ask for credentials right away. + Some authentication mechanisms (NTLM/Negotiate) can use the credentials + of the currently logged on user. Consequently we only ask for credentials + if we're unable to do so without asking. Methods that require credentials + (basic, digest) test for their existence explicitly." + + | headers authHeader params | + + "Pick the right set of parameters" + response code = 401 ifTrue:[ + params := authParams. + headers := response headersAt: 'WWW-Authenticate'. + "If the connection was closed, we need to flush the + proxy params or we won't pick up prior credentials." + self isConnected + ifFalse:[self flushAuthState: proxyParams]. + ] ifFalse:[ + params := proxyParams. + headers := response headersAt: 'Proxy-Authenticate'. + ]. + + "Remove any old response" + params removeKey: #authResponse ifAbsent:[]. + + "Process the authentication header(s)" + 1 to: headers size do:[:i| + authHeader := headers at: i. + self authDispatch: request from: response header: authHeader params: params. + "If we generated an authentication response for the header use it" + params at: #authResponse ifPresent:[:resp| + request headerAt: (response code = 401 + ifTrue:['Authorization'] + ifFalse:['Proxy-Authorization']) + put: (params at: #authMethod), ' ', resp. + ^true]. + ]. + + "If we fall through here this can have two reasons: One is that we don't have + a suitable authentication method. Check for that first." + params at: #authMethod ifAbsent:[^false]. + + "The other possibility is that the credentials are wrong. + Clean out the previous auth state and go ask for credentials." + self flushAuthState: params. + + "Clean out old authentication headers" + response code = 401 + ifTrue:[request removeHeader: 'Authorization']. + "Always clean out the proxy auth header since we don't support pre-authentication" + request removeHeader: 'Proxy-Authorization'. + + "Signal WebAuthRequired" + (WebAuthRequired client: self request: request response: response) + signal == true ifFalse:[^false]. + + "And retry with the new credentials" + ^self authenticate: request from: response! Item was added: + ----- Method: WebClient>>basicAuth:from:header:params: (in category 'authentication') ----- + basicAuth: request from: response header: header params: params + "Provide basic authentication for the request" + + | user pass args | + authParams at: #authMethod ifPresent:[:method| ^self]. "do not retry repeatedly" + authParams at: #authMethod put: 'Basic'. + + args := WebUtils parseAuthParams: header. + args at: 'realm' ifPresent:[:realm| authParams at: #authRealm put: realm]. + + user := (params at: #username ifAbsent:[nil]) ifNil:[^self]. + pass := (params at: #password ifAbsent:[nil]) ifNil:[^self]. + authParams at: #authResponse put: (user, ':', pass value) base64Encoded. + ! Item was added: + ----- Method: WebClient>>bearerAuth:from:header:params: (in category 'authentication') ----- + bearerAuth: request from: response header: header params: params + "Provide token-based OAuth2 authentication for the request" + + | token args | + authParams at: #authMethod ifPresent:[:method| ^self]. "do not retry repeatedly" + authParams at: #authMethod put: 'Bearer'. + + args := WebUtils parseAuthParams: header. + args at: 'realm' ifPresent:[:realm| authParams at: #authRealm put: realm]. + + token := (params at: #token ifAbsent:[nil]) ifNil:[^self]. + authParams at: #authResponse put: token. + ! Item was added: + ----- Method: WebClient>>canVerify (in category 'testing') ----- + canVerify + + ^ (stream respondsTo: #canVerify) + ifTrue: [stream canVerify] + ifFalse: [WebUtils platformName ~= 'Mac OS']! Item was added: + ----- Method: WebClient>>close (in category 'initialize') ----- + close + "Close the client's stream" + + stream ifNotNil:[ + stream isConnected ifTrue: [stream close]. + stream := nil]. + ! Item was added: + ----- Method: WebClient>>connect (in category 'initialize') ----- + connect + "Connect the client to a web server. Returns nil if successful, + a WebResponse if a proxy CONNECT request fails." + + | actualServer actualPort | + + "Determine which server to connect to (proxy or real)" + proxyServer ifNil:[ + actualServer := self serverName. + actualPort := self serverPort. + ] ifNotNil:[ + actualServer := self proxyServerName. + actualPort := self proxyServerPort. + ]. + + "Check if we can use the same stream or if we need to reconnect" + (stream notNil + and:[stream isConnected + and:[lastServer = actualServer + and:[lastPort = actualPort + and:[lastScheme = scheme]]]]) ifTrue:[^nil]. + + self close. + lastServer := actualServer. + lastPort := actualPort. + lastScheme := scheme. + stream := SocketStream openConnectionToHostNamed: lastServer port: lastPort. + stream timeout: timeout. + "Perform ssl initialization if necessary" + scheme = 'https' ifTrue:[^self sslConnect]. + ^nil! Item was added: + ----- Method: WebClient>>contentDecoders (in category 'initialize') ----- + contentDecoders + + | result | + result := nil. + (self class environment hasBindingOf: #GZipReadStream) + ifTrue: [result := 'gzip']. + (self class environment hasBindingOf: #BrotliReadStream) + ifTrue: [ result := result ifNil: ['br'] ifNotNil: [:r | r, ', br']]. + ^ result! Item was added: + ----- Method: WebClient>>cookies (in category 'accessing') ----- + cookies + "The cookies that have been set for this session" + + ^cookies! Item was added: + ----- Method: WebClient>>cookies: (in category 'accessing') ----- + cookies: aCollection + "The cookies that have been set for this session" + + cookies := aCollection.! Item was added: + ----- Method: WebClient>>debugLog (in category 'accessing') ----- + debugLog + "If provided, WebClient will print all requests and responses to the debugLog, + except from the content of the message. The debug log must be a stream of + some sort; file names (like for the accessLog are not supported)." + + ^debugLog! Item was added: + ----- Method: WebClient>>debugLog: (in category 'accessing') ----- + debugLog: aStream + "If provided, WebClient will print all requests and responses to the debugLog, + except from the content of the message. The debug log must be a stream of + some sort; file names (like for the accessLog are not supported)." + + debugLog := aStream! Item was added: + ----- Method: WebClient>>defaultPort (in category 'initialize') ----- + defaultPort + "Return the default port to use if no port was specified. + Since we only support https and http, default to port 80 unless https." + + ^scheme = 'https' + ifTrue:[443] + ifFalse:[80]! Item was added: + ----- Method: WebClient>>defaultUserAgent (in category 'initialize') ----- + defaultUserAgent + "Answer the default User-Agent string to use for WebClient" + + ^'WebClient/1.5 (', + WebUtils mcVersion, '; ', + SystemVersion current version,'-', + SystemVersion current highestUpdate printString, '; ', + WebUtils platformName,')'. + ! Item was added: + ----- Method: WebClient>>destroy (in category 'initialize') ----- + destroy + "Destroys the client" + + stream ifNotNil:[ + stream destroy. + stream := nil. + ]. + ! Item was added: + ----- Method: WebClient>>detectProxyServer (in category 'initialize') ----- + detectProxyServer + "Automatically detect the proxy server to use" + + proxyServer := ProxyHandler proxyServerFor: self server. + ! Item was added: + ----- Method: WebClient>>digestAuth:from:header:params: (in category 'authentication') ----- + digestAuth: request from: response header: authHeader params: params + "Perform digest authentication" + + | realm nonce ha1 ha2 nc cnonce qop header uri md5 key args user pass | + params at: #authMethod ifPresent:[:method| ^self]. "do not retry repeatedly" + params at: #authMethod put: 'Digest'. + + args := WebUtils parseAuthParams: authHeader. + realm := args at: 'realm'. + authParams at: #authRealm put: realm. + + user := (params at: #username ifAbsent:[nil]) ifNil:[^self]. + pass := (params at: #password ifAbsent:[nil]) ifNil:[^self]. + + nonce := args at: 'nonce'. + uri := request rawUrl. + + "VERY IMPORTANT NOTE: Some servers fail horribly if the nonce count + isn't precisely eight digits and without quotes." + nc := args at: 'nc' put: (args at: 'nc' ifAbsent:[0]) + 1. + nc := nc asString padded: #left to: 8 with: $0. + + key := user, ':', realm, ':', pass value. + ha1 := WebUtils md5Digest: key. + ha2 := WebUtils md5Digest: request method, ':', uri. + cnonce := UUID new hex. + + (args includesKey: 'qop') ifTrue:["use qop" + qop := 'auth'. "the only qop we support" + md5 := WebUtils md5Digest: ha1, ':', nonce, ':', nc, ':', cnonce, ':', qop, ':', ha2. + header := + 'username="', user, '"', + ', realm="', realm, '"', + ', nonce="', nonce, '"', + ', uri="', uri, '"', + ', response="', md5, '"', + ', qop="', qop,'"', + ', nc="', nc, '"', + ', cnonce="', cnonce, '"'. + ] ifFalse:["ignore qop" + md5 := WebUtils md5Digest: ha1, ':', nonce, ':', ha2. + header := + 'username="', user, '"', + ', realm="', realm, '"', + ', nonce="', nonce, '"', + ', uri="', uri, '"', + ', response="', md5, '"'. + ]. + args at: 'opaque' ifPresent: [:opaque | + header := header, ', opaque="', opaque, '"' + ]. + params at: #authResponse put: header.! Item was added: + ----- Method: WebClient>>flushAuthState (in category 'initialize') ----- + flushAuthState + "Flush all the auth state" + + self flushAuthState: authParams. + self flushAuthState: proxyParams.! Item was added: + ----- Method: WebClient>>flushAuthState: (in category 'authentication') ----- + flushAuthState: params + "Fliush authentication state that should not been preserved + inbetween failed attempts to authenticate. + Subclasses can extend this method to support more auth methods." + + params removeKey: #authMethod ifAbsent:[]. + ! Item was added: + ----- Method: WebClient>>httpDelete: (in category 'methods') ----- + httpDelete: urlString + "Sends an DELETE request" + + ^self httpDelete: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpDelete:do: (in category 'methods') ----- + httpDelete: urlString do: aBlock + "Sends a DELETE request" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'DELETE'. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request.! Item was added: + ----- Method: WebClient>>httpGet: (in category 'methods') ----- + httpGet: urlString + "GET the response from the given url" + "(WebClient httpGet: 'http://www.squeak.org') content" + + ^self httpGet: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpGet:do: (in category 'methods') ----- + httpGet: urlString do: aBlock + "GET the response from the given url" + "(WebClient httpGet: 'http://www.squeak.org') content" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'GET'. + userAgent ifNotNil:[:ua | request headerAt: 'User-Agent' put: ua]. + self contentDecoders ifNotNil: [:decoders | request headerAt: 'Accept-Encoding' put: decoders]. + aBlock value: request. + ^self sendRequest: request + ! Item was added: + ----- Method: WebClient>>httpHead: (in category 'methods') ----- + httpHead: urlString + "Sends a HEAD request" + + ^self httpHead: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpHead:do: (in category 'methods') ----- + httpHead: urlString do: aBlock + "Sends a HEAD request" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'HEAD'. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request.! Item was added: + ----- Method: WebClient>>httpOptions: (in category 'methods') ----- + httpOptions: urlString + "Sends an OPTIONS request" + + ^self httpOptions: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpOptions:do: (in category 'methods') ----- + httpOptions: urlString do: aBlock + "Sends an OPTIONS request" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'OPTIONS'. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request + ! Item was added: + ----- Method: WebClient>>httpPost:content:type: (in category 'methods') ----- + httpPost: urlString content: postData type: contentType + "POST the data to the given url" + + ^self httpPost: urlString content: postData type: contentType do:[:req|]! Item was added: + ----- 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. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request content: postData readStream size: postData size! Item was added: + ----- Method: WebClient>>httpPostChunked:content:type: (in category 'methods') ----- + httpPostChunked: urlString content: chunkBlock type: contentType + "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." + + ^self httpPostChunked: urlString content: chunkBlock type: contentType do: [:req|]! Item was added: + ----- 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]. + 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 added: + ----- Method: WebClient>>httpPut:content:type: (in category 'methods') ----- + httpPut: urlString content: postData type: contentType + "PUT the data to the given url" + + ^self httpPut: urlString content: postData type: contentType do:[:req|]! Item was added: + ----- 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. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request content: postData readStream size: postData size! Item was added: + ----- Method: WebClient>>httpTrace: (in category 'methods') ----- + httpTrace: urlString + "Sends a TRACE request" + + ^self httpTrace: urlString do:[:req|] + ! Item was added: + ----- Method: WebClient>>httpTrace:do: (in category 'methods') ----- + httpTrace: urlString do: aBlock + "Sends a TRACE request" + + | request | + self initializeFromUrl: urlString. + request := self requestWithUrl: urlString. + request method: 'TRACE'. + userAgent ifNotNil:[request headerAt: 'User-Agent' put: userAgent]. + aBlock value: request. + ^self sendRequest: request + ! Item was added: + ----- Method: WebClient>>initialize (in category 'initialize') ----- + initialize + "Initializes the receiver" + flags := 0. + super initialize. + + self allowAuth: true. + self allowRedirect: true. + self acceptCookies: true. + + timeout := Socket standardTimeout. + cookies := OrderedCollection new. + redirections := Dictionary new. + maxRedirect := 10. + userAgent := self defaultUserAgent. + authParams := IdentityDictionary new. + proxyParams := IdentityDictionary new. + + "Use the default debug log" + debugLog := DebugLog. + ! Item was added: + ----- Method: WebClient>>initializeFromUrl: (in category 'initialize') ----- + initializeFromUrl: urlString + "Initialize the client from a url string" + + | urlStream serverAndPort userAndPass | + urlStream := urlString readStream. + scheme := (urlStream upToAll: '://') asLowercase. + (scheme = 'http' or:[scheme = 'https']) + ifFalse:[self error: 'Unsupported scheme: ', scheme]. + serverAndPort := urlStream upTo: $/. + + userAndPass := serverAndPort copyUpTo: $@. + userAndPass = serverAndPort ifFalse:[ + serverAndPort := serverAndPort copyAfter: $@. + self username: (userAndPass copyUpTo: $:). + self password: (userAndPass copyAfter: $:). + ]. + + self server: serverAndPort. + self detectProxyServer.! Item was added: + ----- Method: WebClient>>isConnected (in category 'testing') ----- + isConnected + "Returns true if the client is still connected" + + ^stream notNil and:[stream isConnected]! Item was added: + ----- Method: WebClient>>maxRedirect (in category 'accessing') ----- + maxRedirect + "The max. number of redirects we allow for the SAME SITE before giving up. + Redirects can happen for any number of reasons between any number of sites + and we give up if we have seen the SAME SITE maxRedirect number of times." + + ^maxRedirect! Item was added: + ----- Method: WebClient>>maxRedirect: (in category 'accessing') ----- + maxRedirect: aNumber + "The max. number of redirects we allow for the SAME SITE before giving up. + Redirects can happen for any number of reasons between any number of sites + and we give up if we have seen the SAME SITE maxRedirect number of times." + + maxRedirect := aNumber! Item was added: + ----- Method: WebClient>>newRequest (in category 'initialize') ----- + newRequest + "Create an return a new WebRequest. + Subclasses can use this method to override the default request class." + + ^WebRequest new! Item was added: + ----- Method: WebClient>>password (in category 'accessing') ----- + password + "The password for remote authentication. + The password should generally not be a plain-text + version but rather a block that can retrieve the password + when required." + + ^authParams at: #password ifAbsent:[nil]! Item was added: + ----- Method: WebClient>>password: (in category 'accessing') ----- + password: aStringOrValuable + "The password for remote authentication. + The password should generally not be a plain-text + version but rather a block that can retrieve the password + when required." + + ^authParams at: #password put: aStringOrValuable! Item was added: + ----- Method: WebClient>>printOn: (in category 'printing') ----- + printOn: aStream + "Print the receiver on aStream" + + aStream nextPutAll: self class name. + aStream nextPut: $(. + (stream notNil and:[stream isConnected]) ifTrue:[ + aStream nextPutAll: 'Connected: '. + ]. + scheme ifNotNil:[aStream nextPutAll: scheme, '://']. + server ifNotNil:[aStream nextPutAll: server]. + aStream nextPut:$). + ! Item was added: + ----- Method: WebClient>>proxyConnect (in category 'initialize') ----- + proxyConnect + "Send a proxy CONNECT request to connect to a remote host via the chosen proxy server" + + | uri request repeatAuth response | + uri := self serverUrlName,':', self serverPort. + request := self newRequest. + request method: 'CONNECT'. + request rawUrl: uri. + + [repeatAuth := false. + + "The proxy response may use Connection: Close; reconnect when that happens" + self isConnected ifFalse:[ + stream := SocketStream openConnectionToHostNamed: lastServer port: lastPort. + stream timeout: timeout. + ]. + + debugLog ifNotNil:[ + request writeOn: debugLog. + debugLog flush. + ]. + + "Don't use 'self writeRequestOn:' since this will insert both cookies + as well as modify the url target when a proxy is present" + request writeOn: stream. + stream flush. + + response := request newResponse readFrom: stream. + + debugLog ifNotNil:[ + response writeOn: debugLog. + debugLog flush. + ]. + + "Handle authentication if needed" + (self allowAuth and:[response code = 407]) ifTrue:[ + "Eat up the content of the previous response" + response content. + repeatAuth := self authenticate: request from: response. + ]. + repeatAuth] whileTrue. + + ^response! Item was added: + ----- Method: WebClient>>proxyParams (in category 'proxy') ----- + proxyParams + "The proxy authentication parameters" + + ^proxyParams! Item was added: + ----- Method: WebClient>>proxyParams: (in category 'proxy') ----- + proxyParams: aDictionary + "The proxy authentication parameters" + + proxyParams := aDictionary! Item was added: + ----- Method: WebClient>>proxyPass (in category 'proxy') ----- + proxyPass + "The password for an authenticating proxy. + The password should generally not be a plain-text + version but rather a block that can retrieve the password + when required." + + ^proxyParams at: #password! Item was added: + ----- Method: WebClient>>proxyPass: (in category 'proxy') ----- + proxyPass: aStringOrValuable + "The password for an authenticating proxy. + The password should generally not be a plain-text + version but rather a block that can retrieve the password + when required." + + proxyParams at: #password put: aStringOrValuable! Item was added: + ----- Method: WebClient>>proxyServer (in category 'proxy') ----- + proxyServer + "The proxy server to use for connections. + The server should be specified as server:port if the proxy + port to be used is different from the desitation port." + + ^proxyServer! Item was added: + ----- Method: WebClient>>proxyServer: (in category 'proxy') ----- + proxyServer: aString + "The proxy server to use for connections. + The server should be specified as server:port if the proxy + port to be used is different from the desitation port." + + proxyServer := aString! Item was added: + ----- Method: WebClient>>proxyServerName (in category 'proxy') ----- + proxyServerName + "Returns the name part of the server:port description" + + ^proxyServer copyUpTo: $:! Item was added: + ----- Method: WebClient>>proxyServerPort (in category 'proxy') ----- + proxyServerPort + "Returns the port of the proxyServer:port description" + + ^(proxyServer copyAfter: $:) + ifEmpty:[self serverPort] + ifNotEmpty:[:portString| portString asInteger]. + ! Item was added: + ----- Method: WebClient>>proxyUser (in category 'proxy') ----- + proxyUser + "The user name for an authenticating proxy" + + ^proxyParams at: #username ifAbsent:[nil]! Item was added: + ----- Method: WebClient>>proxyUser: (in category 'proxy') ----- + proxyUser: aString + "The user name for an authenticating proxy" + + proxyParams at: #username put: aString! Item was added: + ----- Method: WebClient>>redirect:from: (in category 'sending') ----- + redirect: request from: response + "Handle a 3xx redirect response" + + | location max | + + "Check if we handle the specific type of redirect here" + (#( 301 + 302 "Found" + 303 "See Other" + 307 "Temporary Redirect") + includes: response code) ifFalse:[^false]. + + "RFC 2616 states that requests other than HEAD and GET MUST NOT be auto + redirected for 302 and 307 responses" + (request method = 'GET' or:[request method = 'HEAD']) ifFalse:[ + (response code = 302 or:[response code = 307]) ifTrue:[^false]. + ]. + + "Find the new location" + location := response headerAt: 'location'. + + "Check if we've exceeded max redirections" + max := redirections at: location ifAbsent:[0]. + max > self maxRedirect ifTrue:[^false]. + redirections at: location put: max+1. + + "Do the actual redirect, i.e., set us up for the new url" + (location findString: '://') > 0 "do we have a scheme:// url?" + ifTrue:[self initializeFromUrl: location]. + + request initializeFromUrl: location. + + ^true! Item was added: + ----- Method: WebClient>>requestWithUrl: (in category 'initialize') ----- + requestWithUrl: urlString + "Create and return a new WebRequest initialized with the given url." + + ^self newRequest initializeFromUrl: urlString! Item was added: + ----- Method: WebClient>>scheme (in category 'accessing') ----- + scheme + "The scheme used for the request (usually http or https)" + + ^scheme! Item was added: + ----- Method: WebClient>>scheme: (in category 'accessing') ----- + scheme: aString + "The scheme used for the request (usually http or https)" + + scheme := aString! Item was added: + ----- Method: WebClient>>sendRequest: (in category 'sending') ----- + sendRequest: request + "Send an http request" + + ^self sendRequest: request content: nil size: 0! Item was added: + ----- Method: WebClient>>sendRequest:content:size: (in category 'sending') ----- + sendRequest: request content: contentStream size: streamSize + "Send an http request" + + ^self sendRequest: request contentBlock:[:aStream| + contentStream ifNotNil:[ + "Upload content if provided" + contentStream position: 0. + request streamFrom: contentStream to: aStream size: streamSize + progress:[:total :amount| + (HTTPProgress new) + total: total; + amount: amount; + signal: 'Uploading...']]]. + ! Item was added: + ----- Method: WebClient>>sendRequest:contentBlock: (in category 'sending') ----- + sendRequest: request contentBlock: contentBlock + "Send an http request" + + | response repeatRedirect repeatAuth | + + "XXXX: Fixme. Pre-authenticate the request if we have valid auth credentials" + + redirections := Dictionary new. + + ["The outer loop handles redirections" + repeatRedirect := false. + + "Always update the host header due to redirect" + request headerAt: 'Host' put: server. + + ["The inner loop handles authentication" + repeatAuth := false. + + "Connect can fail if SSL proxy CONNECT is involved" + self connect ifNotNil:[:resp| ^resp]. + + "Write the request to the debugLog if present" + debugLog ifNotNil:[self writeRequest: request on: debugLog]. + + "Send the request itself" + self writeRequest: request on: stream. + contentBlock value: stream. + + response := request newResponse readFrom: stream. + response url: (scheme, '://', server, request rawUrl). + + debugLog ifNotNil:[ + response writeOn: debugLog. + debugLog flush. + ]. + response setCookiesDo:[:cookie| + self acceptCookie: cookie host: self serverUrlName path: request url. + ]. + accessLog ifNotNil:[ + WebUtils logRequest: request response: response on: accessLog + ]. + "Handle authentication if needed" + (self allowAuth and:[response code = 401 or:[response code = 407]]) ifTrue:[ + "Eat up the content of the previous response" + response content. + repeatAuth := self authenticate: request from: response. + ]. + + repeatAuth] whileTrue. + + "Flush previous authState. + XXXX: Fixme. authState must be preserved for pre-authentication of requests." + self flushAuthState. + + "Handle redirect if needed" + (self allowRedirect and:[response isRedirect]) ifTrue:[ + "Eat up the content of the previous response" + response content. + repeatRedirect := self redirect: request from: response. + ]. + repeatRedirect] whileTrue:[ + "When redirecting, remove authentication headers" + request removeHeader: 'Authorization'. + request removeHeader: 'Proxy-Authorization'. + ]. + + "If the response is not a success, eat up its content" + (response isSuccess or:[response isInformational]) ifFalse:[response content]. + + ^response! Item was added: + ----- Method: WebClient>>server (in category 'accessing') ----- + server + "The server to use for connections. + The server is specified as server:port if needed" + + ^server! Item was added: + ----- Method: WebClient>>server: (in category 'accessing') ----- + server: aString + "The server to use for connections. + The server should be specified as server:port if needed" + + server := aString + ! Item was added: + ----- Method: WebClient>>serverName (in category 'accessing') ----- + serverName + "Returns the name part of the server:port description" + + | serverUrlName | + serverUrlName := self serverUrlName. + ^ (serverUrlName includes: $[) + ifTrue: [serverUrlName copyFrom: 2 to: serverUrlName size - 1] + ifFalse: [serverUrlName]! Item was added: + ----- Method: WebClient>>serverPort (in category 'accessing') ----- + serverPort + "Returns the port of the server:port description" + + (self server copyAfterLast: $:) + ifNotEmpty:[:portString| + portString isAllDigits + ifTrue: [^ portString asInteger]]. + ^ self defaultPort! Item was added: + ----- Method: WebClient>>serverUrlName (in category 'accessing') ----- + serverUrlName + "Returns the name part of the server:port description in the way it would appear in an Url" + + ^ (self server includes: $[) + ifTrue: [self server copyUpThrough: $] ] + ifFalse: [self server copyUpToLast: $:]! Item was added: + ----- Method: WebClient>>sslConnect (in category 'initialize') ----- + sslConnect + "Do the SSL handshake" + "Connect the client to a web server" + + | sqSSL | + proxyServer ifNotNil:[ | resp | + "If we have a proxy server, do the proxy connect" + resp := self proxyConnect. + resp isSuccess ifFalse:[^resp]. + ]. + + sqSSL := Smalltalk at: #SqueakSSL ifAbsent:[self error: 'SqueakSSL is missing']. + "Convert the stream to a secure stream" + stream := sqSSL secureSocketStream on: stream socket. + stream timeout: timeout. + self sslConnect: stream to: self serverName. + "And cert verification" + self canVerify + ifTrue: [stream verifyCert: self serverName]. + ^ nil"indicating success" + ! Item was added: + ----- Method: WebClient>>sslConnect:to: (in category 'initialize') ----- + sslConnect: stream to: lastServer + "Do the SSL handshake, use SNI if available" + (stream respondsTo: #sslConnectTo:) + ifTrue: [stream sslConnectTo: lastServer] + ifFalse: [stream sslConnect].! Item was added: + ----- Method: WebClient>>timeout (in category 'accessing') ----- + timeout + "Timeout for the http operations" + + ^timeout! Item was added: + ----- Method: WebClient>>timeout: (in category 'accessing') ----- + timeout: aNumber + "Timeout for the http operations" + + timeout := aNumber! Item was added: + ----- Method: WebClient>>token (in category 'accessing') ----- + token + "The token for remote OAuth2 authentication" + + ^authParams at: #token ifAbsent:[nil]! Item was added: + ----- Method: WebClient>>token: (in category 'accessing') ----- + token: aString + "The token for remote OAuth2 authentication" + + authParams at: #token put: aString! Item was added: + ----- Method: WebClient>>userAgent (in category 'accessing') ----- + userAgent + "The User-Agent string sent to the server" + + ^userAgent! Item was added: + ----- Method: WebClient>>userAgent: (in category 'accessing') ----- + userAgent: aString + "The User-Agent string sent to the server. + If no user agent should be sent, this value can be set to nil" + + userAgent := aString! Item was added: + ----- Method: WebClient>>username (in category 'accessing') ----- + username + "The username for remote authentication" + + ^authParams at: #username ifAbsent:[nil]! Item was added: + ----- Method: WebClient>>username: (in category 'accessing') ----- + username: aString + "The username for remote authentication" + + authParams at: #username put: aString! Item was added: + ----- Method: WebClient>>writeCookiesFor:on: (in category 'sending') ----- + writeCookiesFor: request on: stream + "Write the cookies for a particular request" + + (cookies select:[:ck| (request acceptsCookie: ck from: self )]) ifNotEmpty:[:ckset| + stream nextPutAll: 'Cookie: '. + ckset + do:[:ck| stream nextPutAll: ck name,'=', ck value] + separatedBy:[stream nextPutAll:'; ']. + stream crlf. + ]. + ! Item was added: + ----- Method: WebClient>>writeHeadersFor:on: (in category 'sending') ----- + writeHeadersFor: request on: aStream + "Write all the headers for the given request on aStream" + + request headersDo:[:key :value| aStream nextPutAll: key, ': ', value asString; crlf]. + ! Item was added: + ----- Method: WebClient>>writeRequest:on: (in category 'sending') ----- + writeRequest: request on: aStream + "Write all the request headers on the given stream" + + self writeRequestLine: request on: aStream. + self writeHeadersFor: request on: aStream. + self writeCookiesFor: request on: aStream. + aStream crlf. + aStream flush.! Item was added: + ----- Method: WebClient>>writeRequestLine:on: (in category 'sending') ----- + writeRequestLine: request on: aStream + "Write the HTTP request line on the given stream" + + aStream nextPutAll: request method; space. + + "https proxy support is transparent via CONNECT" + (proxyServer notNil and:[scheme ~= 'https']) ifTrue:[ + "http://www.ietf.org/rfc/rfc2616.txt + 5.1.2 Request-URI: + ... + The absoluteURI form is REQUIRED when the request is being made to a + proxy. The proxy is requested to forward the request or service it + from a valid cache, and return the response. Note that the proxy MAY + forward the request on to another proxy or directly to the server" + aStream nextPutAll: scheme, '://', self server. + + "XXXX: This is a hack. Indicate that we want the proxy connection + to be persistent. This should NOT be necessary; the proxy should + know that from the HTTP/1.1 request but apparently, squid will fail + NTLM and Negotiate authentication unless explicitly instructed to + keep the proxy connection alive." + request headerAt: 'Proxy-Connection' put: 'keep-alive'. + ]. + + aStream nextPutAll: request rawUrl; space; nextPutAll: request protocol; crlf.! Item was added: + Object subclass: #WebCookie + instanceVariableNames: 'name value path domain expiry version secure httpOnly comment sameSite' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebCookie commentStamp: 'ar 2/22/2010 05:28' prior: 0! + WebCookie represents an http cookie for use by WebClient.! Item was added: + ----- Method: WebCookie>>= (in category 'comparing') ----- + = aCookie + "Compare the receiver with aCookie" + + ^aCookie class == self class + and:[aCookie name = self name + and:[aCookie domain = self domain + and:[aCookie path = self path]]].! Item was added: + ----- Method: WebCookie>>asString (in category 'converting') ----- + asString + "Create the string representation for this cookie" + + ^String streamContents:[:s| self printOn: s].! Item was added: + ----- Method: WebCookie>>comment (in category 'accessing') ----- + comment + "Cookie comment" + + ^comment! Item was added: + ----- Method: WebCookie>>comment: (in category 'accessing') ----- + comment: aString + "Cookie comment" + + comment := aString! Item was added: + ----- Method: WebCookie>>domain (in category 'accessing') ----- + domain + "Cookie domain" + + ^domain! Item was added: + ----- Method: WebCookie>>domain: (in category 'accessing') ----- + domain: aString + "Cookie domain" + + domain := aString.! Item was added: + ----- Method: WebCookie>>expiry (in category 'accessing') ----- + expiry + "The expiry DateAndTime" + + ^expiry! Item was added: + ----- Method: WebCookie>>expiry: (in category 'accessing') ----- + expiry: aDateAndTime + "The expiry DateAndTime" + + expiry := aDateAndTime ifNotNil:[:dt| dt asUTC].! Item was added: + ----- Method: WebCookie>>expirySeconds: (in category 'accessing') ----- + expirySeconds: maxAge + "Compute the cookie's expiry age from the given number of seconds" + + maxAge = 0 ifTrue:[self expiry: DateAndTime new]. + self expiry: DateAndTime now + maxAge seconds.! Item was added: + ----- Method: WebCookie>>hash (in category 'comparing') ----- + hash + "Hash is re-implemented because #= is re-implemented" + + ^name hash + domain hash + path hash.! Item was added: + ----- Method: WebCookie>>httpOnly (in category 'accessing') ----- + httpOnly + "If the cookie should be httpOnly (not scriptable). + See http://msdn2.microsoft.com/en-us/library/ms533046.aspx" + + ^httpOnly! Item was added: + ----- Method: WebCookie>>httpOnly: (in category 'accessing') ----- + httpOnly: aBool + "If the cookie should be httpOnly (not scriptable). + See http://msdn2.microsoft.com/en-us/library/ms533046.aspx" + + httpOnly := aBool! Item was added: + ----- Method: WebCookie>>initialize (in category 'initialize') ----- + initialize + "Initializes the receiver" + super initialize. + secure := false. + httpOnly := false. + ! Item was added: + ----- Method: WebCookie>>isExpired (in category 'testing') ----- + isExpired + "Return true if this cookie is expired" + + expiry ifNil:[^false]. + ^expiry asUTC < DateAndTime now asUTC! Item was added: + ----- Method: WebCookie>>name (in category 'accessing') ----- + name + "The name of the cookie" + + ^name! Item was added: + ----- Method: WebCookie>>name: (in category 'accessing') ----- + name: aString + "The name of the cookie" + + name := aString! Item was added: + ----- Method: WebCookie>>path (in category 'accessing') ----- + path + "Cookie path" + + ^path! Item was added: + ----- Method: WebCookie>>path: (in category 'accessing') ----- + path: aString + "Cookie path" + + path := aString! Item was added: + ----- Method: WebCookie>>printOn: (in category 'printing') ----- + printOn: aStream + "Creates the string representation for this cookie" + + aStream nextPutAll: name, '=', value asString. + expiry ifNotNil:[ + aStream nextPutAll:'; expires='. + aStream nextPutAll: expiry asDate weekday, ', '. + expiry asDate printOn: aStream format: #(1 2 3 $- 2 2 2 ). + aStream nextPutAll: ' ', expiry asTime print24,' GMT'. + ]. + path ifNotNil:[ + aStream nextPutAll:'; path=', (WebUtils quote: path). + ]. + domain ifNotNil:[ + aStream nextPutAll:'; domain=', (WebUtils quote: domain). + ]. + version ifNotNil:[ + aStream nextPutAll:'; version=', version asString. + ]. + secure ifTrue:[ + aStream nextPutAll: '; secure'. + ]. + httpOnly ifTrue:[ + aStream nextPutAll: '; HttpOnly'. + ]. + ! Item was added: + ----- Method: WebCookie>>readExpiryFrom: (in category 'initialize') ----- + readExpiryFrom: aString + "Read a cookie expiry date from the given string. + The expiration date is specified in the 'Wdy, DD-Mon-YYYY HH:MM:SS GMT' format." + + | tokens | + ^[ + tokens := aString withBlanksTrimmed. + (tokens copyAfterLast: Character space) = 'GMT' + ifFalse:[^DateAndTime new]. + tokens := (tokens copyAfter: Character space) copyUpToLast: Character space. + (DateAndTime readFrom: tokens readStream) offset: Duration zero. + ] on: Error do:[:ex| ex return: DateAndTime new].! Item was added: + ----- Method: WebCookie>>readFrom: (in category 'initialize') ----- + readFrom: aStream + "Read a cookie from the given stream" + + | keyval key val | + aStream skipSeparators. + name := (aStream upTo: $=) withBlanksTrimmed. + value := (aStream upTo: $;) withBlanksTrimmed. + [aStream atEnd] whileFalse:[ + keyval := aStream upTo: $;. + key := (keyval copyUpTo: $=) withBlanksTrimmed. + val := (keyval copyAfter: $=) withBlanksTrimmed. + key asLowercase caseOf: { + ['expires'] -> [self expiry: (self readExpiryFrom: val)]. + ['path'] -> [self path: (WebUtils unquote: val)]. + ['domain'] -> [self domain: (WebUtils unquote: val)]. + ['secure'] -> [self secure: true]. + ['version'] -> [self version: val]. + ['httponly'] -> [self httpOnly: true]. + ['comment'] ->[self comment: val]. + ['max-age'] ->[self expirySeconds: val asNumber]. + ['samesite'] -> [self sameSite: val]. + } otherwise:[Transcript showln: 'Unknown cookie field: ', key, ' = ', val]. + ].! Item was added: + ----- Method: WebCookie>>sameSite (in category 'accessing') ----- + sameSite + "https://datatracker.ietf.org/doc/html/draft-west-cookie-samesite-firstparty…" + + ^ sameSite! Item was added: + ----- Method: WebCookie>>sameSite: (in category 'accessing') ----- + sameSite: value + + sameSite := value.! Item was added: + ----- Method: WebCookie>>secure (in category 'accessing') ----- + secure + "Secure cookie flag" + + ^secure! Item was added: + ----- Method: WebCookie>>secure: (in category 'accessing') ----- + secure: aBool + "Secure cookie flag" + + secure := aBool! Item was added: + ----- Method: WebCookie>>value (in category 'accessing') ----- + value + "The value of the cookie" + + ^value! Item was added: + ----- Method: WebCookie>>value: (in category 'accessing') ----- + value: aString + "The value of the cookie" + + value := aString! Item was added: + ----- Method: WebCookie>>version (in category 'accessing') ----- + version + "Cookie version" + + ^version! Item was added: + ----- Method: WebCookie>>version: (in category 'accessing') ----- + version: aString + "Cookie version" + + version := aString! Item was added: + Object subclass: #WebMessage + instanceVariableNames: 'stream protocol headers content' + classVariableNames: 'StatusCodes' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebMessage commentStamp: 'ar 2/23/2010 10:37' prior: 0! + A common base class for WebRequest and WebResponse.! Item was added: + ----- Method: WebMessage class>>initialize (in category 'class initialization') ----- + initialize + "self initialize" + + StatusCodes := Dictionary newFromPairs:{ + "1xx: Meta status codes" + 100. 'Continue'. + 101. 'Switching Protocols'. + 102. 'Processing'. + "2xx: Success status codes" + 200. 'OK'. + 201. 'Created'. + 202. 'Accepted'. + 203. 'Non-Authoritative Information'. + 204. 'No Content'. + 205. 'Reset Content'. + 206. 'Partial Content'. + 207. 'Multi-Status'. "WebDav RFC: 2518" + "3xx: Redirection status codes" + 300. 'Multiple Choices'. + 301. 'Moved Permanently'. + 302. 'Moved Temporarily'. + 303. 'See Other'. + 304. 'Not Modified'. + 305. 'Use Proxy'. + 307. 'Temporary Redirect'. + "4xx: Client-Side Error status code" + 400. 'Bad Request'. + 401. 'Unauthorized'. + 402. 'Payment Required'. + 403. 'Forbidden'. + 404. 'Not Found'. + 405. 'Method Not Allowed'. + 406. 'Not Acceptable'. + 407. 'Proxy Authentication Required'. + 408. 'Request Timeout'. + 409. 'Conflict'. + 410. 'Gone'. + 411. 'Lenght Required'. + 412. 'Precondition Failed'. + 413. 'Request Entity Too Large'. + 414. 'Request-URI Too Long'. + 415. 'Unsupported Media Type'. + 416. 'Requested Range Not Satisfiable'. + 417. 'Expectation Failed'. + 422. 'Unprocessable Entity'. "WebDav RFC: 2518" + 423. 'Locked'. "WebDav RFC: 2518" + 424. 'Failed Dependency'. "WebDav RFC: 2518" + "5xx: Server-Side Error status codes" + 500. 'Internal Server Error'. + 501. 'Not Implemented'. + 502. 'Bad Gateway'. + 503. 'Service Unavailable'. + 504. 'Gateway Timeout'. + 505. 'HTTP Version Not Supported'. + 507. 'Insufficient Storage'. "WebDav RFC: 2518" + }.! Item was added: + ----- Method: WebMessage class>>statusCodeAt: (in category 'utilities') ----- + statusCodeAt: code + "Return the textual description of a status code" + + ^StatusCodes at: code ifAbsent: [ 'Unknown error' ]! Item was added: + ----- Method: WebMessage>>addHeader:value: (in category 'headers') ----- + addHeader: key value: value + "Adds an ADDITIONAL header for the given key" + + headers add: key -> value.! Item was added: + ----- Method: WebMessage>>asString (in category 'converting') ----- + asString + "Prints the receiver" + + ^String streamContents:[:s| self writeOn: s].! Item was added: + ----- Method: WebMessage>>chunkFrom:to:progress: (in category 'streaming') ----- + chunkFrom: srcStream to: dstStream progress: progressBlock + "Stream the content of srcStream to dstStream. + Use chunked transfer-encoding." + + | chunkSize firstLine buffer totalRead | + totalRead := 0. + buffer := (srcStream isBinary ifTrue:[ByteArray] ifFalse:[String]) new. + [firstLine := srcStream nextLine asString. + chunkSize := ('16r',firstLine asUppercase) asNumber. + chunkSize = 0] whileFalse:[ + progressBlock ifNotNil:[progressBlock value: nil value: totalRead]. + buffer size = chunkSize ifFalse:[buffer := buffer class new: chunkSize]. + buffer := srcStream next: chunkSize into: buffer startingAt: 1. + dstStream nextPutAll: buffer. + srcStream skip: 2. "CRLF" + totalRead := totalRead + chunkSize. + ]. + srcStream skip: 2. "CRLF" + dstStream flush. + progressBlock ifNotNil:[progressBlock value: nil value: totalRead].! Item was added: + ----- Method: WebMessage>>close (in category 'initialize') ----- + close + "Always closes regardless of connection header" + + stream ifNotNil:[stream close].! Item was added: + ----- Method: WebMessage>>closeIfTransient (in category 'initialize') ----- + closeIfTransient + "Close the underlying connection if it's not persistent" + + self isPersistent ifFalse:[self close]. + ! Item was added: + ----- Method: WebMessage>>content (in category 'accessing') ----- + content + "Reads and caches available content and returns it." + + ^content ifNil:[content := self getContent]. + ! Item was added: + ----- Method: WebMessage>>content: (in category 'accessing') ----- + content: aString + "Sets content for a response" + + content := aString.! Item was added: + ----- Method: WebMessage>>contentLength (in category 'accessing') ----- + contentLength + "Answers the numeric value of the Content-Length header, or nil if no header exist" + + ^(self headerAt: 'Content-Length' ifAbsent:[^nil]) asInteger! Item was added: + ----- Method: WebMessage>>contentLength: (in category 'accessing') ----- + contentLength: aNumber + "Sets the numeric value of the Content-Length header" + + ^self headerAt: 'Content-Length' put: aNumber! Item was added: + ----- Method: WebMessage>>contentStream (in category 'accessing') ----- + contentStream + "Answers a stream for the conent." + + ^stream! Item was added: + ----- Method: WebMessage>>contentType (in category 'accessing') ----- + contentType + "Answer the content type for the receiver" + + ^self headerAt: 'Content-Type' ifAbsent:['application/octet-stream'] + ! Item was added: + ----- Method: WebMessage>>contentType: (in category 'accessing') ----- + contentType: aString + "Sets the content type for the receiver" + + ^self headerAt: 'Content-Type' put: aString! Item was added: + ----- Method: WebMessage>>contentWithProgress: (in category 'accessing') ----- + contentWithProgress: progressBlock + "Reads and caches available content and returns it." + + ^content ifNil: [ content := self getContentWithProgress: progressBlock ]! Item was added: + ----- Method: WebMessage>>decoderForContentEncoding (in category 'private') ----- + decoderForContentEncoding + + (self headerAt: 'content-encoding') = 'gzip' + ifTrue: [^ self class environment + at: #GZipReadStream ifAbsent: [self error: 'GZip encoded responses not supported']]. + (self headerAt: 'content-encoding') = 'br' + ifTrue: [^ self class environment + at: #BrotliReadStream ifAbsent: [self error: 'Brotli encoded responses not supported']]. + ^ nil! Item was added: + ----- Method: WebMessage>>destroy (in category 'initialize') ----- + destroy + "Destroys the underlying stream" + + stream ifNotNil:[stream destroy].! Item was added: + ----- Method: WebMessage>>getContent (in category 'private') ----- + getContent + "Reads available content and returns it." + + ^self getContentWithProgress: nil! Item was added: + ----- Method: WebMessage>>getContentWithProgress: (in category 'private') ----- + getContentWithProgress: progressBlockOrNil + "Reads available content and returns it." + + | length result | + length := self contentLength. + result := (stream isBinary ifTrue:[ ByteArray ] ifFalse: [ ByteString ]) + new: (length ifNil: [ 1000 ]) + streamContents: [ :outputStream | + self + streamFrom: stream + to: outputStream + size: length + progress: progressBlockOrNil ]. + self decoderForContentEncoding ifNotNil: [:decoder | + result := (decoder on: result) upToEnd]. + self textConverterForContentType ifNotNil: [:converter | + [result := result convertFromWithConverter: converter] + on: InvalidUTF8 "some servers lie" + do: [^ result]]. + ^ result + ! Item was added: + ----- Method: WebMessage>>headerAt: (in category 'headers') ----- + headerAt: key + "Answers a single value for the given http header. + Do not use for headers that may appear multiple times, such at www-authenticate." + + ^self headerAt: key ifAbsent:[''].! Item was added: + ----- Method: WebMessage>>headerAt:ifAbsent: (in category 'headers') ----- + headerAt: key ifAbsent: aBlock + "Answers a single value for the given http header. + Do not use for headers that may appear multiple times, such at www-authenticate." + + self headersAt: key do:[:value| ^value]. + ^aBlock value! Item was added: + ----- Method: WebMessage>>headerAt:put: (in category 'headers') ----- + headerAt: key put: value + "Sets the value of a header, adding if necessary" + + headers do:[:assoc| + (assoc key sameAs: key) ifTrue:[ + assoc value: value. + ^self + ]. + ]. + self addHeader: key value: value.! Item was added: + ----- Method: WebMessage>>headersAt: (in category 'headers') ----- + headersAt: key + "Answers a collection of values for the given http header. + Use for headers that may appear multiple times, such at www-authenticate." + + ^self headersAt: key ifAbsent:[#()].! Item was added: + ----- Method: WebMessage>>headersAt:do: (in category 'headers') ----- + headersAt: aKey do: aBlock + "Evaluate aBlock with all the headers matching aKey" + + self headersDo:[:key :value| + (aKey sameAs: key) ifTrue:[ aBlock value: value]. + ].! Item was added: + ----- Method: WebMessage>>headersAt:ifAbsent: (in category 'headers') ----- + headersAt: key ifAbsent: aBlock + "Answers a collection of values for the given http header. + Use for headers that may appear multiple times, such at www-authenticate." + + | hdrs | + hdrs := OrderedCollection new. + self headersAt: key do:[:value| hdrs add: value]. + ^hdrs asArray ifEmpty:[aBlock value] + ! Item was added: + ----- Method: WebMessage>>headersDo: (in category 'headers') ----- + headersDo: aBlock + "Evaluate aBlock with all of the headers key-value pairs" + + headers do:[:assoc| + aBlock value: assoc key value: assoc value. + ].! Item was added: + ----- Method: WebMessage>>isPersistent (in category 'testing') ----- + isPersistent + "Return true if this is a persistent connection" + + "Check for explicit connection headers" + ((self headerAt:'Connection') sameAs: 'close') ifTrue:[^false]. + ((self headerAt:'Connection') sameAs: 'keep-alive') ifTrue:[^true]. + + "Defaults for various versions" + (self protocol = 'HTTP/1.0') ifTrue:[^false]. + (self protocol = 'HTTP/1.1') ifTrue:[^true]. + + "Assume that later HTTP versions are compatible with 1.1" + ^true! Item was added: + ----- Method: WebMessage>>multipartBoundary (in category 'accessing') ----- + multipartBoundary + "Answer the boundary of a multipart/form-data message" + + | header | + header := self headerAt: 'Content-Type' ifAbsent:[^nil]. + (header beginsWith: 'multipart/form-data') ifFalse:[^nil]. + ^(header copyFrom: (header findString: 'boundary=') + 9 to: header size)! Item was added: + ----- Method: WebMessage>>nextChunk (in category 'streaming') ----- + nextChunk + "Answer the next chunk from a message using chunked transfer encoding." + + | chunkSize chunk | + chunkSize := Integer readFrom: (stream upToAll: String crlf) asString base: 16. + chunkSize = 0 ifFalse:[chunk := stream next: chunkSize]. + stream skip: 2. "CrLf" + ^chunk! Item was added: + ----- Method: WebMessage>>nextChunkPut: (in category 'streaming') ----- + nextChunkPut: chunk + "Send the next chunk of a message using chunked transfer encoding. + + Note: This method does not allow to send empty chunks to avoid accidentally + terminating the chunked transfer. Ending the transfer is part of the chunked + request/response protocol (see #httpPostChunked:encoded:content:type:do: + as well as #sendResponse:chunked:do:)" + + chunk ifNotEmpty:[ + stream nextPutAll: (chunk size printStringBase: 16); crlf. + stream nextPutAll: chunk; crlf; flush. + ].! Item was added: + ----- Method: WebMessage>>printOn: (in category 'printing') ----- + printOn: aStream + "Prints the receiver" + + aStream nextPutAll: self class name. + aStream nextPut: $(. + self writeOn: aStream. + aStream nextPut: $).! Item was added: + ----- Method: WebMessage>>protocol (in category 'accessing') ----- + protocol + "Returns the requested protocol" + + ^protocol! Item was added: + ----- Method: WebMessage>>protocol: (in category 'accessing') ----- + protocol: aString + "Returns the requested protocol" + + protocol := aString! Item was added: + ----- Method: WebMessage>>remoteHost (in category 'accessing') ----- + remoteHost + "Return the name of the remote host" + + | remote | + (stream isKindOf: SocketStream) ifFalse:[^nil]. "don't have it" + remote := stream socket remoteAddress. + ^ NetNameResolver stringFromAddress: remote. + ! Item was added: + ----- Method: WebMessage>>removeHeader: (in category 'headers') ----- + removeHeader: key + "Removes ALL headers with the given key" + + headers := headers reject:[:assoc| assoc key sameAs: key]. + ! Item was added: + ----- Method: WebMessage>>stream (in category 'accessing') ----- + stream + "Answers the underlying TCP stream" + + ^stream! Item was added: + ----- Method: WebMessage>>stream: (in category 'accessing') ----- + stream: aStream + "Sets the underlying TCP stream" + + stream := aStream! Item was added: + ----- 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." + + | buffer bufferSize totalBytesRead bytesInBuffer | + 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! Item was added: + ----- Method: WebMessage>>streamFrom:size:progress: (in category 'streaming') ----- + streamFrom: srcStream size: size progress: aBlock + "Stream the given source stream to the message's socket stream. + Outbound. Can be used on both request/response depending on + whether it is utilized by WebClient or WebServer." + + ^self streamFrom: srcStream to: stream size: size progress: aBlock! Item was added: + ----- Method: WebMessage>>streamFrom:to:size:progress: (in category 'streaming') ----- + streamFrom: srcStream to: dstStream size: sizeOrNil progress: progressBlock + "Stream the content of srcStream to dstStream applying any conversations necessary." + + (self headerAt: 'transfer-encoding') ifNotEmpty:[:encoding| + encoding = 'chunked' + ifTrue:[ + self flag: #todo. " Ideally this would use the WebChunkedStream --pre" + ^self chunkFrom: srcStream to: dstStream progress: progressBlock] + ifFalse:[self error: 'Unknown transfer-encoding: ', encoding]]. + + ^ self streamDirectlyFrom: srcStream to: dstStream size: sizeOrNil progress: progressBlock.! Item was added: + ----- Method: WebMessage>>streamTo:size:progress: (in category 'streaming') ----- + streamTo: dstStream size: size progress: aBlock + "Stream from the receiver's socket stream to the given destination stream. + Inbound. Can be used on both request/response depending on + whether it is utilized by WebClient or WebServer." + content ifNil:[ + self streamFrom: stream to: dstStream size: size progress: aBlock + ] ifNotNil:[ + self streamDirectlyFrom: content readStream to: dstStream size: size progress: aBlock + ].! Item was added: + ----- Method: WebMessage>>textConverterForContentType (in category 'accessing') ----- + textConverterForContentType + + | index contentType | + contentType := self contentType. + contentType size < 8 ifTrue: [ ^nil ]. + index := contentType findString: 'charset=' startingAt: 1 caseSensitive: false. + index = 0 ifTrue: [ ^nil ]. + contentType := contentType allButFirst: index + 7. "'charset=' size - 1". + (contentType beginsWith: '"') ifTrue: [ + "quoted content-type parameter. see rfc2068 section 3.7" + contentType := contentType + copyFrom: 2 + to: (contentType indexOf: $" startingAt: 2) ]. + ^[ TextConverter newForEncoding: contentType ] + on: NoConverterFound + do: [ nil ]! Item was added: + ----- Method: WebMessage>>writeHeadersOn: (in category 'printing') ----- + writeHeadersOn: aStream + "Write the request" + + self headersDo:[:key :value| aStream nextPutAll: key, ': ', value asString; crlf]. + ! Item was added: + ----- Method: WebMessage>>writeOn: (in category 'printing') ----- + writeOn: aStream + "Write the request" + + self writeHeadersOn: aStream. + aStream crlf. + ! Item was added: + WebMessage subclass: #WebRequest + instanceVariableNames: 'method request rawUrl server' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebRequest commentStamp: 'ar 2/23/2010 10:38' prior: 0! + Represents an HTTP request for WebClient/WebServer.! Item was added: + ----- Method: WebRequest class>>readFrom: (in category 'instance creation') ----- + readFrom: aStream + "Create a WebRequest from a given stream" + + ^self new readFrom: aStream! Item was added: + ----- Method: WebRequest>>acceptsCookie:from: (in category 'testing') ----- + acceptsCookie: aCookie from: webClient + "Returns true if this cookie is applicable to this request" + + aCookie domain ifNotNil:[:domain| + (webClient serverName endsWith: domain) ifFalse:[^false]. + ]. + aCookie path ifNotNil:[:path| + (self url beginsWith: path) ifFalse:[^false]. + ]. + aCookie secure ifNotNil:[:secure| + secure ifTrue:[webClient scheme = 'https' ifFalse:[^false]]. + ]. + aCookie expiry ifNotNil:[:expiry| + aCookie isExpired ifTrue:[^false]. + ]. + ^true! Item was added: + ----- Method: WebRequest>>asWebSocket (in category 'converting') ----- + asWebSocket + "Convert this request into a WebSocket" + + "Figure out the version of the protocol" + | field version | + version := self headerAt: 'Sec-WebSocket-Version' ifAbsent:[nil]. + version ifNil:[ + field := self headerAt: 'Sec-WebSocket-Key1' ifAbsent:[nil]. + field + ifNil:[^self asWebSocket68] + ifNotNil:[^self asWebSocket00]. + ]. + + "Attempt WebSocket07 conversion" + ^self asWebSocket07 + ! Item was added: + ----- Method: WebRequest>>asWebSocket00 (in category 'converting') ----- + asWebSocket00 + "Convert this request into a WebSocket" + + | field key1 key2 bytes resp | + resp := self newResponse protocol: 'HTTP/1.1' code: 101. + resp status: 'HTTP/1.1 101 Web Socket Protocol Handshake'. + + "Chrome 4/5 is *VERY* sensitive to the order of the fields" + resp headerAt: 'Upgrade' put: 'WebSocket'. + resp headerAt: 'Connection' put: 'Upgrade'. + + field := self headerAt: 'Sec-WebSocket-Key1'. + key1 := WebUtils extractWebSocketKey: field. + field := self headerAt: 'Sec-WebSocket-Key2'. + key2 := WebUtils extractWebSocketKey: field. + bytes := WebUtils webSocketHandshake: key1 with: key2 with: (stream next: 8). + + resp headerAt: 'Sec-WebSocket-Origin' put: (self headerAt: 'Origin'). + resp headerAt: 'Sec-WebSocket-Location' put: ('ws://', (self headerAt: 'host'), self rawUrl). + (self headerAt: 'Sec-WebSocket-Protocol' ifAbsent:[nil]) ifNotNil:[:hdr| + resp headerAt: 'Sec-WebSocket-Protocol' put: hdr. + ]. + + resp writeOn: stream. + bytes ifNotNil:[stream nextPutAll: bytes]. + stream flush. + ^WebSocket00 on: stream. + ! Item was added: + ----- Method: WebRequest>>asWebSocket07 (in category 'converting') ----- + asWebSocket07 + "Convert this request into a WebSocket" + + | resp hash nonce | + resp := self newResponse protocol: 'HTTP/1.1' code: 101. + resp status: 'HTTP/1.1 101 Web Socket Protocol Handshake'. + + "Chrome 4/5 is *VERY* sensitive to the order of the fields" + resp headerAt: 'Upgrade' put: 'WebSocket'. + resp headerAt: 'Connection' put: 'Upgrade'. + + nonce := self headerAt: 'Sec-WebSocket-Key'. + hash := WebUtils webSocketHash07: nonce. + + resp headerAt: 'Sec-WebSocket-Accept' put: hash. + (self headerAt: 'Sec-WebSocket-Origin' ifAbsent: [self headerAt: 'Origin']) + ifNotNil: [ :origin | resp headerAt: 'Sec-WebSocket-Origin' put: origin ]. + resp headerAt: 'Sec-WebSocket-Location' put: ('ws://', (self headerAt: 'host'), self rawUrl). + (self headerAt: 'Sec-WebSocket-Protocol' ifAbsent:[nil]) ifNotNil:[:hdr| + resp headerAt: 'Sec-WebSocket-Protocol' put: hdr. + ]. + + resp writeOn: stream. + stream flush. + ^(WebSocket07 on: stream) + masking: false; + yourself. + "http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07#section-… says: + ''Frames sent from the server to the client are not masked.'' + http://tools.ietf.org/html/rfc6455#section-5.1 says: + ''A client MUST close a connection if it detects a masked + frame.'' + So not using masking is compatible with the 07 protocol and is required by RFC 6455."! Item was added: + ----- Method: WebRequest>>asWebSocket68 (in category 'converting') ----- + asWebSocket68 + "Convert this request into a WebSocket" + + | resp | + resp := self newResponse protocol: 'HTTP/1.1' code: 101. + resp status: 'HTTP/1.1 101 Web Socket Protocol Handshake'. + + "Chrome 4/5 is *VERY* sensitive to the order of the fields" + resp headerAt: 'Upgrade' put: 'WebSocket'. + resp headerAt: 'Connection' put: 'Upgrade'. + + resp headerAt: 'WebSocket-Origin' put: (self headerAt: 'Origin'). + resp headerAt: 'WebSocket-Location' put: ('ws://', (self headerAt: 'host'), self rawUrl). + (self headerAt: 'WebSocket-Protocol' ifAbsent:[nil]) ifNotNil:[:hdr| + resp headerAt: 'WebSocket-Protocol' put: hdr. + ]. + resp writeOn: stream. + stream flush. + ^WebSocket00 on: stream.! Item was added: + ----- Method: WebRequest>>closeIfTransient:after: (in category 'sending') ----- + closeIfTransient: resp after: aBlock + "Evaluate aBlock. Close the connection if it is transient. + Inserts Connection: close header if needed." + + | close | + close := self isPersistent not. + close + ifTrue: [ + "Always be explicit and insert the Connection: close header" + resp headerAt: 'Connection' put: 'close' ] + ifFalse: [ + "We should tell the client that we keep this connection alive." + resp headerAt: 'Connection' put: 'Keep-Alive' ]. + aBlock value. + stream flush. + close ifTrue:[self close]. + ! Item was added: + ----- Method: WebRequest>>cookieAt: (in category 'cookies') ----- + cookieAt: aString + "Answer the value for a cookie with the given name" + + ^self cookieAt: aString ifAbsent:['']! Item was added: + ----- Method: WebRequest>>cookieAt:ifAbsent: (in category 'cookies') ----- + cookieAt: aString ifAbsent: aBlock + "Answer the value for a cookie with the given name" + + self cookiesDo:[:name :value| name = aString ifTrue:[^value]]. + ^aBlock value! Item was added: + ----- Method: WebRequest>>cookies (in category 'cookies') ----- + cookies + "Answer all the cookies defined in the request" + + | cookies | + cookies := Dictionary new. + self cookiesDo:[:name :value| cookies at: name put: value]. + ^cookies! Item was added: + ----- Method: WebRequest>>cookiesDo: (in category 'cookies') ----- + cookiesDo: aBlock + "Parse the cookie headers and evaluate aBlock with name / value pairs" + + self headersAt: 'Cookie' do:[:hdr| + (hdr findTokens: ';,') do:[:token| + aBlock + value: (token copyUpTo: $=) withBlanksTrimmed + value: (token copyAfter: $=) withBlanksTrimmed]].! Item was added: + ----- Method: WebRequest>>fields (in category 'fields') ----- + fields + "Answer the fields for the given request." + + | fields | + fields := Dictionary new. + self getFields associationsDo:[:a| fields add: a]. + self postFields associationsDo:[:a| fields add: a]. + self multipartFields associationsDo:[:a| fields add: a]. + ^fields + ! Item was added: + ----- Method: WebRequest>>getFields (in category 'fields') ----- + getFields + "Decodes the fields embedded in the url ?var1=val1&var2=val2" + + | args | + args := (rawUrl copyAfter: $?) ifEmpty:[^Dictionary new]. + ^WebUtils decodeUrlEncodedForm: args multipleValues: false + ! Item was added: + ----- Method: WebRequest>>initialize (in category 'initialize') ----- + initialize + "Initialize the receiver" + + super initialize. + method := 'GET'. + protocol := 'HTTP/1.1'. + headers := OrderedCollection new.! Item was added: + ----- Method: WebRequest>>initializeFromUrl: (in category 'initialize') ----- + initializeFromUrl: urlString + "Initialize the client from a http url or string" + + | urlStream | + urlStream := urlString readStream. + "Skip past scheme if present" + urlStream upToAll: '://'. + urlStream atEnd + ifTrue:[rawUrl := urlString] + ifFalse:[rawUrl := urlStream upTo: $/; upToEnd]. + (rawUrl beginsWith: '/') ifFalse:[rawUrl := '/', rawUrl]. + ! Item was added: + ----- Method: WebRequest>>isDeleteRequest (in category 'testing') ----- + isDeleteRequest + "Returns true if this is an HTTP DELETE request" + + ^self method = 'DELETE'! Item was added: + ----- Method: WebRequest>>isGetRequest (in category 'testing') ----- + isGetRequest + "Returns true if this is an HTTP GET request" + + ^self method = 'GET'! Item was added: + ----- Method: WebRequest>>isHeadRequest (in category 'testing') ----- + isHeadRequest + "Returns true if this is an HTTP HEAD request" + + ^self method = 'HEAD'! Item was added: + ----- Method: WebRequest>>isOptionsRequest (in category 'testing') ----- + isOptionsRequest + "Returns true if this is an HTTP OPTIONS request" + + ^self method = 'OPTIONS'! Item was added: + ----- Method: WebRequest>>isPostRequest (in category 'testing') ----- + isPostRequest + "Returns true if this is an HTTP POST request" + + ^self method = 'POST'! Item was added: + ----- Method: WebRequest>>isPutRequest (in category 'testing') ----- + isPutRequest + "Returns true if this is an HTTP PUT request" + + ^self method = 'PUT'! Item was added: + ----- Method: WebRequest>>isTraceRequest (in category 'testing') ----- + isTraceRequest + "Returns true if this is an HTTP TRACE request" + + ^self method = 'TRACE'! Item was added: + ----- Method: WebRequest>>method (in category 'accessing') ----- + method + "The request method (GET, POST etc)" + + ^method! Item was added: + ----- Method: WebRequest>>method: (in category 'accessing') ----- + method: aString + "The request method (GET, POST etc)" + + method := aString! Item was added: + ----- Method: WebRequest>>multipartFields (in category 'fields') ----- + multipartFields + "Answers the multipart fields of a post request" + + | fields | + fields := Dictionary new. + self multipartFieldsDo:[:hdrs :params :cntnt| + params at: 'name' ifPresent:[:fieldName| fields at: fieldName put: cntnt]. + ]. + ^fields! Item was added: + ----- Method: WebRequest>>multipartFieldsDo: (in category 'fields') ----- + multipartFieldsDo: aBlock + "Evaluate aBlock with the multipart fields of a post request. + The block is expected to take three arguments: + * The headers from the part being processed + * The parameters from the content-disposition header + * The content from the part being processed + " + + ^(self isPostRequest and: [ + self contentType beginsWith: 'multipart/form-data']) + ifTrue: [WebUtils decodeMultipartForm: self content readStream boundary: self multipartBoundary do: aBlock] + ifFalse: [Dictionary new]! Item was added: + ----- Method: WebRequest>>newResponse (in category 'initialize') ----- + newResponse + "Create a new response entitiy. + Subclasses can override this method to provide a different response class" + + ^(WebResponse new) + request: self; + yourself! Item was added: + ----- Method: WebRequest>>newWebSocketOn: (in category 'initialize') ----- + newWebSocketOn: aStream + "Create a new socket entitiy. + Subclasses can override this method to provide a different response class" + + ^WebSocket on: aStream! Item was added: + ----- Method: WebRequest>>postFields (in category 'fields') ----- + postFields + "Answers the multipart fields of a post request" + + ^(self isPostRequest and: [ + self contentType beginsWith: 'application/x-www-form-urlencoded']) + ifTrue: [ + WebUtils + decodeUrlEncodedForm: self content + multipleValues: true + withConverter: self textConverterForContentType ] + ifFalse: [Dictionary new]! Item was added: + ----- Method: WebRequest>>rawUrl (in category 'accessing') ----- + rawUrl + "The raw (unparsed) url" + + ^rawUrl! Item was added: + ----- Method: WebRequest>>rawUrl: (in category 'accessing') ----- + rawUrl: aString + "The raw (unparsed) url" + + rawUrl := aString + ! Item was added: + ----- Method: WebRequest>>readFrom: (in category 'initialize') ----- + readFrom: aStream + "Initialize the receiver initialized from an existing socket stream + This method will block until the headers have been parsed." + + | tokens | + stream := aStream. + stream isBinary ifTrue:[stream ascii]. + "Parse request header" + request := stream upToAll: String crlf. + tokens := request findTokens: ' '. + tokens size < 2 ifTrue:[^self error: 'Invalid HTTP request: ', request]. + method := tokens first. + rawUrl := tokens second. + tokens size > 2 + ifTrue:[protocol := tokens third] + ifFalse:[protocol := 'HTTP/1.0']. + + "Parse HTTP header" + headers := WebUtils readHeadersFrom: stream. + ! Item was added: + ----- Method: WebRequest>>requestLine (in category 'accessing') ----- + requestLine + "The actual request line as sent by the client" + + ^request ifNil:[self method, ' ', self rawUrl, ' ', self protocol]! Item was added: + ----- Method: WebRequest>>send200Response: (in category 'responses') ----- + send200Response: aString + "Send a 200 OK response" + + ^self + send200Response: (aString convertToWithConverter: UTF8TextConverter new) + contentType: 'text/plain; charset=utf-8'.! Item was added: + ----- Method: WebRequest>>send200Response:contentType: (in category 'responses') ----- + send200Response: aString contentType: contentType + "Send a 200 OK response" + + ^self send200Response: aString contentType: contentType do:[:resp|]! Item was added: + ----- 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. + aBlock value: resp. + ^self sendResponse: resp content: aString.! Item was added: + ----- Method: WebRequest>>send301Response: (in category 'responses') ----- + send301Response: location + "Send a 301 permanent redirect response" + + ^self send301Response: location do:[:resp|].! Item was added: + ----- Method: WebRequest>>send301Response:do: (in category 'responses') ----- + send301Response: location do: aBlock + "Send a 301 permanent redirect response" + + ^self send3xxResponse: location code: 301 do: aBlock! Item was added: + ----- Method: WebRequest>>send302Response: (in category 'responses') ----- + send302Response: location + "Send a 302 temporary redirect response" + + ^self send302Response: location do:[:resp|].! Item was added: + ----- Method: WebRequest>>send302Response:do: (in category 'responses') ----- + send302Response: location do: aBlock + "Send a 302 temporary redirect response" + + ^self send3xxResponse: location code: 302 do: aBlock! Item was added: + ----- Method: WebRequest>>send3xxResponse:code: (in category 'responses') ----- + send3xxResponse: location code: statusCode + "Send a 3xx redirect response" + + ^self send3xxResponse: location code: statusCode do:[:resp|].! Item was added: + ----- Method: WebRequest>>send3xxResponse:code:do: (in category 'responses') ----- + send3xxResponse: location code: statusCode do: aBlock + "Send a 3xx redirect response" + + | resp url | + "If the redirect is not to an absolute url, prefix it with the host if we have one" + url := location. + (location findString: '://') > 0 ifFalse:[ + (self headerAt: 'host') ifNotEmpty:[:host| url := 'http://', host, location]]. + + resp := self newResponse protocol: 'HTTP/1.1' code: statusCode. + resp headerAt: 'Location' put: url. + aBlock value: resp. + ^self sendResponse: resp content: ''. + ! Item was added: + ----- Method: WebRequest>>send400Response (in category 'responses') ----- + send400Response + "Send a 400 bad request response" + + | message | + message := '<html><head><title>400 Bad Request</title></head><body>', + '<h1>Bad Request</h1> + <p>The server encountered a request it did not understand. + </body></html>'. + + self sendResponseCode: 400 + content: message squeakToUtf8 + type: 'text/plain; charset=utf-8' + close: true! Item was added: + ----- Method: WebRequest>>send404Response (in category 'responses') ----- + send404Response + "Send a 404 not found response" + + ^self send404Response: '<html><head><title>404 Not Found</title></head><body><h1>404 Not Found</h1><p>The requested URL ',self rawUrl,' was not found on this server.</p></body></html>'. + ! Item was added: + ----- 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' ]! Item was added: + ----- 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'. + aBlock value: resp. + ^self sendResponse: resp content: body. + ! Item was added: + ----- Method: WebRequest>>send405Response: (in category 'responses') ----- + send405Response: allowed + "Send a 405 method not allowed response" + + ^self send405Response: allowed content: '<html><head><title>405 Method Not Allowed</title></head><body><h1>405 Method Not Allowed</h1><p>The requested method ',self method,' is not allowed for the URL', self rawUrl, '</p></body></html>'.! Item was added: + ----- 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: 'allow' put: (String streamContents:[:s| + allowed do:[:m| s nextPutAll: m] separatedBy:[s nextPut: $,] + ]). + ^self sendResponse: resp content: body.! Item was added: + ----- Method: WebRequest>>send500Response: (in category 'responses') ----- + send500Response: errReport + "Send a 500 internal server error response" + + | errLog | + errLog := '<html><head><title>500 Internal Server Error</title></head><body>', + '<h1>Internal Server Error</h1><pre>', + (errReport copyReplaceAll: String cr with: String crlf), + '</pre></body></html>'. + + self sendResponseCode: 500 + content: errLog squeakToUtf8 + type: 'text/html; charset=utf-8' + close: true. + ! Item was added: + ----- Method: WebRequest>>sendOptionsResponse: (in category 'responses') ----- + sendOptionsResponse: allowed + "Send a 200 OK response for an OPTIONS request" + + ^self send200Response: '' contentType: 'application/octet-stream' do:[:resp| + resp headerAt: 'allow' put: (String streamContents:[:s| + allowed do:[:m| s nextPutAll: m] separatedBy:[s nextPut: $,] + ]). + ].! Item was added: + ----- Method: WebRequest>>sendResponse:chunked: (in category 'responses') ----- + sendResponse: code chunked: chunkBlock + "Send a chunked response" + + ^self sendResponse: code chunked: chunkBlock do:[:resp|]! Item was added: + ----- Method: WebRequest>>sendResponse:chunked:do: (in category 'responses') ----- + sendResponse: code chunked: chunkBlock do: hdrBlock + "Send a chunked response" + + | resp | + resp := self newResponse protocol: 'HTTP/1.1' code: code. + resp headerAt: 'Transfer-Encoding' put: 'chunked'. + hdrBlock value: resp. + ^self sendResponse: resp contentBlock:[:aStream| + "Set the stream in the request and pass it in the chunk block" + resp stream: aStream. + chunkBlock value: resp. + "send termination chunk" + aStream nextPutAll: '0'; crlf; crlf; flush. + ]. + ! Item was added: + ----- Method: WebRequest>>sendResponse:content: (in category 'sending') ----- + sendResponse: resp content: aString + "Send a WebResponse with content." + + ^self sendResponse: resp contentStream: aString readStream size: aString size! Item was added: + ----- Method: WebRequest>>sendResponse:contentBlock: (in category 'sending') ----- + sendResponse: resp contentBlock: contentBlock + "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." + + "Add Date and Server headers" + resp headerAt: 'Date' put: (server ifNil:[WebServer]) serverDate. + resp headerAt: 'Server' put: (server ifNil:[WebServer]) serverString. + + self closeIfTransient: resp after:[ + "Ignore all network errors while sending the response" + [resp writeOn: stream. + stream flush. + self isHeadRequest ifFalse:[contentBlock value: stream]. + ] on: NetworkError do:["ignore"]. + + "Make sure we log before closing the connection" + server ifNotNil:[server logRequest: self response: resp]. + ].! Item was added: + ----- 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]. + + ^self sendResponse: resp contentBlock:[:sockStream| + resp streamFrom: aStream to: sockStream size: streamSize progress: nil + ]! Item was added: + ----- Method: WebRequest>>sendResponseCode:content:type:close: (in category 'responses') ----- + sendResponseCode: code content: aString type: contentType close: aBool + "Send a 500 Internal server error response" + + ^self sendResponseCode: code content: aString type: contentType do:[:hdr| + aBool ifTrue:[hdr headerAt: 'Connection' put: 'close']. + ].! Item was added: + ----- 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]. + aBlock value: resp. + ^self sendResponse: resp content: aString.! Item was added: + ----- Method: WebRequest>>sendXmlResponse: (in category 'responses') ----- + sendXmlResponse: xmlString + "Send an a-ok 200 xml-ish response" + + ^self send200Response: xmlString contentType: 'application/xml'! Item was added: + ----- Method: WebRequest>>server (in category 'accessing') ----- + server + "If non-nil, the WebServer instance associated with the request." + + ^server! Item was added: + ----- Method: WebRequest>>server: (in category 'accessing') ----- + server: aWebServer + "If non-nil, the WebServer instance associated with the request." + + server := aWebServer! Item was added: + ----- Method: WebRequest>>stream200Response: (in category 'responses') ----- + stream200Response: aStream + "Stream a 200 OK response" + + ^self stream200Response: aStream size: aStream size! Item was added: + ----- Method: WebRequest>>stream200Response:size: (in category 'responses') ----- + stream200Response: aStream size: streamSize + "Stream a 200 OK response" + + ^self stream200Response: aStream size: streamSize type: 'application/octet-stream'! Item was added: + ----- Method: WebRequest>>stream200Response:size:type: (in category 'responses') ----- + stream200Response: aStream size: streamSize type: contentType + "Stream a 200 OK response" + + ^self stream200Response: aStream size: streamSize type: contentType do:[:resp|].! Item was added: + ----- 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. + aBlock value: resp. + ^self sendResponse: resp contentStream: aStream size: streamSize.! Item was added: + ----- Method: WebRequest>>url (in category 'accessing') ----- + url + "The url without fragment or arguments" + + ^((rawUrl copyUpTo: $#) copyUpTo: $?) unescapePercentsWithTextEncoding: nil! Item was added: + ----- Method: WebRequest>>writeOn: (in category 'printing') ----- + writeOn: aStream + "Write the request" + + self writeRequestOn: aStream. + super writeOn: aStream! Item was added: + ----- Method: WebRequest>>writeRequestOn: (in category 'printing') ----- + writeRequestOn: aStream + "Write the request" + + aStream nextPutAll: method; space; nextPutAll: rawUrl; space; nextPutAll: protocol; crlf. + ! Item was added: + WebMessage subclass: #WebResponse + instanceVariableNames: 'request status code url' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebResponse commentStamp: 'ar 2/23/2010 10:39' prior: 0! + Represents an HTTP response for WebClient/WebServer.! Item was added: + ----- Method: WebResponse class>>protocol:code: (in category 'instance creation') ----- + protocol: protocol code: code + "Create a response using the given protocol / code" + + ^self new protocol: protocol code: code! Item was added: + ----- Method: WebResponse>>code (in category 'accessing') ----- + code + "The HTTP response code" + + ^code! Item was added: + ----- Method: WebResponse>>contentStream (in category 'accessing') ----- + contentStream + "Answers a stream for the conent." + + (self headerAt: 'transfer-encoding') = 'chunked' ifTrue:[ + ^WebChunkedStream on: stream. + ]. + ^super contentStream! Item was added: + ----- Method: WebResponse>>getContentWithProgress: (in category 'private') ----- + getContentWithProgress: progressBlockOrNil + "Any response to a HEAD request and any response with a 1xx (Informational), 204 (No Content), or 304 (Not Modified) status code is always terminated by the first empty line after the header fields, regardless of the header fields present in the message, and thus cannot contain a message body. See https://tools.ietf.org/html/rfc7230#section-3.3.3 " + + [ + (request method = 'HEAD' + or: [(code between: 100 and: 199) + or: [code = 204 + or: [code = 304]]]) ifTrue: [^ '']. + + ^ super getContentWithProgress: progressBlockOrNil + + ] ensure: [self closeIfTransient]! Item was added: + ----- Method: WebResponse>>isInformational (in category 'testing') ----- + isInformational + "Is this a 1xx response?" + + ^self code between: 100 and: 199 + ! Item was added: + ----- Method: WebResponse>>isRedirect (in category 'testing') ----- + isRedirect + "Is this a redirect response?" + + ^self code between: 300 and: 399 + ! Item was added: + ----- Method: WebResponse>>isSuccess (in category 'testing') ----- + isSuccess + "Is this a successful response?" + + ^self code between: 200 and: 299 + ! Item was added: + ----- Method: WebResponse>>protocol:code: (in category 'initialize') ----- + protocol: respProtocol code: respCode + "Initialize a response from protocol and code" + + code := respCode. + protocol := respProtocol. + status := protocol, ' ', code asString, ' ', (self class statusCodeAt: code). + headers := OrderedCollection new.! Item was added: + ----- Method: WebResponse>>readFrom: (in category 'initialize') ----- + readFrom: aStream + "Parse an HTTP response from the given stream" + + | tokens | + stream := aStream. + status := stream upToAll: String crlf. + tokens := status findTokens: ' '. + tokens size < 2 ifTrue:[^self error:'Invalid response: ', status]. + protocol := tokens first. + code := tokens second asNumber. + headers := WebUtils readHeadersFrom: stream. + ! Item was added: + ----- Method: WebResponse>>request (in category 'accessing') ----- + request + "The original request for this response" + + ^request! Item was added: + ----- Method: WebResponse>>request: (in category 'accessing') ----- + request: aRequest + "The original request for this response" + + request := aRequest! Item was added: + ----- Method: WebResponse>>setCookie: (in category 'cookies') ----- + setCookie: aCookie + "Adds a Set-Cookie header" + + ^self addHeader: 'Set-Cookie' value: aCookie asString! Item was added: + ----- Method: WebResponse>>setCookie:value:path: (in category 'cookies') ----- + setCookie: name value: value path: path + "Adds a Set-Cookie header" + + ^self setCookie: ((WebCookie new) + name: name; + value: value; + path: path; + yourself)! Item was added: + ----- Method: WebResponse>>setCookie:value:path:expires:domain:secure: (in category 'cookies') ----- + setCookie: name value: value path: path expires: date domain: domain secure: aBool + "Adds a Set-Cookie header" + + ^self setCookie: ((WebCookie new) + name: name; + value: value; + path: path; + expiry: date; + domain: domain; + secure: aBool; + yourself)! Item was added: + ----- Method: WebResponse>>setCookieAt: (in category 'cookies') ----- + setCookieAt: key + "Evaluate aBlock with all the cookies deined in the request" + + self setCookiesDo:[:cookie| + cookie name = key ifTrue:[^cookie]. + ]. + ^nil! Item was added: + ----- Method: WebResponse>>setCookiesDo: (in category 'cookies') ----- + setCookiesDo: aBlock + "Evaluate aBlock with all the cookies deined in the request" + + self headersAt: 'Set-Cookie' do:[:hdr| + aBlock value: (WebCookie new readFrom: hdr readStream) + ]. + ! Item was added: + ----- Method: WebResponse>>status (in category 'accessing') ----- + status + "The status line from the response" + + ^status! Item was added: + ----- Method: WebResponse>>status: (in category 'accessing') ----- + status: aString + "The status line from the response" + + status := aString! Item was added: + ----- Method: WebResponse>>url (in category 'accessing') ----- + url + "The url of the resource at which a request was terminated after a series + of redirects. Without redirects, this will be the same as the request url." + + ^url! Item was added: + ----- Method: WebResponse>>url: (in category 'accessing') ----- + url: urlString + "The url of the resource at which a request was terminated after a series + of redirects. Without redirects, this will be the same as the request url." + + url := urlString! Item was added: + ----- Method: WebResponse>>writeOn: (in category 'printing') ----- + writeOn: aStream + "Store this response on aStream" + + self writeStatusOn: aStream. + super writeOn: aStream. + ! Item was added: + ----- Method: WebResponse>>writeStatusOn: (in category 'printing') ----- + writeStatusOn: aStream + "Store this response on aStream" + + aStream nextPutAll: status; crlf. + ! Item was added: + Object subclass: #WebServer + instanceVariableNames: 'listenerSocket listenerProcess interface port mutex connections entryPoints vault logAction nonceCache sessions serverString errorHandler accessLog certName siteUrl' + classVariableNames: 'Default Registry' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebServer commentStamp: 'ar 5/4/2010 13:17' prior: 0! + WebClient provides a simple yet complete HTTP server implementation. + + To view the documentation evaluate: + + HelpBrowser openOn: WebServerHelp. + ! Item was added: + ----- Method: WebServer class>>benchmark (in category 'benchmarks') ----- + benchmark + "Runs a WebClient/WebServer streaming benchmark to measure throughput" + + " + WebServer benchmark + MessageTally spyOn:[WebServer benchmark] + " + + | amount time resp port | + port := 8888. + amount := 128 * 1024 * 1024. + WebServer reset default listenOn: port. + WebServer default addService: '/streaming' action:[:req| + req stream200Response: NullStream new size: amount. + ]. + time := [ + resp := WebClient httpGet: 'http://localhost:', port, '/streaming'. + resp isSuccess ifFalse:[self error: resp status]. + resp streamTo: NullStream new size: resp contentLength progress: nil. + resp close. + ] timeToRun. + WebServer reset. + ^(amount * 1000 // time) asStringWithCommas, ' bytes/sec' + ! Item was added: + ----- Method: WebServer class>>browseDir:request: (in category 'examples') ----- + browseDir: directory request: request + "Responds with a directory listing back to the original request" + + | entries listing url | + url := request url. + (url endsWith: '/') ifTrue:[url := url allButLast]. + + entries := directory entries sort:[:e1 :e2| + e1 isDirectory = e2 isDirectory + ifTrue:[e1 name <= e2 name] + ifFalse:[e2 isDirectory]]. + + listing := String streamContents:[:s| + s nextPutAll:'<html><head><title>Index of ', request url,'</title></head><body>'. + s nextPutAll:'<h1>Index of ', request url,'</h1>'. + s nextPutAll:'<pre> Name Last modified Size Description<hr>'. + s nextPutAll: '[up] <a href="', (url copyUpToLast: $/),'">parent</a>'; crlf. + entries do:[:e| + s nextPutAll:(e isDirectory ifTrue:['[dir] '] ifFalse:[' ']). + s nextPutAll: '<a href="', url, '/', e name, '">'. + s nextPutAll: (e name truncateTo: 30). + s nextPutAll: '</a>'. + e name size < 30 ifTrue:[s nextPutAll: (String new: 30 - e name size withAll: $ )]. + s nextPutAll: (e modificationDateAndTime asString padded: #right to: 20 with: $ ). + s nextPutAll: (e fileSize asString padded: #right to: 20 with: $ ). + s crlf. + ]. + ]. + + request + send200Response: (listing convertToWithConverter: UTF8TextConverter new) + contentType: 'text/html; charset=utf-8'. + + ! Item was added: + ----- 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. + request sendResponse: resp contentStream: file size: fileSize.! Item was added: + ----- Method: WebServer class>>browseRequest: (in category 'examples') ----- + browseRequest: request + "Handle an HTTP request for browsing some resource" + + | path fd entry file | + + "Extract the file path from the request" + path := request url findTokens: '/'. + path ifEmpty:[^self browseDir: FileDirectory default request: request.]. + + "Find the directory entry for the resource" + fd := path allButLast inject: FileDirectory default into:[:dir :part| dir directoryNamed: part]. + entry := fd entryAt: path last ifAbsent:[^request send404Response]. + + "Reply with the proper resource" + entry isDirectory ifTrue:[ + "Send file listing. We handle this synchronously for simplicity." + self browseDir: (fd directoryNamed: entry name) request: request. + ] ifFalse:[ + "Send file content. Since files can be large, we fork this off. + However, since we forked it, we need to handle two different + possible conditions: + - closing the file in case of error + - handling errors when sending it + This makes the code below a bit ugly" + [[ + file := fd readOnlyFileNamed: entry name. + [self browseFile: file request: request.] + ensure:[file close] "close file even in case of error" + ] on: Error do:[] "ignore errors altogether" + ] fork. "fork it" + ]. + ! Item was added: + ----- Method: WebServer class>>default (in category 'accessing') ----- + default + "A default WebServer instance. Mostly for the examples." + + ^Default ifNil:[Default := self new].! Item was added: + ----- Method: WebServer class>>exampleAuth (in category 'examples') ----- + exampleAuth "WebServer exampleAuth" + "Simple example requiring basic auth" + + | server port realm | + port := 9999. + server := WebServer reset default. + + "The realm to use for the server" + realm := 'Example Realm'. + + "Add a sample user (note: password is hashed, not stored verbatim)" + server passwordAt: 'squeak' realm: realm put: 'squeak'. + + server listenOn: port. + server addService: '/' action:[:req| + server + authenticate: req + realm: realm + methods: #(digest basic) + do:[self browseRequest: req]]. + ! Item was added: + ----- Method: WebServer class>>exampleBrowse (in category 'examples') ----- + exampleBrowse "WebServer exampleBrowse" + "This example implements a simple http server allowing to view + and download files (like browsing ftp sites etc)." + + | server port | + port := 9999. + server := WebServer reset default. + server listenOn: port. + server addService: '/' action:[:req| self browseRequest: req]. + ! Item was added: + ----- Method: WebServer class>>exampleDoIt (in category 'examples') ----- + exampleDoIt "WebServer exampleDoIt" + "This example executes doIts from a POST request. + It's the simplest possible RPC interface to Squeak." + + | server port | + port := 9999. + server := WebServer reset default. + server listenOn: port. + server addService: '/' action:[:req| + | data result | + req isPostRequest ifTrue:[ + "We fetch all of the data instead of streaming it" + data := req content. + "Compute the result" + result := [Compiler evaluate: data] on: Error do:[:ex| ex return: ex asString]. + req send200Response: result asString + ] ifFalse:[req send404Response]. + ]. + ! Item was added: + ----- Method: WebServer class>>exampleSSL: (in category 'examples') ----- + exampleSSL: certName + + "This example implements a simple https server allowing to view + and download files (like browsing ftp sites etc): + + WebServer exampleSSL: 'Internet Widgits Pty'. + WebServer exampleSSL: '/home/andreas/certs/testcert.pem'. + + " + + | server port | + port := 8443. + server := WebServer reset default. + server accessLog: Transcript. + server certName: certName. + server listenOn: port. + server addService: '/' action:[:req| self browseRequest: req]. + ! Item was added: + ----- Method: WebServer class>>exampleSession (in category 'examples') ----- + exampleSession "WebServer exampleSession" + "This example uses a simple session cookie to avoid + authentication for every request." + + | server port realm | + realm := 'Example Realm'. "authentication realm" + port := 9999. + server := WebServer reset default. + server listenOn: port. + + "Add a sample user (note: password is hashed, not stored verbatim)" + server passwordAt: 'squeak' realm: realm put: 'squeak'. + + "Register the login service (sets cookie when successful)" + server addService: '/login' action:[:req| + server authenticate: req realm: realm methods: #(digest) do:[ | id | + "Set the cookie and redirect back to /" + server sessionAt: (id := UUID new hex) put: ''. + req send302Response: (req fields at: 'url' ifAbsent:['/']) + do:[:resp| resp setCookie: 'session' value: id path: '/']]]. + + "Register the normal browse service" + server addService: '/' action:[:req| + "Check if we have a valid session cookie. If not redirect to login." + (server sessionAt: (req cookieAt: 'session')) notNil + ifTrue:[self browseRequest: req] + ifFalse:[req send302Response: '/login?url=', req url encodeForHTTP]]. + ! Item was added: + ----- Method: WebServer class>>forUrl: (in category 'registry') ----- + forUrl: urlString + "Answer the WebServer registered for a given URL string." + + ^self forUrl: urlString ifAbsent:[self newForUrl: urlString]! Item was added: + ----- Method: WebServer class>>forUrl:ifAbsent: (in category 'registry') ----- + forUrl: urlString ifAbsent: aBlock + "Answer the WebServer registered for a given URL string. + If no WebServer is registered, evaluate aBlock." + + ^self registry at: urlString ifAbsent: aBlock! Item was added: + ----- Method: WebServer class>>newForUrl: (in category 'registry') ----- + newForUrl: urlString + "Create a new WebServer instance registered for a given URL string." + + | server | + "Out with the old ...." + server := self removeUrl: urlString. + server ifNotNil:[server destroy]. + + "... and in with the new." + server := self new. + server siteUrl: urlString. + self registry at: urlString put: server. + ^server + ! Item was added: + ----- Method: WebServer class>>registry (in category 'registry') ----- + registry + "Answer the WebServer site registry" + + ^Registry ifNil:[Registry := Dictionary new]! Item was added: + ----- Method: WebServer class>>removeUrl: (in category 'registry') ----- + removeUrl: urlString + "Remove and answer the WebServer registered for a given URL string. + If no WebServer was registered, return nil." + + ^self removeUrl: urlString ifAbsent:[nil]! Item was added: + ----- Method: WebServer class>>removeUrl:ifAbsent: (in category 'registry') ----- + removeUrl: urlString ifAbsent: aBlock + "Remove and answer the WebServer registered for a given URL string." + + ^self registry removeKey: urlString ifAbsent: aBlock! Item was added: + ----- Method: WebServer class>>requestBenchmark: (in category 'benchmarks') ----- + requestBenchmark: persistent + "Runs a WebClient/WebServer benchmark to measure request handling speed. + Uses a persistent connection if requested." + + " + WebServer requestBenchmark: false. + WebServer requestBenchmark: true. + MessageTally spyOn:[WebServer requestBenchmark: true] + " + + | port | + port := 8888. + WebServer reset default listenOn: port. + WebServer default addService: '/benchmark' action:[:req| + req send200Response: ''. + ]. + ^[WebClient + requestBenchmark: 'http://localhost:', port, '/benchmark' + persistent: persistent] ensure:[WebServer reset]. + ! Item was added: + ----- Method: WebServer class>>reset (in category 'accessing') ----- + reset "WebServer reset" + "Reset the default WebServer instance." + + Default ifNotNil:[ + Default destroy. + Default := nil. + ].! Item was added: + ----- Method: WebServer class>>serverDate (in category 'accessing') ----- + serverDate + "Returns the date string to be used in responses" + + | date | + ^String streamContents:[:s| + date := DateAndTime now asUTC. + s nextPutAll: date dayOfWeekAbbreviation, ', '. + date asDate printOn: s format: #(1 2 3 $ 2 1 2 ). + s space; nextPutAll: (Time seconds: date asSeconds) print24. + s nextPutAll: ' GMT'. + ].! Item was added: + ----- Method: WebServer class>>serverString (in category 'accessing') ----- + serverString + "Returns the server string to be used in responses" + + ^'WebServer/1.5 (', + WebUtils mcVersion, '; ', + SystemVersion current version,'-', + SystemVersion current highestUpdate printString, '; ', + WebUtils platformName,')'. + ! Item was added: + ----- Method: WebServer>>accessLog (in category 'logging') ----- + accessLog + "The standard access log. Can be either a stream or a string; if the access log + is a string then the string is assumed to be a file name and the file will be opened + and closed for each request." + + ^accessLog! Item was added: + ----- Method: WebServer>>accessLog: (in category 'logging') ----- + accessLog: aStreamOrFilename + "The standard access log. Can be either a stream or a string; if the access log + is a string then the string is assumed to be a file name and the file will be opened + and closed for each request." + + accessLog := aStreamOrFilename! Item was added: + ----- Method: WebServer>>addService:action: (in category 'services') ----- + addService: entryPoint action: aBlockOrMessage + "Add a service to the web server. The service is specified by an entryPoint, + denoting the url under which the service can be requested + (such as /my/great/service) and an action which is a message + send taking a single argument, the WebRequest." + + ^self addService: entryPoint + action: aBlockOrMessage + methods: self defaultHttpMethods.! Item was added: + ----- Method: WebServer>>addService:action:methods: (in category 'services') ----- + addService: entryPoint action: aBlockOrMessage methods: methods + "Add a service to the web server. The service is specified by an entryPoint, + denoting the url under which the service can be requested + (such as /my/great/service) and an action which is a message + send taking a single argument, the WebRequest. + + The list of methods describes what HTTP methods the given url supports." + + mutex critical:[ + entryPoints at: entryPoint asLowercase put: {methods. aBlockOrMessage}. + ].! Item was added: + ----- Method: WebServer>>addToken:toRealm: (in category 'authentication') ----- + addToken: aString toRealm: realm + | hash | + hash := WebUtils md5Digest: aString, ':', realm. + self passwordHashAt: (aString,':',realm) put: hash! Item was added: + ----- Method: WebServer>>asyncHandleConnectionFrom: (in category 'handling') ----- + asyncHandleConnectionFrom: aSocket + "Handle an incoming connection asynchronously to avoid blocking the listener." + + | handlerProcess | + handlerProcess := [ + [ [ self handleConnectionFrom: aSocket ] + on: Error do: [ :ex | aSocket destroy ] ] + ensure: [ + aSocket destroy. + mutex critical: [ + "At this point handlerProcess is initialized, so it is safe to use that variable. Using Processor activeProcess is not possible, because this unwind block may be evaluated by another process. Doing this outside the #ensure: block is not safe." + connections remove: handlerProcess ifAbsent: nil ] ] ] newProcess. + + mutex critical:[connections add: handlerProcess]. + "Process priority has to be set to a lower level here, else it'll have lowIOPriority (60), and will block many important processes (UI, WeakArrayFinalization, etc.)" + handlerProcess + priority: Processor userBackgroundPriority; + resume! Item was added: + ----- Method: WebServer>>authAccept:request:realm:header: (in category 'authentication') ----- + authAccept: method request: request realm: realm header: authHeader + "Performs the requested authentication method. + Returns true if successfully authenticated. + Subclasses can extend this method to support more auth methods." + + ^method asLowercase caseOf: { + ['basic'] -> [self basicAuth: request realm: realm header: authHeader]. + ['digest'] -> [self digestAuth: request realm: realm header: authHeader]. + ['bearer'] -> [self bearerAuth: request realm: realm header: authHeader]. + } otherwise:[false]. + ! Item was added: + ----- Method: WebServer>>authHeader:request:realm: (in category 'authentication') ----- + authHeader: method request: request realm: realm + "Answer the authentication header for the given method. + Subclasses can extend this method to support more auth methods." + + ^method asLowercase caseOf: { + ['basic'] -> ['Basic realm="', realm,'"']. + ['digest'] -> ['Digest realm="', realm,'", nonce="', self newNonce,'", qop="auth"']. + ['bearer'] -> ['Bearer realm="', realm,'"']. + } otherwise:[nil]. + + ! Item was added: + ----- 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'. + 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>'. + ! Item was added: + ----- Method: WebServer>>basicAuth:realm:header: (in category 'authentication') ----- + basicAuth: request realm: realm header: authHeader + "Perform Basic auth for the given request" + + | data user pass hash | + data := (authHeader copyAfter: $ ) base64Decoded. + user := data copyUpTo: $:. + pass := data copyAfter: $:. + data atAllPut: $*. data := nil. + + hash := self hashUser: user password: pass realm: realm. + pass atAllPut: $*. pass := nil. + + ^(self passwordHashAt: user, ':', realm) = hash + ! Item was added: + ----- Method: WebServer>>bearerAuth:realm:header: (in category 'authentication') ----- + bearerAuth: request realm: realm header: authHeader + "Perform Bearer-based OAuth2 auth for the given request" + + | data hash | + data := authHeader copyAfter: $ . + hash := WebUtils md5Digest: data, ':', realm. + ^(self passwordHashAt: data, ':', realm) = hash + ! Item was added: + ----- Method: WebServer>>builtinHttpMethods (in category 'initialize') ----- + builtinHttpMethods + "Returns the list of HTTP methods that the server handles built-in, + i.e., without passing them to the registered service." + + ^#('HEAD' 'TRACE' 'OPTIONS')! Item was added: + ----- Method: WebServer>>certName (in category 'accessing') ----- + certName + "The cert name to use for a secure (SSL/TLS) web server." + + ^certName! Item was added: + ----- Method: WebServer>>certName: (in category 'accessing') ----- + certName: aString + "The cert name to use for a secure (SSL/TLS) web server." + + certName := aString.! Item was added: + ----- Method: WebServer>>connections (in category 'accessing') ----- + connections + "The active connection processes. Can only be examined after aquiring + the WebServer's mutex." + + ^connections! Item was added: + ----- Method: WebServer>>critical: (in category 'initialize') ----- + critical: aBlock + "Evaluate aBlock protected byt the server's mutex. + Necessary if code needs to manipulate internal server state." + + ^mutex critical: aBlock + ! Item was added: + ----- Method: WebServer>>defaultHttpMethods (in category 'initialize') ----- + defaultHttpMethods + "Answer the list of HTTP methods that should be be supported by default. + The methods must be implemented by the request handler." + + ^#('GET' 'POST')! Item was added: + ----- Method: WebServer>>destroy (in category 'initialize') ----- + destroy + "Destroys the receiver" + + self stopListener. + self destroyConnections. + listenerSocket ifNotNil:[listenerSocket destroy]. + + "De-register the WebServer" + (self class forUrl: self siteUrl ifAbsent:[self]) == self + ifTrue:[self class removeUrl: siteUrl] + ! Item was added: + ----- Method: WebServer>>destroyConnections (in category 'initialize') ----- + destroyConnections + "Destroy all current connections." + + | copy | + copy := mutex critical: [ connections copy ]. + " #terminate will trigger the #ensure: block in #asyncHandleConnectionFrom:, which will block if we don't release the mutex " + copy do: [ :p | p terminate ]. + " make sure all of them were really removed " + mutex critical: [ connections removeAll ] + ! Item was added: + ----- Method: WebServer>>digestAuth:realm:header: (in category 'authentication') ----- + digestAuth: request realm: realm header: authHeader + "Authenticates an incoming request using Digest auth." + + | user nonce uri response ha1 ha2 md5 qop nc cnonce + nonceData nonceCounter nonceTimeout params | + + params := WebUtils parseAuthParams: authHeader. + + "Flush the nonce cache randomly about every 100 auth attempts" + 100 atRandom = 42 ifTrue:[self flushNonceCache]. + + user := params at: 'username' ifAbsent:['']. + nonce := params at: 'nonce' ifAbsent:['']. + uri := params at: 'uri' ifAbsent:[request url]. + response := params at: 'response' ifAbsent:['']. + + qop := params at: 'qop' ifAbsent:['']. + qop = 'auth' ifFalse:[^false]. "we require qop=auth" + + nc := params at: 'nc' ifAbsent:['']. + cnonce := params at: 'cnonce' ifAbsent:['']. + + "Verify that this is a nonce that we have handed out, that it isn't expired + and that the nc counter has increased from the last use." + mutex critical:[ + nonceData := nonceCache at: nonce ifAbsent:[^false]. + ]. + nonceCounter := nonceData first. "last used nc" + nonceTimeout := nonceData second. "timeout for nonce" + nc <= nonceCounter ifTrue:[^false]. "nc must increase" + Time totalSeconds > nonceTimeout ifTrue:[^false]. "nonce expired" + nonceData at: 1 put: nc. + + ha1 := self passwordHashAt: user, ':', realm. + ha2 := WebUtils md5Digest: request method, ':', uri. + md5 := WebUtils md5Digest: ha1, ':', nonce, ':', nc, ':', cnonce, ':', qop, ':', ha2. + ^md5 = response + ! Item was added: + ----- Method: WebServer>>dispatchRequest: (in category 'handling') ----- + dispatchRequest: request + "Look up the handler for a given request and dispatch to it" + + ^self dispatchRequest: request url: request url! Item was added: + ----- Method: WebServer>>dispatchRequest:url: (in category 'handling') ----- + dispatchRequest: request url: dispatchUrl + "Look up the handler for a given url and dispatch to it" + + | entryUrl action | + "Handle TRACE requests right away" + request method = 'TRACE' ifTrue:[ + ^request send200Response: request asString contentType: 'message/http'. + ]. + + "Look up the entry point for the request" + action := nil. + entryUrl := dispatchUrl asLowercase. + (entryUrl beginsWith: '/') ifFalse:[entryUrl := '/', entryUrl]. + mutex critical:[ + [entryUrl notEmpty and:[action == nil]] whileTrue: [ + action := entryPoints at: entryUrl ifAbsent:[nil]. + entryUrl := entryUrl copyUpToLast: $/. + ]. + action ifNil:[action := entryPoints at: '/' ifAbsent:[nil]]. + ]. + + "Handle OPTIONS requests" + request method = 'OPTIONS' ifTrue:[ + "HEAD, TRACE, and OPTIONS are always supported" + request sendOptionsResponse: self builtinHttpMethods, + (action ifNil:[self defaultHttpMethods] ifNotNil:[action first]) + ]. + + "Handle 404 not found" + action ifNil:[^request send404Response]. + + "Handle 405 method not allowed" + (request method = 'HEAD' "builtin" + or:[(action at: 1) includes: request method]) ifFalse:[ + ^request send405Response: self builtinHttpMethods, action first. + ]. + + ^[self invokeAction: (action at: 2) request: request] + on: Error do:[:ex| + errorHandler + ifNil:[self handleError: ex request: request] + ifNotNil:[errorHandler value: ex value: request] + ]. + ! Item was added: + ----- Method: WebServer>>errorHandler (in category 'accessing') ----- + errorHandler + "The user-supplied error handler. If present the handler takes two arguments: + * The error being caught by WebServer + * The request the error occurred in. + The user-supplied error handler can do whatever it wants, including calling + WebServer's #handleError:request: method which is the default." + + ^errorHandler! Item was added: + ----- Method: WebServer>>errorHandler: (in category 'accessing') ----- + errorHandler: aBlock + "The user-supplied error handler. If present the handler takes two arguments: + * The error being caught by WebServer + * The request the error occurred in. + The user-supplied error handler can do whatever it wants, including calling + WebServer's #handleError:request: method which is the default." + + errorHandler := aBlock.! Item was added: + ----- Method: WebServer>>errorReportFor: (in category 'errors') ----- + errorReportFor: anError + "Provide a report for an error that's been caught during processing" + + ^[ + String streamContents:[:s| + self errorReportFor: anError + stack: ([anError signalerContext stackOfSize: 2000] + on: Error do:[:ex| ex return: #()]) + on: s + ]. + ] on: Error do: [:ex| ex pass. 'error reporting failed'].! Item was added: + ----- Method: WebServer>>errorReportFor:stack:on: (in category 'errors') ----- + errorReportFor: anError stack: preStack on: strm + "Provide a report for an error that's been caught during processing" + + self errorStackFor: anError stack: preStack on: strm. + strm cr; nextPutAll: '-----------------------------------------------------------------'; cr; cr. + self systemInfoOn: strm. + ! Item was added: + ----- Method: WebServer>>errorStackFor:stack:on: (in category 'errors') ----- + errorStackFor: anError stack: preStack on: strm + "Provide a report for an error that's been caught during processing" + + | cnt | + cnt := 0. + (preStack copyFrom: 1 to: (5 min: preStack size)) do:[:ctx| + ctx printDetails: strm. "variable values" + strm cr. + ]. + + strm cr; nextPutAll: '--- The full stack ---'; cr. + cnt := 0. + + preStack do:[:ctx| + cnt := cnt + 1. + cnt = 5 ifTrue: [ + strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. + strm print: ctx; cr. "just class>>selector" + ]. + ! Item was added: + ----- Method: WebServer>>flushNonceCache (in category 'authentication') ----- + flushNonceCache + "Flushes expired nonces from the cache" + + | deadline | + deadline := Time totalSeconds. + mutex critical:[ + nonceCache := nonceCache reject:[:nonceData| deadline > nonceData second] + ]. + ! Item was added: + ----- Method: WebServer>>handleConnectionFrom: (in category 'handling') ----- + handleConnectionFrom: aSocket + "Synchronously handle an incoming socket connection." + + | stream request | + + "Give the process a pretty name" + Processor activeProcess name: (String streamContents:[:s| + aSocket remoteAddress do:[:b| s print: b] separatedBy:[s nextPut: $.]. + s nextPut: $:; print: aSocket remotePort. + s nextPutAll: ' - ', self class name, ' request handler'. + ]). + + "Read the request from the socket, and dispatch it. + Since we've been forked already it's okay to block." + [ + certName ifNil:["Regular request" + stream := SocketStream on: aSocket. + ] ifNotNil:["SSL/TLS" + | ssl | + ssl := Smalltalk at: #SqueakSSL ifAbsent:[self error: 'SqueakSSL not installed']. + stream := ssl secureSocketStream on: aSocket. + [stream sslAccept: certName] on: Error do:[^stream destroy]. + ]. + + [aSocket isConnected] whileTrue:[ + + "Read the next request from the connection. If the connection is closed, + or if a network error occurs, or the read times out, just close the connection + without further ado (rather than logging an error). Any other error resulting + from parsing the input is treated as a 400 bad request." + + stream peek ifNil:[^aSocket destroy]. + request := self newRequest. + [request readFrom: stream] on: Error do:[:ex| + (ex isKindOf: NetworkError) ifFalse:[ + [request send400Response] on: Error do:[:ignore|]. + ]. + ^aSocket destroy]. + + self dispatchRequest: request. + ]. + ] on: Error do:[:ex| + (ex isKindOf: NetworkError) ifFalse:[ + self log: 'Error in request handling: ', ex description. + self log: (self errorReportFor: ex). + ]. + ].! Item was added: + ----- Method: WebServer>>handleError:request: (in category 'errors') ----- + handleError: ex request: aRequest + "The default error handling during processing. Sends a 500 response." + + | errLabel errReport | + errLabel := [ex description] on: Error do:[:ex2| + ex2 return: ex class name + ]. + errReport := [self errorReportFor: ex] on: Error do:[:ex2| + ex2 return: '<error report failed>'. + ]. + [self log: errLabel] on: Error do:[:ex2| ex return]. + [self log: String cr, errReport] on: Error do:[:ex2| ex return]. + aRequest send500Response: errReport. ! Item was added: + ----- Method: WebServer>>hashUser:password:realm: (in category 'authentication') ----- + hashUser: user password: pass realm: realm + "Creates a hash for the given username password pair. + This method is the ha1 part of digest auth and can be used for both digest + as well as basic auth." + + ^WebUtils md5Digest: user, ':', realm, ':', pass! Item was added: + ----- Method: WebServer>>initialize (in category 'initialize') ----- + initialize + "Initialize the receiver" + + mutex := Mutex new. + entryPoints := Dictionary new. + connections := IdentitySet new. + vault := Dictionary new. + nonceCache := Dictionary new. + sessions := Dictionary new. + self logAction:[:aString| Transcript cr; show: aString]. + ! Item was added: + ----- Method: WebServer>>invokeAction:request: (in category 'handling') ----- + invokeAction: action request: request + "Invokes the given action. Subclasses can override this method to serialize + actions if necessary. At this point, the request header has been read from + the network, but not its content." + + ^action valueWithArguments: {request} + ! Item was added: + ----- Method: WebServer>>isRunning (in category 'testing') ----- + isRunning + "Is the server still running?" + + ^self isStopped not! Item was added: + ----- Method: WebServer>>isStopped (in category 'testing') ----- + isStopped + "Is the server still running?" + + ^listenerProcess == nil or:[listenerProcess isTerminated]! Item was added: + ----- Method: WebServer>>listenOn: (in category 'listening') ----- + listenOn: aPort + "Starts the server listening on the given port" + + ^self listenOn: aPort interface: nil! Item was added: + ----- Method: WebServer>>listenOn:interface: (in category 'listening') ----- + listenOn: aPort interface: anInterface + "Starts the server listening on the given port / network interface" + + ^self listenOn: aPort interface: anInterface backlogSize: 8! Item was added: + ----- Method: WebServer>>listenOn:interface:backlogSize: (in category 'listening') ----- + listenOn: aPort interface: anInterface backlogSize: backlog + "Starts the server listening on the given port / network interface" + + | ipString | + interface := anInterface. + port := aPort. + ipString := interface ifNil:['*'] ifNotNil:[ + String streamContents:[:s| interface do:[:b| s print: b] separatedBy:[s nextPut:$.]]]. + self log: 'listener starting (interface: ', ipString, ' port: ', port asString, ')'. + listenerSocket := Socket newTCP. + interface + ifNil:[listenerSocket listenOn: port backlogSize: backlog] + ifNotNil:[listenerSocket listenOn: port backlogSize: backlog interface: interface]. + listenerSocket isWaitingForConnection ifFalse:[ + self error: 'Failed to listen(interface: ', interface printString, ' port: ', aPort printString,' )'. + ]. + self startListener.! Item was added: + ----- Method: WebServer>>listenerInterface (in category 'accessing') ----- + listenerInterface + "Returns the listener interface for the server" + + ^interface! Item was added: + ----- Method: WebServer>>listenerPort (in category 'accessing') ----- + listenerPort + "Returns the listener port for the server" + + ^port! Item was added: + ----- Method: WebServer>>listenerProcess (in category 'accessing') ----- + listenerProcess + "Returns the socket listener process for the server." + + ^listenerProcess! Item was added: + ----- Method: WebServer>>listenerProcessPriority (in category 'listening') ----- + listenerProcessPriority + "The priority at which the listener process should run" + + ^Processor lowIOPriority! Item was added: + ----- Method: WebServer>>listenerSocket (in category 'accessing') ----- + listenerSocket + "Returns the listener socket for the server." + + ^listenerSocket! Item was added: + ----- Method: WebServer>>log: (in category 'initialize') ----- + log: aString + "Log the given information." + + logAction ifNotNil:[logAction valueWithArguments: {aString}]. + ! Item was added: + ----- Method: WebServer>>logAction (in category 'accessing') ----- + logAction + "The current log action (a block or message)" + + ^logAction! Item was added: + ----- Method: WebServer>>logAction: (in category 'accessing') ----- + logAction: aBlockOrMessage + "The current log action (a block or message). + Example: + WebServer new logAction: [:aString| Transcript show: aString]. + WebServer new logAction: (MessageSend receiver: Transcript selector: #show). + " + + logAction := aBlockOrMessage! Item was added: + ----- Method: WebServer>>logRequest:response: (in category 'logging') ----- + logRequest: request response: response + "Log a request after it has been successfully processed" + + accessLog ifNil:[^self]. + + "Do not use the standard exception handler for errors logging; + it would possibly send a 500 response. Really this should be handled + by a different process with its own error handler." + + [WebUtils logRequest: request response: response on: accessLog] + on: Error do:[:ex| self log: 'Error in logging: ', ex description]. + ! Item was added: + ----- Method: WebServer>>newNonce (in category 'authentication') ----- + newNonce + "Create a new nonce to be used for a client authentication session" + + | nonce | + nonce := UUID new hex. + mutex critical:[ + nonceCache at: nonce put: {''. Time totalSeconds + self nonceDeadline}. + ]. + ^nonce! Item was added: + ----- Method: WebServer>>newRequest (in category 'handling') ----- + newRequest + "Answer a new request. + Subclasses should override this method to use a different request class." + + ^(WebRequest new) + server: self; + yourself! Item was added: + ----- Method: WebServer>>nonceDeadline (in category 'authentication') ----- + nonceDeadline + "Answer the number of seconds a nonce is considered valid for digest auth + by the server. After this period, the client will have to reauthenticate. + The default is 30 minutes." + + ^30*60 ! Item was added: + ----- Method: WebServer>>passwordAt:realm:put: (in category 'authentication') ----- + passwordAt: username realm: realm put: password + "Store the password hash for the key." + + | hash | + hash := self hashUser: username password: password realm: realm. + self passwordHashAt: (username,':',realm) put: hash! Item was added: + ----- Method: WebServer>>passwordHashAt: (in category 'authentication') ----- + passwordHashAt: key + "Answer the password hash for the given key" + + ^vault at: key ifAbsent:['']! Item was added: + ----- Method: WebServer>>passwordHashAt:put: (in category 'authentication') ----- + passwordHashAt: key put: hash + "Store the password hash for the key." + + ^vault at: key put: hash! Item was added: + ----- Method: WebServer>>removeService: (in category 'services') ----- + removeService: entryPoint + "Remove a service from the HTTP service provider. See #addService:action:" + + mutex critical:[ + entryPoints removeKey: entryPoint asLowercase ifAbsent: []. + ].! Item was added: + ----- Method: WebServer>>runListener (in category 'listening') ----- + runListener + "Runs the server's listener loop. + Accepts incoming connections and handles them asynchronously" + + | connectionSocket | + [[[listenerSocket notNil and:[listenerSocket isValid]] whileTrue:[ + "Waiting for five seconds means that WebServer will be + back up after roughly five seconds when the system restarts." + connectionSocket := listenerSocket waitForAcceptFor: 5. + "Fork this off since or else errors in acceptClient: kill the listener" + connectionSocket ifNotNil:[self asyncHandleConnectionFrom: connectionSocket]. + ]] ensure:[ + "Logging here is only for the purpose of catching sockets going randomly bad" + self log: 'listener terminating, socket: ', (listenerSocket ifNotNil:[:s| s statusString]). + + "Try to restart the listener" + (listenerSocket notNil and:[listenerSocket isValid not]) ifTrue:[ + listenerSocket destroy. + listenerProcess := nil. + "Wait a little before retrying" + (Delay forSeconds: 2) wait. + ^self listenOn: port interface: interface + ]. + ]] on: Error do:[:ex| self log: ex]. + ! Item was added: + ----- Method: WebServer>>serverDate (in category 'accessing') ----- + serverDate + "Returns the date string to be used in responses" + + ^self class serverDate! Item was added: + ----- Method: WebServer>>serverString (in category 'accessing') ----- + serverString + "Returns the server string to be used in responses. + The response is cached for efficiency." + + ^serverString ifNil:[serverString := self class serverString].! Item was added: + ----- Method: WebServer>>serverString: (in category 'accessing') ----- + serverString: aString + "Set the server string to be used in responses" + + ^serverString := aString! Item was added: + ----- Method: WebServer>>sessionAt: (in category 'sessions') ----- + sessionAt: key + "Answer the session associated with the given key" + + ^mutex critical:[sessions at: key ifAbsent:[nil]].! Item was added: + ----- Method: WebServer>>sessionAt:ifAbsentPut: (in category 'sessions') ----- + sessionAt: key ifAbsentPut: session + "Answer the session associated with the given key" + + ^mutex critical:[sessions at: key ifAbsentPut:[session]].! Item was added: + ----- Method: WebServer>>sessionAt:put: (in category 'sessions') ----- + sessionAt: key put: session + "Store the session associated with the given key" + + ^mutex critical:[sessions at: key put: session].! Item was added: + ----- Method: WebServer>>sessions (in category 'sessions') ----- + sessions + "The sessions associated with the WebServer. These are not used by the server + directly but rather provided so that client code has a convenient place to store + session data." + + ^sessions! Item was added: + ----- Method: WebServer>>sessions: (in category 'sessions') ----- + sessions: aDictionary + "The sessions associated with the WebServer. These are not used by the server + directly but rather provided so that client code has a convenient place to store + session data." + + sessions := aDictionary! Item was added: + ----- Method: WebServer>>siteUrl (in category 'accessing') ----- + siteUrl + "The site URL for WebServer, i.e., http://www.mysite.com or http://www.mysite.com/server (when used in a proxied environment) or https://www.mysite.com (when using SSL). Used to allow a client to derive the 'correct' full URL for a running server instance." + + ^siteUrl! Item was added: + ----- Method: WebServer>>siteUrl: (in category 'accessing') ----- + siteUrl: aString + "The site URL for WebServer, i.e., http://www.mysite.com or http://www.mysite.com/server (when used in a proxied environment) or https://www.mysite.com (when using SSL). Used to allow a client to derive the 'correct' full URL for a running server instance." + + siteUrl := aString! Item was added: + ----- Method: WebServer>>startListener (in category 'listening') ----- + startListener + "Starts the server's listener process" + + self stopListener. + listenerProcess := [self runListener] newProcess. + listenerProcess priority: self listenerProcessPriority. + listenerProcess name: self class name, '''s listener process'. + listenerProcess resume. + ! Item was added: + ----- Method: WebServer>>stopListener (in category 'listening') ----- + stopListener + "Stops the server's listener process" + + listenerProcess ifNotNil:[listenerProcess terminate]. + listenerProcess := nil.! Item was added: + ----- Method: WebServer>>systemInfoOn: (in category 'errors') ----- + systemInfoOn: strm + "Provides system information for a server error report" + + strm nextPutAll: 'VM: '; + nextPutAll: WebUtils platformName; + nextPutAll: ' - '; + nextPutAll: WebUtils vmVersion; + cr. + + strm nextPutAll: 'Image: '; + nextPutAll: SystemVersion current version asString; + nextPutAll: ' ['; + nextPutAll: SmalltalkImage current lastUpdateString asString; + nextPutAll: ']'; + cr. + + strm cr. + + SecurityManager default printStateOn: strm. + + "Additional info available from the windows VM" + WebUtils platformName = 'Win32' ifTrue:[ + 10001 to: 10003 do:[:i| | info | + info := (SmalltalkImage current getSystemAttribute: i) ifNil:['']. + info := info copyReplaceAll: String lf with: String cr. + info isEmpty ifFalse:[strm cr; nextPutAll: info]]]. + ! Item was added: + ----- Method: WebServer>>vault (in category 'accessing') ----- + vault + "The vault used for storing password hashes." + + ^vault! Item was added: + ----- Method: WebServer>>vault: (in category 'accessing') ----- + vault: anObject + "The vault used for storing password hashes. + + Clients can provide their own storage mechanism. + Subclasses can also override the lookup and authentication mechanism." + + vault := anObject! Item was added: + Object subclass: #WebSocket + instanceVariableNames: 'name process stream handlers' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebSocket commentStamp: '<historical>' prior: 0! + A wrapper object for the WebSocket API.! Item was added: + ----- Method: WebSocket class>>example (in category 'example') ----- + example "WebSocket example" + + "This is a very simple WebSocket example implementing a basic chat system. + Each message sent by a client connection is broadcast to everyone." + + | mutex sockets | + mutex := Mutex new. + sockets := OrderedCollection new. + WebServer reset default listenOn: 8080. + + WebServer default addService: '/' action:[:req| + "Serves the main html chat page" + req send200Response: self examplePage contentType: 'text/html'. + ]. + + WebServer default addService: '/broadcast' action:[:req| | ws | + "Implements the WebSocket broadcaster" + ws := req asWebSocket. + ws timeout: 300. "5 minutes timeout" + + Transcript cr; show: 'New ', ws. + + ws onMessage:[:data| + mutex critical:[sockets do:[:s| s send: data]]. + ]. + ws onClose:[ + Transcript cr; show: 'Closing ', ws. + mutex critical:[sockets remove: ws ifAbsent:[]]. + ]. + ws onError:[:ex| + Transcript cr; show: ws. + Transcript cr; show: ex description. + Transcript cr; show: ex signalerContext longStack. + ]. + mutex critical:[sockets add: ws]. + + "We don't need to #fork here, in fact we shouldn't since it ensures + that shutting down WebServer shuts down any WebSockets, too." + ws run. + ].! Item was added: + ----- Method: WebSocket class>>examplePage (in category 'example') ----- + examplePage + "The example HTML page for WebServer" + + ^'<html> + <p id="status">WebSocket: Not connected</p> + <form> + <input type="text" id="chat" placeholder="type and press enter to chat" /> + </form> + <p>To test, open two windows with Web Socket support, type a message above and press return.</p> + <ul id="log"></ul> + + <script> + + var conn = {}; + var log = document.getElementById("log"); + var chat = document.getElementById("chat"); + var form = chat.form; + var state = document.getElementById("status"); + + if (window.WebSocket === undefined) { + state.innerHTML = "(WebSockets not supported)"; + } else { + conn = new WebSocket("ws://localhost:8080/broadcast"); + conn.onopen = function () { + state.innerHTML = "WebSocket: Connected"; + }; + + conn.onmessage = function (event) { + log.innerHTML = "<li>" + event.data + "</li>" + log.innerHTML; + }; + + conn.onclose = function (event) { + state.innerHTML = "WebSocket: Closed"; + }; + + form.addEventListener("submit", function (event) { + event.preventDefault(); + if (conn.readyState === 1) { + conn.send(chat.value); + chat.value = ""; + } + }, false); + }; + + </script> + + </body> + </html>'! Item was added: + ----- Method: WebSocket class>>on: (in category 'instance creation') ----- + on: aStream + "Create a new WebSocket instance using the given SocketStream" + + ^self new on: aStream! Item was added: + ----- Method: WebSocket>>close (in category 'initialize') ----- + close + "Request graceful close" + + ^self subclassResponsibility! Item was added: + ----- Method: WebSocket>>fork (in category 'running') ----- + fork + "Fork the WebSocket's input process." + + process := [self run] newProcess. + process resume. + ! Item was added: + ----- Method: WebSocket>>handle:arguments: (in category 'private') ----- + handle: selector arguments: argList + + ^self handle: selector arguments: argList ifAbsent:[nil]! Item was added: + ----- Method: WebSocket>>handle:arguments:ifAbsent: (in category 'private') ----- + handle: selector arguments: argList ifAbsent: aBlock + + ^(handlers at: selector ifAbsent:[^aBlock value]) + valueWithPossibleArgs: argList.! Item was added: + ----- Method: WebSocket>>handleClose (in category 'private') ----- + handleClose + "Handle a connection close" + + ^self handle: 'close' arguments: (Array with: self) + ! Item was added: + ----- Method: WebSocket>>handleError: (in category 'private') ----- + handleError: exception + "Handle an error" + + ^self handle: 'error' arguments: (Array with: exception with: self)! Item was added: + ----- Method: WebSocket>>handleMessage:type: (in category 'private') ----- + handleMessage: msgData type: msgType + "Handle an incoming message of the given type" + + self handle: 'message' arguments: (Array with: msgData with: msgType with: self)! Item was added: + ----- Method: WebSocket>>initialize (in category 'initialize') ----- + initialize + super initialize. + handlers := Dictionary new.! Item was added: + ----- Method: WebSocket>>on: (in category 'initialize') ----- + on: aStream + "Create a new WebSocket instance using the given SocketStream" + + stream := aStream. + name := String streamContents:[:s| + stream socket remoteAddress + do:[:b| s print: b] + separatedBy:[s nextPut: $.]]. + name := name, ':', stream socket remotePort. + ! Item was added: + ----- Method: WebSocket>>onClose: (in category 'running') ----- + onClose: aBlock + "Set the handler block to invoke when the socket is closed" + + handlers at: 'close' put: aBlock.! Item was added: + ----- Method: WebSocket>>onError: (in category 'running') ----- + onError: aBlock + "Set the handler block to invoke when an error occurs" + + handlers at: 'error' put: aBlock.! Item was added: + ----- Method: WebSocket>>onMessage: (in category 'running') ----- + onMessage: aBlock + "Set the handler block to invoke when a message is received" + + handlers at: 'message' put: aBlock. + ! Item was added: + ----- Method: WebSocket>>printOn: (in category 'private') ----- + printOn: aStream + "Print the receiver" + + aStream nextPutAll: self class name. + aStream nextPutAll: '(', name, ')'.! Item was added: + ----- Method: WebSocket>>run (in category 'running') ----- + run + "Run the WebSocket's input process." + + ^self subclassResponsibility! Item was added: + ----- Method: WebSocket>>send: (in category 'read/write') ----- + send: aString + "Writes one frame worth of data" + + ^self subclassResponsibility! Item was added: + ----- Method: WebSocket>>timeout (in category 'accessing') ----- + timeout + "The underlying stream timeout" + + ^stream timeout! Item was added: + ----- Method: WebSocket>>timeout: (in category 'accessing') ----- + timeout: seconds + "Sets the underlying stream timeout" + + ^stream timeout: seconds! Item was added: + WebSocket subclass: #WebSocket00 + instanceVariableNames: 'frameType frameData' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebSocket00 commentStamp: 'ar 7/8/2010 18:21' prior: 0! + A wrapper object for the WebSocket API.! Item was added: + ----- Method: WebSocket00>>close (in category 'running') ----- + close + "Request graceful close" + + stream isConnected ifFalse: [ ^self ]. + stream + nextPut: (Character value: 255); + nextPut: (Character value: 0); + flush + ! Item was added: + ----- Method: WebSocket00>>readMessage (in category 'read/write') ----- + readMessage + "Reads one frame worth of data" + + | byte length | + byte := stream next ifNil:[ + frameType := 255. + ^nil]. + frameType := byte asInteger. + frameType < 128 ifTrue:[ + "Frame type < 128: UTF-8 encoded text with 0xFF frame delimiter" + frameData := (stream upTo: 255 asCharacter) utf8ToSqueak. + ] ifFalse:[ + "Frame type >= 128: Binary data with length prefix" + length := 0. + [byte := stream next asInteger. + length := (length * 128) + (byte bitClear: 128). + byte >= 128] whileTrue. + frameData := ByteArray new: length. + stream nextInto: frameData. + ]. + ! Item was added: + ----- Method: WebSocket00>>run (in category 'running') ----- + run + "Run the WebSocket's input process." + + [[[stream isConnected] whileTrue:[ + self readMessage. + "XXXX: Should this be moved into handleMessage:type: ???" + frameType = 255 ifTrue:[stream close. ^self]. + self handleMessage: frameData type: frameType. + ]] on: Error do:[:ex| self handleError: ex]] ensure:[ + [stream socket destroy] on: Error do:[:ex|]. + self handleClose. + ]. + ! Item was added: + ----- Method: WebSocket00>>send: (in category 'read/write') ----- + send: aString + "Writes one frame worth of data" + + ^self send: aString type: 0! Item was added: + ----- Method: WebSocket00>>send:type: (in category 'read/write') ----- + send: data type: type + "Writes one frame worth of data using the given frame type" + + "Frame type" + stream nextPut: (Character value: type). + type < 128 ifTrue:[ + "Frame type < 128: UTF-8 encoded text with 0xFF frame delimiter" + stream nextPutAll: data squeakToUtf8. + stream nextPutAll: (Character value: 255). + ] ifFalse:[ | prefix length | + "Frame type >= 128: Binary data with length prefix" + prefix := ByteArray new. + length := data size. + [length > 127] whileTrue:[ + prefix := prefix copyWith: prefix \\ 128. + length := length // 128. + ]. + prefix := prefix copyWith: length. + stream nextPutAll: prefix reversed. + stream nextPutAll: data. + stream flush. + ]. + stream flush. + ! Item was added: + WebSocket subclass: #WebSocket07 + instanceVariableNames: 'frameType frameData closing masking' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebSocket07 commentStamp: '<historical>' prior: 0! + A wrapper object for the WebSocket API.! Item was added: + ----- Method: WebSocket07>>close (in category 'control requests') ----- + close + "Send a close control request" + + closing ifFalse:[ + closing := true. + self send: #[] code: 8. + ].! Item was added: + ----- Method: WebSocket07>>firstFragment: (in category 'read/write') ----- + firstFragment: aStringOrBytes + "Writes the first fragment of data" + + aStringOrBytes isString + ifTrue:[^self send: aStringOrBytes squeakToUtf8 code: 1 final: false] + ifFalse:[^self send: aStringOrBytes code: 2 final: false].! Item was added: + ----- Method: WebSocket07>>handleClose: (in category 'control requests') ----- + handleClose: payload + "Close is being sent by remote in process of shutting down connection" + + closing ifFalse:[^self close]. + + "We're done. We've received the close and responded to it" + stream close. + + ! Item was added: + ----- Method: WebSocket07>>handleControl:type: (in category 'control requests') ----- + handleControl: payload type: opcode + "Handle a control opcode" + + opcode caseOf: { + [8] -> [self handleClose: payload]. + [9] -> [self handlePing: payload]. + [10] -> [self handlePong: payload]. + } otherwise:[self error: 'Unknown control request: ', opcode]. + + ! Item was added: + ----- Method: WebSocket07>>handlePing: (in category 'control requests') ----- + handlePing: payload + + self handle: 'ping' + arguments: (Array with: payload with: self) + ifAbsent:[self pong: payload]. + ! Item was added: + ----- Method: WebSocket07>>handlePong: (in category 'control requests') ----- + handlePong: payload + + self handle: 'pong' arguments: (Array with: payload with: self).! Item was added: + ----- Method: WebSocket07>>initialize (in category 'initialize') ----- + initialize + + super initialize. + closing := false. + masking := true. " http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07#section-… says: + ''Frames sent from the client to the server are masked to + avoid confusing network intermediaries, such as intercepting proxies.''"! Item was added: + ----- Method: WebSocket07>>lastFragment: (in category 'read/write') ----- + lastFragment: aStringOrBytes + "Writes the last fragment of data. + Note: Spec says that code is ZERO for final fragment." + + aStringOrBytes isString + ifTrue:[^self send: aStringOrBytes squeakToUtf8 code: 0 final: true] + ifFalse:[^self send: aStringOrBytes code: 0 final: true].! Item was added: + ----- Method: WebSocket07>>masking (in category 'accessing') ----- + masking + "If true, outgoing frames are masked." + + ^masking! Item was added: + ----- Method: WebSocket07>>masking: (in category 'accessing') ----- + masking: aBool + "If true, outgoing frames are masked." + + masking := aBool! Item was added: + ----- Method: WebSocket07>>nextFragment: (in category 'read/write') ----- + nextFragment: aStringOrBytes + "Writes the first fragment of data + Note: Spec says that code is ZERO for intermediate fragments." + + aStringOrBytes isString + ifTrue:[^self send: aStringOrBytes squeakToUtf8 code: 0 final: false] + ifFalse:[^self send: aStringOrBytes code: 0 final: false].! Item was added: + ----- Method: WebSocket07>>nextNumber:from: (in category 'private') ----- + nextNumber: n from: aStream + "Answer the next n bytes as a positive Integer or LargePositiveInteger." + | s | + s := 0. + 1 to: n do: + [:i | s := (s bitShift: 8) bitOr: aStream next asInteger]. + ^ s normalize! Item was added: + ----- Method: WebSocket07>>onPing: (in category 'control requests') ----- + onPing: aBlock + "Set the handler block to invoke when a ping is received" + + handlers at: 'ping' put: aBlock.! Item was added: + ----- Method: WebSocket07>>onPong: (in category 'control requests') ----- + onPong: aBlock + "Set the handler block to invoke when a pong is received" + + handlers at: 'pong' put: aBlock.! Item was added: + ----- Method: WebSocket07>>ping: (in category 'control requests') ----- + ping: data + "Send a ping control request" + + self send: data code: 9.! Item was added: + ----- Method: WebSocket07>>pong: (in category 'control requests') ----- + pong: data + "Send a pong control request" + + self send: data code: 10.! Item was added: + ----- Method: WebSocket07>>readFrame (in category 'read/write') ----- + readFrame + "Reads one frame worth of data" + + ^self readFrameFrom: stream! Item was added: + ----- Method: WebSocket07>>readFrameFrom: (in category 'read/write') ----- + readFrameFrom: aStream + "Reads one frame worth of data" + + | byte length final mask opcode payload | + byte := (aStream next ifNil:[^nil]) asInteger. + + final := byte anyMask: 128. + opcode := byte bitAnd: 15. + + byte := (aStream next ifNil:[^nil]) asInteger. + mask := byte anyMask: 128. + length := byte bitAnd: 127. + + length = 126 ifTrue:[ + length := self nextNumber: 2 from: aStream. + ] ifFalse:[ + length = 127 ifTrue:[length := self nextNumber: 8 from: aStream]. + ]. + + mask + ifTrue:[mask := aStream next: 4] + ifFalse:[mask := nil]. + + payload := ByteArray new: length. + aStream next: length into: payload. + + "Unmask payload" + mask ifNotNil:[self xor: payload with: mask]. + + "First see if this is a control frame which can be inserted into fragmented messages." + opcode >= 8 ifTrue:[^self handleControl: payload type: opcode]. + + "Now see if this is a fragmented message" + frameType ifNil:[ + frameType := opcode. + frameData := Array with: payload. + ] ifNotNil:[ + frameData := frameData copyWith: payload. + ]. + + final ifTrue:[ + "This was the final fragment" + frameData size = 1 ifTrue:[ + payload := frameData first + ] ifFalse:[ + payload := frameData allButFirst + inject: frameData first + into:[:each :next| each, next]. + ]. + frameType = 1 ifTrue:[payload := payload asString utf8ToSqueak]. + self handleMessage: payload type: frameType. + frameType := frameData := nil. + ]. + ! Item was added: + ----- Method: WebSocket07>>run (in category 'running') ----- + run + "Run the WebSocket's input process." + + [[[stream isConnected] whileTrue:[ + self readFrame. + ]] on: Error do:[:ex| self handleError: ex]] ensure:[ + [stream socket destroy] on: Error do:[:ex|]. + self handleClose. + ]. + ! Item was added: + ----- Method: WebSocket07>>send: (in category 'read/write') ----- + send: aStringOrBytes + "Writes one frame worth of data" + + aStringOrBytes isString + ifTrue:[^self send: aStringOrBytes squeakToUtf8 code: 1] + ifFalse:[^self send: aStringOrBytes code: 2].! Item was added: + ----- Method: WebSocket07>>send:code: (in category 'read/write') ----- + send: data code: opcode + "Sends unfragmented data using the given opcode" + + ^self send: data code: opcode final: true! Item was added: + ----- Method: WebSocket07>>send:code:final: (in category 'read/write') ----- + send: data code: opcode final: isFinal + "Sends unfragmented data using the given opcode" + + ^self send: data code: opcode final: isFinal mask: self masking! Item was added: + ----- Method: WebSocket07>>send:code:final:mask: (in category 'read/write') ----- + send: data code: opcode final: isFinal mask: doMask + "Sends unfragmented data using the given opcode" + + | byte1 byte2 mask xLength copy | + byte1 := opcode. "FIN = 1, RSV1=RSV2=RSV3=0" + isFinal ifTrue:[byte1 := byte1 bitOr: 128]. + data size > 125 ifTrue:[ + data size > 16rFFFF ifTrue:[ + byte2 := 127. + xLength := ByteArray new: 8. + (WriteStream on: xLength) nextNumber: 8 put: data size. + ] ifFalse:[ + byte2 := 126. + xLength := ByteArray new: 2. + (WriteStream on: xLength) nextNumber: 2 put: data size. + ]. + ] ifFalse:[ + byte2 := data size. + xLength := #[]. + ]. + doMask ifTrue:[ + byte2 := byte2 bitOr: 128. "Mask = 1" + mask := ByteArray new: 4. + 1 to: 4 do:[:i| mask at: i put: 256 atRandom-1]. + copy := data copy. + self xor: copy with: mask. + ] ifFalse:[ + copy := data. + ]. + stream nextPut: byte1. + stream nextPut: byte2. + stream nextPutAll: xLength. + mask ifNotNil:[stream nextPutAll: mask]. + stream nextPutAll: copy. + stream flush.! Item was added: + ----- Method: WebSocket07>>xor:with: (in category 'read/write') ----- + xor: data with: mask + "XOR all the data using the given mask bytes. + + WARNING: Does inplace reversal; do not call with literal data." + + "This would be much faster w/ BitBlt but data may not be + 4-byte aligned and so BB will barf." + 1 to: data size do:[:i| + data byteAt: i put: ((data byteAt: i) bitXor: (mask byteAt: i-1 \\ 4 + 1)). + ]. + ! Item was added: + Object subclass: #WebUtils + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'WebClient-Core'! + + !WebUtils commentStamp: 'ar 2/23/2010 10:39' prior: 0! + WebUtils contains a number of utility methods used by WebClient/WebServer.! Item was added: + ----- Method: WebUtils class>>decodeMultipartForm:boundary:do: (in category 'decoding') ----- + decodeMultipartForm: aStream boundary: boundary do: aBlock + "Parse the contents of a multipart/form-data submission. + + Evaluate aBlock with three parts: The headers, the (parsed) form-data + arguments and the (undecoded) contents of the part. The sender is + expected to take care of other issues such as content-transfer-encoding + and similar headers." + + | skip headers content disposition index params | + aStream upToAll: '--', boundary. + [aStream atEnd or:[(skip := aStream next: 2) = '--']] whileFalse:[ + skip = String crlf ifFalse:[self error: 'Error decoding multipart/form-data fields']. + headers := Dictionary new. + (WebUtils readHeadersFrom: aStream) do:[:hdr| headers add: hdr]. + content := aStream upToAll: String crlf, '--', boundary. + params := Dictionary new. + disposition := headers at: 'content-disposition' ifAbsent:['']. + #(name filename) do:[:arg| | len val | + len := arg size + 2. + index := disposition findString: arg,'='. + index > 0 ifTrue:[ + val := disposition copyFrom: index + len to: (disposition indexOf: $" startingAt: index+len) - 1. + params at: arg put: val. + ]. + ]. + aBlock value: headers value: params value: content. + ].! Item was added: + ----- Method: WebUtils class>>decodeUrlEncodedForm: (in category 'decoding') ----- + decodeUrlEncodedForm: aString + "Decodes the fields embedded in the url ?var1=val1&var2=val2" + + ^self decodeUrlEncodedForm: aString multipleValues: false! Item was added: + ----- Method: WebUtils class>>decodeUrlEncodedForm:do: (in category 'decoding') ----- + decodeUrlEncodedForm: aString do: aBlock + "Decodes the fields embedded in the url ?var1=val1&var2=val2. + Evaluates aBlock with the key/value pairs defined in the fields." + + | args keyval index key value | + args := aString readStream. + [args atEnd] whileFalse:[ + keyval := args upTo: $&. + (index := keyval indexOf: $=) = 0 ifTrue:[ + key := keyval. + value := ''. + ] ifFalse:[ + key := keyval copyFrom: 1 to: index-1. + value := keyval copyFrom: index +1 to: keyval size. + ]. + key := key unescapePercentsWithTextEncoding: nil. + value := value unescapePercentsWithTextEncoding: nil. + aBlock value: key value: value. + ]. + ! Item was added: + ----- Method: WebUtils class>>decodeUrlEncodedForm:multipleValues: (in category 'decoding') ----- + decodeUrlEncodedForm: aString multipleValues: aBool + "Decodes the fields embedded in the url ?var1=val1&var2=val2" + + | fields | + fields := Dictionary new. + self decodeUrlEncodedForm: aString do:[:key :value| + aBool + ifTrue:[fields at: key put: (fields at: key ifAbsent:['']), value] + ifFalse:[fields at: key put: value]. + ]. + ^fields! Item was added: + ----- Method: WebUtils class>>decodeUrlEncodedForm:multipleValues:withConverter: (in category 'decoding') ----- + decodeUrlEncodedForm: aString multipleValues: aBool withConverter: aTextConverter + "Decodes the fields embedded in the url ?var1=val1&var2=val2" + + | fields | + fields := Dictionary new. + self decodeUrlEncodedForm: aString do:[:key :value| + aBool + ifTrue:[ + fields + at: key + put: (fields at: key ifAbsent:['']), (value convertFromWithConverter: aTextConverter) ] + ifFalse:[ + fields + at: key + put: (value convertFromWithConverter: aTextConverter) ]. + ]. + ^fields! Item was added: + ----- Method: WebUtils class>>defaultProxyServer (in category 'proxy') ----- + defaultProxyServer + "Answer the default proxy server to use." + + HTTPSocket httpProxyServer isEmptyOrNil ifTrue:[^'']. + + "Note: This is a hack since HTTPSocket is too specific for our use here." + HTTPSocket httpProxyPort = 80 ifTrue:[ + "Assumes that port 80 means 'use default'" + ^HTTPSocket httpProxyServer ifNil:[''] + ] ifFalse:[ + ^HTTPSocket httpProxyServer, ':', HTTPSocket httpProxyPort + ].! Item was added: + ----- Method: WebUtils class>>encodeMultipartForm:boundary: (in category 'decoding') ----- + encodeMultipartForm: fieldMap boundary: boundary + "Encodes the fieldMap as multipart/form-data. + + The fieldMap may contain MIMEDocument instances to indicate the presence + of a file to upload to the server. If the MIMEDocument is present, its + content type and file name will be used for the upload. + + The fieldMap can be EITHER an array of associations OR a Dictionary of + key value pairs (the former is useful for providing multiple fields and/or + specifying the order of fields)." + + ^String streamContents:[:stream| + (fieldMap as: Dictionary) keysAndValuesDo:[:fieldName :fieldValue | | fieldContent | + "Write multipart boundary and common headers" + stream nextPutAll: '--', boundary; crlf. + stream nextPutAll: 'Content-Disposition: form-data; name="', fieldName, '"'. + "Figure out if this is a file upload" + (fieldValue isKindOf: MIMEDocument) ifTrue:[ + stream nextPutAll: '; filename="', fieldValue url pathForFile, '"'; crlf. + stream nextPutAll: 'Content-Type: ', fieldValue contentType. + fieldContent := (fieldValue content ifNil:[ + (FileStream readOnlyFileNamed: fieldValue url pathForFile) contentsOfEntireFile. + ]) asString. + ] ifFalse: [fieldContent := fieldValue]. + stream crlf; crlf. + stream nextPutAll: fieldContent asString. + stream crlf. + ]. + stream nextPutAll: '--', boundary, '--', String crlf. + ]. + ! Item was added: + ----- Method: WebUtils class>>encodeUrlEncodedForm: (in category 'decoding') ----- + encodeUrlEncodedForm: fieldMap + "Encodes the fieldsMap in the form of var1=val1&var2=val2. + The fieldMap can be EITHER an array of associations OR a Dictionary of + key value pairs (the former is useful for providing multiple fields and/or + specifying the order of fields)." + + | associations | + associations := fieldMap isDictionary ifTrue:[fieldMap associations] ifFalse:[fieldMap]. + ^String streamContents:[:s| + associations do:[:assoc| + s nextPutAll: assoc key encodeForHTTP. + assoc value ifNotNil:[ + s nextPutAll: '='. + s nextPutAll: assoc value asString encodeForHTTP + ]. + ] separatedBy:[s nextPutAll:'&']. + ].! Item was added: + ----- Method: WebUtils class>>extractWebSocketKey: (in category 'websockets') ----- + extractWebSocketKey: field + "Decodes a WebSocket key: + + Sec-WebSocket-Key1: 18x 6]8vM;54 *(5: { U1]8 z [ 8 + Sec-WebSocket-Key2: 1_ tx7X d < nw 334J702) 7]o}` 0 + + For each of these fields, the server has to take the digits from the + value to obtain a number (in this case 1868545188 and 1733470270 + respectively), then divide that number by the number of spaces + characters in the value (in this case 12 and 10) to obtain a 32-bit + number (155712099 and 173347027). These two resulting numbers are + then used in the server handshake, as described below. + " + + | digits spaces | + digits := spaces := 0. + field do:[:ch| + ch isDigit ifTrue:[digits := digits * 10 + ch digitValue]. + ch = $ ifTrue:[spaces := spaces + 1]. + ]. + ^digits // spaces. + ! Item was added: + ----- Method: WebUtils class>>handleAuth: (in category 'auth') ----- + handleAuth: aBlock + "Utility method to handle web authentication requests interactively. + + Use like here: + | wc | + wc := WebClient new. + WebUtils handleAuth:[wc httpGet: 'http://some.auth.required']. + " + + | user pass | + ^[aBlock value] on: WebAuthRequired do:[:ex| + "Allow outer handlers to take over authentication" + ex isNested ifFalse:[ + user := UIManager default request: ex message, + '\Please enter your user name:' withCRs initialAnswer:''. + user ifNotEmpty:[ + "Just a little obfuscation to avoid completely plain passwords" + pass := (UIManager default requestPassword: + 'Please enter the password for "', user,'":') base64Encoded. + ex username: user password: [pass base64Decoded]]]. + ex pass].! Item was added: + ----- Method: WebUtils class>>hmacSha1:key: (in category 'oauth') ----- + hmacSha1: message key: signKey + "Compute the SHA1 HMAC for the given message" + + | blockSize key | + blockSize := 64. "SHA1 block size" + key := signKey asByteArray. + key size > blockSize ifTrue:[key := self sha1Hash: key]. + key size < blockSize ifTrue:[key := key grownBy: blockSize - key size ]. + ^self sha1Hash: + (key collect: [ :byte | byte bitXor: 16r5c "opad byte" ]), + (self sha1Hash: (key collect: [ :byte | byte bitXor: 16r36 "ipad byte" ]), message)! Item was added: + ----- Method: WebUtils class>>jsonArray:on: (in category 'json-encode') ----- + jsonArray: anArray on: stream + "Encodes an array" + + stream nextPut: $[. + anArray + do:[:each| self jsonObj: each on: stream] + separatedBy:[stream nextPutAll:', ']. + stream nextPut:$]. + ! Item was added: + ----- Method: WebUtils class>>jsonArrayFrom: (in category 'json-decode') ----- + jsonArrayFrom: stream + "Decodes a JSON [value, *] array from the stream" + + | ch result | + (ch := stream next) = $[ ifFalse:[^self error: 'JSON Array expected']. + stream skipSeparators. + stream peek = $] ifTrue:[stream next. ^#()]. + result := WriteStream on: (Array new: 10). + ["Decode the next value" + stream skipSeparators. + result nextPut: (self jsonDecode: stream). + stream skipSeparators. + (ch := stream next) = $]] whileFalse:[ + ch = $, ifFalse:[^self error: 'Comma expected']. + ]. + + ^result contents! Item was added: + ----- Method: WebUtils class>>jsonChar:on: (in category 'json-encode') ----- + jsonChar: aCharacter on: stream + "Writes a single encoded character" + + | ascii | + ascii := aCharacter asciiValue. + + ascii < 32 ifTrue:["Control character" + ascii caseOf: { + [13] -> [^stream nextPutAll: '\r']. + [12] -> [^stream nextPutAll: '\f']. + [10] -> [^stream nextPutAll: '\n']. + [9] -> [^stream nextPutAll: '\t']. + [8] -> [^stream nextPutAll: '\b']. + } otherwise:[ + ^stream nextPutAll: '\u'; nextPutAll: + ((ascii printStringBase: 16) padded: #left to: 4 with: $0) + ]. + ]. + + (ascii >= 32 and:[ascii <=127]) ifTrue:["Ascii character" + (ascii = 34 or:[ascii = 92 or:[ascii = 47]]) ifTrue:[stream nextPut: $\]. + ^stream nextPut: aCharacter + ]. + + "Encode other characters (control chars, accents, umlauts, unicode)" + stream nextPutAll: + '\u', (((ascii bitAnd: 16rFFFF) printStringBase: 16) padded: #left to: 4 with: $0). + ! Item was added: + ----- Method: WebUtils class>>jsonCharFrom: (in category 'json-decode') ----- + jsonCharFrom: stream + "Decodes a backslash-escaped character" + + | ch | + ^(ch := stream next) caseOf: { + [$u] -> [Unicode value: + (Integer readFrom: (stream next: 4) readStream base: 16)]. + [$r] -> [Character cr]. + [$n] -> [Character lf]. + [$t] -> [Character tab]. + [$b] -> [Character backspace]. + [$f] -> [Character newPage]. + } otherwise:[ch]. + ! Item was added: + ----- Method: WebUtils class>>jsonDecode: (in category 'json-decode') ----- + jsonDecode: stream + "Decodes an arbitrary JSON encoded value from the given stream" + + stream skipSeparators. + ^stream peek caseOf: { + [$"] -> [self jsonStringFrom: stream]. + [$t] -> [self jsonTrueFrom: stream]. + [$f] -> [self jsonFalseFrom: stream]. + [$n] -> [self jsonNullFrom: stream]. + [${] -> [self jsonMapFrom: stream]. + [$[] -> [self jsonArrayFrom: stream]. + } otherwise:[self jsonNumberFrom: stream]. + ! Item was added: + ----- Method: WebUtils class>>jsonEncode: (in category 'json-encode') ----- + jsonEncode: anObject + "Encode the given object as JSON" + + ^String streamContents:[:s| self jsonObj: anObject on: s]! Item was added: + ----- Method: WebUtils class>>jsonFalseFrom: (in category 'json-decode') ----- + jsonFalseFrom: stream + "Decodes 'false' from aStream" + + ((stream next: 5) = 'false' + and:[stream atEnd or:[stream peek isAlphaNumeric not]]) + ifFalse:[^self error: 'Expected ''false''']. + ^false! Item was added: + ----- Method: WebUtils class>>jsonFloatSignificand:exp10: (in category 'json-decode') ----- + jsonFloatSignificand: value exp10: exponent + "Take care to convert to nearest Float" + ^self jsonFloatSignificand: value exp10: exponent scale: (10 raisedTo: exponent abs)! Item was added: + ----- Method: WebUtils class>>jsonFloatSignificand:exp10:scale: (in category 'json-decode') ----- + jsonFloatSignificand: value exp10: exponent scale: scale + "Take care to convert to nearest Float" + "self assert: scale = (10 raisedTo: exponent abs)." + ^(value isAnExactFloat and: ["scale isAnExactFloat" + exponent between: -22 and: 22 + "(1 to: 100) detect: [:i | (10 raisedTo: i) isAnExactFloat not]"]) + ifTrue: [exponent >= 0 + ifTrue: [value asExactFloat * scale asExactFloat] + ifFalse: [value asExactFloat / scale asExactFloat]] + ifFalse: [exponent >= 0 + ifTrue: [(value * scale) asFloat] + ifFalse: [(Fraction numerator: value denominator: scale) asFloat]]! Item was added: + ----- Method: WebUtils class>>jsonFromString: (in category 'json-decode') ----- + jsonFromString: aString + + ^ self jsonDecode: aString readStream! Item was added: + ----- Method: WebUtils class>>jsonMap:on: (in category 'json-encode') ----- + jsonMap: aDictionary on: stream + "Encodes a dictionary" + + stream nextPut: ${. + "Sorting keys ensures deterministic order" + aDictionary keys asArray sort do:[:key| + self jsonString: key on: stream. + stream nextPutAll:': '. + self jsonObj: (aDictionary at: key) on: stream. + ] separatedBy:[stream nextPutAll: ', ']. + stream nextPut: $}.! Item was added: + ----- Method: WebUtils class>>jsonMapFrom: (in category 'json-decode') ----- + jsonMapFrom: stream + "Decodes a JSON {key:value, *} object from the stream" + + | map ch key value | + map := Dictionary new. + (ch := stream next) = ${ ifFalse:[^self error: 'JSON Object expected']. + stream skipSeparators. + stream peek = $} ifTrue:[^map]. + + ["Decode the next key:value pair" + stream skipSeparators. + key := self jsonStringFrom: stream. + stream skipSeparators. + stream next = $: ifFalse:[^self error: 'Key-value pair expected']. + value := self jsonDecode: stream. + map at: key put: value. + stream skipSeparators. + (ch := stream next) = $}] whileFalse:[ + ch = $, ifFalse:[^self error: 'Comma expected']. + ]. + + ^map! Item was added: + ----- Method: WebUtils class>>jsonNullFrom: (in category 'json-decode') ----- + jsonNullFrom: stream + "Decodes 'null' from aStream" + + ((stream next: 4) = 'null' + and:[stream atEnd or:[stream peek isAlphaNumeric not]]) + ifFalse:[^self error: 'Expected ''null''']. + ^nil! Item was added: + ----- Method: WebUtils class>>jsonNumber:on: (in category 'json-encode') ----- + jsonNumber: aNumber on: stream + "Encodes a number" + + | value | + value := aNumber. + value isInteger ifFalse:[value := aNumber asFloat]. + stream print: aNumber. + ! Item was added: + ----- Method: WebUtils class>>jsonNumberFrom: (in category 'json-decode') ----- + jsonNumberFrom: stream + "Decodes a JSON number from the stream" + + | ascii ch integer fraction scale sign expSign exponent exp value beFloat | + integer := fraction := exponent := exp := 0. sign := scale := expSign := 1. + ascii := stream next asciiValue. + ascii = 45 "$- asciiValue" ifTrue:[ + sign := -1. + ascii := stream next asciiValue. + ]. + "JSON requires at least one digit" + (ascii >= 48 and:[ascii <= 57]) ifFalse:[^self error: 'Digit expected']. + + "Read the integer part" + integer := ascii - 48. + [ch := stream next ifNil:[^integer * sign]. + ascii := ch asciiValue. + ascii >= 48 and:[ascii <= 57]] whileTrue:[ + integer := (integer * 10) + (ascii - 48). + ]. + + (beFloat := ascii = 46) "$. asciiValue" ifTrue:[ + "Read the fraction part" + [ch := stream next ifNil: + [value := integer * scale + fraction * sign. + ^self jsonFloatSignificand: value exp10: exponent scale: scale]. + ascii := ch asciiValue. + ascii >= 48 and:[ascii <= 57]] whileTrue:[ + fraction := (fraction * 10) + (ascii - 48). + exponent := exponent - 1. + scale := scale * 10. + ]. + value := integer * scale + fraction * sign. + ] ifFalse:[value := integer * sign]. + (ascii = 69 "$E asciiValue" or:[ascii = 101 "$e asciiValue"]) ifTrue:[ + "Read exponent" + ascii := stream next asciiValue. + ascii = 45 "$- asciiValue" ifTrue:[ + expSign := -1. + ascii := stream next asciiValue. + ] ifFalse:[ascii = 43 "$+ asciiValue" ifTrue:[ascii := stream next asciiValue]]. + exp := ascii - 48. + [ch := stream next ifNil: + [exponent := exp * expSign + exponent. + (beFloat or: [expSign = -1]) ifTrue: [^self jsonFloatSignificand: value exp10: exponent]. + ^value * (10 raisedTo: exponent)]. + ascii := ch asciiValue. + ascii >= 48 and:[ascii <= 57]] whileTrue:[ + exp := (exp * 10) + (ascii - 48). + ]. + exponent := exp * expSign + exponent + ]. + + "Skip back before last character since number might be part of a sequence + like 1, 2, 3, 4, etc (which would eat the trailing comma)" + ch isAlphaNumeric ifTrue:[^self error: 'Delimiter expected']. + stream skip: -1. + + (beFloat or: [expSign = -1]) ifTrue: [^self jsonFloatSignificand: value exp10: exponent]. + ^value * (10 raisedTo: exponent)! Item was added: + ----- Method: WebUtils class>>jsonObj:on: (in category 'json-encode') ----- + jsonObj: anObject on: stream + "Encode a generic object" + + anObject isString ifTrue:[^self jsonString: anObject on: stream]. + anObject isNumber ifTrue:[^self jsonNumber: anObject on: stream]. + anObject == nil ifTrue:[^stream nextPutAll: 'null']. + anObject == true ifTrue:[^stream nextPutAll: 'true']. + anObject == false ifTrue:[^stream nextPutAll: 'false']. + anObject isArray ifTrue:[^self jsonArray: anObject on: stream]. + anObject isDictionary ifTrue:[^self jsonMap: anObject on: stream]. + + self error: 'Cannot encode: ', anObject! Item was added: + ----- Method: WebUtils class>>jsonString:on: (in category 'json-encode') ----- + jsonString: aString on: stream + "Encodes a string" + + stream nextPut: $". + aString do:[:ch| self jsonChar: ch on: stream]. + stream nextPut: $". + ! Item was added: + ----- Method: WebUtils class>>jsonStringFrom: (in category 'json-decode') ----- + jsonStringFrom: stream + "Decodes a JSON encoded string" + + | ch result | + (ch := stream next) = $" + ifFalse:[^self error: 'String expected']. + result := WriteStream on: (String new: 20). + [(ch := stream next) == nil] whileFalse:[ + ch = $" ifTrue:[^result contents]. + ch = $\ ifTrue:[ch := self jsonCharFrom: stream]. + result nextPut: ch. + ]. + ^self error: 'Unterminated string'! Item was added: + ----- Method: WebUtils class>>jsonTrueFrom: (in category 'json-decode') ----- + jsonTrueFrom: stream + "Decodes 'true' from aStream" + + ((stream next: 4) = 'true' + and:[stream atEnd or:[stream peek isAlphaNumeric not]]) + ifFalse:[^self error: 'Expected ''true''']. + ^true! Item was added: + ----- Method: WebUtils class>>logEntryFor:response: (in category 'misc') ----- + logEntryFor: request response: response + "Create a log entry in common log format from the given request / response" + + | entry logdate logsize | + + "CLF prints date as [day/month/year:hour:min:sec zone]" + logdate := String streamContents:[:s| | date | + date := DateAndTime fromSeconds: Time totalSeconds. + s nextPut: $[. + date asDate printOn: s format: #( 1 2 3 $/ 2 1 2). + s nextPut: $:. + date asTime print24: true on: s. + s nextPutAll:(' ', + (date offset hours >= 0 ifTrue:['+'] ifFalse:['-']), + (date offset hours abs asString padded: #left to: 2 with: $0), + (date offset minutes abs asString padded: #left to: 2 with: $0) + ). + s nextPut: $]. + ]. + + "CLF prints zero length as - " + logsize := response contentLength ifNil:[0]. + logsize = 0 ifTrue:[logsize := '-']. + + entry := String streamContents:[:s| + s + nextPutAll: (request remoteHost ifNil:[ + "Substitute with the host header" + (request headerAt: 'host') copyUpTo: $: + ]); + nextPutAll: ' -'; "RFC 1413 identity of client" + nextPutAll: ' -'; "TODO: userid of authenticated user" + nextPutAll: ' ', logdate; + nextPutAll: ' "', request requestLine, '"'; + nextPutAll: ' ', response code; + nextPutAll: ' ', logsize. + ]. + ^entry + ! Item was added: + ----- Method: WebUtils class>>logRequest:response:on: (in category 'misc') ----- + logRequest: request response: response on: streamOrFilename + "Log a request in common log format on the given stream / file." + + | entry stream | + + "Create the log entry for the request/response pair" + entry := self logEntryFor: request response: response. + + "If the argument is a string, it represents the file name to log to" + streamOrFilename isString ifTrue:[ + stream := [FileStream oldFileNamed: streamOrFilename] + on: FileDoesNotExistException + do:[FileStream newFileNamed: streamOrFilename]. + stream wantsLineEndConversion: true; setToEnd. + ] ifFalse:[stream := streamOrFilename]. + + stream nextPutAll: entry; cr. + + stream == streamOrFilename + ifTrue:[stream flush] + ifFalse:[stream close]. + ! Item was added: + ----- Method: WebUtils class>>mcVersion (in category 'misc') ----- + mcVersion + "Answers the Monticello version of WebServer's MC package" + + | version | + Smalltalk at: #MCWorkingCopy ifPresent:[:mc| + mc managersForClass: self do:[:wc| + wc ancestors ifNotEmpty:[:ancestry| version := ancestry first name]]]. + ^version ifNil:[''].! Item was added: + ----- Method: WebUtils class>>md5Digest: (in category 'md5') ----- + md5Digest: aStringOrByteArray + "This creates a little endian hex string to be used with various auth methods + This is the same as htdigest (apache) uses for its md5 digest auth db. + + self md5Digest: 'foo' " + + ^(self md5HashStreamAsBytes: aStringOrByteArray readStream) hex! Item was added: + ----- Method: WebUtils class>>md5HashStream: (in category 'md5') ----- + md5HashStream: aStream + "This method returns the bytes of the md5 hash in revese order for backwards compatibility. Consider updating your implementation to avoid unnecessary reversal. + + self md5HashStream: 'foo' readStream " + + self deprecated: 'Use #md5HashStreamAsBytes: and reverse the bytes in your code.'. + ^(self md5HashStreamAsBytes: aStream) reverseInPlace! Item was added: + ----- Method: WebUtils class>>md5HashStreamAsBytes: (in category 'md5') ----- + md5HashStreamAsBytes: aStream + "Return a ByteArray containing the md5 hash of aStream. + + self md5HashStreamAsBytes: 'foo' readStream " + + | start buffer chunkSize n hash | + hash := WordArray + with: 16r67452301 + with: 16rEFCDAB89 + with: 16r98BADCFE + with: 16r10325476. + buffer := ByteArray new: 64. + start := aStream position. + [ + chunkSize := aStream readInto: buffer startingAt: 1 count: 64. + chunkSize < 64 or: [ aStream atEnd ] ] + whileFalse: [ + WordArray adoptInstance: buffer. + self md5Transform: buffer hash: hash. + ByteArray adoptInstance: buffer ]. + buffer from: chunkSize +1 to: buffer size put: 0. + chunkSize < 56 ifTrue: [ + buffer at: chunkSize + 1 put: 128. "trailing bit" + ] ifFalse:[ + "not enough room for the length, so just pad this one, then..." + chunkSize < 64 ifTrue:[buffer at: chunkSize + 1 put: 128]. + WordArray adoptInstance: buffer. + self md5Transform: buffer hash: hash. + ByteArray adoptInstance: buffer. + "process one additional block of padding ending with the length" + buffer atAllPut: 0. + chunkSize = 64 ifTrue: [buffer at: 1 put: 128]. + ]. + "Fill in the final 8 bytes with the 64-bit length in bits." + n := (aStream position - start) * 8. + 7 to: 0 by: -1 do:[:i| buffer at: (buffer size - i) put: ((n bitShift: 7 - i * -8) bitAnd: 255)]. + "Final round" + WordArray adoptInstance: buffer. + self md5Transform: buffer hash: hash. + ByteArray adoptInstance: hash. "Trick to avoid reallocation." + ^hash! Item was added: + ----- Method: WebUtils class>>md5Transform:hash: (in category 'md5') ----- + md5Transform: in hash: hash + "This adds the incoming words to the existing hash" + + | a b c d | + <primitive: 'primitiveMD5Transform' module: 'CroquetPlugin'> + a := hash at: 1. + b := hash at: 2. + c := hash at: 3. + d := hash at: 4. + + a := self step1: a x: b y: c z: d data: (in at: 1) add: 16rD76AA478 shift: 7. + d := self step1: d x: a y: b z: c data: (in at: 2) add: 16rE8C7B756 shift: 12. + c := self step1: c x: d y: a z: b data: (in at: 3) add: 16r242070DB shift: 17. + b := self step1: b x: c y: d z: a data: (in at: 4) add: 16rC1BDCEEE shift: 22. + a := self step1: a x: b y: c z: d data: (in at: 5) add: 16rF57C0FAF shift: 7. + d := self step1: d x: a y: b z: c data: (in at: 6) add: 16r4787C62A shift: 12. + c := self step1: c x: d y: a z: b data: (in at: 7) add: 16rA8304613 shift: 17. + b := self step1: b x: c y: d z: a data: (in at: 8) add: 16rFD469501 shift: 22. + a := self step1: a x: b y: c z: d data: (in at: 9) add: 16r698098D8 shift: 7. + d := self step1: d x: a y: b z: c data: (in at: 10) add: 16r8B44F7AF shift: 12. + c := self step1: c x: d y: a z: b data: (in at: 11) add: 16rFFFF5BB1 shift: 17. + b := self step1: b x: c y: d z: a data: (in at: 12) add: 16r895CD7BE shift: 22. + a := self step1: a x: b y: c z: d data: (in at: 13) add: 16r6B901122 shift: 7. + d := self step1: d x: a y: b z: c data: (in at: 14) add: 16rFD987193 shift: 12. + c := self step1: c x: d y: a z: b data: (in at: 15) add: 16rA679438E shift: 17. + b := self step1: b x: c y: d z: a data: (in at: 16) add: 16r49B40821 shift: 22. + + a := self step2: a x: b y: c z: d data: (in at: 2) add: 16rF61E2562 shift: 5. + d := self step2: d x: a y: b z: c data: (in at: 7) add: 16rC040B340 shift: 9. + c := self step2: c x: d y: a z: b data: (in at: 12) add: 16r265E5A51 shift: 14. + b := self step2: b x: c y: d z: a data: (in at: 1) add: 16rE9B6C7AA shift: 20. + a := self step2: a x: b y: c z: d data: (in at: 6) add: 16rD62F105D shift: 5. + d := self step2: d x: a y: b z: c data: (in at: 11) add: 16r02441453 shift: 9. + c := self step2: c x: d y: a z: b data: (in at: 16) add: 16rD8A1E681 shift: 14. + b := self step2: b x: c y: d z: a data: (in at: 5) add: 16rE7D3FBC8 shift: 20. + a := self step2: a x: b y: c z: d data: (in at: 10) add: 16r21E1CDE6 shift: 5. + d := self step2: d x: a y: b z: c data: (in at: 15) add: 16rC33707D6 shift: 9. + c := self step2: c x: d y: a z: b data: (in at: 4) add: 16rF4D50D87 shift: 14. + b := self step2: b x: c y: d z: a data: (in at: 9) add: 16r455A14ED shift: 20. + a := self step2: a x: b y: c z: d data: (in at: 14) add: 16rA9E3E905 shift: 5. + d := self step2: d x: a y: b z: c data: (in at: 3) add: 16rFCEFA3F8 shift: 9. + c := self step2: c x: d y: a z: b data: (in at: 8) add: 16r676F02D9 shift: 14. + b := self step2: b x: c y: d z: a data: (in at: 13) add: 16r8D2A4C8A shift: 20. + + a := self step3: a x: b y: c z: d data: (in at: 6) add: 16rFFFA3942 shift: 4. + d := self step3: d x: a y: b z: c data: (in at: 9) add: 16r8771F681 shift: 11. + c := self step3: c x: d y: a z: b data: (in at: 12) add: 16r6D9D6122 shift: 16. + b := self step3: b x: c y: d z: a data: (in at: 15) add: 16rFDE5380C shift: 23. + a := self step3: a x: b y: c z: d data: (in at: 2) add: 16rA4BEEA44 shift: 4. + d := self step3: d x: a y: b z: c data: (in at: 5) add: 16r4BDECFA9 shift: 11. + c := self step3: c x: d y: a z: b data: (in at: 8) add: 16rF6BB4B60 shift: 16. + b := self step3: b x: c y: d z: a data: (in at: 11) add: 16rBEBFBC70 shift: 23. + a := self step3: a x: b y: c z: d data: (in at: 14) add: 16r289B7EC6 shift: 4. + d := self step3: d x: a y: b z: c data: (in at: 1) add: 16rEAA127FA shift: 11. + c := self step3: c x: d y: a z: b data: (in at: 4) add: 16rD4EF3085 shift: 16. + b := self step3: b x: c y: d z: a data: (in at: 7) add: 16r04881D05 shift: 23. + a := self step3: a x: b y: c z: d data: (in at: 10) add: 16rD9D4D039 shift: 4. + d := self step3: d x: a y: b z: c data: (in at: 13) add: 16rE6DB99E5 shift: 11. + c := self step3: c x: d y: a z: b data: (in at: 16) add: 16r1FA27CF8 shift: 16. + b := self step3: b x: c y: d z: a data: (in at: 3) add: 16rC4AC5665 shift: 23. + + a := self step4: a x: b y: c z: d data: (in at: 1) add: 16rF4292244 shift: 6. + d := self step4: d x: a y: b z: c data: (in at: 8) add: 16r432AFF97 shift: 10. + c := self step4: c x: d y: a z: b data: (in at: 15) add: 16rAB9423A7 shift: 15. + b := self step4: b x: c y: d z: a data: (in at: 6) add: 16rFC93A039 shift: 21. + a := self step4: a x: b y: c z: d data: (in at: 13) add: 16r655B59C3 shift: 6. + d := self step4: d x: a y: b z: c data: (in at: 4) add: 16r8F0CCC92 shift: 10. + c := self step4: c x: d y: a z: b data: (in at: 11) add: 16rFFEFF47D shift: 15. + b := self step4: b x: c y: d z: a data: (in at: 2) add: 16r85845DD1 shift: 21. + a := self step4: a x: b y: c z: d data: (in at: 9) add: 16r6FA87E4F shift: 6. + d := self step4: d x: a y: b z: c data: (in at: 16) add: 16rFE2CE6E0 shift: 10. + c := self step4: c x: d y: a z: b data: (in at: 7) add: 16rA3014314 shift: 15. + b := self step4: b x: c y: d z: a data: (in at: 14) add: 16r4E0811A1 shift: 21. + a := self step4: a x: b y: c z: d data: (in at: 5) add: 16rF7537E82 shift: 6. + d := self step4: d x: a y: b z: c data: (in at: 12) add: 16rBD3AF235 shift: 10. + c := self step4: c x: d y: a z: b data: (in at: 3) add: 16r2AD7D2BB shift: 15. + b := self step4: b x: c y: d z: a data: (in at: 10) add: 16rEB86D391 shift: 21. + + a := (a + (hash at: 1)) bitAnd: 16rFFFFFFFF. hash at: 1 put: a. + b := (b + (hash at: 2)) bitAnd: 16rFFFFFFFF. hash at: 2 put: b. + c := (c + (hash at: 3)) bitAnd: 16rFFFFFFFF. hash at: 3 put: c. + d := (d + (hash at: 4)) bitAnd: 16rFFFFFFFF. hash at: 4 put: d. + + ^hash! Item was added: + ----- Method: WebUtils class>>multipartBoundary (in category 'decoding') ----- + multipartBoundary + "Answer a string to be used as multpart boundary in posts" + + ^'----squeak-', Date today,'-', Time millisecondClockValue, '-webclient-----'.! Item was added: + ----- Method: WebUtils class>>oAuthSign:url:extra:using: (in category 'oauth') ----- + oAuthSign: webRequest url: requestUrl extra: postFields using: params + "Sign the given webRequest using the set of oauth parameters provided" + + | epoch timestamp nonce normalized baseString query signature key header extraKeys baseUrl | + + "Allow providing an oauth_timestamp; HOWEVER this is only useful for + tests etc. For actual API calls the timestamp *must* match real-time closely + or else the request will be rejected". + + timestamp := params at: 'oauth_timestamp' ifAbsent:[ + "Timestamp is relative to Jan. 1st 1970 GMT" + epoch := DateAndTime year: 1970 day: 1 hour: 0 minute: 0 second: 0 + offset: (Duration seconds: 0). + (DateAndTime now asUTC - epoch) asSeconds. + ]. + + "Same for nonces (although nonces can be reused)" + nonce := params at: 'oauth_nonce' ifAbsent:[UUID new hex]. + + "Assemble the required parameters. Start with the (POST) body fields." + normalized := (postFields as: Dictionary) associations asOrderedCollection. + + "If present, extract any (GET) fields from the URL" + (requestUrl copyAfter: $?) ifNotEmpty:[:fields| + self decodeUrlEncodedForm: fields do:[:fkey :fval| normalized add: fkey -> fval]]. + + "Keep the extra argument keys so we can exclude them below" + extraKeys := normalized collect:[:assoc| assoc key] as: Set. + normalized add:('oauth_nonce' -> nonce). + normalized add: ('oauth_timestamp' -> timestamp asString). + + normalized add: (params associationAt: 'oauth_consumer_key'). + normalized add: (params associationAt: 'oauth_signature_method'). + normalized add: (params associationAt: 'oauth_version'). + + (params includesKey: 'oauth_callback') ifTrue:[ + normalized add: (params associationAt: 'oauth_callback'). + ]. + (params includesKey: 'oauth_token') ifTrue:[ + normalized add: (params associationAt: 'oauth_token'). + ]. + (params includesKey: 'oauth_verifier') ifTrue:[ + normalized add: (params associationAt: 'oauth_verifier'). + ]. + + normalized := normalized sort:[:a1 :a2| + a1 key = a2 key + ifTrue:[a1 value <= a2 value] + ifFalse:[a1 key <= a2 key]]. + + query := String streamContents:[:s| + normalized do:[:assoc| + s nextPutAll: assoc key. + s nextPutAll: '='. + s nextPutAll: assoc value encodeForHTTP. + ] separatedBy:[s nextPutAll: '&']. + ]. + + baseUrl := (requestUrl copyUpTo: $?) copyUpTo: $#. + baseString := webRequest method, + '&', baseUrl encodeForHTTP, + '&', query encodeForHTTP. + + key := (params at: 'oauth_consumer_secret'), + '&', (params at: 'oauth_token_secret' ifAbsent:['']). + (params at: 'oauth_signature_method') caseOf: { + ['HMAC-SHA1'] -> [ + signature := (WebUtils hmacSha1: baseString key: key) base64Encoded + ]. + } otherwise:[self error: 'Unsupported signature method']. + + header := String streamContents:[:s| + s nextPutAll: 'OAuth '. + "Even though we need to include the extra args in the computation, + they do NOT go into the OAuth header field." + normalized do:[:assoc| + (extraKeys includes: assoc key) + ifFalse:[ s nextPutAll: assoc key, '="', assoc value encodeForHTTP, '",']]. + s nextPutAll: 'oauth_signature="', signature encodeForHTTP, '"'. + ]. + + webRequest headerAt: 'Authorization' put: header.! Item was added: + ----- Method: WebUtils class>>oAuthSign:url:using: (in category 'oauth') ----- + oAuthSign: webRequest url: requestUrl using: params + "Sign the given webRequest using the set of oauth parameters provided" + + ^self oAuthSign: webRequest url: requestUrl extra: #() using: params! Item was added: + ----- Method: WebUtils class>>parseAuthParams: (in category 'auth utils') ----- + parseAuthParams: authHeader + "Parse the auth header to find authentication parameters" + + | authParams stream key value| + authParams := Dictionary new. + stream := ReadStream on: authHeader. + authParams at: 'method' put: (stream upTo: Character space) asLowercase. + [stream skipSeparators. + stream atEnd] whileFalse:[ + key := stream upTo: $=. + stream skipSeparators. + stream peek = $" + ifTrue:[value := stream next; upTo: $". stream upTo: $,] + ifFalse:[value := stream upToAnyOf: ' ,' asCharacterSet]. + authParams at: key asLowercase put: value. + ]. + ^authParams! Item was added: + ----- Method: WebUtils class>>platformName (in category 'misc') ----- + platformName + "Return the name of the platform we're running on." + + ^Smalltalk getSystemAttribute: 1001! Item was added: + ----- Method: WebUtils class>>proxyExceptionsDo: (in category 'proxy') ----- + proxyExceptionsDo: aBlock + "Evaluate aBlock with all registered proxy exceptions. + Uses the information from HTTPSocket." + + HTTPSocket httpProxyExceptions do: aBlock.! Item was added: + ----- Method: WebUtils class>>proxyServerFor: (in category 'proxy') ----- + proxyServerFor: serverName + "Answer the proxy server to use for the given server:port + Returns the proxy server:port to use or nil if no proxy is required." + + | domain | + domain := serverName copyUpTo: $:. + self proxyExceptionsDo:[:pattern| (pattern match: domain) ifTrue:[^nil]]. + ^self defaultProxyServer ifEmpty:[nil]! Item was added: + ----- Method: WebUtils class>>quote: (in category 'quoting') ----- + quote: aString + "Quote the given string, escaping as necessary any embedded quotes" + + ^'"', (aString copyReplaceAll: '"' with: '\"'), '"' + ! Item was added: + ----- Method: WebUtils class>>readHeadersFrom: (in category 'headers') ----- + readHeadersFrom: aStream + "Parse http headers and answer a collection of key -> value pairs." + + | headers nextLine existing | + headers := OrderedCollection new. + [nextLine := aStream upToAll: String crlf. + nextLine isEmpty] whileFalse:[ + nextLine first isSeparator ifTrue:["Continuation as per HTTP 1.1 spec" + existing := headers last. + existing value: (existing value, String space, nextLine withBlanksTrimmed). + ] ifFalse:["Regular header" + headers add: + (nextLine copyUpTo: $:) asLowercase -> + (nextLine copyAfter: $:) withBlanksTrimmed. + ]. + ]. + ^headers! Item was added: + ----- Method: WebUtils class>>rotate:by: (in category 'md5') ----- + rotate: value by: amount + "Rotate value left by amount" + + | lowMask highMask | + lowMask := (1 bitShift: 32-amount) - 1. + highMask := 16rFFFFFFFF - lowMask. + ^((value bitAnd: lowMask) bitShift: amount) + + ((value bitAnd: highMask) bitShift: amount-32)! Item was added: + ----- Method: WebUtils class>>sha1Hash: (in category 'oauth') ----- + sha1Hash: message + "Compute the SHA1 hash for the given message. Slightly different from + SecureHashAlgorithm to produce fixed-length byte arrays." + + | sha hash | + sha := SecureHashAlgorithm new hashMessage: message. + hash := ByteArray new: 20. + 1 to: 20 do:[:i| hash at: i put: (sha digitAt: 21-i)]. + ^hash + ! Item was added: + ----- Method: WebUtils class>>step1:x:y:z:data:add:shift: (in category 'md5') ----- + step1: w x: x y: y z: z data: data add: add shift: s + "Step 1 in MD5 transformation" + + | f result | + f := z bitXor: (x bitAnd: (y bitXor: z)). + result := w + f + data + add. + result := self rotate: result by: s. + ^result + x bitAnd: 16rFFFFFFFF! Item was added: + ----- Method: WebUtils class>>step2:x:y:z:data:add:shift: (in category 'md5') ----- + step2: w x: x y: y z: z data: data add: add shift: s + "Step 2 in MD5 transformation" + + | f result | + f := y bitXor: (z bitAnd: (x bitXor: y)). + result := w + f + data + add. + result := self rotate: result by: s. + ^result + x bitAnd: 16rFFFFFFFF! Item was added: + ----- Method: WebUtils class>>step3:x:y:z:data:add:shift: (in category 'md5') ----- + step3: w x: x y: y z: z data: data add: add shift: s + "Step 3 in MD5 transformation" + + | f result | + f := (x bitXor: y) bitXor: z. + result := w + f + data + add. + result := self rotate: result by: s. + ^result + x bitAnd: 16rFFFFFFFF! Item was added: + ----- Method: WebUtils class>>step4:x:y:z:data:add:shift: (in category 'md5') ----- + step4: w x: x y: y z: z data: data add: add shift: s + "Step 4 in MD5 transformation" + + | f result | + f := y bitXor: (x bitOr: (z bitXor: 16rFFFFFFFF)). + result := w + f + data + add. + result := self rotate: result by: s. + ^result + x bitAnd: 16rFFFFFFFF! Item was added: + ----- Method: WebUtils class>>unquote: (in category 'quoting') ----- + unquote: aString + "Unquote the given string, unescaping as necessary any embedded quotes" + + (aString beginsWith: '"') ifFalse:[^aString]. + (aString endsWith: '"') ifFalse:[^aString]. + ^(aString copyReplaceAll: '\"' with: '"') allButFirst allButLast! Item was added: + ----- Method: WebUtils class>>urlEncode: (in category 'misc') ----- + urlEncode: urlString + "For backwards compatibility only. Use 'urlString urlEncoded' if you can." + + ^urlString asUrl asString! Item was added: + ----- Method: WebUtils class>>vmVersion (in category 'misc') ----- + vmVersion + "Return a string identifying the interpreter version" + + ^Smalltalk getSystemAttribute: 1004! Item was added: + ----- Method: WebUtils class>>webSocketHandshake:with:with: (in category 'websockets') ----- + webSocketHandshake: key1 with: key2 with: data + "Do the actual WebSocket handshake computation" + + | bytes | + bytes := ByteArray new: 16. + bytes longAt: 1 put: key1 bigEndian: true. + bytes longAt: 5 put: key2 bigEndian: true. + bytes replaceFrom: 9 to: 16 with: data. + ^self md5HashStreamAsBytes: bytes readStream! Item was added: + ----- Method: WebUtils class>>webSocketHash07: (in category 'websockets') ----- + webSocketHash07: key + "Do the actual WebSocket hash computation" + + | uid | + uid := '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'. + ^(ByteArray newFrom: (SecureHashAlgorithm new hashMessage: key, uid)) reversed base64Encoded!

1 0

Interesting build problem on Raspberry PI 32 bit
by Bruce O'Neel 11 Apr '23

11 Apr '23

Hi all, First, this is not our problem :-). But it affects us. I have kept a 32 bit Pi OS around even though the rest of my ARM systems are 64 bit. Until today Squeak built fine. The last build I did was 901401c from the 28th but tonight it started failing on Pi OS 32 bit with: tmp/opensmalltalk-vm/platforms/Cross/plugins/BitBltPlugin/BitBltArm64.c:261:9: error: invalid 'asm': invalid operand for code 'w' which is bizarre. Why would it start building the BitBltArm64.c plugin? It's ARM32 (armv7l to be exact). And the is no way that the two commits since the last successful build could have changed this. And what do you know, that commit fails as well now. But there is the problem. uname -m returned armv7l. Yesterday But today it does not return armv7l. Today uname -m and arch both return aarch64. Which is technically at some level correct. This system IS a PI/400 so therefore it is an ARM64, but with a 32 bit OS installed. I think the change is this package: libc-bin:armhf 2.31-13+rpt2+rpi1+deb11u5 We'll see if Debian or Raspberry PI fixes this in the next few days. cheers bruce

5 17

The Trunk: Tools-mt.1197.mcz
by commits＠source.squeak.org 11 Apr '23

11 Apr '23

Marcel Taeumel uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-mt.1197.mcz ==================== Summary ==================== Name: Tools-mt.1197 Author: mt Time: 11 April 2023, 11:03:12.65283 am UUID: a5846202-532b-b44e-803d-4277997b1383 Ancestors: Tools-mt.1196 For custom browsers, simplify extension point for hierarchy-browsing by letting only the Browser class know of its current HierarchyBrowser specialization. StandardToolSet and SystemBrowser (i.e., app registry) only pre-scribe class-side protocol, which is here: #fullHierarchyOnClass: and #fullHierarchyOnClass:selector:. =============== Diff against Tools-mt.1196 =============== Item was added: + ----- Method: Browser class>>fullHierarchyOnClass: (in category 'instance creation') ----- + fullHierarchyOnClass: aClass + + ^ HierarchyBrowser fullOnClass: aClass! Item was added: + ----- Method: Browser class>>fullHierarchyOnClass:selector: (in category 'instance creation') ----- + fullHierarchyOnClass: aClass selector: aSelector + + ^ HierarchyBrowser fullOnClass: aClass selector: aSelector! Item was changed: ----- Method: Model>>addItem: (in category '*Tools') ----- addItem: classAndMethod "Open a browser directly on the given class and method Model new addItem: 'Model addItem:' Model new addItem: 'Model>>addItem:' " self flag: #mref. "classAndMethod is a String" MessageSet parse: classAndMethod toClassAndSelector: [ :class :sel | class ifNil: [^self]. sel = #Comment ifTrue: [^ SystemBrowser default fullOnClassComment: class]. sel = #Definition ifTrue: [^ SystemBrowser default newOnClass: class]. + sel = #Hierarchy ifTrue: [^ SystemBrowser default fullHierarchyOnClass: class]. - sel = #Hierarchy ifTrue: [^ HierarchyBrowser fullOnClass: class]. sel = #Help ifTrue: [^HelpBrowser openOn: class]. SystemBrowser default newOnClass: class selector: sel ] ! Item was changed: ----- Method: StandardToolSet class>>browseHierarchy:selector: (in category 'browsing') ----- browseHierarchy: aClass selector: aSelector + "Open a hierarchy browser" + + ^ SystemBrowser default fullHierarchyOnClass: aClass selector: aSelector! - "Open a browser" - - ^ HierarchyBrowser fullOnClass: aClass selector: aSelector.!

1 0

← Newer
1
2
3
4
5
6
7
8
9
Older →