/Domains/FossilProxy/FossilProxy.tcl

package require OO
package require Cookies
package require Query
package require jQ

package provide FossilProxy 1.0

set ::API(Domains/FossilProxy) {
    {
	A domain to serve as proxy for the 'fossil http' web interface.
    }
    fossil_dir {Directory where fossil repositories are located. The proxy will work for all repositories in this directory which are named *.fossil, where the basename of the repository is part of the URL. Mandatory.}
    fossil_command {Path to fossil command. Default is 'fossil'}
    prefix {Path where fossil repositories are mounted in the URL. Mounted in root is the default.}
    repositories_list_body {HTML body used to show list of available repositories. %REPOS% is replace by an unordered list of repositories. Default is empty.}
}

oo::class create FossilProxy {

    superclass Direct

    method strip_prefix { path } {
 	variable prefix
 	if {[string length $prefix] && [string match "$prefix*" $path]} {
 	    set path [string range $path [string length $prefix] end]
 	}
	return $path
    }

    method /direct/user/togglepriv/post {r R U P} {
 	variable fossil_dir
 	variable fossil_command
 	if {[catch {exec $fossil_command user capabilities $U -R [file join $fossil_dir $R]} Res]} {
 	    error $Res
 	}
 	set idx [string first $P $Res]
 	if {$idx >= 0} {
 	    set Res [string replace $Res $idx $idx]
 	    set msg "Revoked $P from user $U for repository $R: $Res"
 	} else {
 	    append Res $P
 	    set msg "Granted $P to user $U for repository $R: $Res"
 	}
 	if {[catch {exec $fossil_command user capabilities $U $Res -R [file join $fossil_dir $R]} Res]} {
 	    error $Res
 	}
 	return [Http NoCache [Http Ok $r $msg]]
    }

    method /direct/user/create/post {r R U C P} {
 	variable fossil_dir
 	variable fossil_command
 	if {[catch {exec $fossil_command user new $U $C $P -R [file join $fossil_dir $R]} Res]} {
 	    error $Res
 	}
 	return [Http NoCache [Http Ok $r $Res]]
    }

    method /direct/user/password/post { r R U P} {
 	variable fossil_dir
 	variable fossil_command
 	if {[catch {exec $fossil_command user password $U $P -R [file join $fossil_dir $R]} Res]} {
 	    error $Res
 	}
 	return [Http NoCache [Http Ok $r $Res]]
    }

    method /direct/privs {r} {
	variable prefix
	variable fossil_dir
	variable fossil_command
	set uidl {}
	set C ""
	set repoid 0
	set privid 0
	set fnml [lsort -dictionary [glob -nocomplain -tails -dir $fossil_dir *.fossil]]
	foreach fnm $fnml {
	    append C [<a> name repo$repoid [<h2> [file rootname $fnm]]]
	    set rnm [file join $fossil_dir $fnm]
	    if {[catch {exec $fossil_command user list -R $rnm} R]} {
		error $R
	    }
	    unset -nocomplain kprivs
	    unset -nocomplain privs
	    unset -nocomplain uidl
	    foreach l [split $R \n] {
		set idx [string first " " $l]
		set uid [string trim [string range $l 0 $idx]]
		set contact [string trim [string range $l $idx end]]
		lappend uidl [list $uid $contact]
		if {[catch {exec $fossil_command user capabilities -R $rnm $uid} P]} {
		    error $P
		}
		foreach p [split $P {}] {
		    set kprivs($p) 1
		    set privs($uid,$p) 1
		}
	    }
	    set data {}
	    foreach l $uidl {
		lassign $l uid contact
		set l [list uid $uid contact $contact]
		foreach p [lsort -dictionary [array names kprivs]] {
		    #lappend l $p "<input id='$privid' type='checkbox' OnClick='FossilProxy.togglepriv($privid, \"$fnm\", \"$uid\", \"$p\")' [expr {[info exists privs($uid,$p)]?"checked":""}]>"
		    lappend l $p [expr {[info exists privs($uid,$p)]?"X":"-"}]
		    incr privid
		}
		lappend data [incr i] $l
		append C "  </tr>\n"
	    }
	    append C [Report html $data headers [list uid contact {*}[lsort -dictionary [array names kprivs]]] class tablesorter sortable 0 evenodd 0 htitle ""]
	    incr repoid
	}
	set T [<h1> "Repository privileges"]\n
	append T <ul>\n
	set repoid 0
	foreach fnm $fnml {
	    append T [<li> [<a> href #repo$repoid [file rootname $fnm]]]\n
	    incr repoid
	}
	append T </ul>\n
	append T $C
	set r [jQ tablesorter $r table]
	dict set r -content $T
	dict set r content-type x-text/html-fragment
	dict set r -title "Repository privileges"
	return [Http NoCache [Http Ok $r]]
    }

    method list_repos {r} {
	variable prefix
	variable fossil_dir
	variable repositories_list_body
	set C "<ul>\n"
	foreach fnm [lsort -dictionary [glob -nocomplain -tails -dir $fossil_dir *.fossil]] {
	    append C [<li> [<a> href $prefix/[file rootname $fnm] [file rootname $fnm]]]\n
	}
	append C "</ul>\n"
	return [Http NoCache [Http Ok $r [regsub {%REPOS%} $repositories_list_body $C]]]
    }

    method fossil_http { r } { 

	variable fnmid
	variable prefix
	variable fossil_dir
	variable fossil_command

	# Construct a HTTP request to send to 'fossil http', strip the prefix as fossil doesn't know about it
	if {[dict get $r -method] eq "POST"} {
	    set fr "POST [my strip_prefix [dict get $r -path]]"
	    append fr " HTTP/1.1\n"
	} else {
	    lassign [dict get $r -header] meth url ver
	    set url [my strip_prefix $url]
	    if {$url in {{} {/}}} {
		return [my list_repos $r]
	    }
	    set fr "$meth $url $ver\n"
	}

	# Add headers to request
	dict for {k v} $r {
	    switch -nocase -glob -- $k {
		-* {}
		default { append fr "$k: $v\n" }
	    }
	}
	# Add content to request
	if {[dict exists $r -entity]} {
	    append fr \n[dict get $r -entity]
	}
	
	# Use a thread to process the request to avoid blocking on long running calls
	return [Httpd Thread {

	    package require Cookies
	    package require Dict

	    set qfnm Q$fnmid
	    set f [open $qfnm w]
	    fconfigure $f -encoding binary -translation binary
	    puts -nonewline $f $fr
	    close $f

	    # Call fossil
	    set fnm R$fnmid
	    set f [open $fnm w]
	    fconfigure $f -encoding binary -translation binary
	    if {[catch {exec $fossil_command http $fossil_dir >@ $f < $qfnm} R]} {
		error $R
	    }
	    close $f

	    set f [open $fnm r]
	    fconfigure $f -encoding binary -translation binary
	    set R [read $f]
	    close $f

	    file delete $qfnm
	    file delete $fnm

	    # Extract headers from response
	    set n 0
	    set response 404
	    set location ""
	    set content_type "test/html"
	    set content_length -1
	    set content_found 0
	    foreach l [split $R \n] {
		incr n
		if {[string length $l] == 0} {
		    set content_found 1
		    break
		}
		switch -nocase -glob -- $l {
		    "HTTP/*" {
			lassign [split $l] http response
		    }
		    "Content-Type:*" {
			set content_type [string trim [string range $l 13 end]]
		    }
		    "Content-Length:*" {
			set content_length [string trim [string range $l 15 end]]
		    }
		    "Location:*" {
			set location [string trim [string range $l 9 end]]
		    }
		    "Set-Cookie:*" {
			# Pass on cookies, make sure to fix the path by adding prefix
			set cdict [lindex [Cookies parse4client [string trim [string range $l 11 end]]] 1]
			set r [Cookies Add $r -path $prefix[dict get? $cdict -Path] -name [dict get? $cdict -name] -value [dict get? $cdict -value] -expires "next month"]
		    }
		}
	    }
	    
	    # Extract contents from response
	    set C ""
	    if {$content_length >= 0} {
		set C [string range $R end-[expr {$content_length-1}] end]
	    }
	    
	    # Fix up prefixes if not mounted in /
 	    if {[string length $prefix] && [string match "text/html*" $content_type]} {
 		regsub -all { href=\"\/} $C " href=\"$prefix/" C
 		regsub -all { href=\'\/} $C " href='$prefix/" C
 		regsub -all { src=\"\/} $C " src=\"$prefix/" C
 		regsub -all { src=\'\/} $C " src='$prefix/" C
 	    }

	    # Send responses
	    switch -exact -- $response {
		200 {
		    return [Http NoCache [Http Ok $r $C $content_type]]
		}
		302 {
		    # Make sure to fix the path by adding prefix
		    return [Http Redirect $r $prefix$location]
		}
		404 {
		    return [Http NotFound $r]
		}
		default {
		    return [Http NoCache [Http Ok $r "Dont know what to do with 'fossil http' response:\n$R"]]
		}
	    }

	} r $r fr $fr fossil_dir $fossil_dir fossil_command $fossil_command prefix $prefix fnmid [incr fnmid]]
    }

    method do {r} {
	variable prefix
	set path [dict get $r -path]
	if {[string match "$prefix/direct/privs*" $path] || 
	    [string match "$prefix/direct/user*" $path]} {
	    return [next $r]
	} else {
	    return [my fossil_http $r]
	}
    }

    constructor {args} {
	variable fnmid 0
	variable prefix ""
	variable fossil_command "fossil"

	variable {*}[Site var? FossilProxy] {*}$args ;# allow .ini file to modify defaults

	if {![info exists fossil_dir]} {
	    error "fossil_dir not set"
	}

	catch {next {*}$args}
    }
}