1###
2# Class to deliver Static content
3# When utilized, this class is fed a local filename
4# by the dispatcher
5###
6::clay::define ::httpd::content.file {
7
8  method FileName {} {
9    # Some dispatchers will inject a fully qualified name during discovery
10    if {[my clay exists FILENAME] && [file exists [my clay get FILENAME]]} {
11      my request set PREFIX_URI [file dirname [my clay get FILENAME]]
12      return [my clay get FILENAME]
13    }
14    set uri [string trimleft [my request get REQUEST_PATH] /]
15    set path [my clay get path]
16    set prefix [my clay get prefix]
17    set fname [string range $uri [string length $prefix] end]
18    if {$fname in "{} index.html index.md index index.tml index.tcl"} {
19      return $path
20    }
21    if {[file exists [file join $path $fname]]} {
22      return [file join $path $fname]
23    }
24    if {[file exists [file join $path $fname.md]]} {
25      return [file join $path $fname.md]
26    }
27    if {[file exists [file join $path $fname.html]]} {
28      return [file join $path $fname.html]
29    }
30    if {[file exists [file join $path $fname.tml]]} {
31      return [file join $path $fname.tml]
32    }
33    if {[file exists [file join $path $fname.tcl]]} {
34      return [file join $path $fname.tcl]
35    }
36    return {}
37  }
38
39  method DirectoryListing {local_file} {
40    set uri [string trimleft [my request get REQUEST_PATH] /]
41    set path [my clay get path]
42    set prefix [my clay get prefix]
43    set fname [string range $uri [string length $prefix] end]
44    my puts [my html_header "Listing of /$fname/"]
45    my puts "Listing contents of /$fname/"
46    my puts "<TABLE>"
47    if {$prefix ni {/ {}}} {
48      set updir [file dirname $prefix]
49      if {$updir ne {}} {
50        my puts "<TR><TD><a href=\"/$updir\">..</a></TD><TD></TD></TR>"
51      }
52    }
53    foreach file [glob -nocomplain [file join $local_file *]] {
54      if {[file isdirectory $file]} {
55        my puts "<TR><TD><a href=\"[file join / $uri [file tail $file]]\">[file tail $file]/</a></TD><TD></TD></TR>"
56      } else {
57        my puts "<TR><TD><a href=\"[file join / $uri [file tail $file]]\">[file tail $file]</a></TD><TD>[file size $file]</TD></TR>"
58      }
59    }
60    my puts "</TABLE>"
61    my puts [my html_footer]
62  }
63
64  method content {} {
65    my variable reply_file
66    set local_file [my FileName]
67    if {$local_file eq {} || ![file exist $local_file]} {
68      my log httpNotFound [my request get REQUEST_PATH]
69      my error 404 {File Not Found}
70      tailcall my DoOutput
71    }
72    if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} {
73      my request set PREFIX_URI [my request get REQUEST_PATH]
74      my request set LOCAL_DIR $local_file
75      ###
76      # Produce an index page
77      ###
78      set idxfound 0
79      foreach name {
80        index.tcl
81        index.html
82        index.tml
83        index.md
84        index.info
85        index.clay
86        content.htm
87      } {
88        if {[file exists [file join $local_file $name]]} {
89          set idxfound 1
90          set local_file [file join $local_file $name]
91          break
92        }
93      }
94      if {!$idxfound} {
95        tailcall my DirectoryListing $local_file
96      }
97    } else {
98      my request set PREFIX_URI [file dirname [my request get REQUEST_PATH]]
99      my request set LOCAL_DIR [file dirname $local_file]
100    }
101    my request set LOCAL_FILE $local_file
102
103    switch [file extension $local_file] {
104      .apng {
105        my reply set Content-Type {image/apng}
106        set reply_file $local_file
107      }
108      .bmp {
109        my reply set Content-Type {image/bmp}
110        set reply_file $local_file
111      }
112      .css {
113        my reply set Content-Type {text/css}
114        set reply_file $local_file
115      }
116      .gif {
117        my reply set Content-Type {image/gif}
118        set reply_file $local_file
119      }
120      .cur - .ico {
121        my reply set Content-Type {image/x-icon}
122        set reply_file $local_file
123      }
124      .jpg - .jpeg - .jfif - .pjpeg - .pjp {
125        my reply set Content-Type {image/jpg}
126        set reply_file $local_file
127      }
128      .js {
129        my reply set Content-Type {text/javascript}
130        set reply_file $local_file
131      }
132      .md {
133        package require Markdown
134        my reply set Content-Type {text/html; charset=UTF-8}
135        set mdtxt  [::fileutil::cat $local_file]
136        my puts [::Markdown::convert $mdtxt]
137      }
138      .png {
139        my reply set Content-Type {image/png}
140        set reply_file $local_file
141      }
142      .svgz -
143      .svg {
144        # FU magic screws it up
145        my reply set Content-Type {image/svg+xml}
146        set reply_file $local_file
147      }
148      .tcl {
149        my reply set Content-Type {text/html; charset=UTF-8}
150        try {
151          source $local_file
152        } on error {err errdat} {
153          my error 500 {Internal Error} [dict get $errdat -errorinfo]
154        }
155      }
156      .tiff {
157        my reply set Content-Type {image/tiff}
158        set reply_file $local_file
159      }
160      .tml {
161        my reply set Content-Type {text/html; charset=UTF-8}
162        set tmltxt  [::fileutil::cat $local_file]
163        set headers [my request dump]
164        dict with headers {}
165        my puts [subst $tmltxt]
166      }
167      .txt {
168        my reply set Content-Type {text/plain}
169        set reply_file $local_file
170      }
171      .webp {
172        my reply set Content-Type {image/webp}
173        set reply_file $local_file
174      }
175      default {
176        ###
177        # Assume we are returning a binary file
178        ###
179        my reply set Content-Type [::fileutil::magic::filetype $local_file]
180        set reply_file $local_file
181      }
182    }
183  }
184
185  method Dispatch {} {
186    my variable reply_body reply_file reply_chan chan
187    try {
188      my reset
189      # Invoke the URL implementation.
190      my content
191    } on error {err errdat} {
192      my error 500 $err [dict get $errdat -errorinfo]
193      catch {
194        tailcall my DoOutput
195      }
196    }
197    if {$chan eq {}} return
198    catch {
199      # Causing random issues. Technically a socket is always open for read and write
200      # anyway
201      #my wait writable $chan
202      if {![info exists reply_file]} {
203        tailcall my DoOutput
204      }
205      chan configure $chan  -translation {binary binary}
206      my log HttpAccess {}
207      ###
208      # Return a stream of data from a file
209      ###
210      set size [file size $reply_file]
211      my reply set Content-Length $size
212      append result [my reply output] \n
213      chan puts -nonewline $chan $result
214      set reply_chan [open $reply_file r]
215      my ChannelRegister $reply_chan
216      my log SendReply [list length $size]
217      ###
218      # Output the file contents. With no -size flag, channel will copy until EOF
219      ###
220      chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0
221      if {$size < 40960} {
222        # Raw copy small files
223        chan copy $reply_chan $chan
224      } else {
225        my ChannelCopy $reply_chan $chan -chunk 4096
226      }
227    }
228  }
229}
230