Rev 14 | Rev 18 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
#!/usr/bin/env tclsh
# $Id: koakuma.cgi.in 15 2024-10-02 06:42:12Z nishi $
set KOAKUMA_VERSION "1.00"
set components ""
chan configure stdout -buffering none
proc exiting {code} {
exit $code
}
proc loop_components {run} {
global components
foreach {name description version genre} $components {
eval $run
}
}
proc crash {reason} {
global components KOAKUMA_VERSION
puts stderr "----- Start Koakuma Crash dump log -----"
puts stderr "Included components:"
loop_components {
puts stderr " $name: $description, version $version"
}
puts stderr "Reason: $reason"
puts stderr "Code: $::errorCode"
puts stderr "Info: $::errorInfo"
puts stderr "----- End Koakuma Crash dump log -----"
puts "Content-Type: text/html"
puts "Status: 500 Internal Server Error"
puts ""
puts "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"
puts "<html>"
puts " <head>"
puts " <meta http-equiv=\"Content-Type\" content=\"text/html;charset=UTF-8\">"
puts " <title>Oops</title>"
puts " </head>"
puts " <body>"
puts " <h1>Oops</h1>"
puts " <hr>"
puts " Koakuma version $KOAKUMA_VERSION crashed, reason: <code>$reason</code><br>"
puts " See the server error log for details."
puts " </body>"
puts "</html>"
exiting 1
}
if { ![info exists env(PATH_INFO)] } {
puts "Status: 301 Moved Permanently"
puts "Location: $env(SCRIPT_NAME)/"
puts ""
exiting 0
}
if { [file exists "@@PREFIX@@/etc/koakuma/cgi.conf"] } {
if { [catch {
source "@@PREFIX@@/etc/koakuma/cgi.conf"
}] } {
crash "Config failure"
}
}
if { [catch {
set tdom_version "[package require tdom]"
dom createNodeCmd -tagName "rpc" elementNode rootXML
dom createNodeCmd -tagName "project" elementNode keyProject
dom createNodeCmd -tagName "version" -jsonType NONE elementNode keyVersion
dom createNodeCmd -tagName "error" -jsonType NONE elementNode keyError
dom createNodeCmd -tagName "name" -jsonType NONE elementNode keyName
dom createNodeCmd -tagName "description" -jsonType NONE elementNode keyDescription
dom createNodeCmd -tagName "vcs" -jsonType NONE elementNode keyVCS
dom createNodeCmd -tagName "url" -jsonType NONE elementNode keyURL
dom createNodeCmd -jsonType STRING textNode valueString
}] } {
crash "Failed to load tDOM"
}
if { [catch {
set tclx_version "[package require Tclx]"
}] } {
crash "Failed to load TclX"
}
proc Get_KV {lst key} {
foreach {k v} $lst {
if { "$k" == "$key" } {
return "$v"
}
}
return ""
}
proc URL_parse {url} {
if { [regexp {^([^:]+)://(([^:]+:[^@]+|[^:]+:|[^:]+)@)?([^/]+)(.+)?$} "$url" -> scheme userpass_at userpass host path] } {
lappend result "scheme" "$scheme"
lappend result "userpass" "$userpass"
lappend result "host" "$host"
lappend result "path" "$path"
return $result
} elseif { [regexp {^/.+$} "$url" path] } {
lappend result "scheme" "file"
lappend result "userpass" ""
lappend result "host" ""
lappend result "path" "$path"
return $result
}
}
if { [catch {
foreach path [glob @@PREFIX@@/lib/koakuma/component/*.tcl] {
source "$path"
}
}] } {
crash "Could not load components"
}
set data ""
while { [gets stdin line] >= 0 } {
if { "$data" == "" } {
set data "$line"
} else {
set data "$data\n$line"
}
}
chan close stdin
set toc ""
set result ""
set content ""
proc write_db {data} {
set fid [open "@@PREFIX@@/lib/koakuma/db/projects.db" "w"]
puts $fid "$data"
close $fid
}
proc readall_db {} {
set data ""
set fid [open "@@PREFIX@@/lib/koakuma/db/projects.db" "r"]
while { [gets $fid line] >= 0 } {
if { "$data" == "" } {
set data "$line"
} else {
set data "$data\n$line"
}
}
close $fid
return "$data"
}
proc rputs {data} {
global result
if { "$result" == "" } {
set result "$data"
} else {
set result "$result\n$data"
}
}
proc tputs {data} {
global content
if { "$content" == "" } {
set content "$data"
} else {
set content "$content\n$data"
}
}
proc html_escape {data} {
set tmp "[regsub -all {<} "[regsub -all {>} "$data" {\>}]" {\<}]"
return "[regsub -all {[^:]+://[^ ]+} "$tmp" {<a href="\0">\0</a>}]"
}
proc open_projects {} {
while 1 {
if { ![info exists "@@PREFIX@@/lib/koakuma/db/projects.lock"] } {
break
}
set fid [open "@@PREFIX@@/lib/koakuma/db/projects.lock" "w"]
if { ![info exists "/proc/[gets $fid line]"] } {
close $fid
break
}
after 10
close $fid
}
set fid [open "@@PREFIX@@/lib/koakuma/db/projects.lock" "w"]
puts $fid "[pid]"
close $fid
}
proc scan_projects {run} {
set fid [open "@@PREFIX@@/lib/koakuma/db/projects.db" "r"]
set content ""
while { [gets $fid line] >= 0 } {
if { "$content" == "" } {
set content "$line"
} else {
set content "$content\n$line"
}
}
close $fid
set dom [dom parse "$content"]
set doc [$dom documentElement]
foreach elem [$doc selectNodes "/projects/project"] {
set name "[$elem selectNodes "string(name)"]"
set description "[$elem selectNodes "string(description)"]"
set vcs "[$elem selectNodes "string(vcs)"]"
set vcs_url "[$elem selectNodes "string(url)"]"
eval $run
}
}
proc project_exists {projname} {
set desc ""
scan_projects {
upvar 1 desc desc
upvar 1 projname projname
if { "$name" == "$projname" } {
set desc "$description"
break
}
}
return "$desc"
}
proc close_projects {} {
file delete "@@PREFIX@@/lib/koakuma/db/projects.lock"
}
proc start_html {title has_toc} {
global toc env koakuma_png css
rputs "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">"
rputs "<html>"
rputs " <head>"
rputs " <meta http-equiv=\"Content-Type\" content=\"text/html;charset=UTF-8\">"
rputs " <title>$title - Koakuma</title>"
rputs " <link rel=\"stylesheet\" href=\"$css\">"
rputs " </head>"
rputs " <body>"
rputs " <a href=\"/koakuma\" id=\"gomain\">"
rputs " <img src=\"$koakuma_png\" alt=\"Koakuma by Kasuya Baian\" height=\"192px\">"
rputs " </a>"
rputs " <div id=\"space\"></div>"
rputs " <div id=\"title\">"
rputs " Koakuma"
rputs " </div>"
rputs " <a href=\"$env(SCRIPT_NAME)\">Root</a>"
rputs " <div id=\"clearfix\"></div>"
if { "$has_toc" == "1" } {
rputs " <div id=\"toc\">"
rputs " <div id=\"toctitle\">TOC</div>"
foreach sect $toc {
if { "[string range "[regsub -all { } "$sect" "-"]" 0 0]" == "-" } {
rputs "<a class=\"shiftlink\" href=\"#TOC-[regsub {^-} "[regsub -all { } "$sect" "-"]" ""]\">[regsub {^-} "$sect" ""]</a><br>"
} else {
rputs "<a href=\"#TOC-[regsub -all { } "$sect" "-"]\">$sect</a><br>"
}
}
rputs " </div>"
}
if { "$has_toc" == "1" } {
rputs " <div id=\"doc\">"
} else {
rputs " <div id=\"doc-notoc\">"
}
rputs " <h1>$title</h1>"
}
proc end_html {has_toc} {
global KOAKUMA_VERSION
rputs " </div>"
rputs " <hr>"
rputs " <i>Powered by <a href=\"http://nishi.boats/koakuma\">Koakuma</a> $KOAKUMA_VERSION</i>"
rputs " </body>"
rputs "</html>"
}
proc add_toc {data} {
global toc
tputs "<h2 id=\"TOC-[regsub -all { } "$data" "-"]\"><a href=\"#TOC-[regsub -all { } "$data" "-"]\">#</a> $data</h2>"
lappend toc "$data"
}
proc add_toc2 {data} {
global toc
tputs "<h3 id=\"TOC-[regsub -all { } "$data" "-"]\"><a href=\"#TOC-[regsub -all { } "$data" "-"]\">#</a> $data</h3>"
lappend toc "-$data"
}
if { [catch {
set path "[regsub -all {/+} "$env(PATH_INFO)" "/"]"
if { [regexp {^/rpc(/.*)?$} "$path"] } {
rputs "Content-Type: application/json"
} else {
if { ![regexp {/$} "$env(PATH_INFO)"] } {
puts "Status: 301 Moved Permanently"
puts "Location: $env(SCRIPT_NAME)$env(PATH_INFO)/"
puts ""
exiting 0
}
rputs "Content-Type: text/html"
}
if { "$path" == "/" } {
add_toc "Tcl Information"
tputs "<table border=\"0\">"
tputs " <tr>"
tputs " <th>"
tputs " Version"
tputs " </th>"
tputs " <td>"
tputs " $tcl_version"
tputs " </td>"
tputs " </tr>"
tputs " <tr>"
tputs " <th>"
tputs " Platform"
tputs " </th>"
tputs " <td>"
tputs " $tcl_platform(os)/$tcl_platform(machine) $tcl_platform(osVersion)"
tputs " </td>"
tputs " </tr>"
tputs " <tr>"
tputs " <th>"
tputs " tDOM version"
tputs " </th>"
tputs " <td>"
tputs " $tdom_version"
tputs " </td>"
tputs " </tr>"
tputs " <tr>"
tputs " <th>"
tputs " TclX version"
tputs " </th>"
tputs " <td>"
tputs " $tclx_version"
tputs " </td>"
tputs " </tr>"
tputs "</table>"
add_toc "Components"
loop_components {
if { [llength [info procs "${name}_info"]] > 0 } {
${name}_info
}
}
set has_projects 0
add_toc "Projects"
open_projects
scan_projects {
upvar 1 has_projects has_projects
if { "$has_projects" == "0" } {
set has_projects 1
tputs "<table border=\"0\">"
}
tputs "<tr>"
tputs " <th><a href=\"/koakuma/project/$name\">$name</a></th>"
tputs " <td>[html_escape "$description"]</td>"
tputs "</tr>"
}
close_projects
if { "$has_projects" == "1" } {
tputs "</table>"
} else {
tputs "No projects have been added, yet."
}
rputs ""
start_html "Main" 1
rputs "$content"
end_html 1
} elseif { [regexp {^/rpc(/.*)?$} "$path"] } {
regexp {^/rpc(/.*)?$} "$path" -> api
set doc [dom createDocumentNode]
$doc appendFromScript {
keyVersion {valueString "$KOAKUMA_VERSION"}
}
if { "$api" == "" || "$api" == "/" } {
rputs ""
rputs "[$doc asJSON]"
} elseif { "$api" == "/launch-job" } {
if { [catch {dom parse -json "$data" clidoc}] } {
rputs "Status: 400 Bad Request"
$doc appendFromScript {
keyError {valueString "Bad JSON"}
}
} else {
set projname "[$clidoc selectNodes "string(/name)"]"
set builddesc "[$clidoc selectNodes "string(/description)"]"
if { "$projname" == "" || "$builddesc" == "" } {
rputs "Status: 400 Bad Request"
$doc appendFromScript {
keyError {valueString "Required field missing"}
}
} else {
set has_name 0
set use_vcs ""
set use_vcs_url ""
open_projects
scan_projects {
upvar 1 has_name has_name
upvar 1 projname projname
upvar 1 use_vcs use_vcs
upvar 1 use_vcs_url use_vcs_url
if { "$name" == "$projname" } {
set has_name 1
set use_vcs "$vcs"
set use_vcs_url "$vcs_url"
break
}
}
close_projects
if { $has_name == 0 } {
rputs "Status: 400 Bad Request"
$doc appendFromScript {
keyError {valueString "Project does not exist"}
}
} else {
set cont 1
if { [file exists "@@PREFIX@@/lib/koakuma/db/data/$projname/build.lock"] } {
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/build.lock" "r"]
set readpid "[gets $fid]"
close $fid
if { [file exists "/proc/$readpid"] } {
set cont 0
rputs "Status: 403 Forbidden"
$doc appendFromScript {
keyError {valueString "Other building process has been running"}
}
}
}
if { $cont == 1 } {
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/buildcount" "r"]
set count [expr [gets $fid] + 1]
close $fid
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/buildcount" "w"]
puts $fid "$count"
close $fid
set count "[format %08s "$count"]"
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/lastrun" "w"]
puts $fid "[clock seconds]"
close $fid
file mkdir "@@PREFIX@@/lib/koakuma/db/data/$projname/build-$count"
set pid [fork]
if { $pid } {
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/build.lock" "w"]
puts $fid "$pid"
close $fid
} else {
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/build-$count/log" "w"]
set fail 0
dup $fid stdout
dup $fid stderr
puts "===== Checkout"
puts "Using VCS: $use_vcs"
if { [llength [info procs "${use_vcs}_repository"]] == 0 } {
puts "Component internal failure"
set fail 1
} else {
cd "@@PREFIX@@/lib/koakuma/db/data/$projname"
if { [${use_vcs}_repository "$use_vcs_url" "workspace"] } {
puts "Checkout failure"
set fail 1
}
}
if { $fail == 0 } {
puts "===== Build"
cd "@@PREFIX@@/lib/koakuma/db/data/$projname/workspace"
if { [file exists "@@PREFIX@@/lib/koakuma/db/data/$projname/workspace/Koakumafile"] } {
if { [catch {
namespace eval koakumafile {
source "@@PREFIX@@/lib/koakuma/db/data/$projname/workspace/Koakumafile"
}
koakumafile::run "$projname"
}] } {
puts "Failed to run Koakumafile"
set fail 1
}
} else {
puts "Nothing to do"
}
}
if { $fail == 0 } {
puts "Build successful"
set fidsuc [open "@@PREFIX@@/lib/koakuma/db/data/$projname/lastsuccessfulrun" "w"]
puts $fidsuc "[clock seconds]"
close $fidsuc
set fidsuc [open "@@PREFIX@@/lib/koakuma/db/data/$projname/successbuild" "r"]
set sucbul [gets $fidsuc]
close $fidsuc
set fidsuc [open "@@PREFIX@@/lib/koakuma/db/data/$projname/successbuild" "w"]
puts $fidsuc "[expr $sucbul + 1]"
close $fidsuc
}
close $fid
file delete "@@PREFIX@@/lib/koakuma/db/data/$projname/build.lock"
exit 0
}
}
}
}
}
rputs ""
rputs "[$doc asJSON]"
} elseif { "$api" == "/create-project" } {
if { [catch {dom parse -json "$data" clidoc}] } {
rputs "Status: 400 Bad Request"
$doc appendFromScript {
keyError {valueString "Bad JSON"}
}
} else {
set projname "[$clidoc selectNodes "string(/name)"]"
set projdescription "[$clidoc selectNodes "string(/description)"]"
set projvcs "[$clidoc selectNodes "string(/vcs)"]"
set url "[$clidoc selectNodes "string(/url)"]"
if { "$projname" == "" || "$projdescription" == "" || "$projvcs" == "" || "$url" == "" } {
rputs "Status: 400 Bad Request"
$doc appendFromScript {
keyError {valueString "Required field missing"}
}
} else {
set has_vcs 0
set has_name 0
loop_components {
upvar 1 has_vcs has_vcs
upvar 1 projvcs projvcs
if { "$name" == "$projvcs" && "$genre" == "VCS" } {
set has_vcs 1
break
}
}
open_projects
scan_projects {
upvar 1 has_name has_name
upvar 1 projname projname
if { "$name" == "$projname" } {
set has_name 1
break
}
}
close_projects
if { $has_vcs == 0 } {
rputs "Status: 400 Bad Request"
$doc appendFromScript {
keyError {valueString "Not a valid VCS"}
}
} elseif { $has_name == 1 } {
rputs "Status: 400 Bad Request"
$doc appendFromScript {
keyError {valueString "Project already exists"}
}
} else {
open_projects
set xml "[readall_db]"
set xmldoc [dom parse "$xml"]
set root [$xmldoc documentElement]
$root appendFromScript {
keyProject {
keyName {valueString "$projname"}
keyDescription {valueString "$projdescription"}
keyVCS {valueString "$projvcs"}
keyURL {valueString "$url"}
}
}
write_db "[$xmldoc asXML]"
file mkdir "@@PREFIX@@/lib/koakuma/db/data/$projname"
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/buildcount" "w"]
puts $fid "0"
close $fid
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/successbuild" "w"]
puts $fid "0"
close $fid
close_projects
}
}
}
rputs ""
rputs "[$doc asJSON]"
} else {
$root appendFromScript {
keyError {valueString "No such endpoint"}
}
rputs "Status: 404 Not Found"
rputs ""
rputs "[$doc asJSON]"
}
} elseif { [regexp {^/project/[^/]+.*$} "$path"] } {
regexp {^/project/([^/]+)(.*)$} "$path" -> projname projpath
open_projects
set has_project [project_exists "$projname"]
close_projects
if { "$has_project" != "" } {
if { "$projpath" == "" || "$projpath" == "/" } {
add_toc "Description"
tputs "[html_escape "$has_project"]"
add_toc "Details"
tputs "<table border=\"0\">"
tputs " <tr>"
tputs " <th>"
tputs " Status"
tputs " </th>"
tputs " <td>"
if { [file exists "@@PREFIX@@/lib/koakuma/db/data/$projname/build.lock"] } {
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/build.loc" "r"]
if { [file exists "/proc/[gets $fid]"] } {
tputs "Running"
} else {
tputs "Idle"
}
close $fid
} else {
tputs "Idle"
}
tputs " "
tputs " </td>"
tputs " </tr>"
tputs " <tr>"
tputs " <th>"
tputs " Last run"
tputs " </th>"
tputs " <td>"
if { [file exists "@@PREFIX@@/lib/koakuma/db/data/$projname/lastrun"] } {
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/lastrun" "r"]
set date "[clock format "[gets $fid]" -format "%a %b %d %H:%M:%S %Z %Y"]"
close $fid
tputs "$date"
} else {
tputs "No builds yet"
}
tputs " "
tputs " </td>"
tputs " </tr>"
tputs " <tr>"
tputs " <th>"
tputs " Last successful run"
tputs " </th>"
tputs " <td>"
if { [file exists "@@PREFIX@@/lib/koakuma/db/data/$projname/lastsuccessfulrun"] } {
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/lastsuccessfulrun" "r"]
set date "[clock format "[gets $fid]" -format "%a %b %d %H:%M:%S %Z %Y"]"
close $fid
tputs "$date"
} else {
tputs "No successful builds yet"
}
tputs " "
tputs " </td>"
tputs " </tr>"
set builds [lsort -ascii [glob -nocomplain "@@PREFIX@@/lib/koakuma/db/data/$projname/build-*"]]
if { [llength $builds] > 0 } {
tputs " <tr>"
tputs " <th>"
tputs " Successful builds"
tputs " </th>"
tputs " <td>"
if { [file exists "@@PREFIX@@/lib/koakuma/db/data/$projname/successbuild"] } {
set fid [open "@@PREFIX@@/lib/koakuma/db/data/$projname/successbuild" "r"]
tputs "[format %.2f [expr [gets $fid] / [llength $builds] * 100]]%"
close $fid
}
tputs " "
tputs " </td>"
tputs " </tr>"
}
tputs "</table>"
set builds [lsort -ascii [glob -nocomplain "@@PREFIX@@/lib/koakuma/db/data/$projname/build-*"]]
if { [llength $builds] > 0 } {
add_toc "Last build log"
set lastbuild "[lindex $builds [expr [llength $builds] - 1]]"
set fid [open "$lastbuild/log" "r"]
tputs "<pre>"
while { [gets $fid line] >= 0 } {
tputs "[html_escape "$line"]"
}
tputs "</pre>"
close $fid
}
rputs ""
start_html "Project: $projname" 1
rputs "$content"
end_html 1
} else {
tputs "I could not find the endpoint you were finding."
rputs "Status: 404 Not Found"
rputs ""
start_html "Project: $projname" 1
rputs "$content"
end_html 1
}
} else {
tputs "I could not find the project you were finding."
rputs "Status: 404 Not Found"
rputs ""
start_html "Not Found" 0
rputs "$content"
end_html 0
}
} else {
tputs "I could not find the content you were finding."
rputs "Status: 404 Not Found"
rputs ""
start_html "Not Found" 0
rputs "$content"
end_html 0
}
}] } {
crash "Could not render the HTML"
} else {
puts "$result"
}
exiting 0