(defmodule nemoptera_proxy
(export all))
(defun handle (req)
(cond
((not (nemoptera_setup:installed?)) (nemoptera_http:redirect "/setup"))
('true
(let ((path (binary_to_list (cowboy_req:path req))))
(case (resolve path)
(`#(ok ,port ,rest) (forward req port rest))
('starting
(nemoptera_http:html 503
(nemoptera_ui:render "Starting" 'home 'public (logged-in? req)
"<h1 class=\"page\">Repository</h1><p>The Fossil process is still starting. Try again in a moment.</p>")))
(_
(nemoptera_http:html 404
(nemoptera_ui:render "Not found" 'home 'public (logged-in? req)
"<h1 class=\"page\">Not found</h1><p>There is no repository at this path.</p>"))))))))
(defun resolve (path)
(let ((segs (lists:filter (lambda (seg) (not (=:= "" seg)))
(string:split (strip path) "/" 'all))))
(case segs
('() 'missing)
(`(,slug) (try-one slug "/"))
(`(,first . ,rest)
(case (port-for first 'none)
(`#(ok ,port) `#(ok ,port ,(join-path rest)))
('starting 'starting)
(_
(case rest
(`(,second . ,tail)
(case (port-for second first)
(`#(ok ,port) `#(ok ,port ,(join-path tail)))
('starting 'starting)
(_ 'missing)))
(_ 'missing))))))))
(defun try-one (slug forward)
(case (port-for slug 'none)
(`#(ok ,port) `#(ok ,port ,forward))
('starting 'starting)
(_ 'missing)))
(defun port-for (slug org-name)
(let ((rows (if (=:= org-name 'none)
(catch (nemoptera_db:q "SELECT id FROM repositories WHERE name=? AND organization_id IS NULL;" (list slug)))
(catch (nemoptera_db:q "SELECT r.id FROM repositories r JOIN organizations o ON o.id=r.organization_id WHERE r.name=? AND o.name=?;"
(list slug org-name))))))
(case rows
(`((,_))
(case (nemoptera_registry:lookup org-name slug)
(`#(ok ,port) `#(ok ,port))
(_ 'starting)))
(_ 'undefined))))
(defun forward (req port rest)
(application:ensure_all_started 'inets)
(let* ((method (string:lowercase (binary_to_list (cowboy_req:method req))))
(qs (binary_to_list (cowboy_req:qs req)))
(url (lists:flatten
(io_lib:format "http://127.0.0.1:~p~s~s"
(list port (if (=:= "" rest) "/" rest)
(if (=:= "" qs) "" (lists:append "?" qs))))))
(headers (forward-headers req)))
(case (dispatch method url headers req)
((tuple 'ok (tuple (tuple _version status _reason) resp-headers body))
(reply req status resp-headers body))
(`#(error ,reason)
(nemoptera_http:html 502
(nemoptera_ui:render "Unavailable" 'home 'public (logged-in? req)
(list "<h1 class=\"page\">Unavailable</h1><p>"
(nemoptera_ui:escape (lists:flatten (io_lib:format "~p" (list reason))))
"</p>")))))))
(defun dispatch (method url headers req)
(let ((sent (drop headers "content-length")))
(case method
("post"
(case (read-body req)
(`#(ok ,body)
(httpc:request 'post
(tuple url sent (content-type sent) body)
(list (tuple 'autoredirect 'false))
(list (tuple 'body_format 'binary))))
(error error)))
(_
(httpc:request (list_to_atom method)
(tuple url sent)
(list (tuple 'autoredirect 'false))
(list (tuple 'body_format 'binary)))))))
(defun read-body (req)
(case (maps:find 'body req)
(`#(ok ,body) `#(ok ,(to-bin body)))
(_
(case (catch (cowboy_req:read_body req))
(`#(ok ,body ,_) `#(ok ,body))
(_ `#(ok #""))))))
(defun forward-headers (req)
(lists:filtermap
(lambda (pair)
(let (((tuple key value) pair))
(if (allowed-header key)
`#(true ,(tuple (binary_to_list key) (binary_to_list value)))
'false)))
(maps:to_list (cowboy_req:headers req))))
(defun allowed-header (key)
(lists:member key
'(#"host" #"cookie" #"authorization" #"content-type" #"accept"
#"accept-language" #"user-agent" #"if-modified-since"
#"if-none-match" #"referer" #"origin")))
(defun content-type (headers)
(case (proplists:get_value "content-type" headers)
('undefined "application/x-www-form-urlencoded")
(value value)))
(defun reply (req status headers body)
(let (((tuple header-map cookies) (split-headers headers)))
(let ((req2 (lists:foldl #'put-cookie/2 req cookies)))
`#(status ,status ,header-map ,(to-bin body) ,req2))))
(defun split-headers (headers)
(lists:foldl
(lambda (pair acc)
(let* (((tuple header-map cookies) acc)
((tuple key value) pair)
(name (string:lowercase (nemoptera_text:to-str key))))
(cond
((=:= name "set-cookie")
(tuple header-map (lists:append cookies (list (to-bin value)))))
((lists:member name '("content-length" "transfer-encoding" "connection"))
acc)
('true
(tuple (maps:put (list_to_binary name) (to-bin value) header-map) cookies)))))
(tuple #M() '())
headers))
(defun put-cookie (raw req)
(case (catch (cow_cookie:parse_set_cookie (to-bin raw)))
(`#(ok ,name ,value ,attrs)
(cowboy_req:set_resp_cookie name value req (cookie-opts attrs)))
(_ req)))
(defun cookie-opts (attrs)
(lists:foldl
(lambda (key acc)
(case (maps:find key attrs)
(`#(ok ,value)
(if (keep-opt? key value) (maps:put key value acc) acc))
(_ acc)))
#M()
'(path domain secure http_only same_site max_age)))
(defun keep-opt? (key value)
(case key
('max_age (is_integer value))
('secure (is_boolean value))
('http_only (is_boolean value))
('same_site (lists:member value '(lax strict none default)))
(_ 'true)))
(defun drop (headers name)
(lists:filter
(lambda (pair)
(let (((tuple key _value) pair))
(not (=:= (string:lowercase (nemoptera_text:to-str key)) name))))
headers))
(defun join-path (segs)
(if (=:= '() segs)
"/"
(lists:append "/" (string:join segs "/"))))
(defun strip (path)
(if (and (> (length path) 0) (=:= (hd path) 47))
(tl path)
path))
(defun to-bin (value)
(cond
((is_binary value) value)
((is_list value)
(case (catch (iolist_to_binary value))
(bin (if (is_binary bin) bin #""))
(_ #"")))
('true #"")))
(defun logged-in? (req)
(nemoptera_public:logged-in? req))