SystemOrganization addCategory: #'FTP-Server'! SystemOrganization addCategory: #'FTP-Context'! Notification subclass: #FTPStatusNotification instanceVariableNames: 'status' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPStatusNotification class methodsFor: 'status-5xx' stamp: 'lr 11/22/2004 10:44'! badCommandSequencee ^self status: 503 description: 'Bad sequence of commands.'! ! !FTPStatusNotification class methodsFor: 'status-5xx' stamp: 'lr 11/22/2004 10:44'! errorInArguments ^self status: 501 description: 'Syntax error in arguments.'! ! !FTPStatusNotification class methodsFor: 'status-5xx' stamp: 'lr 11/22/2004 10:44'! notImplemented ^self status: 502 description: 'Command not implemented.'! ! !FTPStatusNotification class methodsFor: 'status-1xx' stamp: 'lr 11/22/2004 10:40'! okay ^self status: 200 description: 'Command okay.'! ! !FTPStatusNotification class methodsFor: 'instance-creation' stamp: 'lr 11/22/2004 10:39'! status: aNumber ^self new status: aNumber; signal.! ! !FTPStatusNotification class methodsFor: 'instance-creation' stamp: 'lr 11/22/2004 10:49'! status: aNumber description: aString ^self new status: aNumber; messageText: aString; signal.! ! !FTPStatusNotification class methodsFor: 'status-5xx' stamp: 'lr 11/22/2004 10:43'! unrecognizedCommand ^self status: 500 description: 'Command unrecognized.'! ! !FTPStatusNotification methodsFor: 'printing' stamp: 'lr 11/22/2004 11:08'! printOn: aStream aStream print: self status. self messageText isEmptyOrNil ifFalse: [ aStream space; nextPutAll: self messageText ].! ! !FTPStatusNotification methodsFor: 'accessing' stamp: 'lr 11/22/2004 10:34'! status ^status! ! !FTPStatusNotification methodsFor: 'accessing' stamp: 'lr 11/22/2004 10:34'! status: aNumber status := aNumber! ! Object subclass: #FTPContext instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! FTPContext subclass: #FTPAuthenticatedContext instanceVariableNames: 'username password' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPAuthenticatedContext methodsFor: 'accessing' stamp: 'lr 11/21/2004 19:15'! password ^password! ! !FTPAuthenticatedContext methodsFor: 'accessing' stamp: 'lr 11/21/2004 19:15'! password: aString password := aString! ! !FTPAuthenticatedContext methodsFor: 'accessing' stamp: 'lr 11/21/2004 19:14'! username ^username! ! !FTPAuthenticatedContext methodsFor: 'accessing' stamp: 'lr 11/21/2004 19:15'! username: aString username := aString! ! FTPAuthenticatedContext subclass: #FTPFilesystemContext instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! FTPAuthenticatedContext subclass: #FTPImageContext instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPContext class methodsFor: 'instance creation' stamp: 'lr 11/21/2004 19:32'! on: aConnection ^self new connection: aConnection; yourself.! ! !FTPContext methodsFor: 'private' stamp: 'lr 11/21/2004 19:10'! errorInvalidCommand ^self error: 'Invalid command'! ! !FTPContext methodsFor: 'accessing-information' stamp: 'lr 11/22/2004 00:56'! help ^self class comment.! ! !FTPContext methodsFor: 'actions' stamp: 'lr 11/21/2004 19:26'! password: aString! ! !FTPContext methodsFor: 'accessing-information' stamp: 'lr 11/22/2004 00:56'! statistics ^SmalltalkImage current vmStatisticsReportString.! ! !FTPContext methodsFor: 'accessing-information' stamp: 'lr 11/22/2004 00:55'! system ^SmalltalkImage current vmVersion.! ! !FTPContext methodsFor: 'actions' stamp: 'lr 11/21/2004 19:26'! username: aString! ! Object subclass: #FTPServer instanceVariableNames: 'process port priority context listener' classVariableNames: 'Servers' poolDictionaries: '' category: 'FTP-Server'! !FTPServer commentStamp: 'ijp 1/14/2005 19:09' prior: 0! An FTP Server.! !FTPServer class methodsFor: 'private' stamp: 'lr 11/21/2004 21:35'! addServer: aServer self servers add: aServer.! ! !FTPServer class methodsFor: 'class initialization' stamp: 'lr 11/21/2004 21:35'! initialize Smalltalk addToStartUpList: self.! ! !FTPServer class methodsFor: 'private' stamp: 'lr 11/21/2004 19:56'! removeServer: aServer self servers remove: aServer.! ! !FTPServer class methodsFor: 'accessing' stamp: 'lr 11/21/2004 23:14'! responseCodes ^#(200 'Command okay.' 500 'Syntax error, command unrecognized. This may include errors such as command line too long.' 501 'Syntax error in parameters or arguments.' 202 'Command not implemented, superfluous at this site.' 502 'Command not implemented.' 503 'Bad sequence of commands.' 504 'Command not implemented for that parameter.' 110 'Restart marker reply. In this case, the text is exact and not left to the particular implementation; it must read: MARK yyyy = mmmm Where yyyy is User-process data stream marker, and mmmm server''s equivalent marker (note the spaces between markers and "=").' 211 'System status, or system help reply.' 212 'Directory status.' 213 'File status.' 214 'Help message. On how to use the server or the meaning of a particular non-standard command. This reply is useful only to the human user.' 215 'NAME system type. Where NAME is an official system name from the list in the Assigned Numbers document.' 120 'Service ready in nnn minutes.' 220 'Service ready for new user.' 221 'Service closing control connection. Logged out if appropriate.' 421 'Service not available, closing control connection. This may be a reply to any command if the service knows it must shut down.' 125 'Data connection already open; transfer starting.' 225 'Data connection open; no transfer in progress.' 425 'Can''t open data connection.' 226 'Closing data connection. Requested file action successful (for example, file transfer or file abort).' 426 'Connection closed; transfer aborted.' 227 'Entering Passive Mode (h1,h2,h3,h4,p1,p2).' 230 'User logged in, proceed.' 530 'Not logged in.' 331 'User name okay, need password.' 332 'Need account for login.' 532 'Need account for storing files.' 150 'File status okay; about to open data connection.' 250 'Requested file action okay, completed.' 257 '"PATHNAME" created.' 350 'Requested file action pending further information.' 450 'Requested file action not taken. File unavailable (e.g., file busy).' 550 'Requested action not taken. File unavailable (e.g., file not found, no access).' 451 'Requested action aborted. Local error in processing.' 551 'Requested action aborted. Page type unknown.' 452 'Requested action not taken. Insufficient storage space in system.' 552 'Requested file action aborted. Exceeded storage allocation (for current directory or dataset).' 553 'Requested action not taken. File name not allowed.') ! ! !FTPServer class methodsFor: 'private' stamp: 'lr 11/21/2004 20:06'! servers Servers isNil ifTrue: [ Servers := Set new ]. ^Servers! ! !FTPServer class methodsFor: 'instance creation' stamp: 'lr 11/21/2004 21:19'! start ^self new start; yourself.! ! !FTPServer class methodsFor: 'instance creation' stamp: 'lr 11/21/2004 20:28'! start: aContext ^self new context: aContext; start; yourself.! ! !FTPServer class methodsFor: 'instance creation' stamp: 'lr 11/21/2004 21:36'! start: aContext port: anInteger ^self new context: aContext; port: anInteger; start; yourself.! ! !FTPServer class methodsFor: 'private-callbacks' stamp: 'lr 11/21/2004 21:35'! startUp self servers do: [ :each | each restart ].! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 11/21/2004 20:29'! context context isNil ifTrue: [ context := self defaultContext ]. ^context! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 11/21/2004 20:29'! context: aContext context := aContext.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/21/2004 23:16'! createListener listener := Socket newTCP. listener listenOn: self port backlogSize: self defaultBacklog.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/21/2004 23:56'! createProcess process := Process forContext: [ [ self serverLoop ] ensure: [ self destroyServer ] ] priority: self priority.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/21/2004 21:08'! createServer self createProcess. self createListener.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/22/2004 10:19'! createSession: aSocket FTPSession start: self context copy socket: aSocket server: self.! ! !FTPServer methodsFor: 'accessing-configuration' stamp: 'lr 11/21/2004 20:46'! defaultAcceptTimeout ^10.! ! !FTPServer methodsFor: 'accessing-configuration' stamp: 'lr 11/21/2004 20:46'! defaultBacklog ^10.! ! !FTPServer methodsFor: 'accessing-configuration' stamp: 'lr 11/21/2004 20:31'! defaultContext ^FTPFilesystemContext on: (FileDirectory default).! ! !FTPServer methodsFor: 'accessing-configuration' stamp: 'lr 11/21/2004 20:45'! defaultPort ^21.! ! !FTPServer methodsFor: 'accessing-configuration' stamp: 'lr 11/21/2004 19:47'! defaultPriority ^Processor userBackgroundPriority.! ! !FTPServer methodsFor: 'accessing-configuration' stamp: 'lr 11/22/2004 00:09'! defaultSessionTimeout ^320.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/21/2004 23:16'! destroyListener listener destroy. listener := nil.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/21/2004 20:53'! destroyProcess process := nil.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/21/2004 21:08'! destroyServer self destroyProcess. self destroyListener.! ! !FTPServer methodsFor: 'testing' stamp: 'lr 11/21/2004 23:00'! isConnected ^self listener notNil and: [ self listener isValid ] and: [ self listener isWaitingForConnection ].! ! !FTPServer methodsFor: 'testing' stamp: 'lr 11/21/2004 22:57'! isRunning ^self process notNil.! ! !FTPServer methodsFor: 'accessing-readonly' stamp: 'lr 11/21/2004 22:11'! listener ^listener! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 11/21/2004 19:51'! port port isNil ifTrue: [ port := self defaultPort ]. ^port! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 11/21/2004 19:44'! port: aNumber port := aNumber. self isRunning ifTrue: [ self restart ].! ! !FTPServer methodsFor: 'printing' stamp: 'lr 11/21/2004 21:38'! printOn: aStream super printOn: aStream. aStream space; nextPutAll: 'port: '; print: self port. aStream space; nextPutAll: 'context: '; print: self context.! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 11/21/2004 19:52'! priority priority isNil ifTrue: [ priority := self defaultPriority ]. ^priority! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 11/21/2004 19:43'! priority: aNumber priority := aNumber. self isRunning ifTrue: [ process priority: aNumber ].! ! !FTPServer methodsFor: 'accessing-readonly' stamp: 'lr 11/21/2004 20:56'! process ^process! ! !FTPServer methodsFor: 'actions' stamp: 'lr 11/21/2004 19:45'! restart self stop; start.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/21/2004 20:55'! serverLoop [ self serverLoopBody ] repeat.! ! !FTPServer methodsFor: 'private' stamp: 'lr 11/22/2004 10:19'! serverLoopBody | socket | self isConnected ifFalse: [ self destroyListener; createListener ]. socket := listener waitForAcceptFor: self defaultAcceptTimeout ifTimedOut: [ nil ]. socket notNil ifTrue: [ socket isConnected ifTrue: [ self createSession: socket ] ifFalse: [ socket destroy ] ]. ! ! !FTPServer methodsFor: 'actions' stamp: 'lr 11/21/2004 20:56'! start self isRunning ifTrue: [ ^self ]. self createServer. self process resume. self class addServer: self.! ! !FTPServer methodsFor: 'actions' stamp: 'lr 11/21/2004 20:56'! stop self isRunning ifFalse: [ ^self ]. self process terminate. self class removeServer: self.! ! Object subclass: #FTPSession instanceVariableNames: 'server context socket stream process' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPSession class methodsFor: 'instance-creation' stamp: 'lr 11/21/2004 23:52'! start: aContext socket: aSocket server: aServer self new setSocket: aSocket server: aServer; context: aContext; start.! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:13'! abor: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-login' stamp: 'lr 11/21/2004 23:42'! acct: aString "The argument field is a Telnet string identifying the user's account. The command is not necessarily related to the USER command, as some sites may require an account for login and others only for specific access, such as storing files. In the latter case the command may arrive at any time. There are reply codes to differentiate these cases for the automation: when account information is required for login, the response to a successful PASSword command is reply code 332. On the other hand, if account information is NOT required for login, the reply to a successful PASSword command is 230; and if the account information is needed for a command issued later in the dialogue, the server should return a 332 or 532 reply depending on whether it stores (pending receipt of the ACCounT command) or discards the command, respectively." self writeStatus: 502. ! ! !FTPSession methodsFor: 'commands-file-actions' stamp: 'lr 11/22/2004 00:13'! allo: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:13'! appe: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-login' stamp: 'lr 11/22/2004 00:14'! cdup: aString "This command is a special case of CWD, and is included to simplify the implementation of programs for transferring directory trees between operating systems having different syntaxes for naming the parent directory. The reply codes shall be identical to the reply codes of CWD." self writeStatus: 502.! ! !FTPSession methodsFor: 'accessing' stamp: 'lr 11/21/2004 21:05'! context ^context! ! !FTPSession methodsFor: 'accessing' stamp: 'lr 11/21/2004 23:28'! context: aContext context := aContext.! ! !FTPSession methodsFor: 'private-server' stamp: 'lr 11/22/2004 10:20'! createServer process := Process forContext: [ [ self sessionLoop ] ensure: [ self destroyServer ] ] priority: self server priority.! ! !FTPSession methodsFor: 'commands-login' stamp: 'lr 11/22/2004 00:14'! cwd: aString "This command allows the user to work with a different directory or dataset for file storage or retrieval without altering his login or accounting information. Transfer parameters are similarly unchanged. The argument is a pathname specifying a directory or other system dependent file group designator." self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:13'! dele: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'private-server' stamp: 'lr 11/22/2004 00:03'! destroyServer self stream close. self socket destroy. process := socket := stream := nil.! ! !FTPSession methodsFor: 'private-server' stamp: 'lr 11/22/2004 11:07'! execute: aString | command selector argument | Transcript show: '>> '; show: aString; cr. aString isEmptyOrNil ifFalse: [ command := aString copyUpTo: $ . command notEmpty ifTrue: [ selector := (command asLowercase copyWith: $:) asSymbol. (self isValidCommand: selector) ifTrue: [ argument := aString copyAfter: $ . ^self perform: selector with: argument ] ] ]. FTPStatusNotification notImplemented.! ! !FTPSession methodsFor: 'commands-informational' stamp: 'lr 11/22/2004 01:03'! help: aString self write: self context help.! ! !FTPSession methodsFor: 'testing' stamp: 'lr 11/22/2004 00:06'! isConnected ^self socket isValid and: [ self socket isConnected ].! ! !FTPSession methodsFor: 'testing' stamp: 'lr 11/21/2004 23:51'! isRunning ^self process notNil.! ! !FTPSession methodsFor: 'testing' stamp: 'lr 11/22/2004 00:33'! isValidCommand: aSelector | category | category := self class whichCategoryIncludesSelector: aSelector. ^category notNil and: [ category beginsWith: 'commands' ].! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:14'! list: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:14'! mkd: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-parameters' stamp: 'lr 11/21/2004 23:43'! mode: aString self halt.! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:14'! nlst: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-miscellaneous' stamp: 'lr 11/21/2004 23:37'! noop: aString "This command does not affect any parameters or previously entered commands. It specifies no action other than that the server send an OK reply." self writeStatus: 200.! ! !FTPSession methodsFor: 'commands-login' stamp: 'lr 11/22/2004 00:35'! pass: aString "The argument field is a Telnet string specifying the user's password. This command must be immediately preceded by the user name command, and, for some sites, completes the user's identification for access control. Since password information is quite sensitive, it is desirable in general to 'mask' it or suppress typeout. It appears that the server has no foolproof way to achieve this. It is therefore the responsibility of the user-FTP process to hide the sensitive password information." self context password: aString. self writeStatus: 200.! ! !FTPSession methodsFor: 'commands-parameters' stamp: 'lr 11/21/2004 23:43'! pasv: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-parameters' stamp: 'lr 11/22/2004 00:16'! port: aString self halt.! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 11/21/2004 23:51'! process ^process! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:14'! pwd: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-logout' stamp: 'lr 11/21/2004 23:45'! quit: aString "This command terminates a USER and if file transfer is not in progress, the server closes the control connection. If file transfer is in progress, the connection will remain open for result response and the server will then close it. If the user-process is transferring files for several USERs but does not wish to close and then reopen connections for each, then the REIN command should be used instead of QUIT. An unexpected close on the control connection will cause the server to take the effective action of an abort (ABOR) and a logout (QUIT)." self stop.! ! !FTPSession methodsFor: 'commands-logout' stamp: 'lr 11/21/2004 23:44'! rein: aString "This command terminates a USER, flushing all I/O and account information, except to allow any transfer in progress to be completed. All parameters are reset to the default settings and the control connection is left open. This is identical to the state in which a user finds himself immediately after the control connection is opened. A USER command may be expected to follow." self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-file-actions' stamp: 'lr 11/22/2004 00:13'! rest: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-file-actions' stamp: 'lr 11/22/2004 00:12'! retr: aString self halt.! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:14'! rmd: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:14'! rnfr: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-file-transfer' stamp: 'lr 11/22/2004 00:14'! rnto: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 11/21/2004 21:05'! server ^server! ! !FTPSession methodsFor: 'private-server' stamp: 'lr 11/22/2004 10:20'! sessionLoop [ self isConnected ] whileTrue: [ self sessionLoopBody ].! ! !FTPSession methodsFor: 'private-server' stamp: 'lr 11/22/2004 11:00'! sessionLoopBody self withErrorHandlerDo: [ self withStatusHandlerDo: [ self execute: self stream nextLineCrLf ] ]. ! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 11/21/2004 23:53'! setSocket: aSocket server: aServer socket := aSocket. stream := SocketStream on: aSocket. server := aServer.! ! !FTPSession methodsFor: 'commands-miscellaneous' stamp: 'lr 11/22/2004 00:15'! site: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'commands-login' stamp: 'lr 11/21/2004 23:41'! smnt: aString "This command allows the user to mount a different file system data structure without altering his login or accounting information. Transfer parameters are similarly unchanged. The argument is a pathname specifying a directory or other system dependent file group designator." self writeStatus: 502.! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 11/21/2004 23:49'! socket ^socket! ! !FTPSession methodsFor: 'actions' stamp: 'lr 11/22/2004 10:56'! start self isRunning ifTrue: [ ^self ]. self createServer; writeWelcome. self process resume.! ! !FTPSession methodsFor: 'commands-informational' stamp: 'lr 11/22/2004 00:42'! stat: aString self write: self context statistics.! ! !FTPSession methodsFor: 'actions' stamp: 'lr 11/22/2004 00:20'! stop self isRunning ifFalse: [ ^self ]. self process terminate.! ! !FTPSession methodsFor: 'commands-file-actions' stamp: 'lr 11/22/2004 00:12'! stor: aString self halt.! ! !FTPSession methodsFor: 'commands-file-actions' stamp: 'lr 11/22/2004 00:13'! stou: aString self writeStatus: 502.! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 11/21/2004 21:14'! stream ^stream! ! !FTPSession methodsFor: 'commands-parameters' stamp: 'lr 11/21/2004 23:43'! stru: aString self halt.! ! !FTPSession methodsFor: 'commands-informational' stamp: 'lr 11/22/2004 00:51'! syst: aString self write: self context system.! ! !FTPSession methodsFor: 'commands-parameters' stamp: 'lr 11/21/2004 23:43'! type: aString self halt.! ! !FTPSession methodsFor: 'commands-login' stamp: 'lr 11/22/2004 00:34'! user: aString "The argument field is a Telnet string identifying the user. The user identification is that which is required by the server for access to its file system. This command will normally be the first command transmitted by the user after the control connections are made (some servers may require this). Additional identification information in the form of a password and/or an account command may also be required by some servers. Servers may allow a new USER command to be entered at any point in order to change the access control and/or accounting information. This has the effect of flushing any user, password, and account information already supplied and beginning the login sequence again. All transfer parameters are unchanged and any file transfer in progress is completed under the old access control parameters." self context username: aString. self writeStatus: 200.! ! !FTPSession methodsFor: 'private-handlers' stamp: 'lr 11/22/2004 11:04'! withErrorHandlerDo: aBlock aBlock on: Error do: [ :ex | self write: '500 ' , ex messageText ].! ! !FTPSession methodsFor: 'private-handlers' stamp: 'lr 11/22/2004 11:09'! withStatusHandlerDo: aBlock aBlock on: FTPStatusNotification do: [ :notification | self write: notification asString. notification resume ].! ! !FTPSession methodsFor: 'private-writing' stamp: 'lr 11/22/2004 01:01'! write: aString | command | Transcript show: '<< '; show: aString; cr. command := aString readStream. [ command atEnd ] whileFalse: [ self stream nextPutAll: (command upTo: Character cr). self stream crlf; flush ].! ! !FTPSession methodsFor: 'private-writing' stamp: 'lr 11/22/2004 10:57'! writeWelcome self write: '220 SqueakFtp ready'.! ! FTPServer initialize!