'From Squeak3.1alpha of 28 February 2001 [latest update: #4290] on 24 August 2001 at 3:19:54 pm'! "Change Set: EToyUsers Date: 24 August 2001 Author: Andreas Raab, Michael Rueger Enable a simple login mechanism for schools. *NOT* intended to reliably identify people; only intended to provide basic author information." Preferences addPreference: #eToyLoginEnabled categories: #(security scripting) default: false balloonHelp: 'If true, eToy logins are requested if one of the known servers provides a user list'.! AbstractLauncher subclass: #ProjectLauncher instanceVariableNames: 'showSplash splashURL whichFlaps eToyAuthentificationServer ' classVariableNames: 'LastUserList SplashMorph ' poolDictionaries: '' category: 'Framework-Download'! Object subclass: #ServerDirectory instanceVariableNames: 'server directory type user passwordHolder group moniker altURL urlObject socket loaderUrl eToyUserList eToyUserListUrl ' classVariableNames: 'EtoyUserListUrl LocalProjectDirectories Servers ' poolDictionaries: '' category: 'Network-Kernel'! !AutoStart class methodsFor: 'class initialization' stamp: 'ar 8/23/2001 22:56'! initialize "AutoStart initialize" "Order: ExternalSettings, SecurityManager, AutoStart" Smalltalk addToStartUpList: AutoStart after: SecurityManager.! ! !ExternalSettings class methodsFor: 'class initialization' stamp: 'ar 8/23/2001 22:56'! initialize "ExternalSettings initialize" "Order: ExternalSettings, SecurityManager, AutoStart" Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self! ! !FileDirectory methodsFor: 'enumeration' stamp: 'mir 8/24/2001 12:01'! matchingEntries: criteria "Ignore the filter criteria for now" ^self entries! ! !FileList2 methodsFor: 'as yet unclassified' stamp: 'mir 8/24/2001 12:03'! listForPattern: pat "Make the list be those file names which match the pattern." | sizePad newList entries | directory ifNil: [^#()]. entries _ (Preferences eToyLoginEnabled and: [Utilities authorNamePerSe notNil]) ifTrue: [directory matchingEntries: {'submittedBy: ' , Utilities authorName.} ] ifFalse: [directory entries]. (fileSelectionBlock isKindOf: MessageSend) ifTrue: [ fileSelectionBlock arguments: {entries}. newList _ fileSelectionBlock value. fileSelectionBlock arguments: #(). ] ifFalse: [ newList _ entries select: [:entry | fileSelectionBlock value: entry value: pat]. ]. newList _ newList asSortedCollection: self sortBlock. sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)]) asStringWithCommas size - 1. newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. ^ newList asArray! ! !MIMEDocument methodsFor: 'accessing' stamp: 'ar 8/23/2001 22:38'! contents "Compatibility with stream protocol" ^self content! ! !ProjectLauncher methodsFor: 'running' stamp: 'ar 8/24/2001 15:01'! startUp World ifNotNil: [World install]. Utilities authorName: nil. HTTPClient determineIfRunningInBrowser. Preferences eToyLoginEnabled ifFalse:[^self startUpAfterLogin]. self doEtoyLogin.! ! !ProjectLauncher methodsFor: 'running' stamp: 'ar 8/23/2001 21:50'! startUpAfterLogin | scriptName loader isUrl | HTTPClient isRunningInBrowser ifTrue:[ self setupFromParameters. scriptName _ self parameterAt: 'src'. CodeLoader defaultBaseURL: (self parameterAt: 'Base'). ] ifFalse:[ scriptName _ (Smalltalk getSystemAttribute: 2) ifNil:['']. scriptName isEmpty ifFalse:[ "figure out if script name is a URL by itself" isUrl _ (scriptName asLowercase beginsWith:'http://') or:[ (scriptName asLowercase beginsWith:'file://') or:[ (scriptName asLowercase beginsWith:'ftp://')]]. isUrl ifFalse:[scriptName _ 'file://',scriptName]]. ]. scriptName isEmptyOrNil ifTrue:[^self]. self setupFlaps. loader _ CodeLoader new. loader loadSourceFiles: (Array with: scriptName). (scriptName asLowercase endsWith: '.pr') ifTrue:[self installProjectFrom: loader] ifFalse:[loader installSourceFiles]. ! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/23/2001 22:04'! cancelLogin "This is fine - we just proceed here. Later we may do something utterly different ;-)" ^self proceedWithLogin! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/24/2001 14:36'! doEtoyLogin "Pop up the eToy login if we have a server that provides us with a known user list" "Find us a server who could do eToy authentification for us" eToyAuthentificationServer _ ServerDirectory servers detect:[:any| any eToyUserListUrl notNil] ifNone:[nil]. eToyAuthentificationServer "no server provides user list information" ifNil:[^self startUpAfterLogin]. self prepareForLogin. EtoyLoginMorph loginAndDo:[:userName| self loginAs: userName] ifCanceled:[self cancelLogin].! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/24/2001 15:15'! loginAs: userName "Assuming that we have a valid user url; read its contents and see if the user is really there." | actualName userList | eToyAuthentificationServer ifNil:[ self proceedWithLogin. ^true]. userList _ eToyAuthentificationServer eToyUserList. userList ifNil:[ self inform: 'Sorry, I cannot find the user list. (this may be due to a network problem) Please hit Cancel if you wish to use Squeak.'. ^false]. "case insensitive search" actualName _ userList detect:[:any| any sameAs: userName] ifNone:[nil]. actualName isNil ifTrue:[ self inform: 'Unknown user: ',userName. ^false]. Utilities authorName: actualName. self proceedWithLogin. ^true! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/23/2001 22:06'! prepareForLogin "Prepare for login - e.g., hide everything so only the login morph is visible." World submorphsDo:[:m| m isLocked ifFalse:[m hide]]. "hide all those guys" World displayWorldSafely. ! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/24/2001 15:17'! proceedWithLogin eToyAuthentificationServer _ nil. World submorphsDo:[:m| m show]. WorldState addDeferredUIMessage: [self startUpAfterLogin].! ! !SecurityManager class methodsFor: 'class initialization' stamp: 'ar 8/23/2001 22:56'! initialize "SecurityManager initialize" "Order: ExternalSettings, SecurityManager, AutoStart" Default _ self new initialize. Smalltalk addToStartUpList: self after: ExternalSettings. Smalltalk addToShutDownList: self.! ! !ServerDirectory methodsFor: 'file directory' stamp: 'mir 8/24/2001 12:01'! matchingEntries: criteria "Ignore the filter criteria for now" ^self entries! ! !ServerDirectory methodsFor: 'school support' stamp: 'ar 8/24/2001 15:09'! eToyUserList "Return a list of all known users for eToy login support" | url urlString userString userList | eToyUserList ifNotNil:[^eToyUserList]. urlString _ self eToyUserListUrl. urlString ifNil:[^nil]. url _ urlString asUrl. ["Note: We need to prevent going through the plugin API when retrieving a local (file) URL, since the plugin API (correctly) rejects file:// downloads." Cursor wait showWhile:[ (url hasRemoteContents) ifTrue:[ "Go through the browser (if present)" userString _ (HTTPClient httpGet: url toText) contents. ] ifFalse:[ "Go grab it directly" userString _ url retrieveContents contents. ]. ]. ] on: Error do:[:ex| userString _ nil. ex return]. userString ifNil:[^nil]. "Get rid of any line ending problems" userString _ userString copyReplaceAll: String crlf with: String cr. userString _ userString copyReplaceAll: String lf with: String cr. userList _ (userString findTokens: Character cr) collect:[:each| each withBlanksTrimmed]. userList _ userList reject:[:any| any isEmpty]. (userList first = '##user list##') ifFalse:[^nil]. userList _ userList copyFrom: 2 to: userList size. self eToyUserList: userList. ^userList! ! !ServerDirectory methodsFor: 'school support' stamp: 'ar 8/24/2001 14:31'! eToyUserList: aCollectionOrNil "Set a list of all known users for eToy login support" eToyUserList _ aCollectionOrNil.! ! !ServerDirectory methodsFor: 'school support' stamp: 'ar 8/24/2001 14:29'! eToyUserListUrl ^eToyUserListUrl! ! !ServerDirectory methodsFor: 'school support' stamp: 'ar 8/24/2001 14:31'! eToyUserListUrl: aString eToyUserListUrl _ aString. eToyUserList _ nil.! ! !ServerDirectory class methodsFor: 'available servers' stamp: 'ar 8/24/2001 14:39'! resetLocalProjectDirectories LocalProjectDirectories _ nil.! ! !ServerDirectory class methodsFor: 'server prefs' stamp: 'ar 8/24/2001 14:31'! parseServerEntryFrom: stream | server type directory entries serverName | entries _ self parseServerEntryArgsFrom: stream. serverName _ entries at: 'name' ifAbsent: [^nil]. directory _ entries at: 'directory' ifAbsent: [^nil]. type _ entries at: 'type' ifAbsent: [^nil]. type = 'file' ifTrue: [ ^self addLocalProjectDirectory: (FileDirectory default directoryNamed: directory)]. type = 'bss' ifTrue: [server _ SuperSwikiServer new type: #http]. type = 'http' ifTrue: [server _ HTTPServerDirectory new type: #ftp]. type = 'ftp' ifTrue: [server _ ServerDirectory new type: #ftp]. server directory: directory. entries at: 'server' ifPresent: [:value | server server: value]. entries at: 'user' ifPresent: [:value | server user: value]. entries at: 'group' ifPresent: [:value | server groupName: value]. entries at: 'passwdseq' ifPresent: [:value | server passwordSequence: value asNumber]. entries at: 'url' ifPresent: [:value | server altUrl: value]. entries at: 'loaderUrl' ifPresent: [:value | server loaderUrl: value]. entries at: 'acceptsUploads' ifPresent: [:value | server acceptsUploads: value asLowercase = 'true']. entries at: 'userListUrl' ifPresent:[:value | server eToyUserListUrl: value]. ServerDirectory addServer: server named: serverName. ! ! !SuperSwikiServer methodsFor: 'testing' stamp: 'ar 8/24/2001 15:12'! parseQueryResult: resultStream | projectInfos projectName downloadUrl | projectInfos _ OrderedCollection new. downloadUrl _ self downloadUrl. resultStream reset; nextLine. [resultStream atEnd] whileFalse: [ projectName _ resultStream nextLine. projectInfos add: projectName. "Transcript show: projectName; cr." ]. "Transcript show: 'done'; cr." ^projectInfos ! ! !SuperSwikiServer methodsFor: 'testing' stamp: 'mir 8/24/2001 12:34'! queryProjects: criteria | result | "SuperSwikiServer defaultSuperSwiki queryProjects: #('submittedBy: mir' )" result _ self sendToSwikiProjectServer: { 'action: findproject'. } , criteria.. (result beginsWith: 'OK') ifFalse: [^self inform: result printString]. ^self parseQueryResult: (ReadStream on: result). ! ! !SuperSwikiServer methodsFor: 'for real' stamp: 'mir 8/23/2001 22:15'! allEntries | answer | answer _ self sendToSwikiProjectServer: { 'action: listallprojects'. }. (answer beginsWith: 'OK') ifFalse: [^#()]. ^self parseListEntries: answer! ! !SuperSwikiServer methodsFor: 'for real' stamp: 'mir 8/23/2001 22:16'! entries ^self allEntries! ! !SuperSwikiServer methodsFor: 'for real' stamp: 'ar 8/24/2001 15:04'! matchingEntries: criteria | result | eToyUserListUrl ifNil:[^self entries]. result _ self sendToSwikiProjectServer: { 'action: listmatchingprojects'. } , criteria.. (result beginsWith: 'OK') ifFalse: [^self entries]. "If command not supported" ^self parseListEntries: result! ! !SuperSwikiServer methodsFor: 'private' stamp: 'mir 8/23/2001 22:04'! parseListEntries: listResult | c first | c _ self fastParseEntriesFrom: listResult. c ifNotNil: [^c]. c _ OrderedCollection new. first _ true. listResult linesDo: [ :x | first ifFalse: [c add: (Compiler evaluate: x)]. first _ false. ]. ^c ! ! !Utilities class methodsFor: 'identification' stamp: 'ar 8/23/2001 22:44'! authorName: aString AuthorName _ aString! ! Object subclass: #ServerDirectory instanceVariableNames: 'server directory type user passwordHolder group moniker altURL urlObject socket loaderUrl eToyUserListUrl eToyUserList ' classVariableNames: 'LocalProjectDirectories Servers ' poolDictionaries: '' category: 'Network-Kernel'! !ServerDirectory reorganize! ('do ftp' fileExists: getDirectory getFileList getFileNamed: getFileNamed:into: getOnlyBuffer:from: openFTP openNoDataFTP putFile:named: putFile:named:retry: putFileSavingOldVersion:named: quit sleep wakeUp) ('updates' checkNames: checkServersWithPrefix:andParseListInto: exportUpdatesExcept: outOfDate: putUpdate: putUpdateMulti:fromDirectory: updateInstallVersion:) ('accessing' acceptsUploads: altUrl altUrl: bareDirectory copy directory directory: directoryObject downloadUrl fullPath: isTypeFTP isTypeFile isTypeHTTP loaderUrl loaderUrl: moniker moniker: password password: passwordSequence passwordSequence: printOn: realUrl server server: slashDirectory type: typeForPrefs typeWithDefault url url: urlObject urlObject: user user:) ('file directory' asServerFileNamed: createDirectory: deleteDirectory: deleteFileNamed: directoryNamed: directoryNames entries exists fileAndDirectoryNames fileNamed: fileNames fullNameFor: getOnly:from: includesKey: localNameFor: matchingEntries: newFileNamed: oldFileNamed: oldFileOrNoneNamed: on: pathName pathNameDelimiter pathParts readOnlyFileNamed: rename:toBe: serverDelimiter splitName:to: streamOnBeginningOf:) ('server groups' closeGroup convertGroupName groupName groupName: openGroup serversInGroup) ('initialize' fromUser reset) ('squeaklets' directoryWrapperClass moveAllButYoungest:in:to: upLoadProject:members:retry: upLoadProject:named:resourceUrl:retry: updateProjectInfoFor:) ('file-in/out' storeServerEntryOn:) ('testing' acceptsUploads isProjectSwiki) ('school support' eToyUserList eToyUserList: eToyUserListUrl eToyUserListUrl:) ! SecurityManager initialize! AbstractLauncher subclass: #ProjectLauncher instanceVariableNames: 'showSplash splashURL whichFlaps eToyAuthentificationServer ' classVariableNames: 'SplashMorph ' poolDictionaries: '' category: 'Framework-Download'! ExternalSettings initialize! AutoStart initialize!