-
-
Save antirez/6ca04dd191bdb82aad9fb241013e88a8 to your computer and use it in GitHub Desktop.
| # LVDB - LLOOGG Memory DB | |
| # Copyriht (C) 2009 Salvatore Sanfilippo <antirez@gmail.com> | |
| # All Rights Reserved | |
| # TODO | |
| # - cron with cleanup of timedout clients, automatic dump | |
| # - the dump should use array startsearch to write it line by line | |
| # and may just use gets to read element by element and load the whole state. | |
| # - 'help','stopserver','saveandstopserver','save','load','reset','keys' commands. | |
| # - ttl with milliseconds resolution 'ttl a 1000'. Check ttl in dump! | |
| # - cluster. Act as master, send write ops to all servers, get from one at random. Auto-serialization. | |
| # - 'hold' and 'continue' command, for sync in cluster mode | |
| # - auto-sync, consider lazy copy or log of operations to re-read at start | |
| # - client timeout | |
| # - save dump in temp file.[clock ticks] than rename it | |
| package require Tclx ;# For [fork] | |
| array set ::clients {} | |
| array set ::state {} | |
| array set ::readlen {} | |
| array set ::readbuf {} | |
| array set ::db {} | |
| array set ::ttl {} | |
| set ::dirty 0 | |
| set ::lastsaved 0 | |
| set ::listensocket {} | |
| signal -restart block SIGCHLD | |
| # the K combinator is using for Tcl object refcount hacking | |
| # in order to avoid useless object copy. | |
| proc K {x y} { | |
| set x | |
| } | |
| proc headappend {var e} { | |
| upvar 1 $var l | |
| set l [lreplace [K $l [set l {}]] -1 -1 $e] | |
| } | |
| proc log msg { | |
| puts stderr "[clock format [clock seconds]]\] $msg " | |
| } | |
| proc warning msg { | |
| log "*** WARNING: $msg" | |
| } | |
| proc writemsg {fd msg} { | |
| puts -nonewline $fd $msg | |
| puts -nonewline $fd "\r\n" | |
| } | |
| proc resetclient {fd} { | |
| set ::clients($fd) [clock seconds] | |
| set ::state($fd) {} | |
| set ::readlen($fd) 0 | |
| set ::readbuf($fd) {} | |
| } | |
| proc accept {fd addr port} { | |
| resetclient $fd | |
| fconfigure $fd -blocking 0 -translation binary -encoding binary | |
| fileevent $fd readable [list readrequest $fd] | |
| } | |
| proc readrequest fd { | |
| if [eof $fd] { | |
| closeclient $fd | |
| return | |
| } | |
| # Handle bulk read | |
| if {$::state($fd) ne {}} { | |
| set buf [read $fd [expr {$::readlen($fd)-[string length $::readbuf($fd)]}]] | |
| append ::readbuf($fd) $buf | |
| if {[string length $::readbuf($fd)] >= $::readlen($fd)} { | |
| set ::readbuf($fd) [string range $::readbuf($fd) 0 end-2] | |
| lappend ::state($fd) $::readbuf($fd) | |
| cmd_[lindex $::state($fd) 0] $fd $::state($fd) | |
| } | |
| return | |
| } | |
| # Handle first line request | |
| set req [string trim [gets $fd] "\r\n "] | |
| if {$req eq {}} return | |
| # Process command | |
| set args [split $req] | |
| set cmd [string tolower [lindex $args 0]] | |
| foreach ct $::cmdtable { | |
| if {$cmd eq [lindex $ct 0] && [llength $args] == [lindex $ct 1]} { | |
| if {[lindex $ct 2] eq {inline}} { | |
| cmd_$cmd $fd $args | |
| } else { | |
| set readlen [lindex $args end] | |
| if {$readlen < 0 || $readlen > 1024*1024} { | |
| writemsg $fd "protocol error: invalid bulk read length" | |
| closeclient $fd | |
| return | |
| } | |
| bulkread $fd [lrange $args 0 end-1] $readlen | |
| } | |
| return | |
| } | |
| } | |
| writemsg $fd "protocol error: invalid command '$cmd'" | |
| closeclient $fd | |
| } | |
| proc bulkread {fd argv len} { | |
| set ::state($fd) $argv | |
| set ::readlen($fd) [expr {$len+2}] ;# Add two bytes for CRLF | |
| } | |
| proc closeclient fd { | |
| unset ::clients($fd) | |
| unset ::state($fd) | |
| unset ::readlen($fd) | |
| unset ::readbuf($fd) | |
| close $fd | |
| } | |
| proc cron {} { | |
| # Todo timeout clients timeout | |
| puts "lmdb: [array size ::db] keys, [array size ::clients] clients, dirty: $::dirty, lastsaved: $::lastsaved" | |
| after 1000 cron | |
| } | |
| set ::cmdtable { | |
| {ping 1 inline} | |
| {quit 1 inline} | |
| {set 3 bulk} | |
| {get 2 inline} | |
| {exists 2 inline} | |
| {delete 2 inline} | |
| {incr 2 inline} | |
| {decr 2 inline} | |
| {lpush 3 bulk} | |
| {rpush 3 bulk} | |
| {save 1 inline} | |
| {bgsave 1 inline} | |
| } | |
| proc okreset {fd {msg OK}} { | |
| writemsg $fd $msg | |
| flush $fd | |
| resetclient $fd | |
| } | |
| proc cmd_ping {fd argv} { | |
| writemsg $fd "PONG" | |
| flush $fd | |
| resetclient $fd | |
| } | |
| proc cmd_quit {fd argv} { | |
| okreset $fd | |
| closeclient $fd | |
| } | |
| proc cmd_set {fd argv} { | |
| set ::db([lindex $argv 1]) [lindex $argv 2] | |
| incr ::dirty | |
| okreset $fd | |
| } | |
| proc cmd_get {fd argv} { | |
| if {[info exists ::db([lindex $argv 1])]} { | |
| set val $::db([lindex $argv 1]) | |
| } else { | |
| set val {} | |
| } | |
| writemsg $fd [string length $val] | |
| writemsg $fd $val | |
| flush $fd | |
| resetclient $fd | |
| } | |
| proc cmd_exists {fd argv} { | |
| if {[info exists ::db([lindex $argv 1])]} { | |
| set res 1 | |
| } else { | |
| set res 0 | |
| } | |
| writemsg $fd $res | |
| flush $fd | |
| resetclient $fd | |
| } | |
| proc cmd_delete {fd argv} { | |
| unset -nocomplain -- ::db([lindex $argv 1]) | |
| incr ::dirty | |
| writemsg $fd "OK" | |
| flush $fd | |
| resetclient $fd | |
| } | |
| proc cmd_incr {fd argv} { | |
| cmd_incrdecr $fd $argv 1 | |
| } | |
| proc cmd_decr {fd argv} { | |
| cmd_incrdecr $fd $argv -1 | |
| } | |
| proc cmd_incrdecr {fd argv n} { | |
| if {[catch { | |
| incr ::db([lindex $argv 1]) $n | |
| }]} { | |
| set ::db([lindex $argv 1]) $n | |
| } | |
| incr ::dirty | |
| writemsg $fd $::db([lindex $argv 1]) | |
| flush $fd | |
| resetclient $fd | |
| } | |
| proc cmd_lpush {fd argv} { | |
| cmd_push $fd $argv -1 | |
| } | |
| proc cmd_rpush {fd argv} { | |
| cmd_push $fd $argv 1 | |
| } | |
| proc cmd_push {fd argv dir} { | |
| if {[catch { | |
| llength $::db([lindex $argv 1]) | |
| }]} { | |
| if {![info exists ::db([lindex $argv 1])]} { | |
| set ::db([lindex $argv 1]) {} | |
| } else { | |
| set ::db([lindex $argv 1]) [split $::db([lindex $argv 1])] | |
| } | |
| } | |
| if {$dir == 1} { | |
| lappend ::db([lindex $argv 1]) [lindex $argv 2] | |
| } else { | |
| headappend ::db([lindex $argv 1]) [lindex $argv 2] | |
| } | |
| incr ::dirty | |
| okreset $fd | |
| } | |
| proc savedb {} { | |
| set err [catch { | |
| set fp [open "saved.lmdb" w] | |
| fconfigure $fp -encoding binary -translation binary | |
| set search [array startsearch ::db] | |
| set elements [array size ::db] | |
| for {set i 0} {$i < $elements} {incr i} { | |
| set key [array nextelement ::db $search] | |
| set val $::db($key) | |
| puts $fp "[string length $key] [string length $val]" | |
| puts -nonewline $fp $key | |
| puts -nonewline $fp $val | |
| } | |
| close $fp | |
| set ::dirty 0 | |
| set ::lastsaved [clock seconds] | |
| } errmsg] | |
| if {$err} {return $errmsg} | |
| return {} | |
| } | |
| proc backgroundsave {} { | |
| unset -nocomplain ::dbcopy | |
| array set ::dbcopy [array get ::db] | |
| } | |
| proc cmd_bgsave {fd argv} { | |
| backgroundsave | |
| okreset $fd | |
| } | |
| proc cmd_save {fd argv} { | |
| set errmsg [savedb] | |
| if {$errmsg ne {}} { | |
| okreset $fd "ER" | |
| warning "Error trying to save: $errmsg" | |
| } else { | |
| okreset $fd | |
| log "State saved" | |
| } | |
| } | |
| proc loaddb {} { | |
| set err [catch { | |
| set fp [open "saved.lmdb"] | |
| fconfigure $fp -encoding binary -translation binary | |
| set count 0 | |
| while {[gets $fp len] != -1} { | |
| set key [read $fp [lindex $len 0]] | |
| set val [read $fp [lindex $len 1]] | |
| set ::db($key) $val | |
| incr count | |
| } | |
| log "$count keys loaded" | |
| close $fp | |
| } errmsg] | |
| if {$err} { | |
| warning "Loading DB from file: $errmsg" | |
| } | |
| return $err | |
| } | |
| proc main {} { | |
| log "Server started" | |
| if {[file exists saved.lmdb]} loaddb | |
| set ::dirty 0 | |
| set ::listensocket [socket -server accept 6379] | |
| cron | |
| } | |
| main | |
| vwait forever |
@antirez That's a nice story. Also, the link to "la gelateria" is invalid, btw.
Thank you @tomas-fp, I was very happy to discover it since I did not ever remember at this point if the story I told to people about the first Tcl version having already lists was true, but actually it was far more advanced than that: there was already the concept of fork() for persistency for example, and certain comments and function names totally resamble modern Redis names / parts.
Lovely, its always amazing to see how a product evolved from a "very simple" program. Also this implementation reminds me something that apparently a lot forger these days. People are lost in which framework to use, which programming language, functional programming, DDD, TDD, BDD, XXD etc but here we are, redis v1 in tcl doing the job and moving the development forward. Nearly every successful software project out there is made with whatever the developer felt comfortable with at the time of the development.
Thx for sharing this.
If you enjoyed reading this, you might enjoy reading git's first self-hosted commit: git/git@e83c516
SOMEONE ELSE ON THE INTERNET HAS USED TCL??!?!
I thought I was the only one.
Potential name conflict https://symas.com/lightning-memory-mapped-database/
@sammy007 no problem I've no intention of using the name :-) I just left the original name, that btw predates the LMDB from Symas, but anyway the Symas folks could never know there was another LMDB since was never released in this form before. Later I tought that LMDB was too much of an acronym and that Redis was much more a name that users could remember/like, so I changed it with the C rewrite.
@antirez Finally I just noticed date at line 2 :)
@garrettwilkin AOL Server uses TCL. https://github.com/aolserver. Also everyone who uses good old expect is using TCL.
Dude I will definitely go get some ice-cream there! XD
The idea behind the cmdtable is still the same (now a struct redisCommand redisCommandTable[])
This shows that every complex system has evolved from simple system that works and does something useful.
I was recently reading Systemantics book recommended by some famous programmers - here is a quote from it.
"A complex system that works is invariably found to have evolved from a simple system that worked. A complex system designed from scratch never works and cannot be patched up to make it work. You have to start over with a working simple system." – John Gall Systemantics (1975, p.71)
Awesome
Also the port 6379, still the same
Maybe license it under BSD (that Redis uses) or another libre license? I bet there'll be Tcl hackers that would like play with it.
For anyone getting an ssl error at the above link, adding www appears to work: https://www.gelateriasiciliana.com
@antirez thanks for sharing. What a little treasure this is!
Maybe license it under BSD (that Redis uses) or another libre license? I bet there'll be Tcl hackers that would like play with it.
Sure, consider it BSD-licensed.
This was the first version of Redis... We used it inside our startup, with Fabio Pitrola. I found it while tweeting about the fact that now Fabio, the first user of Redis ever together with me, runs an icecream shop in Barcelona (you should try it btw, http://gelateriasiciliana.com/). Tried my luck with gmail and there was this email from 2009!
Note how in a 300 line so of code trow-away there was already most of Redis main ideas:
So from the POV of programming creation process, it looks like that a short trow-away can already have hints about how to perform future developments, by extending each part that can be, in the original throw away, just a comment.
Email date is: 4 Feb 2009.