REBOL [
	Title: "Mod-QM"
	Content: "Gets QM working in Cheyenne"
	Version: 0.9.18
	Comments: {
		Does not work in Encapped version of Cheyenne, script only.
		Also, change in %handlers/CGI.r the line that reads:

		soc/path-info: join data/in/path data/in/target

		to:

		soc/path-info: join data/in/url
	}
]

do-cache uniserve-path/libs/idate.r

install-HTTPd-extension [
	name: 'mod-qm
	
	order: [
		method-support	last
		url-translate	first
		parsed-headers	last
		url-to-filename	last
		access-check	last
		set-mime-type	last
		make-response	last
		filter-output	last
		reform-headers	last
		logging			last
	]

	dot: #"."
	log-dir: join cheyenne/data-dir %log/
	log-file: %access.log
	
	max-size: 2 * 1024 * 1024 ; in Mb (TBD: export it to the conf file)
	cache: make block! 50
	cache-size: 0
	
	read-cache: func [req /local file path mdate][
		path: req/in/file
		mdate: req/file-info/date
		either file: find cache path [
			either mdate > third file [
				poke file 3 mdate
				poke file 2 file: read/binary path	
			][
				file: second file
			]
		][
			repend cache [path file: read/binary path mdate]
			cache-size: cache-size + length? file
			if cache-size > max-size [clear cache]	; -- for now, very simple management rule
		]
		file
	]

	;====== Server events handling ======
	on-started: does [	
		if not exists? log-dir [
			make-dir/deep log-dir		; TBD: protect it with 'attempt
		]
		false
	]
	;===================================
	
	method-support: func [req][
		if not find [HEAD GET POST] req/in/method [
			req/out/code: 405
			return true
		]
		none
	]
	
	url-translate: func [req /local list out item path matched c][
;-- TBD: rewrite all function using only parsing rules
		; --- Interpret /. and /.. directory shortcuts
		if find path: req/in/path "/." [		
			list: parse path "/"
			while [not tail? list][
				any [
					all [
						any [
							empty? list/1
							list/1 = "."
						]
						remove list
					]
					all [
						list/1 = ".."
						remove list
						any [
							head? list
							remove list: back list
						]
					]
					list: next list			
				]				
			]
			out: make string! 128
			insert out slash
			foreach item head list [
				insert tail out item
				insert tail out slash
			]
			req/in/path: out
			matched: true
		]
		if find path: req/in/path "//" [
			out: make string! 128
			parse/all path [
				any [
					slash any [slash] (insert tail out slash)
					| copy item skip (insert tail out item)
				]
			]			
			req/in/path: out
			matched: true
		]
		if parse req/in/target [some [#"." | #"\"] e: to end][
			req/in/target: e
			matched: true
		]
		if matched [return false]
		none
	]
	
	parsed-headers:  func [req /local cfg host pos][
		; --- Remove the port number in Host header if present (TBD: store it somewhere?)
		if all [
			host: select req/in/headers 'Host
			pos: find host #":"
		][
			req/in/headers/host: copy/part host pos
		]
	]
	
	url-to-filename: func [req /local cfg domain ext][
		cfg: req/cfg		

		if find/any req/in/url "/qm.r*" [
			req/in/path: "/"
			req/in/target: "qm.r"
			req/in/file: rejoin [cfg/root-dir %/qm.r]
			req/file-info: info? req/in/file
			req/handler: select service/handlers req/in/ext: '.cgi
			return false
		]

		; --- Find and assign a default file if necessary		
		if empty? trim req/in/target [		;-- trim should be done when target is parsed
			foreach file to-block any [select cfg 'default []][
				req/in/file: rejoin [cfg/root-dir req/in/path file]				
				if req/file-info: info? req/in/file [
					req/in/target: form file
					if ext: find/last req/in/target dot [
						req/in/ext: to word! ext
						req/handler: select service/handlers req/in/ext
					]
					if req/file-info/type = 'file [return false]
				]
			]
		]

		req/in/file: rejoin [cfg/root-dir req/in/path req/in/target]

		either all [
			req/file-info: info? req/in/file
			req/file-info/type = 'file
		][
			if #"/" = last req/in/file [
				remove back tail req/in/url
				req/out/code: 301
				h-store req/out/headers 'Location req/in/url
			]
		][
			return either all [
				req/file-info
				slash <> last req/in/url
			][
				req/out/code: 301
				h-store req/out/headers 'Location append req/in/url slash
				true
			][
				req/in/path: "/"
				req/in/target: "qm.r"
				req/in/file: rejoin [cfg/root-dir %/qm.r]
				req/file-info: info? req/in/file
				req/handler: select service/handlers req/in/ext: '.cgi
				false
			]
		]
		false
	]

	access-check: func [req /local info mdate][
		; --- Generate the Last-Modified header
		mdate: req/file-info/date
		mdate: to date! rejoin [mdate/date slash mdate/time]
		h-store 
			req/out/headers 
			'Last-Modified 
			to-GMT-idate req/file-info/date: mdate
		false
	]

	set-mime-type: func [req /local ext mime][
		all [
			req/in/file
			ext: find/last/tail req/in/file dot
			ext: to word! to string! ext
		]
		req/out/mime: either all [ext mime: find service/mime-types ext][
			first find/reverse mime path!
		][
			'application/octet-stream
		]
		false
	]

	make-response: func [req /local since][
		; --- If file not modified => send a 304
		if since: select req/in/headers 'If-Modified-Since [		
			if req/file-info/date = attempt [to-rebol-date since][
				req/out/code: 304
				return true
			]
		]
		req/out/code: 200
		either req/file-info/size > 16384 [		; -- for files > 16Kb, stream them from disk
			req/out/content: req/in/file
		][										; -- for files <= 16Kb, send them from memory cache
			req/out/content: read-cache req ; req/in/file
		]
		true
	]

	reform-headers: func [req][
		h-store req/out/headers 'Date to-GMT-idate now
		false
	]

	logging: func [req /local data cache log][
		cache: [0:00:01 ""]

		log: second cache
		insert tail log service/client/remote-ip
		insert tail log " - "
		insert tail log any [req/auth/user "- "]
		insert tail log to-CLF-idate now
		insert tail log { "}
		insert tail log trim/tail req/in/status-line
		insert tail log {" }
		insert tail log req/out/code
		insert tail log #" "
		insert tail log any [
			all [req/in/method = 'HEAD #"-"]
			all [not zero? req/out/length req/out/length]
			all [
				data: req/out/content
				any [all [file? data req/file-info/size] length? data]
			] 
			#"-"
		]
		insert tail log newline

		data: now
		if data <> first cache [
			cache/1: data
			if error? set/any 'err try [
				write/append join log-dir [req/vhost #"-" log-file] second cache
			][
				log/error mold disarm err
			]
			clear second cache
		]
		false
	]

	words: [
		;--- Define the root directory for a vhost
		root-dir: [file!] in main do [
			if slash = last args/1 [remove back tail args/1]			
		]

		;--- Set the maximum data size accepted for POST requests
		post-max: [integer!] in main

		;--- Define the maximum size for POSTed data handled in memory
		post-mem-limit: [integer!] in main

		;--- Define the default file(s) for a directory
		default: [file! | block!] in [main location folder]

		;--- Defines the listen port(s)
		listen: [integer! | block!] in globals

		;--- Set the log file directory
		log-dir: [file!] in globals do [
			service/mod-list/mod-static/log-dir: first args
		]

		;--- Test if an extension has been loaded and apply the body rules if true
		if-loaded?: [word!] [block!] in globals do [
			if find service/mod-list args/1 [process args/2]
		]

		;--- Catch and forward responses based on their status code 
		on-status-code: [block!] in main

		;--- Add a new mime-type
		set-mime: [path!] [word! | block!] in globals do [
			use [pos][
				if pos: find/only service/mime-types args/1 [
					remove/part pos any [find next pos path! tail pos]
				]
			]
			append/only service/mime-types args/1
			foreach ext args/2: to-block args/2 [	;--- word!! not series !!
				ext: mold ext
				if #"." = first ext [remove ext]
			]
			append service/mime-types args/2
		]

		;--- Defines flags for data persistence handling
		persist: [block!] in globals

		;--- associate a file extension with an handler
		bind: [word!] 'to [word! | block!] in globals do [
			foreach ext to-block args/2 [
				repend service/handlers [ext args/1]
			]
		]
	]
]