A sneak-peek at a new web framework written in Arc, Paul Graham's "hundred year language," or whatever. To go: (load "albert.arc") (srv)

albert.arc

(load "lib/re.arc")

(load "albert/httpd.arc")
(load "albert/routes.arc")

httpd.arc

(load "lib/re.arc")
(load "albert/httpdata.arc")

(= quit-server?*     nil ; set (= quit?* t) and reload page to quit
   max-thread-life*  30  ; max allowed time in seconds for a single page to load
   http-handler      nil ; define this fn
)

(def srv ((o port 8080))
  (wipe quit-server?*)
  (prn "albert/httpd: singin' on port " port) 
  (thread:httpd-server port)
)

(def httpd-server (port)
  (w/socket s port
    (until quit-server?*
      (let (i o ip) (socket-accept s)
        (let servethread (thread (serve-request i o ip))
          (thread
            (sleep max-thread-life*)
            (unless (dead servethread)
              (prn "albert/httpd: heckler on " ip " wasting our time")
            )
            (kill-thread servethread)
            (force-close i o)
          )
        )
      )
    )
  )
)

(def serve-request (i o ip)
  (let request (parse-request-headers:read-request-headers i)
    (if ((request "headers") "Content-Length")
      (do (= (request "body") (read-request-body i (int ((request "headers") "Content-Length"))))
          (= (request "query") (parse-args (request "body"))))
    )
    (let response (http-handler request)
      (w/stdout o
        (prn "HTTP/1.1 " (response "code") " " (response-codes* (response "code")))
        (prn "Content-Length: " (len (response "body")))
        (maptable (fn (field content) (prn field ": " content)) (response "headers"))
        (prn)
        (pr (response "body"))
      )
    )
  )
  (close i o)
)

(def read-request-headers (i)
  (let request nil
    (until (is (= line (readline i)) "")
      (= request (cons line request))
    )
    (rev request)
  )
)

