nntp-procs.tcl

XoWiki - main library classes and objects

This file defines the following Objects and Classes: ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session, ::nntp::Session

Location:

packages/xowiki/tcl/nntp-procs.tcl

Created:

2006-01-10

Author:

Gustaf Neumann

CVS Identification:

$Id: xowiki-procs.tcl,v 1.542.2.180 2024/07/28 17:08:02 gustafn Exp $

Procedures in this file

• Class ::nntp::Session (public)
• nntp::Session instproc destroy (public)
• nntp::Session instproc group (public)
• nntp::Session instproc login (public)
• nntp::Session proc refresh (public)

Detailed information

 ::nx::Class ::nntp::Session

 <instance of nntp::Session> destroy

 <instance of nntp::Session> group name

 <instance of nntp::Session> login user password

 nntp::Session refresh [ -server server ] [ -port port ] \
    [ -group group ]

Content File Source

::xo::library doc {
  XoWiki - main library classes and objects

  @creation-date 2006-01-10
  @author Gustaf Neumann
  @cvs-id $Id: xowiki-procs.tcl,v 1.542.2.180 2024/07/28 17:08:02 gustafn Exp $
}

set nntp_group comp.lang.tcl

#
# Make sure, we have the data model defined
#
::xo::db::require table nntp_groups [subst {
    nntp_id     {integer references acs_objects(object_id) on delete cascade primary key}
    name        {[::xo::dc map_datatype text]}
    last_id     {integer default 0}
}]

::xo::db::require table nntp_articles [subst {
    article_id  {integer not null}
    nntp_id     {integer references nntp_groups(nntp_id) on delete cascade}
    dict        {[::xo::dc map_datatype text]}
}]


#
# Define an entry for the default nntp_group
#
if {![::acs::dc list_of_lists -prepare text check_group {select count(*) from nntp_groups where name = :nntp_group}]} {
    ::xo::dc transaction {
        set id [acs::dc call acs_object new]
        xo::dc dml update_group {
            insert into nntp_groups (nntp_id, name) values (:id, :nntp_group)
        }
    }
}

