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