rebol [
	Author: "Romano Paolo Tenca"
	Email: rotenca@telvia.it
	Purpose {Fix some bugs in the ftp handler}
	Date: 09/01/2004
	Version: 0.1.57.2
	File %ftp-patch.r
	Notes: {
		THIS VERSION WORKS ONLY FROM VIEW >= 1.2.10

	  	ADDED SUPPORT FOR NLST MODE
  		The 'nlst algorithm is much more slower than the 'list algorithm,
  		especially with long directories.
  		Use it only if FTP fails in reading directories.
		Usage:
	  		To activate the NLST mode, set port/algorithm (local) or
	  		system/schemes/ftp/algorithm (global) to 'nlst, before opening the port.
	  		Examples:
		  		port/algorithm: 'nlst
		  	or
		  		system/schemes/ftp/algorithm: 'nlst
	}
	Acknowledgment: {
		Thanks to Brett Handley, Ashley Trüter, Kaj de Vos for their support.
		(#.1.# = Rebug version)
	}
	Todo: {
	  	- close-on-fail should cache all ports like close
	}
	History: [
	  0.1.57.2 BETA 09/01/2004 {
	  	- ADDED SUPPORT FOR NLST
	  		- parse-dir-list: if port/algorithm = 'nlst, nlst-check is used instead of list-check
	  		  and every item is tested with CWD to check if it is a dir
	  		- now parse-files check for type <> 'nlst (instead of = 'list)
	  	- moved all function inside the handler, deleted ftp-utils
	  	- changed connections word with conns in open
	  }
	  0.1.57.1 BETA 26/12/03 {
	  	- changed accept/listen handle
	  }
	  0.1.56 BETA 26/12/03 {
	  	- changed name of function close-sub-port to confirm-transfer
	  	- now close cache all cmd ports
	  	- removed file-list-check (now we are always on the right dir, LIST is enough)
	  	- changed replace in parse-cur-dir (CWD must support the syntax CWD a"b)
	  	- added parse-cur-dir (to make easier to change the parse rule)
	  	- now mkdir-check use locals/file instead of target
	  	- new-dir? is no more a function
	  	- added new? var to open
	  	- now fully supports url definition with a block (RT code failed if url was a block)
	  		* changed query and open
	  	- added locals shortcut to parse-dir-list
	  	- removed status field from locals (unuseful)
	  	- removed query field from cmd-port-locals (unuseful)
	  	- added prototype objects port-locals and cmd-port-locals
	  	- no more call get-cur-dir if path is empty (unuseful)
		- changed to-string # in scopy "" (more fast)
	  	- chdir-check changed: no more ./ (unuseful and problems with AS400)
		- added 125 to append-check
	  	- added 250 to transfer-check (some servers return it instead of 226)
	  	- added local x to data-connect (global x was overwritten)
	  	- removed "form type" (unuseful)
		- changed the name of error-try to error-try?
	  }
	  0.1.55 BETA 22/12/03 {
		- fixed mkdir-check and mk-dir code,
		- added some missing error? (after the try-catch remove)
		- added try-error
		- use close-cmd in open for wrong cached connections
	}
	  0.1.54 BETA 20/12/03 "removing catch - THIS VERSION WORKS ONLY FROM VIEW >= 1.2.10"
	  0.0.53 BETA 30/11/03 ""
	 ]
]

;system/options/quiet: false

ftp-utils: make object! [
	;debug option
	raw-lst: off
	make root-protocol [
		spick: sremove: scopy: sclose: sopen: sget-modes: none
		set [spick sremove scopy sclose sopen sget-modes]
		reduce bind [:pick :remove :copy :close :open :get-modes] 'system
		connections: make block! 5
	
		open-check: [none ["220" "230"] ["USER" port/user] "331" ["PASS" port/pass] "230" "SYST" "*"]
		close-check: ["QUIT" ["221" "421"]]
		write-check: ["TYPE I" "200" ["STOR" port/target] ["150" "125"]]

		active-check: [["PORT" port/locals/active-check] "200"]
		read-check: [["RETR" port/target] ["150" "125"]]
		restart-check: [["REST" port/state/index] "350"]
		chdir-check: [["CWD" port/path] ["25" "200"]]
		root-check: [["CWD" port/locals/home-dir] ["25" "200"]]
		list-check: ["TYPE A" "200" "LIST" ["150" "125"]]
		nlst-check: ["TYPE A" "200" "NLST" ["150" "125" ]]
		binary-type-check: ["TYPE I" "200"]
		append-check: ["TYPE I" "200" ["APPE" port/target] ["150" "125"]]
		mkdir-check: [["MKD" port/locals/file] "25"]
		rmdir-check: [["RMD" port/locals/file] "250"]
		rmfile-check: [["DELE" port/locals/file] "250"]
		rename-check: [["RNFR" port/locals/file] "350" ["RNTO" port/locals/to-name] "250"]
		transfer-check: [none ["226" "250"]]
		passive-check: ["PASV" "227"]
		pwd-check: ["PWD" "25"]

		port-locals: make object! [dir-cache: listen-port: passive: cmd-port: none]
		cmd-port-locals: make object! [active-check: file: to-name: home-dir: updated: tuple: none]
	
		error-try?: func [blk][error? try blk]
		confirm-cmd: func [port [port!] check [block!]] [
			net-utils/confirm/multiline port/locals/cmd-port check
		]
		close-cmd: func [cmd-port] [
			net-utils/net-log reform ["Closing cmd port" cmd-port/local-port cmd-port/remote-port]
			error-try? [sclose cmd-port]
		]
		close-listen: func [port] [
			if port? port/locals/listen-port [
				net-utils/net-log reform ["Closing listen port" port/locals/listen-port/local-port]
				error-try? [sclose port/locals/listen-port]
			]
		]
		close-on-fail: func [port blk /local res] [
			if error? set/any 'res try blk [
				if port/locals [
					close-cmd port/locals/cmd-port
					close-listen port
				]
			]
			all [value? 'res res]
		]
		append-active: func [check [string!] id] [
			insert tail check rejoin ["." to-integer id / 256 "." id // 256]
			replace/all check #"." #","
		]
		dir-read?: func [port] [empty? port/target]
		parse-cur-dir: func [str] [
			replace/all second
				parse/all
					replace/all str {""} "^/"
				" ^-"
			"^/" {"}
		]
		parse-files: func [
			str type {none (=list) or 'nlst depending on what list op was performed}
			/local result digit char space attrs chars new-line sp ftp-list ftp-dir vars
			attr owner group size date time file pdate month info-block
			loc ftp-nlst msftp-list msftp-dir dir file-rule
			no-space nosp
			add-date digits no-newline ftp-nlist reduced
		] [
			result: scopy []
			digit: charset "0123456789"
			char: charset [#"a" - #"z" #"A" - #"Z" #"0" - #"9" "=+-_.:&$*',"]
			space: charset " ^-"
			no-space: complement space
			nosp: [any no-space]
			no-newline: complement charset "^M^/"
			attrs: charset "-dlrwxXsStT"
			chars: [any char]
			digits: [any digit]
			new-line: [newline | "^M^/"]
			sp: [any space]
			add-date: func [] [
				month: first pdate
				sremove pdate
				insert next pdate month
				if 3 > length? pdate [
					insert tail pdate now/year
					insert tail pdate to-time time
				]
				loop length? loc: pdate [insert loc "/" loc: skip loc 2]
				sremove pdate
				if (now + 1) < loc: to-date rejoin pdate [loc/year: loc/year - 1]
				insert tail info-block loc
			]
			ftp-list: [
				ftp-dir
				(
					type: 'file
					reduced: reduce vars
					append result to-file rejoin [
						either #"l" = first attr [type: 'link scopy/part file find file " ->"] [file]
						either #"d" = first attr [type: 'directory "/"] [""]
					]
					insert/only tail result info-block: reduce [type to-integer size]
					pdate: parse date none
					add-date
				)
				new-line
			]
			file-rule: [copy file [some no-newline | to "^M^/"]]
			ftp-dir: [
				copy attr 10 attrs sp
				digits sp
				copy owner nosp sp
				copy group nosp sp
				copy size digits sp
				copy date [chars sp digits sp [digits some space | none]]
				copy time [[digits ":" digits sp] | none]
				file-rule
			]
			msftp-list: [
				msftp-dir
				(
					insert tail result to-file file
					insert/only tail result info-block: reduce [type to-integer size]
					pdate: parse date "-"
					add-date
				)
				new-line
			]
			msftp-dir: [
				copy date to " " sp
				copy time [digits ":" digits] (time: to-time time)
				copy ampm to " " sp (if ampm = "PM" [time: time + 12:00])
				[<DIR> (type: 'directory size: 0) | copy size digits (trim/tail size type: 'file)]
				sp file-rule (if type = 'directory [insert tail file "/"])
			]
			ftp-nlist: [
				file-rule (
					insert tail result reduce [to-file file reduce ['file none none]]
				)
				new-line
			]
			vars: [attr owner group size date time file]
			set vars none
			either type <> 'nlst [
				if not parse/all str ["total" sp digits sp new-line some ftp-list | some ftp-list] [
					parse/all str [some msftp-list]
				]
			] [
				parse/all str [some ftp-nlist]
			]
			result
		]
		get-cur-dir: func [cmd-port] [
			parse-cur-dir net-utils/confirm cmd-port pwd-check
		]
		parse-dir-list: func [port /local file-list line dir-cache tmp] [
			file-list: make string! 2000
			while [line: spick port/sub-port 1] [insert insert tail file-list line newline]
			;debug
			if raw-lst [print ["Raw-lst:" newline mold file-list]]
			confirm-transfer port
			port/locals/dir-cache: dir-cache: parse-files file-list port/algorithm ;none or 'nlst
			foreach item [%./ %../] [sremove/part find dir-cache item 2]
			if port/algorithm = 'nlst [
				tmp: get-cur-dir port/locals/cmd-port
				if slash <> spick tail tmp -1 [insert tail tmp slash]
				foreach [name blk] dir-cache [
					if not error? try [
						confirm-cmd port [[join "CWD " [tmp name]] ["25" "200"]]
					][insert tail name slash blk/1: 'directory]
				]
				confirm-cmd port [[join "CWD " tmp] ["25" "200"]]
			]
			(length? dir-cache) / 2
		]
		confirm-transfer: func [port] [
			net-utils/net-log reform ["Closing data port" port/sub-port/host port/sub-port/local-port port/sub-port/remote-port]
			sclose port/sub-port
			confirm-cmd port transfer-check
		]
		data-connect: func [
			port
			/local a-check info num tmp
			locals proxy cmd-port x
		] [
			proxy: all [port/proxy/host port/proxy]
			locals: port/locals
			cmd-port: port/locals/cmd-port
			if any [
				all [proxy proxy/type <> 'socks5 proxy/type <> 'socks]
				all [
					not locals/passive
					not proxy
					error-try? [
						locals/listen-port: sopen/lines [
							scheme: 'tcp
							port-id: 0
							timeout: port/timeout
						]
						net-utils/net-log reform ["Opening listen port" locals/listen-port/port-id]
						a-check: form reduce either zero? locals/listen-port/local-ip [
							cmd-port/local-ip
						][
							locals/listen-port/local-ip
						]
						cmd-port/locals/active-check: append-active a-check locals/listen-port/port-id
						confirm-cmd port active-check
					]
				]
			] [locals/passive: true]
			if all [proxy not locals/passive] [
				cmd-port/host: port/host
				cmd-port/proxy: proxy
				port/sub-port: net-utils/connect-proxy cmd-port 'bind
				cmd-port/locals/active-check: append-active reform port/sub-port/host port/sub-port/port-id
				if error-try? [confirm-cmd port active-check] [locals/passive: true]
			]
			if locals/passive [
				info: make string! 16
				if not parse tmp: confirm-cmd port passive-check [
					thru #"("
					4 [copy x integer! #"," (insert insert tail info x #".")]
					(sremove back tail info)
					[copy x integer! (num: 256 * to-integer x) #"," copy x integer! (num: num + to-integer x) #")"]
					to end
				] [
					net-error join "Invalid port or id number string: " mold tmp
				]
				cmd-port/host: info
				cmd-port/port-id: num
				cmd-port/proxy: proxy
				port/sub-port: either all [proxy proxy/type <> 'generic] [
					net-utils/connect-proxy cmd-port 'connect
				][
					sopen/lines [
						scheme: 'tcp
						host: cmd-port/host
						port-id: num
						timeout: port/timeout
					]
				]
			]
		]
		accept-connect: func [port type][
			if not port/locals/passive [
				either port/locals/listen-port [
					if type <> 'new-dir [port/sub-port: first port/locals/listen-port]
					close-listen port
					port/locals/listen-port: none
				][
					net-utils/accept-proxy port/sub-port
				]
			]
		]
		open: func [
			port
			/local type tmp new-dir? proxy conn
			locals conns cache-size cached
			new? cmd-port
		] [
			close-on-fail port [
				proxy: found? port/proxy/host
				any [port/user port/user: "anonymous"]
				any [port/pass port/pass: rebol-anon@rebol.com]
				if error-try? [to-tuple tmp: port/host] [tmp: form system/words/read join dns:// port/host]
				conns: connections
				while [not empty? conns] [
					conn: first conns
					either all [conn/host = tmp conn/user = port/user] [
						sremove conns
						either error-try? [
							net-utils/confirm/multiline conn root-check
						] [
							close-cmd conn
						] [
							port/locals: make port-locals [cmd-port: conn]
							port/state/flags: port/state/flags or port-flags
							net-utils/net-log reform ["Using the cached port" conn/host conn/local-port conn/remote-port]
							break
						]
					] [conns: next conns]
				]
				locals: port/locals
				if none? locals [
					open-proto port
					locals: port/locals: make port-locals [cmd-port: port/sub-port]
					port/sub-port: none
					locals/cmd-port/locals: make cmd-port-locals [
						tuple: tmp
						home-dir: get-cur-dir locals/cmd-port
					]
				]
				locals/passive: system/schemes/ftp/passive
				cmd-port: locals/cmd-port
				cmd-port/path: port/path: any [port/path scopy ""]
				cmd-port/target: port/target: any [port/target scopy ""]
				if dir-read? port [
					all [
						sget-modes port 'direct
						net-error "Cannot open a dir port in direct mode"
					]
					port/state/flags: port/state/flags or system/standard/port-flags/pass-thru
				]
				all [
					port/state/index <> 0
					any [not sget-modes port 'binary dir-read? port]
					net-error "Cannot skip a not binary file port"
				]
				data-connect port
				new?: port/state/flags and system/standard/port-flags/open-new <> 0
				if not empty? port/path [
					if new-dir?: all [dir-read? port new?][
						cmd-port/path: first tmp: split-path to-file cmd-port/path
						cmd-port/locals/file: second tmp
						if 1 < length? cmd-port/locals/file [
							sremove back tail cmd-port/locals/file
						]
					]
					if cmd-port/path <> %./ [
					 	confirm-cmd port chdir-check
					]
				]
				net-utils/net-log join "Type: " type: any [
					all [new-dir? 'new-dir]
					all [new? 'new]
					all [dir-read? port 'dir]
					all [port/state/flags and system/standard/port-flags/open-append <> 0 'app]
					'file
				]
				do select [
					file [
						confirm-cmd port either port/algorithm = 'nlst [nlst-check][list-check]
						accept-connect port type
						parse-dir-list port
						if tmp: select locals/dir-cache to-file port/target [
							port/status: first tmp
							port/date: third tmp
							if any [none? port/size: second tmp 1024 > port/size] [port/size: 0]
						]
						data-connect port
						confirm-cmd port binary-type-check
						if 0 < cmd-port/state/index: port/state/index [
							confirm-cmd port restart-check
						]
						confirm-cmd port read-check
					]
					new [confirm-cmd port write-check]
					new-dir [confirm-cmd port mkdir-check]
					dir [confirm-cmd port either port/algorithm = 'nlst [nlst-check][list-check]]
					app [confirm-cmd port append-check]
				] type
				accept-connect port type
				if type = 'dir [
					port/size: port/state/tail: parse-dir-list port
				]
			]
			port
		]
		close: func [port /local cmd-port cache-size] [
			cmd-port: port/locals/cmd-port
			if not dir-read? port [error-try? [confirm-transfer port]]
			net-utils/net-log reform ["Caching cmd-port" cmd-port/host cmd-port/local-port cmd-port/remote-port]
			cmd-port/host: cmd-port/locals/tuple
			cmd-port/locals/updated: now/time
			append connections cmd-port
			any [integer? cache-size: system/schemes/ftp/cache-size cache-size: 0]
			while [cache-size < length? connections] [
				close-cmd first connections
				sremove connections
			]
		]
		query: func [port /local info file path err dir-cache] [
			either not port/locals [
				if port/target [
					file: to-file port/target
					port/target: none
				]
				open port
				close port
				dir-cache: port/locals/dir-cache
				either none? file [
					port/status: 'directory
					port/size: port/state/tail
				] [
					either info: select dir-cache file [
						port/status: first info
						port/size: second info
						port/date: third info
					] [
						if info: select dir-cache join file slash [
							port/date: third info
							port/path: join port/path file slash
							port/target: port/locals: none
							query port
						]
					]
				]
			] [
				port/status: spick [directory file] dir-read? port
				port/size: port/state/tail
			]
			none
		]
		change: func [port new-name /local cmd-port] [
			cmd-port: port/locals/cmd-port
			cmd-port/locals/file: to-string spick port/locals/dir-cache 2 * port/state/index + 1
			cmd-port/locals/to-name: either all [
				slash = last cmd-port/locals/file
				slash <> last new-name
			] [new-name: join new-name slash] [scopy new-name]
			close-on-fail port [confirm-cmd port rename-check]
			poke port/locals/dir-cache 2 * port/state/index + 1 to-file new-name
			port
		]
		copy: func [port /local out num index value] [
			out: make block! num: port/state/num
			index: port/state/index
			parse port/locals/dir-cache [index [2 skip] num [set value skip skip (insert tail out scopy value)]]
			out
		]
		pick: func [port] [
			spick port/locals/dir-cache 2 * port/state/index + 1
		]
		remove: func [port /local cmd-port dir-cache] [
			cmd-port: port/locals/cmd-port
			dir-cache: skip port/locals/dir-cache 2 * port/state/index
			loop port/state/num [
				cmd-port/locals/file: to string! first dir-cache
				close-on-fail port [confirm-cmd port either slash = last cmd-port/locals/file [rmdir-check] [rmfile-check]]
				sremove/part dir-cache 2
				port/state/tail: port/state/tail - 1
			]
		]
		net-utils/net-install 'ftp self 21
	]
]