2015-12-29

solr4tcl v0.1: A lightweight Tcl client interface to Apache Solr

Homepage


solr4tcl

About

A lightweight Tcl client interface to Apache Solr. The library consists of a single Tcl Module file.

solr4tcl is using Tcl built-in package http to send request to Aapache Solr.

This library requires package tdom.

Interface

The library has 1 TclOO class, Solr_Request.

Provide below things:
  • A simple search interface
  • A simple interface to add, delete and update documents to the index (using XML Formatted Index Updates)
  • Uploading file data by using Apache Tika

一些說明


經過閱讀 Apache Solr 的文件以後,使用 Tcl http package 送出 request 並且得到結果的記錄。應該是 work 的,起碼沒有出現網頁找不到或者是錯誤回應。

更新 2016/01/02:
雖然都是傳回 OK,但是 ping method 填的參數不是完全正確,我試著更新一份正確的。

2015-12-28

Apache Solr test code

solr4tcl-0.1.tm

# solr4tcl --
#

package require Tcl 8.6
package require TclOO
package require http
package require tdom

package provide solr4tcl 0.1


#
# Solr_Request class: handle send request to Apache Solr
#
oo::class create Solr_Request {
    variable server
    variable path
    variable solr_writer

    constructor {SERVER} {
        set server $SERVER
        set path ""

        set solr_writer "xml"
    }

    destructor {
    }

    method setDocumentPath {PATH} {
        set path $PATH
    }

    #
    # support type: xml, json and cvs
    #
    method setSolrWriter {WRITER} {
        set solr_writer $WRITER
    }

    method send_request {url method {headers ""} {data ""}} {
        variable tok

        if {[string length $data] < 1} {
            if {[catch {set tok [http::geturl $url -method $method \
                -headers $headers]}]} {
                return "error"
            }
        } else {
            if {[catch {set tok [http::geturl $url -method $method \
                -headers $headers -query $data]}]} {
                return "error"
            }
        }

        if {[string compare -nocase $method "HEAD"] == 1} {
            set res [http::data $tok]
        } else {
            set res [http::status $tok]
        }

        http::cleanup $tok
        return $res
    }

    #
    # Call the /admin/ping servlet
    #
    method ping {} {
        set myurl "$server/solr"

        if {[string length $path] < 1} {
            append myurl "/admin/ping"
        } else {
            append myurl "/$path/admin/ping"
        }

        set headerl ""
        set res [my send_request $myurl HEAD $headerl]
        return $res
    }

    #
    # Simple Search interface
    # params is a list, give this funcition name-value pair parameter
    #
    method search {query {offset 0} {limit 10} {params ""}} {
        set myurl "$server/solr"

        if {[string length $path] < 1} {
            append myurl "/select"
        } else {
            append myurl "/$path/select"
        }

        lappend params q $query
        lappend params wt $solr_writer
        lappend params start $offset
        lappend params rows $limit
        set querystring [http::formatQuery {*}$params]

        #
        # The return data format is defined by wt, $solr_writer setting.
        #
        set headerl [list Content-Type "application/x-www-form-urlencoded; charset=UTF-8"]
        set res [my send_request $myurl POST $headerl $querystring]

        return $res
    }

    #
    # parameters - a list include key-value pair
    #
    method add {parameters {OVERWRITE true} {BOOST "1.0"} {COMMIT true}} {
        # Try to build our XML document
        set doc [dom createDocument add]

        set root [$doc documentElement]
        $root setAttribute overwrite $OVERWRITE

        set docnode [$doc createElement doc]
        $docnode setAttribute boost $BOOST
        $root appendChild $docnode

        foreach {key value} $parameters {
            set node [$doc createElement field]
            $node setAttribute name $key
            $node appendChild [$doc createTextNode $value]
            $docnode appendChild $node
        }

        set myaddString [$root asXML]
        set myurl "$server/solr"

        set params [list commit $COMMIT]
        set querystring [http::formatQuery {*}$params]

        if {[string length $path] < 1} {
            append myurl "/update?$querystring"
        } else {
            append myurl "/$path/update?$querystring"
        }

        set headerl [list Content-Type "text/xml; charset=UTF-8"]
        set res [my send_request $myurl POST $headerl $myaddString]

        return $res
    }

    #
    # xmldata - xml data string want to add
    #
    method addData {xmldata {COMMIT true}} {
        set myurl "$server/solr"

        set params [list commit $COMMIT]
        set querystring [http::formatQuery {*}$params]

        if {[string length $path] < 1} {
            append myurl "/update?$querystring"
        } else {
            append myurl "/$path/update?$querystring"
        }

        set headerl [list Content-Type "text/xml; charset=UTF-8"]
        set res [my send_request $myurl POST $headerl $xmldata]

        return $res
    }

    #
    # The <commit>  operation writes all documents loaded since the last
    # commit to one or more segment files on the disk
    #
    method commit {{WAITSEARCHER true} {EXPUNGEDELETES false}} {
        set mycommitString "<commit waitSearcher=\"$WAITSEARCHER\" expungeDeletes=\"$EXPUNGEDELETES\"/>"
        set myurl "$server/solr"

        if {[string length $path] < 1} {
            append myurl "/update"
        } else {
            append myurl "/$path/update"
        }

        set headerl [list Content-Type "text/xml; charset=UTF-8"]
        set res [my send_request $myurl POST $headerl $mycommitString]

        return $res
    }

    #
    # The <optimize> operation requests Solr to merge internal data structures
    # in order to improve search performance.
    #
    method optimize {{WAITSEARCHER true} {MAXSegments 1}} {
        set myoptimizeString "<optimize waitSearcher=\"$WAITSEARCHER\" maxSegments=\"$MAXSegments\"/>"
        set myurl "$server/solr"

        if {[string length $path] < 1} {
            append myurl "/update"
        } else {
            append myurl "/$path/update"
        }

        set headerl [list Content-Type "text/xml; charset=UTF-8"]
        set res [my send_request $myurl POST $headerl $myoptimizeString]

        return $res
    }

    #
    #  "Delete by ID" deletes the document with the specified ID
    #
    method deleteById {ID {COMMIT true}} {
        set mydeleteString "<delete><id>$ID</id></delete>"
        set myurl "$server/solr"

        set params [list commit $COMMIT]
        set querystring [http::formatQuery {*}$params]

        if {[string length $path] < 1} {
            append myurl "/update?$querystring"
        } else {
            append myurl "/$path/update?$querystring"
        }

        set headerl [list Content-Type "text/xml; charset=UTF-8"]
        set res [my send_request $myurl POST $headerl $mydeleteString]

        return $res
    }

    #
    #  "Delete by Query" deletes all documents matching a specified query
    #
    method deleteByQuery {QUERY {COMMIT true}} {
        set mydeleteString "<delete><query>$QUERY</query></delete>"
        set myurl "$server/solr"

        set params [list commit $COMMIT]
        set querystring [http::formatQuery {*}$params]

        if {[string length $path] < 1} {
            append myurl "/update?$querystring"
        } else {
            append myurl "/$path/update?$querystring"
        }

        set headerl [list Content-Type "text/xml; charset=UTF-8"]
        set res [my send_request $myurl POST $headerl $mydeleteString]

        return $res
    }

    #
    #  Uploading Data by using Apache Tika
    #
    method upload {fileContent {FILENAME ""} {COMMIT true} {ExtractOnly false} {params ""}} {
        set myurl "$server/solr"

        lappend params commit $COMMIT extractOnly $ExtractOnly

        if {[string length $FILENAME] > 1} {
            lappend params "resource.name" $FILENAME
        }

        set querystring [http::formatQuery {*}$params]

        if {[string length $path] < 1} {
            append myurl "/update/extract?$querystring"
        } else {
            append myurl "/$path/update/extract?$querystring"
        }

        set headerl [list Content-Type "text/xml; charset=UTF-8"]
        set res [my send_request $myurl POST $headerl $fileContent]

        return $res
    }
}



