LMDB -- First version of Redis written in Tcl

lmdb.tcl

# 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

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:

1. Fork() to persist, even if this was an higher level language.
2. Data structures: this version implements list pop/push primitives.
3. The protocol is the Redis v1 protocol, it's no longer the same nowadays, but the prefixed-length idea + human readable is there.
4. Many names and/or comments in the code even resemble the names of modern Redis parts / functions.

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.

@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.