Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial commit

  • Loading branch information...
commit 52b11b8e8ac0e2975e198c42a33e6b7508cb08dd 0 parents
@samoht authored
1  .#action.ml
1  .#world.ml
13 Makefile
@@ -0,0 +1,13 @@
+.PHONY: all clean
+
+all: static.ml
+ @rm -f tapkaz.bin
+ mir tapkaz.bin
+ @ln -s _build/tapkaz.bin .
+
+static.ml: files/*
+ mlcrunch files/ > $@
+
+clean:
+ ocamlbuild -clean
+ rm -f myocamlbuild.ml tapkaz.bin static.ml
1  _tags
@@ -0,0 +1 @@
+true: debug
24 admin.ml
@@ -0,0 +1,24 @@
+(*
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+let html () =
+ let player p =
+ <:html<<li>Player $str:Player.pretty_string p$</li>&>> in
+ Main.make <:html<
+ <ul>
+ $list:List.map player Player.players$
+ </ul>
+ >>
21 constants.ml
@@ -0,0 +1,21 @@
+(*
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+let size_x = 100
+let size_y = 200
+
+let view_x = 2
+let view_y = 3
46 dispatch.ml
@@ -0,0 +1,46 @@
+open Printf
+open Log
+open Net
+open Lwt
+open Cow
+
+module Resp = struct
+
+ (* dynamic response *)
+ let dyn ?(headers=[]) req body =
+ let status = `OK in
+ Http.Daemon.respond ~body ~headers ~status ()
+
+ (* dispatch non-file URLs *)
+ let dispatch req = function
+ | [] -> dyn req Main.html
+ | [ name; "map" ] -> dyn req (World.html (Http.Request.params_post req) (Player.find name))
+ | [ name; "messages"] -> dyn req (Message.html (Http.Request.params_post req) (Player.find name))
+ | ["admin"] -> dyn req (Admin.html ())
+ | ["index.css"] -> dyn req Style.main
+ | x -> (Http.Daemon.respond_not_found ~url:(Http.Request.path req) ())
+end
+
+(* handle exceptions with a 500 *)
+let exn_handler exn =
+ let body = Printexc.to_string exn in
+ logmod "HTTP" "ERROR: %s" body;
+ return ()
+
+(* main callback function *)
+let t conn_id req =
+ let path = Http.Request.path req in
+
+ logmod "HTTP" "%s %s %s [%s]" (Http.Request.client_addr req) (Http.Common.string_of_method (Http.Request.meth req)) path
+ (String.concat "," (List.map (fun (h,v) -> sprintf "%s=%s" h v)
+ (Http.Request.params_get req)));
+ logmod "header" "Connection: %s" (String.concat ", " (Http.Request.header req ~name:"connection"));
+ let path_elem = Str.split (Str.regexp_string "/") path in
+
+ (* determine if it is static or dynamic content *)
+ match Static.t path with
+ |Some body ->
+ Http.Daemon.respond ~body ()
+ |None ->
+ Resp.dispatch req path_elem
+
BIN  files/lion.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
BIN  files/sheep.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
42 log.ml
@@ -0,0 +1,42 @@
+(*
+ * Copyright (c) 2009 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+module Clock = OS.Clock
+
+open Printf
+
+type log_request = [
+ |`Module of (string * string)
+ |`Debug of string
+]
+
+let datetime () =
+ let tm = Clock.gmtime (Clock.time ()) in
+ Printf.sprintf "%.4d/%.2d/%.2d %.2d:%.2d:%.2d"
+ (1900+tm.Clock.tm_year) tm.Clock.tm_mon
+ tm.Clock.tm_mday tm.Clock.tm_hour tm.Clock.tm_min tm.Clock.tm_sec
+
+let log_request = function
+ |`Debug l -> printf "[%s] %s\n%!" (datetime ()) l;
+ |`Module (m,l) -> printf "[%s] %.10s: %s\n%!" (datetime ()) m l
+
+let logmod m fmt =
+ let xfn f = log_request (`Module (m, f)) in
+ kprintf xfn fmt
+
+let logdbg fmt =
+ let xfn f = log_request (`Debug f) in
+ kprintf xfn fmt
33 main.ml
@@ -0,0 +1,33 @@
+(*
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Cow
+
+let make body = Html.to_string <:html<
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+ <title>Welcome to TakKaz !!!</title>
+ <link rel="stylesheet" type="text/css" href="/index.css"/>
+</head>
+
+<body>
+ $body$
+</body>
+</html>
+>>
+
+let html = make <:html<niet>>
+
127 message.ml
@@ -0,0 +1,127 @@
+(*
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Cow
+
+type month = int
+
+let html_of_month m =
+ let str = match m with
+ | 1 -> "Jan"
+ | 2 -> "Feb"
+ | 3 -> "Mar"
+ | 4 -> "Apr"
+ | 5 -> "May"
+ | 6 -> "Jun"
+ | 7 -> "Jul"
+ | 8 -> "Aug"
+ | 9 -> "Sep"
+ | 10 -> "Oct"
+ | 11 -> "Nov"
+ | 12 -> "Dec"
+ | _ -> "???" in
+ <:html<$str:str$>>
+
+type date = {
+ month : month;
+ day : int;
+ year : int;
+ hour : int;
+ min : int;
+} with html
+
+let date (year, month, day, hour, min) =
+ { month; day; year; hour; min }
+
+let css_of_date = <:css<
+ .date {
+ border: 1px solid #999;
+ line-height: 1;
+ width: 4em;
+ position: relative;
+ float: left;
+ margin-right: 15px;
+ text-align: center;
+
+ .month {
+ text-transform: uppercase;
+ font-size: 1.2em;
+ padding-top: 0.3em;
+ }
+ .day {
+ font-size: 2em;
+ }
+ .year {
+ background-color: #2358B8;
+ color: #FFF;
+ font-size: 1.2em;
+ padding: 0.3em 0;
+ margin-top: 0.3em;
+ }
+ .hour {
+ display: none;
+ }
+ .min {
+ display: none;
+ }
+ }
+>>
+
+type t = {
+ date : date;
+ subject : string;
+ sent_by : string;
+ content : string;
+} with html
+
+let css_of_t = <:css<
+ $css_of_date$;
+ .subject {
+ font-style: italic;
+ display: inline;
+ }
+ .sent_by {
+ font-weight: bold;
+ display: inline;
+ }
+ .content {
+ color: grey;
+ }
+>>
+
+let messages : (string, t list) Hashtbl.t =
+ Hashtbl.create 1024
+
+let find_messages name =
+ if Hashtbl.mem messages name then
+ Hashtbl.find messages name
+ else
+ []
+
+let add_message name m =
+ let ms =
+ if Hashtbl.mem messages name then
+ m :: (Hashtbl.find messages name)
+ else
+ [m] in
+ Hashtbl.replace messages name ms
+
+let html post player =
+ let message m =
+ <:html<$html_of_t m$<hr/>&>> in
+ Main.make <:html<
+ $list:List.map message (find_messages player.Player.name)$
+ >>
88 player.ml
@@ -0,0 +1,88 @@
+(*
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Cow
+
+type t = {
+ name : string;
+ avatar : string option;
+ mutable x : int;
+ mutable y : int;
+}
+
+let pretty_string t =
+ Printf.sprintf "%s: (%d, %d)" t.name t.x t.y
+
+let x p = p.x
+let y p = p.y
+
+let move t = function
+ | `up -> if t.x < Constants.size_x - 1 then t.x <- t.x + 1
+ | `down -> if t.x > 0 then t.x <- t.x - 1
+ | `right -> if t.y < Constants.size_y - 1 then t.y <- t.y + 1
+ | `left -> if t.y > 0 then t.y <- t.y - 1
+
+let html_of_t p =
+ let avatar = match p.avatar with
+ | None -> "/sheep.png"
+ | Some a -> a in
+ <:html<
+ <div class="player">
+ <img src=$str:avatar$ alt=$str:p.name$/>
+ </div>
+ >>
+
+let css_of_t = <:css<
+ .player img {
+ $Css.no_padding$;
+ height: 4em;
+ }
+>>
+
+let default = {
+ name = "Groarr";
+ avatar = Some "/lion.png";
+ x = 0;
+ y = 0;
+}
+
+let c = ref 0
+
+let random x y =
+ incr c; {
+ name = "sheep" ^ string_of_int !c;
+ avatar = Some "/sheep.png";
+ x = Random.int x;
+ y = Random.int y;
+ }
+
+let players = [
+ default;
+ random Constants.size_x Constants.size_y;
+ random Constants.size_x Constants.size_y;
+ random Constants.size_x Constants.size_y;
+ random Constants.size_x Constants.size_y;
+ random Constants.size_x Constants.size_y;
+ random Constants.size_x Constants.size_y;
+ random Constants.size_x Constants.size_y;
+ random Constants.size_x Constants.size_y;
+ random Constants.size_x Constants.size_y;
+]
+
+let find name =
+ Log.logmod "player" "looking for %s" name;
+ try List.find (fun p -> p.name = name) players
+ with _ -> default
18 server.ml
@@ -0,0 +1,18 @@
+open Lwt
+open Net.Http.Daemon
+
+let spec = {
+ address = "0.0.0.0";
+ auth = `None;
+ callback = Dispatch.t;
+ conn_closed = (fun _ -> ());
+ port = 8080;
+ exn_handler = Dispatch.exn_handler;
+ timeout = Some 300.;
+}
+
+let _ =
+ OS.Main.run (
+ Log.logmod "Server" "listening to HTTP on port %d" spec.port;
+ main spec
+ )
24 style.ml
@@ -0,0 +1,24 @@
+(*
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Cow
+
+let main = Css.to_string <:css<
+ $Css.reset_padding$;
+ $World.css_of_t$;
+ $Player.css_of_t$;
+ $Message.css_of_t$;
+>>
11 tapkaz.mir
@@ -0,0 +1,11 @@
+Player
+World
+Dispatch
+Server
+Log
+Main
+Constants
+Static
+Style
+Message
+Admin
184 world.ml
@@ -0,0 +1,184 @@
+(*
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Cow
+
+type state = {
+ mutable water : float;
+ mutable grass : float;
+}
+
+let make_state () = {
+ water = Random.float 100.;
+ grass = Random.float 100.;
+ sand = Random.float 100.;
+}
+
+type kind =
+ | `forest
+ | `lake
+ | `desert
+
+let kind_of_state s =
+ if s.water <
+type elt = {
+ x : int;
+ y : int;
+ state : state;
+ mutable z : int;
+ mutable neighbours : elt list;
+ mutable players : Player.t list;
+}
+
+let make_elt x y = {
+ x; y ; z = 0;
+ neighbours = [];
+ players = [];
+}
+
+let html_of_elt c = <:html<
+ <div class=$str:"elt" ^ string_of_int c.z$>
+ ($int:c.x$,$int:c.y$,$flo:c.state.water$,$flo:c.state.grass$)
+ $list:List.map Player.html_of_t c.players$
+ </div>
+>>
+
+let css_of_elt = <:css<
+ .elt0 {
+ color: white;
+ background-color: green;
+ width: 6em;
+ height: 6em;
+ }
+>>
+
+type t = elt array array
+
+let make x y =
+ let w =
+ Array.init x (fun i ->
+ Array.init y (fun j ->
+ make_elt i j)) in
+ for i=0 to x-1 do
+ for j=0 to y-1 do
+ if i>0 then
+ w.(i-1).(j).neighbours <- w.(i).(j) :: w.(i-1).(j).neighbours;
+ if j>0 then
+ w.(i).(j-1).neighbours <- w.(i).(j) :: w.(i).(j-1).neighbours;
+ if i<x-1 then
+ w.(i+1).(j).neighbours <- w.(i).(j) :: w.(i+1).(j).neighbours;
+ if j<y-1 then
+ w.(i).(j+1).neighbours <- w.(i).(j) :: w.(i).(j+1).neighbours;
+ done
+ done;
+ w
+
+let add_player t p =
+ Log.logmod "world" "Adding player %s" (Player.pretty_string p);
+ t.(p.Player.x).(p.Player.y).players <- p :: t.(p.Player.x).(p.Player.y).players
+
+let rm_player t p =
+ t.(p.Player.x).(p.Player.y).players <- List.filter ((!=) p) t.(p.Player.x).(p.Player.y).players
+
+type view = {
+ dx : int;
+ dy : int;
+}
+
+let default_view = {
+ dx = Constants.view_x;
+ dy = Constants.view_y;
+}
+
+let html_of_t ?(view=default_view) player t =
+ let x = Player.x player in
+ let y = Player.y player in
+ let dx1 = min x view.dx in
+ let dx2 = min (Array.length t - x) view.dx in
+ let dy1 = min y view.dy in
+ let dy2 = min (Array.length t.(0) - y) view.dy in
+ let size_x = dx1 + dx2 + 1 in
+ let size_y = dy1 + dy2 + 1 in
+ let v = Array.make_matrix size_x size_y Html.nil in
+ for i = 0 to size_x - 1 do
+ for j = 0 to size_y - 1 do
+ v.(size_x - i - 1).(j) <- html_of_elt t.(x - dx1 + i).(y - dy1 +j)
+ done
+ done;
+ <:html<
+ <div class="world">$Html.html_of_table v$</div>
+ >>
+
+let css_of_t = <:css< $css_of_elt$ >>
+
+let world =
+ let w = make Constants.size_x Constants.size_y in
+ List.iter (add_player w) Player.players;
+ w
+
+module Action = struct
+ type t =
+ [ `up
+ | `down
+ | `left
+ | `right ]
+
+ let of_string = function
+ | "up" -> `up
+ | "down" -> `down
+ | "right" -> `right
+ | "left" -> `left
+ | s -> failwith (s ^": unknown map action")
+
+ let process world player (k,v) =
+ Log.logmod "action" "process k=%s v=%s" k v;
+ match k with
+ | "action" ->
+ rm_player world player;
+ Player.move player (of_string v);
+ add_player world player
+ | _ ->
+ Log.logmod "action" "[ERROR] %s: unknowm action" k
+
+ let html_of_t player =
+ let url = Printf.sprintf "/%s/map" player.Player.name in
+ let option o = <:html<<option>$str:o$</option>&>> in
+ let x = Player.x player in
+ let y = Player.y player in
+ let moves =
+ (if x < Constants.size_x - 1 then ["up"] else []) @
+ (if x > 0 then ["down"] else []) @
+ (if y < Constants.size_y - 1 then ["right"] else []) @
+ (if y > 0 then ["left"] else []) in
+ <:html<
+ <div class="action">
+ <form method="post" action=$str:url$>
+ <select name="action">
+ $list:List.map option moves$
+ </select>
+ <input type="submit" value="move"/>
+ </form>
+ </div>
+ >>
+end
+
+let html post player =
+ List.iter (Action.process world player) post;
+ Main.make <:html<
+ <div class="welcome">Welcome $str:player.Player.name$!</div>
+ $html_of_t player world$
+ $Action.html_of_t player$
+ >>
Please sign in to comment.
Something went wrong with that request. Please try again.