Test code:

#!/usr/bin/tclsh

package require solr4tcl

set solrresquest [Solr_Request new "http://localhost:8983"]
$solrresquest setDocumentPath gettingstarted

# support xml, json or csv
$solrresquest setSolrWriter xml

set res [$solrresquest ping]
if {[string compare -nocase $res "ok"]!=0} {
    puts "Apache Solr server returns not OK, close."
    exit
}

set res [$solrresquest search "foundation"]
puts "Search result:"
puts $res

set parameters [list authors "Patrick Eagar" subject "Sports" dd "796.35" \
                     isdn "0002166313" yearpub "1982" publisher "Collins"]
set res [$solrresquest add $parameters true]
puts $res

set res [$solrresquest commit]
puts $res

set res [$solrresquest optimize]
puts $res

set res [$solrresquest deleteById "0002166313"]
puts $res

set res [$solrresquest deleteByQuery "publisher:Collins"]
puts $res

#set size [file size "./solr-word.pdf"] 
#set fd [open "./solr-word.pdf" {RDWR BINARY}]  
#fconfigure $fd -blocking 1 -encoding binary -translation binary 
#set data [read $fd $size]  
#close $fd  
#set res [$solrresquest upload $data "solr-word.pdf"]
#puts $res

set res [$solrresquest search "pdf"]
puts "Search result:"
puts $res