(def parse-request-headers (headers)
  (let request (table)
    (let request-line (car headers)
        (let (method uri version) (tokens request-line)
          (= (request "method") (upcase method)
             (request "uri") (urldecode uri)
             (request "http-version") (upcase version))
        )
      )
      (= (request "headers") (table))
      (let header-fields (cdr headers)
        (each field header-fields
          (let parts (tokens field #\:)
            (= ((request "headers") (car parts)) (trim (sjoin (cdr parts) ":") 'both))
          )
        )
      )
    request
  )
)

(def read-request-body (i content-length)
  (let body (string)
    (repeat content-length
      (= body (+ body (readc i)))
    )
    body
  )
)

(def parse-args (argstr)  ; "foo=bar&baz=42" -> (("foo" "bar") ("baz" "42")) -- from http.arc
  (map [map urldecode (tokens _ #\=)] (tokens argstr #\&)))

(def sjoin (parts (o delim ""))
  (with (joined "" ii 1)
    (each part parts
      (= joined (+ joined part))
      (if (isnt ii (len parts))
        (= joined (+ joined delim)))
      (++ ii)
    )
    joined
  )
)

httpdata.arc

(= response-codes*
  (obj
    100 "Continue"       ; 100-199 -- informational
    101 "Switching Protocols"
    102 "Processing"
    
    200 "OK"             ; 200-299 -- success
    201 "Created"
    202 "Accepted"
    203 "Non-Authoritative Information"
    204 "No Content"
    205 "Reset Content"
    206 "Partial Content"
    207 "Multi-Status"
    
    300 "Multiple Choices" ; 300-399 -- redirection
    301 "Moved Permanently"
    302 "Found"
    303 "See Other"
    304 "Not Modified"
    305 "Use Proxy"
    306 "Switch Proxy"
    307 "Temporary Redirect"
    
    400 "Bad Request"    ; 400-499 -- client error
    401 "Unauthorized"
    402 "Payment Required"
    403 "Forbidden"
    404 "Not Found"
    405 "Method Not Allowed"
    406 "Not Acceptable"
    407 "Proxy Authentication Required"
    408 "Request Timeout"
    409 "Conflict"
    410 "Gone"
    411 "Length Required"
    412 "Precondition Failed"
    413 "Request Entity Too Large"
    414 "Request-URI Too Long"
    415 "Unsupported Media Type"
    416 "Requested Range Not Satisfiable"
    417 "Expectation Failed"
    418 "I'm a teapot" ; srsly
    422 "Unprocessable Entity"
    423 "Locked"
    424 "Failed Dependency"
    425 "Unordered Collection"
    426 "Upgrade Required"
    
    500 "Internal Server Error" ; 500-599 -- server made a boo-boo
    501 "Not Implemented"
    502 "Bad Gateway"
    503 "Service Unavailable"
    504 "Gateway Timeout"
    505 "HTTP Version Not Supported"
    506 "Variant Also Negotiates"
    507 "Insufficient Storage"
    510 "Not Extended" 
  )
)

(= ext-mime-types*
  (obj
    "gif" "image/gif"
    "png" "image/png"
    "jpg" "image/jpeg"
    "css" "text/css"
    "js"  "application/javascript"
  )
)

routes-defaults.arc

(def alb-default-header (title) (string "<!DOCTYPE html>
<html>
<head>
  <title>" title "</title>
  <style>
    body {
      font-family: Helvetica Neue, Helvetica, sans-serif;
      color: #333;
    }
    code {
      font-family: Anonymous Pro, Anonymous, Andale Mono, Courier, monospaced;
      font-size: 11pt;
    }
    a:link, a:hover, a:visited, a:active {
      color: #333;
      text-decoration: none;
      border-bottom: 1px solid #ccc;
    }
  </style>
</head>
<body>"))
(=  alb-default-footer "\n</body>\n</html>")

(get "/"
  (prn (alb-default-header "Hello. This is Albert.") "
  <h1>Welcome to Albert.</h1>
  <h2>Albert is a web framework for Arc.</h2>
  <p>This is the default page. Here is a quick demonstration of Albert&rsquo;s simplicity:</p>
    
<pre><code>(get \"/\"
  (prn \"Hello, world!\")
)
</code></pre>
    
  <p>
     Many more exciting things are possible with Arc and Albert. You can handle requests with
     the <code>GET</code>, <code>POST</code>, <code>PUT</code>, and <code>DELETE</code> request
     methods with simple modifications to the above code, and any arbitrary HTTP request method
     using the <code>add-route</code> method. You can replace the <a href=\"/404\">404
     handler</a> by defining method <code>(not-found req)</code>.
  </p>" alb-default-footer)
)

(def not-found (req)
  (prn (alb-default-header "Albert is sorry, but&hellip;") "
  <h1>Uh-oh, looks like that page isn&rsquo;t defined.</h1>
  <h2>This page is the default not-found handler.</h2>
  <p>
    Check your regular expressions, perhaps. Make sure you&rsquo;ve defined your route using
    the correct method. Helpful tools for this are:
    <a href=\"http://barebones.com/products/bbedit/\">BBEdit</a> or any comparable text editor
    which has a regexp engine built in, and <a href=\"http://curl.haxx.se/\">cURL,</a>
    whose verbose option allows you to see what&rsquo;s going on at the HTTP level.
  </p>
  
  <p>To replace this (rather boring) default handler with your own, try something like this:</p>

<pre><code>(def not-found (req)
  (prn \"Aww, shucks.\")
)
</code></pre>

  <p>
    This behaves exactly like a request to a defined route, except that (for obvious reasons)
    <code>matches</code> is not defined.
  </p>" alb-default-footer)
)

routes.arc

(= routes* nil)

(mac header (name value)
  `(= ((resp "headers") ,name) ,value)
)
(mac response-code (code)
  `(= (resp "code") ,code)
)

(def http-handler (req)
  (let resp (obj "code" 200 "headers" (obj "Content-Type" "text/html; charset=utf-8"))
    (= (resp "body")
      (let handler (match-route (req "method") (req "uri"))
        (tostring
          (if handler
            (let _resp (table)
              (= _resp ((handler "fn") req (re-match-pat (handler "uri") (req "uri"))))
              (if (_resp "code") (= (resp "code") (_resp "code")))
            )
          ;  (if (file-exists (string "static" (req "uri")))
          ;    (let fcontent (w/infile (string "static" (req "uri")))
          ;      (prn fcontent)
          ;      (= ((resp "headers") "Content-Type") (ext-mime-types* (last (tokens uri #\.))))
          ;    )
              (let _code 404
                (response-code _code)
                (not-found req)
              )
          ;  )
          )
        )
      )
    )
  resp
  )
)

(def add-route (method uri handler)
  (= routes* (cons (obj "method" (downcase method) "uri" (+ "^" uri "$") "fn" handler) routes*))
)

(def match-route (method uri)
  (car (mem
    (fn (_) (and (re-match-pat (_ "uri") uri) (is (_ "method") (downcase method))))
    routes*
  ))
)

(mac get    (uri . body) `(add-route "get"    ,uri
  (fn (req matches) (let resp (table) ,@body resp))))

(mac post   (uri . body) `(add-route "post"   ,uri
  (fn (req matches) (let resp (table) ,@body resp))))

(mac put    (uri . body) `(add-route "put"    ,uri
  (fn (req matches) (let resp (table) ,@body resp))))

(mac delete (uri . body) `(add-route "delete" ,uri
  (fn (req matches) (let resp (table) ,@body resp))))

; default behaviour
(load "albert/routes-defaults.arc")