173 lines
4.9 KiB
Text
173 lines
4.9 KiB
Text
-- -*- origami-fold-style: triple-braces -*-
|
|
import Lean
|
|
|
|
-- namespace Webserver {{{
|
|
namespace Webserver
|
|
|
|
structure State :=
|
|
(verb : String)
|
|
(path : String)
|
|
(status := "200 OK")
|
|
(outHeaders : Array String := #[])
|
|
(out : String := "")
|
|
(tryNextHandler := false)
|
|
|
|
abbrev HandlerM := StateT State IO
|
|
abbrev Handler := HandlerM Unit
|
|
|
|
def checkVerb (verb : String) : Handler := do
|
|
st ← get;
|
|
when (st.verb != verb) $
|
|
throw $ IO.userError "invalid verb"
|
|
|
|
def checkPathLiteral (p : String) : Handler := do
|
|
st ← get;
|
|
if p.isPrefixOf st.path then
|
|
set { st with path := st.path.extract p.bsize st.path.bsize }
|
|
else
|
|
throw $ IO.userError "invalid path"
|
|
|
|
def getPathPart : HandlerM String := do
|
|
st ← get;
|
|
let stop := st.path.posOf '/';
|
|
set { st with path := st.path.extract stop st.path.bsize };
|
|
pure $ st.path.extract 0 stop
|
|
|
|
def checkPathConsumed : Handler := do
|
|
st ← get;
|
|
when (st.path != "") $
|
|
throw $ IO.userError "invalid path"
|
|
|
|
def write (out : String) : Handler := do
|
|
modify fun st => { st with out := st.out ++ out }
|
|
|
|
def redirect (url : String) : Handler := do
|
|
modify fun st => { st with status := "307 Temporary Redirect", outHeaders := #["Location: " ++ url] }
|
|
|
|
def notFound : Handler := do
|
|
modify fun st => { st with status := "404 Not Found" };
|
|
write "whoops"
|
|
|
|
def mkHandlersRef : IO (IO.Ref (List Handler)) :=
|
|
IO.mkRef ∅
|
|
|
|
@[init mkHandlersRef]
|
|
constant handlersRef : IO.Ref (List Handler) := arbitrary _
|
|
|
|
def registerHandler (h : Handler) : IO Unit := do
|
|
handlersRef.modify fun hs => h::hs
|
|
|
|
partial def parseHeaders : IO.FS.Handle → IO Unit
|
|
| hIn => do
|
|
line ← hIn.getLine;
|
|
if line == "" || line == "\r\n" then pure () else parseHeaders hIn
|
|
|
|
partial def run : IO.FS.Handle → IO.FS.Handle → IO Unit
|
|
| hIn, hOut => do
|
|
line ← hIn.getLine;
|
|
when (line != "") do
|
|
[verb, path, proto] ← pure $ line.splitOn " "
|
|
| panic! "failed to parse request: " ++ line;
|
|
stderr ← IO.stderr; stderr.putStrLn $ "=> " ++ verb ++ " " ++ path;
|
|
headers ← parseHeaders hIn;
|
|
handlers ← handlersRef.get | panic! "no handlers";
|
|
(_, st) ← handlers.foldr (fun h₁ h₂ => h₁ <|> h₂) notFound { verb := verb, path := path };
|
|
stderr ← IO.stderr; stderr.putStrLn $ "<= " ++ st.status;
|
|
hOut.putStrLn $ "HTTP/1.1 " ++ st.status;
|
|
hOut.putStrLn "Content-Type: text/html";
|
|
hOut.putStrLn $ "Content-Length: " ++ toString st.out.bsize;
|
|
st.outHeaders.forM hOut.putStrLn;
|
|
hOut.putStrLn "";
|
|
hOut.putStr st.out;
|
|
hOut.flush;
|
|
run hIn hOut
|
|
|
|
end Webserver
|
|
--}}}
|
|
|
|
|
|
open Lean
|
|
open Lean.Parser
|
|
|
|
-- declare_syntax_cat element {{{
|
|
declare_syntax_cat element
|
|
declare_syntax_cat child
|
|
|
|
syntax "<" ident "/>" : element
|
|
syntax "<" ident ">" child* "</" ident ">" : element
|
|
|
|
-- "JSXTextCharacter : SourceCharacter but not one of {, <, > or }"
|
|
def text : Parser := -- {{{
|
|
withAntiquot (mkAntiquot "text" `LX.text) {
|
|
fn := fun c s =>
|
|
let startPos := s.pos;
|
|
let s := takeWhile1Fn (not ∘ "{<>}$".contains) "HTML text" c s;
|
|
mkNodeToken `LX.text startPos c s } -- }}}
|
|
|
|
syntax text : child
|
|
syntax "{" term "}" : child
|
|
syntax element : child
|
|
|
|
syntax element : term
|
|
|
|
macro_rules
|
|
| `(<$n/>) => mkStxStrLit ("<" ++ toString n.getId ++ ">")
|
|
| `(<$n>$cs*</$m>) => -- {{{
|
|
if n.getId == m.getId then do
|
|
cs ← cs.mapM fun c => match_syntax c with
|
|
| `(child|$t:text) => pure $ mkStxStrLit (t.getArg 0).getAtomVal!
|
|
| `(child|{$t}) => pure t
|
|
| `(child|$e:element) => `($e:element)
|
|
| _ => unreachable!;
|
|
let cs := cs.push (mkStxStrLit ("</" ++ toString m.getId ++ ">"));
|
|
cs.foldlM (fun s e => `($s ++ $e)) (mkStxStrLit ("<" ++ toString n.getId ++ ">"))
|
|
else Macro.throwError m ("expected </" ++ toString n.getId ++ ">")
|
|
-- }}}
|
|
-- }}}
|
|
|
|
-- open Webserver {{{
|
|
open Webserver
|
|
|
|
def pathLiteral : Parser := -- {{{
|
|
withAntiquot (mkAntiquot "pathLiteral" `pathLiteral) {
|
|
fn := fun c s =>
|
|
let startPos := s.pos;
|
|
let s := takeWhile1Fn (fun c => c == '/' || c.isAlphanum) "URL path" c s;
|
|
mkNodeToken `pathLiteral startPos c s } -- }}}
|
|
|
|
declare_syntax_cat pathItem
|
|
syntax pathLiteral : pathItem
|
|
syntax "{" ident "}" : pathItem
|
|
syntax path := pathItem*
|
|
|
|
declare_syntax_cat verb
|
|
syntax "GET" : verb
|
|
syntax "POST" : verb
|
|
|
|
macro v:verb p:path " => " t:term : command => do -- {{{
|
|
t ← `(do checkPathConsumed; $t:term);
|
|
t ← p.getArgs.foldrM (fun pi t => match_syntax pi with
|
|
| `(pathItem|$l:pathLiteral) => `(do checkPathLiteral $(mkStxStrLit (l.getArg 0).getAtomVal!); $t:term)
|
|
| `(pathItem|{$id}) => `(do $id:ident ← getPathPart; $t:term)
|
|
| _ => unreachable!) t;
|
|
`(def handler : Handler := do
|
|
checkVerb $(mkStxStrLit (v.getArg 0).getAtomVal!);
|
|
$t:term
|
|
|
|
@[init] def reg : IO Unit := registerHandler handler)
|
|
-- }}}
|
|
|
|
GET / => redirect "/greet/stranger"
|
|
|
|
GET /greet/{name} => write
|
|
<html>
|
|
<h1>Hello, {name}!</h1>
|
|
</html>
|
|
|
|
def main : IO Unit := do
|
|
hIn ← IO.stdin;
|
|
hOut ← IO.stdout;
|
|
Webserver.run hIn hOut
|
|
-- }}}
|
|
|
|
#check let name := "PLDI"; <h1>Hello, {name}!<br/></h1>
|