Apache Solr 沒有像 Apache CouchDB 一樣,有將 REST API 做一個整理表,所以我只是對 search 的部份做一個簡單的 search method,然後確定有正確的回應回來(而不是無法連線,或者是傳回來一個網頁不存在的 404 錯誤網頁,如果有執行 Solr 的 Solr Quick Start)。

更新 2015/12/29:
加入上傳檔案和 index 處理的部份

更新 2016/01/02:
更新 method ping 的參數

2015-12-26

PostgreSQL extension: hstore

PostgreSQL: hstore


厲害的地方在於,不只可以放一個 key-value pair,而是可以在一個 column 上放一個以上的 key-value pair。

在 Windows 平台上測試最近安裝的  PostgreSQL 9.4.5 是否有支援 hstore:

package require tdbc::postgres
tdbc::postgres::connection create db -user postgres -password postgres -port 5432

set statement [db prepare {
     CREATE EXTENSION hstore
}]

$statement foreach row {
 puts $row
}

$statement close
db close


得到 extension "hstore" already exists 的答案。

更新:列出目前系統上的 extension name:

package require tdbc::postgres
tdbc::postgres::connection create db -user postgres -password postgres -port 5432

set statement [db prepare {
     select extname from pg_extension
}]

$statement foreach row {
 puts $row
}

$statement close
db close

2015-12-24

SSDB 與 retcl

SSDB

Features

  • An alternative to Redis, 100x Redis
  • LevelDB client-server support, written in C/C++
  • Redis API compatible, Redis clients are supported
  • Designed to store collection data, such as list, hash, zset...
  • Client API supports including C++, PHP, Python, Java, Go
  • Persistent queue service
  • Replication(master-slave), load balance

retcl: Tcl client library for Redis


看完了 SSDB 寫的 features,所以我可以拿一個 Redis 的 client 來連線並且測試囉?閱讀 SSDB 的文件,SSDB 的 port 是 8888。

retcl create r 127.0.0.1 8888

接下來使用 retcl 的範例進行一些測試,真的可以直接使用(除了 Publish / Subscribe and callbacks, Handling errors 我沒試,另外 retcl  Commands pipelining 的範例要先 set i 0,總之要先設定 i 的值),SSDB 有些 command 回來的反應和說明不太一致(例如 info 只傳回 OK),不過大體上 SSDB 確實是 Redis API compatible,也就是如果 Redis client 寫的彈性一點,理論上就可以無痛的拿來 SSDB 這邊使用。

PS. 不要嘗試在 Windows 平台使用 SSDB,雖然在網路上可以找到 binary files,但是跟作者網站上講的一樣,不建議在 Windows 平台上使用。

couchdbtcl: rename oauth-1.0.tm

couchdbtcl


我沒注意到 tcllib 中已經有 package 名稱是 oauth,雖然我測試的時候可以正確執行,不過為了避免套件名稱衝突,所以 oauth-1.0.tm 被我改名為 myoauth-1.0.tm,提供的套件從 oauth 變成 myoauth。

2015-12-23

tclusb v0.3: remove hotplug command

Tclusb


因為 hotplug 已經失效很久了(libusb 的 hotplug 是正常的,但是我不知道怎麼修正 Tcl channel notify 失效的問題),經過思考,我決定保持版本在 v0.3,移掉 hotplug 的部份,然後重新整理一次目前 Tclusb 的網頁。雖然這樣 Tclusb 就只剩下簡單的 list devices 功能。

我會再整理並且 review code,確定我有移乾淨,然後把 LICENSE 改成 2-clause BSD license。

2015-12-23 更新:
整理結束。

2015-12-22

Converting Characters (format command)

資料來源:Tcler's wiki


使用 format command 來做到 chr() function 的效果。
interp alias {} chr {} format %c

測試:
set a admin[chr 48]

很有趣的寫法。

2015-12-15

OpenACS 5.9.0 is released

ANNOUNCE: OpenACS 5.9.0 final released

This release contains many security and performance improvements as well as new functionality. The new release differs from OpenACS 5.8.1 in the following points:
- PostgreSQL enhancements and cleanups to improve performance and maintainability of the basic data model
- Greatly improved HTML validity and protection against XSS attacks.
- Improved theming support to create responsive interfaces.
- Various new functionalities to ease debugging and to improve performance. 



看起來更新幅度還蠻大的版本。

更新:
就閱讀的資料,目前支援 AOLserver 與 NaviServer。但是我沒有時間測試,只是對 OpenACS ChangeLog 的 use tcl8.5 idioms 和一些變動有興趣,我想這應該是一個已經全部使用 Tcl 8.5 的版本。

Redland Tcl support is dead

RDF at Tcler's Wiki