namespace eval nntp {
    nx::Class create Session {
        #
        # Support for NNTP session. In essence:
        # 1) login
        # 2) run some commands
        # 3) logout
        #
        :property server:required
        :property port:int,required
        :property {debug:int 1}

        :method log {severity args} {
            if {${:debug}} {
                ns_log $severity "NNTP:" {*}$args
            }
        }
        :method readLine {} {
            set line [string trimright [ns_connchan read ${:channel}]]
            ns_log notice "GOT  line <$line>"
            return $line
        }
        :method writeLine {line} {
            set result [ns_connchan write ${:channel} $line\r\n]
            ns_log notice "SENT line <$line>"
            return $result
        }
        :method init {} {
            set :channel [ns_connchan connect ${:server} ${:port}]
            ns_log notice "CONNECTED via channel ${:channel}"
            set line [:readLine]
        }
        :public method destroy {} {
            #
            # Log-out from the session and destroy the session object.
            #
            ns_log notice "DISCONNECT from channel ${:channel}"
            :writeLine QUIT
            ns_connchan close ${:channel}
            next
        }
        :public method login {user password} {
            #
            # Log-in with the provided credentials
            #
            :writeLine "AUTHINFO USER $user"
            set line [:readLine]
            :writeLine "AUTHINFO PASS $password"
            set line [:readLine]
        }
        :method decodeHeader {nr headerString} {
            #
            # The value "nr" is just needed for the log messages.
            #
            :log notice "HEADER $headerString"
            set hdr ""
            foreach line [split $headerString \n] {
                if {[regexp {^(\S+):\s*(\S.*)$} $line . tag value]} {
                    set value [string trim $value]
                    set start 0
                    while {1} {
                        set l [regexp -inline -indices -all -start $start {=[?]([^?]+)[?]([^?]+)[?](.*)[?]=} $value]
                        if {[llength $l] == 0} {
                            break
                        }
                        foreach {m charset encoding coded} $l {
                            set charset [string range $value {*}$charset]
                            set encoding [string range $value {*}$encoding]
                            if {$encoding eq "B"} {
                                set value [string replace $value {*}$m [ns_base64decode [string range $value {*}$coded]]]
                            } else {
                                ns_log warning "article $nr: ENCODED WORD" charset $charset encoding $encoding not implemented
                            }
                            set start [lindex $m 1]
                        }
                    }
                    if {$start == 0} {
                        :log notice "article $nr: plain <$value>"
                    } else {
                        :log notice "article $nr: decoded <$value>"
                    }
                
                    #if {[regexp {^=[?]([^?]+)[?]([^?]+)[?](.*)[?]=$} $value . charset encoding coded]} {
                        #
                        # Encoded word syntax (RFC 2047)
                        # example: =?UTF-8?B?PyBCVUcgLSBUY2w5LjBiMyBMaW51eCAtIGNhbnZhcyBiaW5k?=
                        #
                        #ns_log notice "========= ENCODED WORD" charset $charset encoding $encoding coded $coded
                    #    if {$encoding eq "B"} {
                    #        set value [ns_base64decode $coded]
                    #        :log notice "article $nr: encoded word syntax: DECODED '$value'"
                    #    } else {
                    #        ns_log warning "article $nr: ENCODED WORD" charset $charset encoding $encoding not implemented
                    #    }
                    #    :log notice "article $nr: decoded <$value>"
                    #} else {
                    #    :log notice "article $nr: plain <$value>"
                    #}
                    :log notice "article $nr: add header <[string tolower $tag]> <$value>"
                    dict set hdr [string tolower $tag] $value
                } elseif {$line ne ""} {
                    ns_log warning "article $nr: ignore HEADER line <$line>"
                }
            }
            return $hdr
        }

        :method readArticle {nr} {
            #
            # Read a single article denoted by the numeric value
            # provided by the NNTP server.
            #
            :writeLine "ARTICLE $nr"
            set raw_lines ""
            while {1} {
                set chunk [ns_connchan read ${:channel}]
                #ns_log notice "CHUNK <$chunk>"
                if {$chunk eq ""} {
                    ns_log warning "ARTICLE $nr: unexpected empty line"
                    break
                }
                append raw_lines $chunk

                if {[string range $raw_lines end-4 end] eq "\r\n.\r\n"} {
                    #ns_log notice "ARTICLE $nr: --- exact 5 char end"
                    set raw_lines [string range $raw_lines 0 end-5]
                    break
                } elseif {[string range $raw_lines end-2 end] eq "\n.\n"} {
                    #ns_log notice "ARTICLE $nr: --- exact 3 char end"
                    set raw_lines [string range $raw_lines 0 end-3]
                    break
                } else {
                    :log notice CHECK last 5 chars '[string range $raw_lines end-4 end]' length [string length [string range $raw_lines end-4 end]]
                }
            }
            regsub -all \r\n [encoding convertfrom utf-8 $raw_lines] \n raw_lines
            :log notice "RAW\n$raw_lines"

            set header ""
            set content ""
            set eoh 0
            set lines [split $raw_lines \n]
            :log notice "REPLY_LINE [lindex $lines 0]"
            lassign [lindex $lines 0] status nr msg_id type
            dict set msg MSG_ID $msg_id

            foreach line [lrange $lines 1 end] {
                #:log notice "PARSE LINE <$line>"
                if {$line eq "."} {
                    break
                }
                if {$line eq "" && !$eoh} {
                    set eoh 1
                    set msg [dict merge $msg [:decodeHeader $nr $header]]
                    continue
                }
                if {$eoh} {
                    append content $line \n
                } else {
                    if {[string is space [string range $line 0 0]]} {
                        :log notice "===== HEADER join '[string range $line 0 0]' -> <$line>"
                        set header [string range $header 0 end-1]
                        append header " "
                        set line [string range $line 1 end]
                    }
                    append header $line \n
                }
            }
            #ns_log notice "ARTICLE $nr: $content"
            dict set msg BODY $content
        }

        :public method group {name} {
            #
            # update all entries from the specified group
            #
            :writeLine "GROUP $name"
            lassign [:readLine] status nr available_from available_to groupname
            ns_log notice "FROM $available_from TO $available_to"
            if {$available_from eq ""} {
                error "nntp group '$name': status '$status' available_from must not be empty"
            }
            lassign [lindex [acs::dc list_of_lists -prepare text dbqd..get_group_info {
                select nntp_id, last_id from nntp_groups where name = :name
            }] 0] nntp_id last_id
            set count 1000
            set fetched_articles [::acs::dc list -prepare integer dbqd..fetch_article_ids {
                select article_id from nntp_articles where nntp_id = :nntp_id
            }]
            ns_log notice "LAST_ID $last_id available_from $available_from, we have [llength $fetched_articles] articles loaded"

            for {set article_id $available_from} {$article_id <= $available_to} {incr article_id} {
                if {0 && $last_id > $article_id} {
                    #
                    # Optimization, don't use it, if we want to refetch some articles
                    #
                    continue
                }
                if {[incr count -1] < 0} break
                if {$article_id in $fetched_articles} {
                    continue
                }
                ns_log notice FETCH ARTICLE $article_id
                set d [:readArticle $article_id]
                ns_log notice INSERT ARTICLE $article_id: $d
                ::xo::dc transaction {
                    xo::dc dml insert_article {
                        insert into nntp_articles (article_id, nntp_id, dict)
                        values (:article_id, :nntp_id, :d)
                    }
                    xo::dc dml update_last_id {
                        update nntp_groups set last_id = :article_id
                    }
                }
            }
        }
        :public object method refresh {
            {-server news.eternal-september.org}
            {-port 119}
            {-group comp.lang.tcl}
        } {
            #
            # Refresh articles in the database with messages from the
            # NNTP news server.
            #
            #    ns_section ns/server/${server}/acs/nntp {
            #       ns_param NttpUser gustafn
            #       ns_param NttpPassword isxqsomzp
            #    }
            #
            # ad_schedule_proc -thread t 5m ::nntp::Session refresh

            set nntp_user [ns_config "ns/server/[ns_info server]/acs/nntp" NttpUser]
            if {$nntp_user eq ""} {
                error "NntpUser is not configured"
            }

            set s [nntp::Session new -server $server -port $port]
            try {
                $s login $nntp_user [ns_config "ns/server/[ns_info server]/acs/nntp" NttpPassword]
                $s group $group
            } finally {
                $s destroy
            }
        }
    }
}

::xo::library source_dependent
#
# Local variables:
#    mode: tcl
#    tcl-indent-level: 4
#    indent-tabs-mode: nil
# End: