From 11a53a7d148d2497c99eb1f51341b67bd3458114 Mon Sep 17 00:00:00 2001
From: urlysses <chrisconstandinou@gmail.com>
Date: Wed, 15 Feb 2017 23:13:46 -0500
Subject: [PATCH] Generalize header words and start implementing content-types
 based on extensions

---
 1991.fs | 86 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 75 insertions(+), 11 deletions(-)

diff --git a/1991.fs b/1991.fs
index 772fd95..15e59c9 100644
--- a/1991.fs
+++ b/1991.fs
@@ -2,6 +2,17 @@
 
 include unix/socket.fs
 
+\ Helper words
+: +s ( addr1 u1 addr2 u2 -- addr3 u3 )          \ like s+ but prepend rather than append.
+    2swap s+ ;
+: exchange ( a1 a2 -- )
+    2dup c@ swap c@ rot c! swap c! ;
+: reverse ( caddr u -- )                        \ reverse a string
+    1- bounds begin 2dup > while
+        2dup exchange
+    -1 /string
+    repeat 2drop ;
+
 \ User-defined routing
 wordlist constant routes
 : find-route ( addr u -- data )
@@ -13,7 +24,7 @@ wordlist constant routes
         routes drop nip nip
         >body !
     else
-        routes get-current >r set-current      \ switch definition word lists
+        routes get-current >r set-current       \ switch definition word lists
         nextname create ,
         r> set-current
     then ;
@@ -26,8 +37,43 @@ pubvar public
 : get-public-path ( -- addr u )
     public 2@ ;
 
+\ Request's Content-Type
+pubvar RequestContentType
+: set-content-type ( addr u -- )
+    RequestContentType 2! ;
+: get-content-type ( -- addr u )
+    RequestContentType 2@ ;
+
+: ctype? ( addr u -- )
+    s" html" compare 0= if
+        s" text/html"
+    else
+        s" text/plain"
+    then ;
+
 \ Internal request handling
-: read-request ( socket -- addr u ) pad 4096 read-socket ;
+: HTTP/1.1 s" HTTP/1.1 " ;
+
+: response-status ( u -- addr u )
+    dup case                                    \ get status code info
+        200 of s"  OK" endof
+        404 of s"  Not Found" endof
+    endcase
+    s\" \n" s+
+    rot s>d <# #s #> +s                         \ convert status code to string and prepend to info
+    HTTP/1.1 +s ;                               \ prepend HTTP/1.1
+
+: content-type ( addr u -- caddr cu )
+    s" Content-Type: " +s                       \ Prepend to the provided content type
+    s\" \n\n" s+ ;                              \ Append 2 new lines
+
+: set-header ( u addr u -- raddr ru )           \ Accepts status code and content type string
+    rot response-status                         \ Set response status
+    2swap content-type                          \ Set content-type
+    s+ ;                                        \ Join
+
+: read-request ( socket -- addr u )
+    pad 4096 read-socket ;
 
 : send-response ( addr u socket -- )
     dup >r write-socket r> close-socket ;
@@ -38,30 +84,48 @@ pubvar public
 : file-exists? ( addr u -- addr u bool )
     2dup file-status nip 0= ;
 
+: .extension ( addr u -- addr u )
+    2dup reverse                                \ reverse the file name
+    2dup s" ." search                           \ search for the first occurance of "."
+    if
+        swap drop -                             \ remove the "." from the search results
+    else
+        s" txt"
+    then
+    2dup reverse ;                              \ reverse reversed extension
+
+: serve-file-type ( addr u -- )
+    .extension ctype? set-content-type ;
+
 : serve-file ( addr u -- addr u )
     slurp-file ;
 
+: 404content-type s" txt" ctype? ;
+: 404html s" 404";
+
 : either-resolve ( addr u -- resolveaddr resolveu )
     s" GET" search if
+        s" html" ctype? set-content-type        \ reset the request's content-type
         requested-route
         2dup find-route dup if
-                >r 2drop r>                 \ keep xt, drop the route string
-                execute                     \ execute the user's route handler
+                >r 2drop r>                     \ keep xt, drop the route string
+                execute                         \ execute the user's route handler
             else
-                drop                        \ drop the xt
-                get-public-path 2swap s+    \ see if route exists in public dir
+                drop                            \ drop the null xt
+                get-public-path +s              \ see if route exists in public dir
                 file-exists? if
-                    serve-file              \ collect file contents
+                    2dup serve-file             \ collect file contents
+                    2swap serve-file-type       \ set the file type
                 else
-                    exit                    \ continue to 404
+                    exit                        \ continue to 404
                 then
             then
-        s\" HTTP/1.1 200 OK\n Content-Type: text/html\n\n" 2swap s+
-    rdrop exit then ;
+        200 get-content-type set-header +s
+        rdrop exit then ;
 
 : or-404 ( addr u -- 404addr 404u )
     2drop
-    s\" HTTP/1.1 404 Not Found\n Content-Type: text/plain\n\n 404" ;
+    404 404content-type set-header 404html s+ ;
 
 : prepare-response ( addr u -- returnaddr returnu)
     either-resolve or-404 ;