File: plugin.tcl

package info (click to toggle)
tcllib 1.20%2Bdfsg-1
  • links: PTS
  • area: main
  • in suites: bullseye
  • size: 68,064 kB
  • sloc: tcl: 216,842; ansic: 14,250; sh: 2,846; xml: 1,766; yacc: 1,145; pascal: 881; makefile: 107; perl: 84; f90: 84; python: 33; ruby: 13; php: 11
file content (210 lines) | stat: -rw-r--r-- 5,832 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
###
# httpd plugin template
###
::clay::define ::httpd::plugin {
  ###
  # Any options will be saved to the local config file
  # to allow threads to pull up a snapshot of the object' configuration
  ###

  ###
  # Define a code snippet to run on plugin load
  ###
  clay set plugin/ load {}

  ###
  # Define a code snippet to run within the object's Headers_Process method
  ###
  clay set plugin/ headers {}

  ###
  # Define a code snippet to run within the object's dispatch method
  ###
  clay set plugin/ dispatch {}

  ###
  # Define a code snippet to run within the object's writes a local config file
  ###
  clay set plugin/ local_config {}

  ###
  # When after all the plugins are loaded
  # allow specially configured ones to light off a thread
  ###
  clay set plugin/ thread {}

}

###
# A rudimentary plugin that dispatches URLs from a dict
# data structure
###
::clay::define ::httpd::plugin.dict_dispatch {
  clay set plugin/ dispatch {
    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }

  ###
  # Implementation of the dispatcher
  ###
  method Dispatch_Dict {data} {
    my variable url_patterns
    set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0]
    set uri   [dict get $data http REQUEST_PATH]
    foreach {host hostpat} $url_patterns {
      if {![string match $host $vhost]} continue
      foreach {pattern info} $hostpat {
        if {![string match $pattern $uri]} continue
        set buffer $data
        foreach {f v} $info {
          dict set buffer $f $v
        }
        return $buffer
      }
    }
    return {}
  }

  ###
  #
  Ensemble uri::add {vhosts patterns info} {
    my variable url_patterns
    foreach vhost $vhosts {
      foreach pattern $patterns {
        set data $info
        if {![dict exists $data prefix]} {
           dict set data prefix [my PrefixNormalize $pattern]
        }
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }

  Ensemble uri::direct {vhosts patterns info body} {
    my variable url_patterns url_stream
    set cbody {}
    if {[dict exists $info superclass]} {
      append cbody \n "superclass {*}[dict get $info superclass]"
      dict unset info superclass
    }
    append cbody \n [list method content {} $body]

    set class [namespace current]::${vhosts}/${patterns}
    set class [string map {* %} $class]
    ::clay::define $class $cbody
    dict set info mixin content $class
    my uri add $vhosts $patterns $info
  }
}

::clay::define ::httpd::reply.memchan {
  superclass ::httpd::reply

  method output {} {
    my variable reply_body
    return $reply_body
  }

  method DoOutput {} {}

  method close {} {
    # Neuter the channel closing mechanism we need the channel to stay alive
    # until the reader sucks out the info
  }
}


::clay::define ::httpd::plugin.local_memchan {

  clay set plugin/ load {
package require tcl::chan::events
package require tcl::chan::memchan
  }

  method local_memchan {command args} {
    my variable sock_to_coro
    switch $command {
      geturl {
        ###
        # Hook to allow a local process to ask for data without a socket
        ###
        set uuid [my Uuid_Generate]
        set ip 127.0.0.1
        set sock [::tcl::chan::memchan]
        set output [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect_Local $uuid $sock GET {*}$args]]]
        return $output
      }
      default {
        error "Valid: connect geturl"
      }
    }
  }

  ###
  # A modified connection method that passes simple GET request to an object
  # and pulls data directly from the reply_body data variable in the object
  #
  # Needed because memchan is bidirectional, and we can't seem to communicate that
  # the server is one side of the link and the reply is another
  ###
  method Connect_Local {uuid sock args} {
    chan event $sock readable {}

    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    set ip 127.0.0.1
    dict set query UUID $uuid
    dict set query http UUID $uuid
    dict set query http HTTP_HOST       localhost
    dict set query http REMOTE_ADDR     127.0.0.1
    dict set query http REMOTE_HOST     localhost
    dict set query http LOCALHOST 1
    my counter url_hit

    dict set query http REQUEST_METHOD  [lindex $args 0]
    set uriinfo [::uri::split [lindex $args 1]]
    dict set query http REQUEST_URI     [lindex $args 1]
    dict set query http REQUEST_PATH    [dict get $uriinfo path]
    dict set query http REQUEST_VERSION [lindex [split [lindex $args end] /] end]
    dict set query http DOCUMENT_ROOT   [my clay get server/ doc_root]
    dict set query http QUERY_STRING    [dict get $uriinfo query]
    dict set query http REQUEST_RAW     $args
    dict set query http SERVER_PORT     [my port_listening]
    my Headers_Process query
    set reply [my dispatch $query]

    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }

    set class ::httpd::reply.memchan
    set pageobj [$class create ::httpd::object::$uuid [self]]
    if {[dict exists $reply mixin]} {
      set mixinmap [dict get $reply mixin]
    } else {
      set mixinmap {}
    }
    foreach item [dict keys $reply MIXIN_*] {
      set slot [string range $reply 6 end]
      dict set mixinmap [string tolower $slot] [dict get $reply $item]
    }
    $pageobj clay mixinmap {*}$mixinmap
    if {[dict exists $reply delegate]} {
      $pageobj clay delegate {*}[dict get $reply delegate]
    }
    $pageobj dispatch $sock $reply
    set output [$pageobj output]
    $pageobj clay refcount_decr
    return $output
  }
}