module Serve
open System
open System.Drawing
open System.IO
open System.Net
open System.Threading
open Execute
open Load
let private main_page link prog steps =
sprintf
"
Krunimír
" link prog steps
let private handle (context:HttpListenerContext) =
let request = context.Request
let response = context.Response
let send_bytes content (buffer:byte array) =
response.ContentType <- content
response.ContentLength64 <- int64 buffer.Length
let output = response.OutputStream
output.Write(buffer, 0, buffer.Length)
output.Close()
let send_string content (str:string) =
let buffer = System.Text.Encoding.UTF8.GetBytes(str)
send_bytes content buffer
match request.Url.AbsolutePath with
| "/" ->
let args = request.QueryString
let prog = match args.["prog"] with null -> "" | str -> str
let mutable steps = try Int32.Parse args.["steps"] with _ -> 0
let mutable link = ""
if args.["prev"] <> null && steps > 0 then steps <- steps - 1
if args.["next"] <> null then steps <- steps + 1
if args.["prev"] <> null || args.["next"] <> null || args.["go"] <> null then
link <- sprintf "
"
(Uri.EscapeDataString prog) steps
send_string "text/html" <| main_page link prog steps
| "/simulate" ->
let args = request.QueryString
let prog = args.["prog"]
let steps = Int32.Parse args.["steps"]
let image =
try
let memstream = new MemoryStream()
draw (load prog) steps memstream
memstream.ToArray()
with e ->
use bitmap = new Bitmap(700, 700, Imaging.PixelFormat.Format24bppRgb)
use graphics = Graphics.FromImage(bitmap)
graphics.Clear(Color.White)
graphics.DrawString("There was an error: " + e.Message,
SystemFonts.DefaultFont, Brushes.Red,
new RectangleF(0.f, 0.f, 700.f, 700.f))
let memstream = new MemoryStream()
bitmap.Save(memstream, Imaging.ImageFormat.Png)
memstream.ToArray()
send_bytes "image/png" image
| _ ->
response.StatusCode <- 404
send_string "text/html" <| "Error 404
Cannot find requested url " + request.Url.ToString()
let serve port =
use server = new HttpListener()
server.Prefixes.Add(sprintf "http://localhost:%d/" port)
server.Prefixes.Add(sprintf "http://127.0.0.1:%d/" port)
for ip in Dns.GetHostEntry(Dns.GetHostName()).AddressList do
server.Prefixes.Add(sprintf "http://%A:%d/" ip port)
server.Start()
while true do
let context = server.GetContext()
if not (ThreadPool.QueueUserWorkItem(fun _ -> handle context)) then
failwith "Cannot start thread to handle the Http request"