根據我搜尋網路的結果,Redland 對於 Tcl binding 已經不再支援(也已經 drop 掉 C# 和 Java),避免有人跟我一樣傻傻的使用各個關鍵字搜尋半天,所以我已經更新了 Tcler's Wiki 的資料。

目前 Tcl 惟一還可能可以用的 RDF Tool 是 XOTcl 的 xoRDF,不過我對 XOTcl 並不是很熟悉,所以也沒有去嘗試使用。

如果要自己使用 Tcl parse RDF/XML 檔案,可能需要使用 XML parer 去解析才行,但是根據 Problems of the RDF syntax 的說法,簡單的資料或許還可以,但是複雜的資料應該會囧。

我本來想研究一下 RDF 的狀況,如果我接下來的搜尋無法取得更有用的資料,那麼 RDF 的研究工作就到這裡了。

更新:
Google 搜尋會跑出來 RDF is dead 基本上有點…… 下面是另外一個參考文章:
Why Microdata, Not RDF, Will Power the Semantic Web

(接在上面連結以後的更新:RDFa Lite 和 Microdata 是二個直接競爭的標準,然後加上 JSON-LD,就是目前可以讓 web page 具備 structured data 特性的三個主要競爭者,不過三個都距離我目前專注的東西太遠了,跳過)

所以我想除了有一些特別領域的需求,大家可以放生 RDF 了。

2015-12-12

tcljsonnet v0.1

檔案放置網頁


tcljsonnet - Jsonnet wrapper for Tcl

About

Jsonnet is a domain specific configuration language that helps you define JSON data. Jsonnet lets you compute fragments of JSON within the structure, bringing the same benefit to structured data that templating languages bring to plain text.

For additional information on Jsonnet see
http://google.github.io/jsonnet/doc/


This package is a Jsonnet wrapper for Tcl.

一些說明


因為覺得 Jsonnet 是個很有趣的工具,所以今天寫了一個很簡單的 Tcl interface 來使用。

2015-12-09

couchdbtcl v0.1

檔案放置網頁


couchdbtcl - A Tcl client interface to Apache CouchDB

About

A Tcl client interface to Apache CouchDB.The library consists of a single Tcl Module file.

couchdbtcl is using Tcl built-in package http and Tcllib base64 package (for HTTP Basic Authentication) to send request to Aapache CouchDB.

一些說明


安裝 CouchDB 1.6.1 在 Windows XP SP3 上並且測試 CouchDB 的設定。這個套件是我閱讀 CouchDB API 文件的過程中使用 Tcl http package 對 CouchDB 進行 API request 並且得到 response,與測試認證方式(Basic Authentication, Cookie Authentication and OAuth Authentication)所撰寫的 client 端程式。

oauth

可以參考的連結:
Tcler's wiki: oauth


Apache CouchDB 支援了四種認證方式,Basic Authentication, Cookie Authentication, Proxy Authentication and OAuth Authentication。

其中我已經確定 Basic Authentication, Cookie Authentication 的使用方式,Proxy Authentication 我目前沒有適合的環境可以測試,所以剩下 OAuth Authentication,我會先測試看看目前 Tcler's wiki 上的 code 是不是可以使用。


更新:
測試成功,所以可以用 Tcler's wiki: oauth 的方式來進行 Apache CouchDB 的 OAuth Authentication。

2015-12-07

Apache CouchDB test code 2

#
# The Database endpoint provides an interface to an entire database with
# in CouchDB. These are database-level, rather than document-level requests.
#
oo::class create CouchDB_Database {
    variable host
    variable port
    variable database
    variable authtype
    variable username
    variable password
    variable firstcookie
    variable authSession

    constructor {HOST PORT DATABASE AUTHTYPE {USERNAME ""} {PASSWORD ""}} {
        set host $HOST
        set port $PORT
        set database $DATABASE
        set authtype $AUTHTYPE
        set username $USERNAME
        set password $PASSWORD
        set firstcookie 0
        set authSession ""
    }

    destructor {
    }

    method send_request {url method {headers ""} {data ""}} {
        # Now support authtype: no basic cookie
        if {[string compare -nocase $authtype "basic"]==0} {
            set auth "Basic [base64::encode $username:$password]"
            lappend headers Authorization $auth
        } elseif {[string compare -nocase $authtype "cookie"]==0} {
            set cookiestring "AuthSession=$authSession"
            lappend headers Cookie $cookiestring
        }

        if { [string length $data] < 1 } {
            set tok [http::geturl $url -method $method -headers $headers]
        } else {
            set tok [http::geturl $url -method $method -headers $headers -query $data]
        }

        if {[string compare -nocase $authtype "cookie"]==0 && $firstcookie==1} {
            set meta [http::meta $tok]
            foreach {name value} $meta {
                if {[string compare $name Set-Cookie]==0} {
                    set firstlocation [string first "=" $value]
                    incr firstlocation 1
                    set lastlocation  [string first "; " $value]
                    incr lastlocation -1
                    set authSession [string range $value $firstlocation $lastlocation]
                }
            }
        }

        set res [http::data $tok]
        http::cleanup $tok
        return $res
    }

    # Initiates new session for specified user credentials by providing Cookie value.
    method cookie_post {} {
        set firstcookie 1
        set myurl "http://$host:$port/_session"
        set headerl [list Accept "application/json" Content-Type "application/x-www-form-urlencoded"]
        set data [::http::formatQuery name $username password $password]
        set res [my send_request $myurl POST $headerl $data]

        set firstcookie 0

        return $res
    }

    # Returns complete information about authenticated user.
    method cookie_get {} {
        set myurl "http://$host:$port/_session"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set cookiestring "AuthSession=$authSession"
        lappend headers Cookie $cookiestring
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Closes user’s session.
    method cookie_delete {} {
        set myurl "http://$host:$port/_session"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set cookiestring "AuthSession=$authSession"
        lappend headers Cookie $cookiestring
        set res [my send_request $myurl DELETE $headerl]

        return $res
    }

    # Creates a new database.
    method create {} {
        set myurl "http://$host:$port/$database"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl PUT $headerl]

        return $res
    }

    # Gets information about the specified database.
    method info {} {
        set myurl "http://$host:$port/$database"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Delete a new database.
    method delete {} {
        set myurl "http://$host:$port/$database"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl DELETE $headerl]

        return $res
    }

    # Creates a new document in the specified database,
    # using the supplied JSON document structure.
    method db_post {data} {
        set myurl "http://$host:$port/$database"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # Returns a JSON structure of all of the documents in a given database.
    method all_docs_get {{data ""}} {
        set myurl "http://$host:$port/$database/_all_docs"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET  $headerl $data]

        return $res
    }

    # The POST to _all_docs allows to specify multiple keys to be
    # selected from the database.
    method all_docs_post {data} {
        set myurl "http://$host:$port/$database/_all_docs"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # The bulk document API allows you to create and update multiple
    # documents at the same time within a single request.
    method bulk_docs {data} {
        set myurl "http://$host:$port/$database/_bulk_docs"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # Requests the database changes feed
    method changes {{data ""}} {
        set myurl "http://$host:$port/$database/_changes"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl $data]

        return $res
    }

    # Request compaction of the specified database.
    method compact {} {
        set myurl "http://$host:$port/$database/_compact"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl]

        return $res
    }

    # Commits any recent changes to the specified database to disk.
    method ensure_full_commit {} {
        set myurl "http://$host:$port/$database/_ensure_full_commit"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl]

        return $res
    }

    # Removes view index files that are no longer required by CouchDB as a
    # result of changed views within design documents.
    method view_cleanup {} {
        set myurl "http://$host:$port/$database/_view_cleanup"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl]

        return $res
    }

    # Returns the current security object from the specified database.
    #
    # If the security object for a database has never been set, then the
    # value returned will be empty.
    method security_get {} {
        set myurl "http://$host:$port/$database/_security"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Sets the security object for the given database.
    method security_put {data} {
        set myurl "http://$host:$port/$database/_security"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl PUT $headerl $data]

        return $res
    }

    # Creates (and executes) a temporary view based on the view function
    # supplied in the JSON request.
    method temp_view {data} {
        set myurl "http://$host:$port/$database/_temp_view"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # A database purge permanently removes the references to deleted
    # documents from the database.
    method purge {data} {
        set myurl "http://$host:$port/$database/_purge"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # With given a list of document revisions, returns the document
    # revisions that do not exist in the database.
    method missing_revs {data} {
        set myurl "http://$host:$port/$database/_missing_revs"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # Given a set of document/revision IDs, returns the subset of those
    # that do not correspond to revisions stored in the database.
    method revs_diff {data} {
        set myurl "http://$host:$port/$database/_revs_diff"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # Gets the current revs_limit (revision limit) setting.
    method revs_limit_get {} {
        set myurl "http://$host:$port/$database/_revs_limit"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Sets the maximum number of document revisions that will be tracked by
    # CouchDB, even after compaction has occurred.
    method revs_limit_put {data} {
        set myurl "http://$host:$port/$database/_revs_limit"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl PUT $headerl $data]

        return $res
    }

    #
    # Method for Apache couchDB Document API
    # Each document in CouchDB has an ID. This ID is unique per database.
    #

    # Gets the specified document.
    method doc_get {id {data ""}} {
        set myurl "http://$host:$port/$database/$id"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl $data]

        return $res
    }

    # Stores the specified document.
    method doc_put {id data} {
        set myurl "http://$host:$port/$database/$id"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl PUT $headerl $data]

        return $res
    }

    # Deletes the specified document.
    # rev - Actual document’s revision
    method doc_delete {id rev} {
        set myurl "http://$host:$port/$database/$id"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        lappend headerl If-Match $rev
        set res [my send_request $myurl DELETE $headerl]

        return $res
    }

    # Copies the specified document.
    # destination – Destination document
    method doc_copy {id destination} {
        set myurl "http://$host:$port/$database/$id"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        lappend headerl Destination $destination
        set res [my send_request $myurl COPY $headerl]

        return $res
    }

    # Returns the file attachment associated with the document.
    # revision is Document revision.
    method docid_attachment_get {id attname revision} {
        set myurl "http://$host:$port/$database/$id/$attname"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        lappend  headerl If-Match $revision
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Uploads the supplied content as an attachment to the specified document.
    # revision is Document revision.
    # ContentType need give it a Attachment MIME type. Required!
    method docid_attachment_put {id attname revision ContentType data} {
        set myurl "http://$host:$port/$database/$id/$attname"
        set headerl [list Content-Type $ContentType]
        lappend  headerl If-Match $revision
        set res [my send_request $myurl PUT $headerl $data]

        return $res
    }

    # Deletes the attachment attachment of the specified doc.
    # revision is Document revision.
    method docid_attachment_delete {id attname revision} {
        set myurl "http://$host:$port/$database/$id/$attname"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        lappend  headerl If-Match $revision
        set res [my send_request $myurl DELETE $headerl]

        return $res
    }

    #
    # In CouchDB, design documents provide the main interface for building
    # a CouchDB application. The design document defines the views used to
    # extract information from CouchDB through one or more views.
    #

    # Returns the contents of the design document specified with the name
    # of the design document and from the specified database from the URL.
    method designdoc_get {ddocument} {
        set myurl "http://$host:$port/$database/_design/$ddocument"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # The PUT method creates a new named design document, or creates a new
    # revision of the existing design document.
    method designdoc_put {ddocument data} {
        set myurl "http://$host:$port/$database/_design/$ddocument"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl PUT $headerl $data]

        return $res
    }

    # Deletes the specified document from the database.
    method designdoc_delete {ddocument revision} {
        set myurl "http://$host:$port/$database/_design/$ddocument"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        lappend  headerl If-Match $revision
        set res [my send_request $myurl DELETE $headerl]

        return $res
    }

    # The COPY (which is non-standard HTTP) copies an existing
    # design document to a new or existing one.
    # destination – Destination document
    method designdoc_copy {ddocument destination} {
        set myurl "http://$host:$port/$database/_design/$ddocument"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        lappend header1 Destination $destination
        set res [my send_request $myurl COPY $headerl]

        return $res
    }

    # Returns the file attachment associated with the design document.
    # The raw data of the associated attachment is returned (just as if
    # you were accessing a static file.
    method designdoc_attachment_get {ddocument attname revision} {
        set myurl "http://$host:$port/$database/_design/$ddocument/$attname"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        lappend  headerl If-Match $revision
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Uploads the supplied content as an attachment to the specified
    # design document. The attachment name provided must be a URL encoded string.
    # revision is Document revision.
    # ContentType need give it a Attachment MIME type. Required!
    method designdoc_attachment_put {ddocument attname revision ContentType data} {
        set myurl "http://$host:$port/$database/_design/$ddocument/$attname"
        set headerl [list Content-Type $ContentType]
        lappend  headerl If-Match $revision
        set res [my send_request $myurl PUT $headerl $data]

        return $res
    }

    # Deletes the attachment of the specified design document.
    # revision is Document revision.
    method designdoc_attachment_delete {ddocument attname revision} {
        set myurl "http://$host:$port/$database/_design/$ddocument/$attname"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        lappend  headerl If-Match $revision
        set res [my send_request $myurl DELETE $headerl]

        return $res
    }

    # Obtains information about the specified design document, including
    # the index, index size and current status of the design document and
    # associated index information.
    method designdoc_info {ddocument} {
        set myurl "http://$host:$port/$database/_design/$ddocument/_info"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Executes the specified view function from the specified design document.
    method designdoc_view_get {ddocument viewname {data ""}} {
        set myurl "http://$host:$port/$database/_design/$ddocument/_view/$viewname"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl $data]

        return $res
    }

    # Executes the specified view function from the specified design document.
    method designdoc_view_post {ddocument viewname data} {
        set myurl "http://$host:$port/$database/_design/$ddocument/_view/$viewname"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # Executes update function on server side for null document.
    method designdoc_update_post {ddocument updatename data} {
        set myurl "http://$host:$port/$database/_design/$ddocument/_update/$updatename"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # Executes update function on server side for null document.
    method designdoc_updatename_post {ddocument updatename docid data} {
        set myurl "http://$host:$port/$database/_design/$ddocument/_update/$updatename/$docid"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl PUT $headerl $data]

        return $res
    }
}

使用 TclOO 包裝一小部份 Apache CouchDB 的 API (使用 http package 與 Apache CouchDB 溝通) ,可以用來建立 database,建立新的文件,取得目前的資訊,與刪除資料庫。

(* 2015/12/08 更新)

package require couchdbtcl

set username danilo
set password danilo

set myserver [CouchDB_Database new localhost 5984 wiki basic $username $password]

set response [$myserver create]
puts $response 

set response [$myserver db_post {{"text" : "Wikipedia on CouchDB", "rating": 5}}]
puts $response 

set response [$myserver info]
puts $response 

set response [$myserver delete]
puts $response 

Apache CouchDB test code

package require Tcl 8.6
package require TclOO
package require http
package require base64

# The CouchDB server interface provides the basic interface to a CouchDB
# server for obtaining CouchDB information and getting and setting
# configuration information.
#
oo::class create CouchDB_Server {
    variable host
    variable port
    variable authtype
    variable username
    variable password
    variable firstcookie
    variable authSession

    constructor {HOST PORT AUTHTYPE {USERNAME ""} {PASSWORD ""}} {
        set host $HOST
        set port $PORT
        set authtype $AUTHTYPE
        set username $USERNAME
        set password $PASSWORD
        set firstcookie 0
        set authSession ""
    }

    destructor {
    }

    method send_request {url method {headers ""} {data ""}} {
        # Now support authtype: no basic cookie
        if {[string compare -nocase $authtype "basic"]==0} {
            set auth "Basic [base64::encode $username:$password]"
            lappend headers Authorization $auth
        } elseif {[string compare -nocase $authtype "cookie"]==0} {
            set cookiestring "AuthSession=$authSession"
            lappend headers Cookie $cookiestring
        }

        if { [string length $data] < 1 } {
            set tok [http::geturl $url -method $method -headers $headers]
        } else {
            set tok [http::geturl $url -method $method -headers $headers -query $data]
        }

        if {[string compare -nocase $authtype "cookie"]==0 && $firstcookie==1} {
            set meta [http::meta $tok]
            foreach {name value} $meta {
                if {[string compare $name Set-Cookie]==0} {
                    set firstlocation [string first "=" $value]
                    incr firstlocation 1
                    set lastlocation  [string first "; " $value]
                    incr lastlocation -1
                    set authSession [string range $value $firstlocation $lastlocation]
                }
            }
        }
        
        set res [http::data $tok] 
        http::cleanup $tok
        return $res
    }

    # Initiates new session for specified user credentials by providing Cookie value.
    method cookie_post {} {
        set firstcookie 1
        set myurl "http://$host:$port/_session"
        set headerl [list Accept "application/json" Content-Type "application/x-www-form-urlencoded"]
        set data [::http::formatQuery name $username password $password]
        set res [my send_request $myurl POST $headerl $data]

        set firstcookie 0

        return $res
    }

    # Returns complete information about authenticated user.
    method cookie_get {} {
        set myurl "http://$host:$port/_session"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set cookiestring "AuthSession=$authSession"
        lappend headers Cookie $cookiestring
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Closes user’s session.
    method cookie_delete {} {
        set myurl "http://$host:$port/_session"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set cookiestring "AuthSession=$authSession"
        lappend headers Cookie $cookiestring
        set res [my send_request $myurl DELETE $headerl]

        return $res
    }

    # Accessing the root of a CouchDB instance returns meta information
    # about the instance.
    method hello {} {
        set myurl "http://$host:$port/"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # List of running tasks, including the task type, name, status and process ID.
    method active_tasks {} {
        set myurl "http://$host:$port/_active_tasks"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Returns a list of all the databases in the CouchDB instance.
    method all_dbs {} {
        set myurl "http://$host:$port/_all_dbs"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    # Returns a list of all database events in the CouchDB instance.
    method log {} {
        set myurl "http://$host:$port/_log"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }

    #
    # CouchDB replication is a mechanism to synchronize databases. Much
    # like rsync synchronizes two directories locally or over a network,
    # replication synchronizes two databases locally or remotely.
    #

    # Request, configure, or stop, a replication operation.
    method replicate {data} {
        set myurl "http://$host:$port/_replicate"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl $data]

        return $res
    }

    # Restarts the CouchDB instance.
    method restart {} {
        set myurl "http://$host:$port/_restart"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl POST $headerl]

        return $res
    }

    # Returns a JSON object containing the statistics for the running server.
    method stats {} {
        set myurl "http://$host:$port/_stats"
        set headerl [list Accept "application/json" Content-Type "application/json"]
        set res [my send_request $myurl GET $headerl]

        return $res
    }
}

_db_updates 我在執行的時候反應怪怪的(可能是我設定 timeout 的方式錯誤),只會 timeout 以後傳回來空白,所以沒有加上在這段 code,其它關於 CouchDB server interface 的部份,我都試過了,最少不會向 _db_updates 一樣全無反應。

測試環境:
Windows XP SP3
ActiveTcl 8.6.4.1
Apache CouchDB 1.6.1
有設定 HTTP Basic Authentication,所以這份 code 反而是不需要認證的部份沒有測試過。

( *2015-12-08 更新)
( *2015-12-09 更新, add Cookie Authentication support)

下面就是測試這個 class 的 code:

source "./couchdb.tcl"

set username admin
set password mypasswd

set myserver [CouchDB_Server new localhost 5984 basic $username $password]

set response [$myserver all_dbs]
puts $response

set response [$myserver active_tasks]
puts $response

set response [$myserver log]
puts $response

set response [$myserver stats]
puts $response

set response [$myserver restart]
puts $response

2015-12-06

HTTP Basic Authentication

資料來自於 Tcler's wiki, http authentication

需要使用 Tcllib 的 base64 與 Tcl 內建的 http 套件。
 
package require http
package require base64

set username admin
set password mypasswd

proc geturl_auth {url username password} {
    set auth "Basic [base64::encode $username:$password]"
    set headerl [list Authorization $auth]
    set tok [http::geturl $url -headers $headerl]
    set res [http::data $tok]
    http::cleanup $tok
    return $res
}


puts [geturl_auth http://127.0.0.1:5984/  $username $password]

在這個例子中,username 和 password 是之前就使用 set 設定好的變數(要替換真正的使用者帳號和密碼)。

另外一個範例,使用 POST method 送出 _restart 要求給 CouchDB。

package require http
package require base64

set username admin
set password mypasswd

proc geturl_auth {url method username password} {
    set auth "Basic [base64::encode $username:$password]"
    set headerl [list Authorization $auth  Content-Type "application/json"]
    set tok [http::geturl $url -method $method -headers $headerl]
    set res [http::data $tok]
    http::cleanup $tok
    return $res
}


puts [geturl_auth http://127.0.0.1:5984/_restart POST $username $password]

另外一個範例,使用 GET method 送出 _all_dbs 要求給 CouchDB,取得目前的資料庫列表。

package require http
package require base64

set username admin
set password mypasswd

proc geturl_auth {url method username password} {
    set auth "Basic [base64::encode $username:$password]"
    set headerl [list Authorization $auth  Content-Type "application/json"]
    set tok [http::geturl $url -method $method -headers $headerl]
    set res [http::data $tok]
    http::cleanup $tok
    return $res
}


puts [geturl_auth http://127.0.0.1:5984/_all_dbs GET $username $password]

另外一個範例,使用 GET method 送出 _uuids 要求給 CouchDB,CouchDB 會回傳一個 UUID 值。

package require http
package require base64

set username admin
set password mypasswd

proc geturl_auth {url method username password} {
    set auth "Basic [base64::encode $username:$password]"
    set headerl [list Authorization $auth  Content-Type "application/json"]
    set tok [http::geturl $url -method $method -headers $headerl]
    set res [http::data $tok]
    http::cleanup $tok
    return $res
}


puts [geturl_auth http://127.0.0.1:5984/_uuids GET $username $password]

另外一個範例,可以說是 CouchDB 的基本操作,使用 PUT method 送出要求,要求給 CouchDB 建立一個資料庫。

package require http
package require base64

set username admin
set password mypasswd

proc geturl_auth {url method username password} {
    set auth "Basic [base64::encode $username:$password]"
    set headerl [list Authorization $auth  Content-Type "application/json"]
    set tok [http::geturl $url -method $method -headers $headerl]
    set res [http::data $tok]
    http::cleanup $tok
    return $res
}


puts [geturl_auth http://127.0.0.1:5984/albums PUT $username $password]

另外一個範例,一樣是 CouchDB 的基本操作,使用 DELETE method 送出要求,要求 CouchDB 刪除一個資料庫。

package require http
package require base64

set username admin
set password mypasswd

proc geturl_auth {url method username password} {
    set auth "Basic [base64::encode $username:$password]"
    set headerl [list Authorization $auth  Content-Type "application/json"]
    set tok [http::geturl $url -method $method -headers $headerl]
    set res [http::data $tok]
    http::cleanup $tok
    return $res
}


puts [geturl_auth http://127.0.0.1:5984/albums DELETE $username $password]