Page MenuHomeDevCentral
Files F3768955

No OneTemporary
Actions

View Options

diff --git a/.hgignore b/.hgignore
new file mode 100644
index 0000000..1521c8b
--- /dev/null
+++ b/.hgignore
@@ -0,0 +1 @@
+dist
diff --git a/Core.tcl b/Core.tcl
new file mode 100644
index 0000000..3c6fc20
--- /dev/null
+++ b/Core.tcl
@@ -0,0 +1,29 @@
+#
+# TCL helpers
+#
+
+#Determines if $proc exists
+proc proc_exists {proc} {
+ expr {[info procs $proc] == $proc}
+}
+
+#
+# Trivial procs
+#
+
+#Determines if $v is a number
+proc isnumber {v} {
+ return [expr {! [catch {expr {int($v)}}]}]
+}
+
+#
+# MySQL
+#
+#Gets the value of the key $key from the registry
+proc registry_get {key} {
+ sql "SELECT value FROM registry WHERE `key` = '$key'"
+}
+
+#Sets the key $key to $value in the registry
+proc registry_set {key value} {
+}
diff --git a/Nasqueron/Bureautique.tcl b/Nasqueron/Bureautique.tcl
new file mode 100644
index 0000000..3ad8da4
--- /dev/null
+++ b/Nasqueron/Bureautique.tcl
@@ -0,0 +1,72 @@
+bind dcc - antidater dcc:antidater
+bind dcc - postdater dcc:postdater
+bind dcc - days dcc:days
+
+#
+# Dates calculation
+#
+
+#Removes $days from $date or if unspecified, current unixtime
+proc antidater {days {date ""}} {
+ postdater [expr $days * -1] $date
+}
+
+#Adds $days from $date or if unspecified, current unixtime
+proc postdater {days {date ""}} {
+ if {$date == ""} {
+ set date [unixtime]
+ }
+ incr date [expr 86400 * $days]
+}
+
+#.antidater 15
+#.antidater 2011-01-29 4
+proc dcc:antidater {handle idx arg} {
+ set argc [llength $arg]
+ if {$argc == 0} {
+ putdcc $idx "De combien de jours dois-je antidater ?"
+ return
+ }
+ if {$argc == 1} {
+ set date ""
+ set days $arg
+ } {
+ if [catch {set date [clock scan [lindex $arg 0]]} err] {
+ putdcc $idx $err
+ return
+ }
+ set days [lindex $arg 1]
+ }
+ if ![isnumber $days] {
+ putdcc $idx "$days n'est pas un nombre de jours"
+ return
+ }
+ putdcc $idx [clock format [antidater $days $date] -format "%Y-%m-%d"]
+ return 1
+}
+
+#.postdater 15
+#.postdater 2011-01-29 4
+proc dcc:postdater {handle idx arg} {
+ set argc [llength $arg]
+ if {$argc == 0} {
+ putdcc $idx "De combien de jours dois-je postdater ?"
+ return
+ }
+ if {$argc == 1} {
+ set date ""
+ set days $arg
+ } {
+ if [catch {set date [clock scan [lindex $arg 0]]} err] {
+ putdcc $idx $err
+ return
+ }
+ set days [lindex $arg 1]
+ }
+ if ![isnumber $days] {
+ putdcc $idx "$days n'est pas un nombre de jours"
+ return
+ }
+ putdcc $idx [clock format [postdater $days $date] -format "%Y-%m-%d"]
+ return 1
+}
diff --git a/Nasqueron/Communication.tcl b/Nasqueron/Communication.tcl
new file mode 100644
index 0000000..4202980
--- /dev/null
+++ b/Nasqueron/Communication.tcl
@@ -0,0 +1,64 @@
+package require http
+
+bind dcc - sms dcc:sms
+bind pub - !identica pub:identica
+bind pub - !pub pub:identica
+bind pub - !twit pub:identica
+
+#
+# SMS
+#
+
+#.sms
+proc dcc:sms {handle idx arg} {
+ if {$arg == "" || $arg == "config"} {
+ #Prints config
+ return 1
+ } elseif {[string range $arg 0 6] == "config "} {
+ putcmdlog "#$handle# sms config ..."
+ return 0
+ } else {
+ #Sends a SMS
+ set to [lindex $arg 0]
+ putcmdlog "#$handle# sms ..."
+ }
+ return 0
+}
+
+#
+# Identi.ca
+#
+
+proc identicapost {account message} {
+ set row [lindex [sql "SELECT account_username, account_password FROM identica_accounts WHERE account_code = '$account'"] 0]
+ set auth "Basic [base64::encode [join $row :]]"
+ set tok [::http::geturl http://identi.ca/api/statuses/update.xml -headers [list Authorization $auth] -query [::http::formatQuery status $message]]
+ ::http::cleanup $tok
+}
+
+proc dcc:identica {handle idx arg} {
+
+}
+
+proc pub:identica {nick uhost handle chan text} {
+ if {$chan == "#wikipedia-fr"} {
+ set account wikipediafr
+ } elseif {$chan == "#wolfplex"} {
+ set account wolfplex
+ } {
+ putquick "NOTICE $nick :!pub n'est pas activésur $chan"
+ return
+ }
+ if {$text == ""} {
+ putquick "NOTICE $nick :Syntaxe : !pub <texte à publier sur identi.ca et Twitter>"
+ return
+ }
+ set len [string length $text]
+ if {$len > 140} {
+ putquick "NOTICE $nick :140 caractères max, là il y en a $len."
+ return
+ }
+ identicapost $account $text
+ putquick "NOTICE $nick :Publié sur identi.ca"
+ return 1
+}
diff --git a/Nasqueron/Server.tcl b/Nasqueron/Server.tcl
new file mode 100644
index 0000000..363844c
--- /dev/null
+++ b/Nasqueron/Server.tcl
@@ -0,0 +1,73 @@
+# ===============================================
+# ========= ==== ====== ============
+# ============ ====== === === = ==========
+# ============ ===== ======== === =========
+# ============ ===== ============= ==========
+# ============ ===== ============ ===========
+# == DcK ===== ===== =========== ============
+# ============ ===== ========== =============
+# ============ ====== === === ==============
+# ============ ======= === ==========
+# ===============================================
+# ===============================================
+# == Tau Ceti Central == Server administration ==
+# == This is a very dangerous product to use ==
+# == Don't deploy it in stable environment ==
+# == Or say goodbye to the serv security ==
+# == This warning will not be repeated ==
+# == All your base are belong to us! ==
+# ===============================================
+# ===============================================
+#
+# (c) 2011 Sébastien Santoro aka Dereckson.
+# Released under BSD license.
+
+bind dcc W phpfpm dcc:phpfpm
+bind dcc W php-fpm dcc:phpfpm
+bind pub W .phpfpm pub:phpfpm
+bind pub W .php-fpm pub:phpfpm
+bind bot - tc2 bot:tc2
+
+set tc2(bot) TC2
+
+proc dcc:phpfpm {handle idx arg} {
+ tc2 dcc $idx $handle phpfpm $arg
+ return 1
+}
+
+proc pub:phpfpm {nick uhost handle chan text} {
+ tc2 pub "$chan $nick" $handle phpfpm $text
+ return 1
+}
+
+proc bot:tc2 {sourcebot command text} {
+ if [catch {
+ set success [dict get $text success]
+ set reply [dict get $text reply]
+ set bind [dict get $text bind]
+ set who [dict get $text who]
+ tc2:reply $bind $who $reply
+ }] {
+ putdebug $text
+ }
+}
+
+proc tc2 {bind who handle command arg} {
+ global tc2
+ if ![islinked $tc2(bot)] {
+ tc2:reply $bind $who "$tc2(bot) isn't linked"
+ return
+ }
+ putbot $tc2(bot) "tc2 [dict create requester $handle command $command arg $arg bind $bind who $who]"
+}
+
+proc tc2:reply {bind who message} {
+ if {$bind == "dcc"} {
+ putdcc $who $message
+ } elseif {$bind == "pub"} {
+ foreach "chan nick" $who {}
+ putserv "PRIVMSG $chan :$nick, $message"
+ } {
+ error "Unknown bind in tc2:reply: $bind (expected: dcc or pub)"
+ }
+}
diff --git a/Nasqueron/Time.tcl b/Nasqueron/Time.tcl
new file mode 100644
index 0000000..1dc8d46
--- /dev/null
+++ b/Nasqueron/Time.tcl
@@ -0,0 +1,25 @@
+utimer 8 onload
+bind cron - "* * * * *" cron:minute
+bind cron - "*/5 * * * *" cron:often
+bind cron - "0 * * * *" cron:hourly
+bind cron - "0 4 * * *" cron:daily
+
+proc onload {} {
+}
+
+#Every minute
+proc cron:minute {minute hour day month weekday} {
+}
+
+#Every 5 minutes
+proc cron:often {minute hour day month weekday} {
+ sqlrehash
+}
+
+#Every hour
+proc cron:hourly {minute hour day month weekday} {
+}
+
+#Every day, at 4am
+proc cron:daily {minute hour day month weekday} {
+}
diff --git a/Nasqueron/Tools.tcl b/Nasqueron/Tools.tcl
new file mode 100644
index 0000000..7ce78af
--- /dev/null
+++ b/Nasqueron/Tools.tcl
@@ -0,0 +1,35 @@
+# Collection of tools and gadgets, to boost
+# your productivity or to have fun.
+
+bind dcc - genpass dcc:genpass
+bind dcc - strlen dcc:strlen
+
+#
+# .genpass <master password> <domain name>
+# www.supergenpass.com/genpass legacy generator
+#
+
+proc genpass {master domain} {
+ string range [md5 "$master:$domain"] 0 8
+}
+
+proc dcc:genpass {handle idx arg} {
+ if {[llength $arg] != 2} {
+ putdcc $idx "Usage: .genpass <master password> <domain name>"
+ } {
+ putcmdlog "#$handle# genpass ..."
+ putdcc $idx [genpass [lindex $arg 0] [lindex $arg 1]]
+ }
+ return 0
+}
+
+#
+# .strlen <string>
+# Gets the specified string's length
+#
+
+proc dcc:strlen {handle idx arg} {
+ putdcc $idx [string length $arg]
+ putcmdlog "#$handle# strlen ..."
+ return 0
+}
diff --git a/TC2/Server.tcl b/TC2/Server.tcl
new file mode 100644
index 0000000..1ed421c
--- /dev/null
+++ b/TC2/Server.tcl
@@ -0,0 +1,113 @@
+# ===============================================
+# ========= ==== ====== ============
+# ============ ====== === === = ==========
+# ============ ===== ======== === =========
+# ============ ===== ============= ==========
+# ============ ===== ============ ===========
+# == DcK ===== ===== =========== ============
+# ============ ===== ========== =============
+# ============ ====== === === ==============
+# ============ ======= === ==========
+# ===============================================
+# ===============================================
+# == Tau Ceti Central == Server administration ==
+# == This is a very dangerous product to use ==
+# == Don't deploy it in stable environment ==
+# == Or say goodbye to the serv security ==
+# == This warning will not be repeated ==
+# == All your base are belong to us! ==
+# ===============================================
+# ===============================================
+#
+# (c) 2011 Sébastien Santoro aka Dereckson.
+# Released under BSD license.
+
+bind bot - tc2 bot:tc2
+
+proc bot:tc2 {sourcebot command text} {
+ #Sourcebot: Nasqueron
+ #Command: tc2
+ #Text: requester Dereckson command phpfpm arg status
+ set requester [dict get $text requester]
+ set cmd [dict get $text command]
+ set arg [dict get $text arg]
+ set bind [dict get $text bind]
+ set who [dict get $text who]
+
+ #Logs entry
+ log tc2 "$requester@$sourcebot" "$cmd $arg"
+
+ #Executes command
+ if [proc_exists tc2:command:$cmd] {
+ set reply [tc2:command:$cmd $requester $arg]
+ } {
+ set reply {0 "Unknown command: $cmd"}
+ }
+
+ #Reports result
+ putbot $sourcebot "tc2 [dict create success [lindex $reply 0] reply [lindex $reply 1] bind $bind who $who]"
+ return 1
+}
+
+proc tc2:username_isvalid {username} {
+
+}
+
+proc tc2:username_exists {username} {
+ #TODO: Windows and other OSes
+ if {[exec -- logins -oxl $username] == ""} {
+ return 0
+ } {
+ return 1
+ }
+}
+
+}
+
+#phpfpm reload
+#phpfpm status
+#phpfpm create <user>
+proc tc2:command:phpfpm {requester arg} {
+ set command [lindex $arg 0]
+
+ switch $command {
+ "reload" {
+ if [catch {exec /usr/local/etc/rc.d/php-fpm reload} output] {
+ return {0 $output}
+ } {
+ return {1 "ok, php-fpm reloaded"}
+ }
+ }
+
+ "status" {
+ catch {exec /usr/local/etc/rc.d/php-fpm status} output
+ set reply 1
+ lappend reply [string map {"\n" " "} $output]
+ putdebug $reply
+ return $reply
+ }
+
+ "create" {
+ set user [lindex $arg 1]
+ if {$user == ""} {
+ return {0 "syntax: phpfpm create <user>"}
+ }
+ if [file exists "/usr/local/etc/php-fpm/$user.conf"] {
+ return {0 "there is already a $user pool"}
+ }
+ return {0 "not yet implemented"}
+ set port [sql "SELECT MAX(pool_port) FROM tc2_phpfpm_pools]
+ if {$port == ""} {
+ set port 9000
+ } {
+ incr port
+ }
+ #string map "%REQUESTER% $requester %TIME% [unixtime] %PORT% $port %USER% $user" $template
+ }
+
+ default {
+ set reply 0
+ lappend reply "unknown command: $command"
+ }
+ }
+}
diff --git a/TC2/Time.tcl b/TC2/Time.tcl
new file mode 100644
index 0000000..82570b8
--- /dev/null
+++ b/TC2/Time.tcl
@@ -0,0 +1,33 @@
+utimer 90 onload
+bind cron - "* * * * *" cron:minute
+bind cron - "*/5 * * * *" cron:often
+bind cron - "0 * * * *" cron:hourly
+bind cron - "0 4 * * *" cron:daily
+
+proc onload {} {
+ #Drops IRC support
+ unloadmodule irc
+ unloadmodule ctcp
+ unloadmodule channels
+ unloadmodule server
+
+ #Links to Nasqueron
+ link Nasqueron
+}
+
+#Every minute
+proc cron:minute {minute hour day month weekday} {
+}
+
+#Every 5 minutes
+proc cron:often {minute hour day month weekday} {
+ sqlrehash
+}
+
+#Every hour
+proc cron:hourly {minute hour day month weekday} {
+}
+
+#Every day, at 4am
+proc cron:daily {minute hour day month weekday} {
+}
diff --git a/Tech.tcl b/Tech.tcl
new file mode 100644
index 0000000..ed2548e
--- /dev/null
+++ b/Tech.tcl
@@ -0,0 +1,216 @@
+unbind dcc n rehash *dcc:rehash
+ bind dcc T rehash dcc:rehash
+ bind dcc T s dcc:source
+unbind dcc n tcl *dcc:tcl
+ bind dcc T tcl dcc:tcl
+
+ bind dcc T sql dcc:sql
+ bind dcc T sql? dcc:sql?
+ bind dcc T sql! dcc:sql!
+ bind dcc T sql1 dcc:sql1
+ bind dcc T sql1? dcc:sql1?
+ bind dcc T sql1! dcc:sql1!
+ bind dcc T sqlrehash dcc:sqlrehash
+
+ bind dcc T tcldoc dcc:tcldoc
+
+#
+# Helpers methods
+#
+
+#Logs a timestamped message to the specified file
+proc log {logfile handle message} {
+ global username
+ set fd [open "logs/$username/$logfile.log" a]
+ puts $fd "\[[unixtime]\] <$handle> $message"
+ close $fd
+}
+
+#Prints a message to all the techs
+proc putdebug {message} {
+ foreach conn [dcclist CHAT] {
+ foreach "idx handle uhost type flags idle" $conn {}
+ #dccputchan 0 "(debug) $conn"
+ if [matchattr $handle T] {
+ putdcc $idx "\[DEBUG\] $message"
+ }
+ }
+}
+
+#
+# Tech commands
+#
+
+#Disconnect SQL, then rehash (to prevent sql connect fatal errors)
+proc dcc:rehash {handle idx arg} {
+ catch {
+ sql disconnect
+ sql2 disconnect
+ }
+ *dcc:rehash $handle $idx $arg
+}
+
+#Loads a script
+proc dcc:source {handle idx arg} {
+ if {$arg == ""} {
+ putdcc $idx "Usage: .s <script> [script2 ...]"
+ return
+ }
+ foreach file $arg {
+ if ![sourcetry $file] {
+ putdcc $idx "Can't find script $file"
+ }
+ }
+}
+
+#Tries to load a script
+proc sourcetry {file} {
+ global username
+ set scriptlist "$file $file.tcl scripts/$file scripts/$file.tcl scripts/$username/$file scripts/$username/$file.tcl"
+ foreach script $scriptlist {
+ if [file exists $script] {
+ source $script
+ return 1
+ }
+ }
+ return 0
+}
+
+#.tcl with tech.log logging
+proc dcc:tcl {handle idx arg} {
+ catch {log tech $handle $arg}
+ *dcc:tcl $handle $idx $arg
+}
+
+#
+# SQL
+#
+
+#TODO: move to Core.tcl
+proc sqlrehash {} {
+ global sql
+ catch {
+ sql disconnect
+ sql2 disconnect
+ }
+ sql connect $sql(host) $sql(user) $sql(pass)
+ sql2 connect $sql(host) $sql(user) $sql(pass)
+ sql selectdb $sql(database)
+ sql2 selectdb $sql(database)
+}
+
+proc sqlescape {data} {
+ #\ -> \\
+ #' -> \'
+ string map {"\\" "\\\\" "'" "\\'"} $data
+
+}
+
+#Adds specified data to specified SQL table
+proc sqladd {table {data1 ""} {data2 ""}} {
+ if {$data1 == ""} {
+ set fields ""
+ #Prints field to fill
+ foreach row [sql "SHOW COLUMNS FROM $table"] {
+ lappend fields [lindex $row 0]
+ }
+ return $fields
+ }
+
+ if {$data2 == ""} {
+ set sql "INSERT INTO $table VALUES ("
+ set data $data1
+ } {
+ set sql "INSERT INTO $table (`[join $data1 "`, `"]`) VALUES ("
+ set data $data2
+ }
+ set first 1
+ foreach value $data {
+ if {$first == 1} {set first 0} {append sql ", "}
+ append sql "'[sqlescape $value]'"
+ }
+ append sql ")"
+ sql $sql
+}
+
+#Reconnects to the MySQL main server (sql and sql2)
+proc dcc:sqlrehash {handle idx arg} {
+ sqlrehash
+ return 1
+}
+
+#
+# dcc:sql1 dcc:sql1? and dcc:sql1! are the main procedures
+# They will be cloned for the 9 other connections command
+#
+
+#Executes a query
+proc dcc:sql1 {handle idx arg} {
+ if {$arg == ""} {
+ putdcc $idx "Usage: .sql1 <query>"
+ return
+ }
+
+ #Executes the query and prints the query one row per line
+ set t1 [clock milliseconds]
+ if [catch {
+ foreach row [sql1 $arg] {
+ putdcc $idx $row
+ }
+ } err] {
+ putdcc $idx $err
+ }
+
+ #Warns after a long query
+ set delta_t [expr [clock milliseconds] - $t1]
+ if {$delta_t > 1999} {
+ putcmdlog "Fin de la requête SQL ($delta_t ms)."
+ }
+
+ #Logs the query
+ log sql $handle "sql1\t$arg"
+}
+
+#Dumps (SELECT * FROM <table>) a table
+proc dcc:sql1! {handle idx arg} {
+ if {$arg == ""} {
+ putdcc $idx "Usage: .sql1! <table>"
+ return
+ }
+ dcc:sql1 $handle $idx "SELECT * FROM $arg"
+}
+
+#Without parameters, list the tables (SHOW TABLES)
+#With a parameter, dump tables info (SHOW CREATE TABLE)
+proc dcc:sql1? {handle idx arg} {
+ if {$arg == ""} {
+ dcc:sql1 $handle $idx "SHOW TABLES"
+ }
+ foreach table $arg {
+ dcc:sql1 $handle $idx "SHOW CREATE TABLE $table"
+ }
+}
+
+#Clones .sql1, .sql1? and .sql1! commands into .sql, .sql? and .sql!
+proc dcc:sql {handle idx arg} [string map "sql1 sql" [info body dcc:sql1]]
+proc dcc:sql? {handle idx arg} [string map "sql1 sql" [info body dcc:sql1?]]
+proc dcc:sql! {handle idx arg} [string map "sql1 sql" [info body dcc:sql1!]]
+
+#Clones .sql1, .sql1? and .sql1! commands into .sql2, .sql3, ..., .sql10.
+for {set i 2} {$i < 11} {incr i} {
+ bind dcc T sql$i dcc:sql$i
+ bind dcc T sql$i? dcc:sql$i?
+ bind dcc T sql$i! dcc:sql$i!
+ proc dcc:sql$i {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1]]
+ proc dcc:sql$i! {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1!]]
+ proc dcc:sql$i? {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1?]]
+}
+
+#
+# Reference documentation
+#
+
+proc dcc:tcldoc {handle idx arg} {
+ putdcc $idx [exec -- grep $arg doc/tcl-commands.doc]
+ return 1
+}

File Metadata

Mime Type
text/x-diff
Expires
Mon, Nov 25, 11:38 (1 d, 13 h)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
2260100
Default Alt Text
(17 KB)

Event Timeline

Nasqueron DevCentral · If it had been much bigger the moon would have had a core of ice. · Powered by Phabricator