mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 19:25:28 -05:00
use oasis to build files, splitted into libraries, including
a Container module that packs everything; ToWeb module (depends on CamlGI) to expoert values on the web
This commit is contained in:
Simon Cruanes
parent
9dc91cec65
commit
7313a258b4
16 changed files with 7637 additions and 44 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -5,3 +5,4 @@ _build
|
|||
.session
|
||||
TAGS
|
||||
*.docdir
|
||||
setup.log
|
||||
|
|
|
|||
44
META
Normal file
44
META
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 228a31c6369b1dd4a6ea763cff7e020e)
|
||||
version = "0.1"
|
||||
description = "A bunch of modules, including polymorphic containers."
|
||||
requires = "unix"
|
||||
archive(byte) = "containers.cma"
|
||||
archive(byte, plugin) = "containers.cma"
|
||||
archive(native) = "containers.cmxa"
|
||||
archive(native, plugin) = "containers.cmxs"
|
||||
exists_if = "containers.cma"
|
||||
package "thread" (
|
||||
version = "0.1"
|
||||
description = "A bunch of modules, including polymorphic containers."
|
||||
requires = "containers lwt"
|
||||
archive(byte) = "containers_thread.cma"
|
||||
archive(byte, plugin) = "containers_thread.cma"
|
||||
archive(native) = "containers_thread.cmxa"
|
||||
archive(native, plugin) = "containers_thread.cmxs"
|
||||
exists_if = "containers_thread.cma"
|
||||
)
|
||||
|
||||
package "lwt" (
|
||||
version = "0.1"
|
||||
description = "A bunch of modules, including polymorphic containers."
|
||||
requires = "containers lwt"
|
||||
archive(byte) = "containers_lwt.cma"
|
||||
archive(byte, plugin) = "containers_lwt.cma"
|
||||
archive(native) = "containers_lwt.cmxa"
|
||||
archive(native, plugin) = "containers_lwt.cmxs"
|
||||
exists_if = "containers_lwt.cma"
|
||||
)
|
||||
|
||||
package "cgi" (
|
||||
version = "0.1"
|
||||
description = "A bunch of modules, including polymorphic containers."
|
||||
requires = "containers CamlGI"
|
||||
archive(byte) = "containers_cgi.cma"
|
||||
archive(byte, plugin) = "containers_cgi.cma"
|
||||
archive(native) = "containers_cgi.cmxa"
|
||||
archive(native, plugin) = "containers_cgi.cmxs"
|
||||
exists_if = "containers_cgi.cma"
|
||||
)
|
||||
# OASIS_STOP
|
||||
|
||||
77
Makefile
77
Makefile
|
|
@ -1,53 +1,52 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb)
|
||||
|
||||
INTERFACE_FILES = $(shell find -name '*.mli')
|
||||
IMPLEMENTATION_FILES = $(shell find -name '*.ml')
|
||||
SETUP = ocaml setup.ml
|
||||
|
||||
build: setup.data
|
||||
$(SETUP) -build $(BUILDFLAGS)
|
||||
|
||||
doc: setup.data build
|
||||
$(SETUP) -doc $(DOCFLAGS)
|
||||
|
||||
test: setup.data build
|
||||
$(SETUP) -test $(TESTFLAGS)
|
||||
|
||||
all:
|
||||
$(SETUP) -all $(ALLFLAGS)
|
||||
|
||||
install: setup.data
|
||||
$(SETUP) -install $(INSTALLFLAGS)
|
||||
|
||||
uninstall: setup.data
|
||||
$(SETUP) -uninstall $(UNINSTALLFLAGS)
|
||||
|
||||
reinstall: setup.data
|
||||
$(SETUP) -reinstall $(REINSTALLFLAGS)
|
||||
|
||||
clean:
|
||||
$(SETUP) -clean $(CLEANFLAGS)
|
||||
|
||||
distclean:
|
||||
$(SETUP) -distclean $(DISTCLEANFLAGS)
|
||||
|
||||
setup.data:
|
||||
$(SETUP) -configure $(CONFIGUREFLAGS)
|
||||
|
||||
.PHONY: build doc test all install uninstall reinstall clean distclean configure
|
||||
|
||||
# OASIS_STOP
|
||||
|
||||
TARGETS_LIB = containers.cmxa containers.cma
|
||||
TARGETS_DOC = containers.docdir/index.html
|
||||
EXAMPLES = examples/mem_size.native examples/collatz.native \
|
||||
examples/bencode_write.native # examples/crawl.native
|
||||
|
||||
OPTIONS = -use-ocamlfind
|
||||
|
||||
ENABLE_THREAD ?= yes
|
||||
ENABLE_LWT ?= yes
|
||||
|
||||
ifeq ($(ENABLE_THREAD), yes)
|
||||
OPTIONS += -tag thread
|
||||
TARGETS_LIB += thread_containers.cmxa thread_containers.cma
|
||||
TARGETS_DOC += thread_containers.docdir/index.html
|
||||
endif
|
||||
ifeq ($(ENABLE_LWT), yes)
|
||||
OPTIONS += -package lwt -package lwt.unix
|
||||
TARGETS_LIB += lwt_containers.cmxa lwt_containers.cma
|
||||
TARGETS_DOC += lwt_containers.docdir/index.html
|
||||
endif
|
||||
|
||||
all: lib
|
||||
|
||||
lib:
|
||||
ocamlbuild $(OPTIONS) $(TARGETS_LIB) $(TARGETS_DOC)
|
||||
|
||||
doc:
|
||||
ocamlbuild $(OPTIONS) $(TARGETS_DOC)
|
||||
|
||||
examples: all
|
||||
ocamlbuild $(OPTIONS) -package unix -I . $(EXAMPLES)
|
||||
|
||||
tests: lib
|
||||
ocamlbuild $(OPTIONS) -package oUnit -I . tests/run_tests.native
|
||||
|
||||
bench:
|
||||
ocamlbuild $(OPTIONS) -package bench -package unix -I . tests/benchs.native
|
||||
|
||||
push_doc: doc
|
||||
scp -r containers.docdir/* cedeela.fr:~/simon/root/software/containers/
|
||||
|
||||
clean:
|
||||
ocamlbuild -clean
|
||||
|
||||
tags:
|
||||
otags *.ml *.mli
|
||||
|
||||
.PHONY: all clean tests tags examples
|
||||
|
||||
.PHONY: examples push_doc tags
|
||||
|
|
|
|||
106
_oasis
Normal file
106
_oasis
Normal file
|
|
@ -0,0 +1,106 @@
|
|||
OASISFormat: 0.3
|
||||
Name: containers
|
||||
Version: 0.1
|
||||
Homepage: https://github.com/c-cube/ocaml-containers
|
||||
Authors: Simon Cruanes
|
||||
License: BSD3
|
||||
LicenseFile: LICENSE
|
||||
Plugins: META (0.3), DevFiles (0.3)
|
||||
OCamlVersion: >= 4.00.1
|
||||
BuildTools: ocamlbuild
|
||||
|
||||
Synopsis: A bunch of modules, including polymorphic containers.
|
||||
Description:
|
||||
A bunch of useful modules, including polymorphic containers, graph
|
||||
abstractions, serialization systems, testing systems and various
|
||||
experiments.
|
||||
|
||||
Flag "cgi"
|
||||
Description: Build modules related to FastCGI, depending on CamlGI
|
||||
Default: false
|
||||
|
||||
Flag "lwt"
|
||||
Description: Build modules which depend on Lwt
|
||||
Default: false
|
||||
|
||||
Flag "thread"
|
||||
Description: Build modules that depend on threads
|
||||
Default: true
|
||||
|
||||
Flag "bench"
|
||||
Description: Build and run benchmarks
|
||||
Default: false
|
||||
|
||||
Library "containers"
|
||||
Path: .
|
||||
Pack: true
|
||||
Modules: Cache, Deque, Gen, FHashtbl, FQueue, FlatHashtbl, Hashset,
|
||||
Heap, LazyGraph, PersistentGraph, PersistentHashtbl,
|
||||
PHashtbl, Sequence, SkipList, SplayTree, SplayMap, Univ,
|
||||
Vector, Bij, PiCalculus, Bencode, Sexp, RAL, MultiSet,
|
||||
UnionFind, SmallSet, Leftistheap, AbsSet, CSM, MultiMap,
|
||||
ActionMan, BV, QCheck, BencodeOnDisk, Show
|
||||
BuildDepends: unix
|
||||
|
||||
Library "containers_thread"
|
||||
Path: .
|
||||
Modules: Future
|
||||
FindlibName: thread
|
||||
FindlibParent: containers
|
||||
Build$: flag(thread)
|
||||
Install$: flag(thread)
|
||||
BuildDepends: containers,threads
|
||||
XMETARequires: containers,lwt
|
||||
|
||||
Library "containers_lwt"
|
||||
Path: .
|
||||
Modules: Behavior
|
||||
FindlibName: lwt
|
||||
FindlibParent: containers
|
||||
Build$: flag(lwt)
|
||||
Install$: flag(lwt)
|
||||
BuildDepends: containers,lwt
|
||||
XMETARequires: containers,lwt
|
||||
|
||||
Library "containers_cgi"
|
||||
Path: .
|
||||
Modules: ToWeb
|
||||
FindlibName: cgi
|
||||
FindlibParent: containers
|
||||
Build$: flag(cgi)
|
||||
Install$: flag(cgi)
|
||||
BuildDepends: containers,CamlGI
|
||||
XMETARequires: containers,CamlGI
|
||||
|
||||
Document containers
|
||||
Title: Containers docs
|
||||
Type: ocamlbuild (0.3)
|
||||
BuildTools+: ocamldoc
|
||||
Install: true
|
||||
XOCamlbuildPath: .
|
||||
XOCamlbuildLibraries: containers,containers.lwt
|
||||
|
||||
Executable benchs
|
||||
Path: tests/
|
||||
Install: false
|
||||
CompiledObject: native
|
||||
MainIs: benchs.ml
|
||||
BuildDepends: containers,bench
|
||||
|
||||
Test all
|
||||
Command: $run_tests
|
||||
TestTools: run_tests
|
||||
Run$: flag(tests)
|
||||
|
||||
Executable run_tests
|
||||
Path: tests/
|
||||
Install: false
|
||||
CompiledObject: native
|
||||
MainIs: run_tests.ml
|
||||
Build$: flag(tests) && flag(lwt)
|
||||
BuildDepends: containers, oUnit, lwt
|
||||
|
||||
SourceRepository head
|
||||
Type: git
|
||||
Location: https://github.com/c-cube/ocaml-containers
|
||||
Browser: https://github.com/c-cube/ocaml-containers/tree/master/src
|
||||
82
_tags
82
_tags
|
|
@ -1,4 +1,78 @@
|
|||
<**/*future.*>: thread
|
||||
<examples/crawl.*>: package(batteries), thread, package(unix)
|
||||
<behavior.*>: package(lwt), package(unix)
|
||||
<tests/*.native>: thread
|
||||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 2ccc5fef0936d36155ec2a8d19a2c516)
|
||||
# Ignore VCS directories, you can use the same kind of rule outside
|
||||
# OASIS_START/STOP if you want to exclude directories that contains
|
||||
# useless stuff for the build process
|
||||
<**/.svn>: -traverse
|
||||
<**/.svn>: not_hygienic
|
||||
".bzr": -traverse
|
||||
".bzr": not_hygienic
|
||||
".hg": -traverse
|
||||
".hg": not_hygienic
|
||||
".git": -traverse
|
||||
".git": not_hygienic
|
||||
"_darcs": -traverse
|
||||
"_darcs": not_hygienic
|
||||
# Library containers
|
||||
"containers.cmxs": use_containers
|
||||
"cache.cmx": for-pack(Containers)
|
||||
"deque.cmx": for-pack(Containers)
|
||||
"gen.cmx": for-pack(Containers)
|
||||
"fHashtbl.cmx": for-pack(Containers)
|
||||
"fQueue.cmx": for-pack(Containers)
|
||||
"flatHashtbl.cmx": for-pack(Containers)
|
||||
"hashset.cmx": for-pack(Containers)
|
||||
"heap.cmx": for-pack(Containers)
|
||||
"lazyGraph.cmx": for-pack(Containers)
|
||||
"persistentGraph.cmx": for-pack(Containers)
|
||||
"persistentHashtbl.cmx": for-pack(Containers)
|
||||
"pHashtbl.cmx": for-pack(Containers)
|
||||
"sequence.cmx": for-pack(Containers)
|
||||
"skipList.cmx": for-pack(Containers)
|
||||
"splayTree.cmx": for-pack(Containers)
|
||||
"splayMap.cmx": for-pack(Containers)
|
||||
"univ.cmx": for-pack(Containers)
|
||||
"vector.cmx": for-pack(Containers)
|
||||
"bij.cmx": for-pack(Containers)
|
||||
"piCalculus.cmx": for-pack(Containers)
|
||||
"bencode.cmx": for-pack(Containers)
|
||||
"sexp.cmx": for-pack(Containers)
|
||||
"RAL.cmx": for-pack(Containers)
|
||||
"multiSet.cmx": for-pack(Containers)
|
||||
"unionFind.cmx": for-pack(Containers)
|
||||
"smallSet.cmx": for-pack(Containers)
|
||||
"leftistheap.cmx": for-pack(Containers)
|
||||
"absSet.cmx": for-pack(Containers)
|
||||
"CSM.cmx": for-pack(Containers)
|
||||
"multiMap.cmx": for-pack(Containers)
|
||||
"actionMan.cmx": for-pack(Containers)
|
||||
"BV.cmx": for-pack(Containers)
|
||||
"qCheck.cmx": for-pack(Containers)
|
||||
"bencodeOnDisk.cmx": for-pack(Containers)
|
||||
"show.cmx": for-pack(Containers)
|
||||
# Library containers_thread
|
||||
"containers_thread.cmxs": use_containers_thread
|
||||
<*.ml{,i}>: pkg_threads
|
||||
# Library containers_lwt
|
||||
"containers_lwt.cmxs": use_containers_lwt
|
||||
<*.ml{,i}>: pkg_lwt
|
||||
# Library containers_cgi
|
||||
"containers_cgi.cmxs": use_containers_cgi
|
||||
<*.ml{,i}>: use_containers
|
||||
<*.ml{,i}>: pkg_CamlGI
|
||||
<*.ml{,i}>: pkg_unix
|
||||
# Executable benchs
|
||||
"tests/benchs.native": use_containers
|
||||
"tests/benchs.native": pkg_bench
|
||||
"tests/benchs.native": pkg_unix
|
||||
<tests/*.ml{,i}>: pkg_bench
|
||||
# Executable run_tests
|
||||
"tests/run_tests.native": use_containers
|
||||
"tests/run_tests.native": pkg_oUnit
|
||||
"tests/run_tests.native": pkg_lwt
|
||||
"tests/run_tests.native": pkg_unix
|
||||
<tests/*.ml{,i}>: use_containers
|
||||
<tests/*.ml{,i}>: pkg_oUnit
|
||||
<tests/*.ml{,i}>: pkg_lwt
|
||||
<tests/*.ml{,i}>: pkg_unix
|
||||
# OASIS_STOP
|
||||
|
|
|
|||
27
configure
vendored
Executable file
27
configure
vendored
Executable file
|
|
@ -0,0 +1,27 @@
|
|||
#!/bin/sh
|
||||
|
||||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7)
|
||||
set -e
|
||||
|
||||
FST=true
|
||||
for i in "$@"; do
|
||||
if $FST; then
|
||||
set --
|
||||
FST=false
|
||||
fi
|
||||
|
||||
case $i in
|
||||
--*=*)
|
||||
ARG=${i%%=*}
|
||||
VAL=${i##*=}
|
||||
set -- "$@" "$ARG" "$VAL"
|
||||
;;
|
||||
*)
|
||||
set -- "$@" "$i"
|
||||
;;
|
||||
esac
|
||||
done
|
||||
|
||||
ocaml setup.ml -configure "$@"
|
||||
# OASIS_STOP
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: c71ccfdbd010237adfeae06ed09c46ad)
|
||||
Cache
|
||||
Deque
|
||||
Gen
|
||||
|
|
@ -33,3 +35,4 @@ BV
|
|||
QCheck
|
||||
BencodeOnDisk
|
||||
Show
|
||||
# OASIS_STOP
|
||||
|
|
@ -1 +0,0 @@
|
|||
containers.mllib
|
||||
39
containers.odocl
Normal file
39
containers.odocl
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 3b0c2006d9fcd3955eb8118014479a19)
|
||||
Cache
|
||||
Deque
|
||||
Gen
|
||||
FHashtbl
|
||||
FQueue
|
||||
FlatHashtbl
|
||||
Hashset
|
||||
Heap
|
||||
LazyGraph
|
||||
PersistentGraph
|
||||
PersistentHashtbl
|
||||
PHashtbl
|
||||
Sequence
|
||||
SkipList
|
||||
SplayTree
|
||||
SplayMap
|
||||
Univ
|
||||
Vector
|
||||
Bij
|
||||
PiCalculus
|
||||
Bencode
|
||||
Sexp
|
||||
RAL
|
||||
MultiSet
|
||||
UnionFind
|
||||
SmallSet
|
||||
Leftistheap
|
||||
AbsSet
|
||||
CSM
|
||||
MultiMap
|
||||
ActionMan
|
||||
BV
|
||||
QCheck
|
||||
BencodeOnDisk
|
||||
Show
|
||||
Behavior
|
||||
# OASIS_STOP
|
||||
4
containers_cgi.mllib
Normal file
4
containers_cgi.mllib
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: f5192440033c9e32b425a31804bbddaa)
|
||||
ToWeb
|
||||
# OASIS_STOP
|
||||
4
containers_lwt.mllib
Normal file
4
containers_lwt.mllib
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: b39a035a995fc6597c8eb942210d1527)
|
||||
Behavior
|
||||
# OASIS_STOP
|
||||
4
containers_thread.mllib
Normal file
4
containers_thread.mllib
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: adff855173c9b92b5478129af7d39e03)
|
||||
Future
|
||||
# OASIS_STOP
|
||||
497
myocamlbuild.ml
Normal file
497
myocamlbuild.ml
Normal file
|
|
@ -0,0 +1,497 @@
|
|||
(* OASIS_START *)
|
||||
(* DO NOT EDIT (digest: 240e1f430a880e29ecae75f577790609) *)
|
||||
module OASISGettext = struct
|
||||
(* # 21 "src/oasis/OASISGettext.ml" *)
|
||||
|
||||
let ns_ str =
|
||||
str
|
||||
|
||||
let s_ str =
|
||||
str
|
||||
|
||||
let f_ (str : ('a, 'b, 'c, 'd) format4) =
|
||||
str
|
||||
|
||||
let fn_ fmt1 fmt2 n =
|
||||
if n = 1 then
|
||||
fmt1^^""
|
||||
else
|
||||
fmt2^^""
|
||||
|
||||
let init =
|
||||
[]
|
||||
|
||||
end
|
||||
|
||||
module OASISExpr = struct
|
||||
(* # 21 "src/oasis/OASISExpr.ml" *)
|
||||
|
||||
|
||||
|
||||
open OASISGettext
|
||||
|
||||
type test = string
|
||||
|
||||
type flag = string
|
||||
|
||||
type t =
|
||||
| EBool of bool
|
||||
| ENot of t
|
||||
| EAnd of t * t
|
||||
| EOr of t * t
|
||||
| EFlag of flag
|
||||
| ETest of test * string
|
||||
|
||||
|
||||
type 'a choices = (t * 'a) list
|
||||
|
||||
let eval var_get t =
|
||||
let rec eval' =
|
||||
function
|
||||
| EBool b ->
|
||||
b
|
||||
|
||||
| ENot e ->
|
||||
not (eval' e)
|
||||
|
||||
| EAnd (e1, e2) ->
|
||||
(eval' e1) && (eval' e2)
|
||||
|
||||
| EOr (e1, e2) ->
|
||||
(eval' e1) || (eval' e2)
|
||||
|
||||
| EFlag nm ->
|
||||
let v =
|
||||
var_get nm
|
||||
in
|
||||
assert(v = "true" || v = "false");
|
||||
(v = "true")
|
||||
|
||||
| ETest (nm, vl) ->
|
||||
let v =
|
||||
var_get nm
|
||||
in
|
||||
(v = vl)
|
||||
in
|
||||
eval' t
|
||||
|
||||
let choose ?printer ?name var_get lst =
|
||||
let rec choose_aux =
|
||||
function
|
||||
| (cond, vl) :: tl ->
|
||||
if eval var_get cond then
|
||||
vl
|
||||
else
|
||||
choose_aux tl
|
||||
| [] ->
|
||||
let str_lst =
|
||||
if lst = [] then
|
||||
s_ "<empty>"
|
||||
else
|
||||
String.concat
|
||||
(s_ ", ")
|
||||
(List.map
|
||||
(fun (cond, vl) ->
|
||||
match printer with
|
||||
| Some p -> p vl
|
||||
| None -> s_ "<no printer>")
|
||||
lst)
|
||||
in
|
||||
match name with
|
||||
| Some nm ->
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
(f_ "No result for the choice list '%s': %s")
|
||||
nm str_lst)
|
||||
| None ->
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
(f_ "No result for a choice list: %s")
|
||||
str_lst)
|
||||
in
|
||||
choose_aux (List.rev lst)
|
||||
|
||||
end
|
||||
|
||||
|
||||
# 117 "myocamlbuild.ml"
|
||||
module BaseEnvLight = struct
|
||||
(* # 21 "src/base/BaseEnvLight.ml" *)
|
||||
|
||||
module MapString = Map.Make(String)
|
||||
|
||||
type t = string MapString.t
|
||||
|
||||
let default_filename =
|
||||
Filename.concat
|
||||
(Sys.getcwd ())
|
||||
"setup.data"
|
||||
|
||||
let load ?(allow_empty=false) ?(filename=default_filename) () =
|
||||
if Sys.file_exists filename then
|
||||
begin
|
||||
let chn =
|
||||
open_in_bin filename
|
||||
in
|
||||
let st =
|
||||
Stream.of_channel chn
|
||||
in
|
||||
let line =
|
||||
ref 1
|
||||
in
|
||||
let st_line =
|
||||
Stream.from
|
||||
(fun _ ->
|
||||
try
|
||||
match Stream.next st with
|
||||
| '\n' -> incr line; Some '\n'
|
||||
| c -> Some c
|
||||
with Stream.Failure -> None)
|
||||
in
|
||||
let lexer =
|
||||
Genlex.make_lexer ["="] st_line
|
||||
in
|
||||
let rec read_file mp =
|
||||
match Stream.npeek 3 lexer with
|
||||
| [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
|
||||
Stream.junk lexer;
|
||||
Stream.junk lexer;
|
||||
Stream.junk lexer;
|
||||
read_file (MapString.add nm value mp)
|
||||
| [] ->
|
||||
mp
|
||||
| _ ->
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
"Malformed data file '%s' line %d"
|
||||
filename !line)
|
||||
in
|
||||
let mp =
|
||||
read_file MapString.empty
|
||||
in
|
||||
close_in chn;
|
||||
mp
|
||||
end
|
||||
else if allow_empty then
|
||||
begin
|
||||
MapString.empty
|
||||
end
|
||||
else
|
||||
begin
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
"Unable to load environment, the file '%s' doesn't exist."
|
||||
filename)
|
||||
end
|
||||
|
||||
let var_get name env =
|
||||
let rec var_expand str =
|
||||
let buff =
|
||||
Buffer.create ((String.length str) * 2)
|
||||
in
|
||||
Buffer.add_substitute
|
||||
buff
|
||||
(fun var ->
|
||||
try
|
||||
var_expand (MapString.find var env)
|
||||
with Not_found ->
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
"No variable %s defined when trying to expand %S."
|
||||
var
|
||||
str))
|
||||
str;
|
||||
Buffer.contents buff
|
||||
in
|
||||
var_expand (MapString.find name env)
|
||||
|
||||
let var_choose lst env =
|
||||
OASISExpr.choose
|
||||
(fun nm -> var_get nm env)
|
||||
lst
|
||||
end
|
||||
|
||||
|
||||
# 215 "myocamlbuild.ml"
|
||||
module MyOCamlbuildFindlib = struct
|
||||
(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *)
|
||||
|
||||
(** OCamlbuild extension, copied from
|
||||
* http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild
|
||||
* by N. Pouillard and others
|
||||
*
|
||||
* Updated on 2009/02/28
|
||||
*
|
||||
* Modified by Sylvain Le Gall
|
||||
*)
|
||||
open Ocamlbuild_plugin
|
||||
|
||||
(* these functions are not really officially exported *)
|
||||
let run_and_read =
|
||||
Ocamlbuild_pack.My_unix.run_and_read
|
||||
|
||||
let blank_sep_strings =
|
||||
Ocamlbuild_pack.Lexers.blank_sep_strings
|
||||
|
||||
let split s ch =
|
||||
let x =
|
||||
ref []
|
||||
in
|
||||
let rec go s =
|
||||
let pos =
|
||||
String.index s ch
|
||||
in
|
||||
x := (String.before s pos)::!x;
|
||||
go (String.after s (pos + 1))
|
||||
in
|
||||
try
|
||||
go s
|
||||
with Not_found -> !x
|
||||
|
||||
let split_nl s = split s '\n'
|
||||
|
||||
let before_space s =
|
||||
try
|
||||
String.before s (String.index s ' ')
|
||||
with Not_found -> s
|
||||
|
||||
(* this lists all supported packages *)
|
||||
let find_packages () =
|
||||
List.map before_space (split_nl & run_and_read "ocamlfind list")
|
||||
|
||||
(* this is supposed to list available syntaxes, but I don't know how to do it. *)
|
||||
let find_syntaxes () = ["camlp4o"; "camlp4r"]
|
||||
|
||||
(* ocamlfind command *)
|
||||
let ocamlfind x = S[A"ocamlfind"; x]
|
||||
|
||||
let dispatch =
|
||||
function
|
||||
| Before_options ->
|
||||
(* by using Before_options one let command line options have an higher priority *)
|
||||
(* on the contrary using After_options will guarantee to have the higher priority *)
|
||||
(* override default commands by ocamlfind ones *)
|
||||
Options.ocamlc := ocamlfind & A"ocamlc";
|
||||
Options.ocamlopt := ocamlfind & A"ocamlopt";
|
||||
Options.ocamldep := ocamlfind & A"ocamldep";
|
||||
Options.ocamldoc := ocamlfind & A"ocamldoc";
|
||||
Options.ocamlmktop := ocamlfind & A"ocamlmktop"
|
||||
|
||||
| After_rules ->
|
||||
|
||||
(* When one link an OCaml library/binary/package, one should use -linkpkg *)
|
||||
flag ["ocaml"; "link"; "program"] & A"-linkpkg";
|
||||
|
||||
(* For each ocamlfind package one inject the -package option when
|
||||
* compiling, computing dependencies, generating documentation and
|
||||
* linking. *)
|
||||
List.iter
|
||||
begin fun pkg ->
|
||||
flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
end
|
||||
(find_packages ());
|
||||
|
||||
(* Like -package but for extensions syntax. Morover -syntax is useless
|
||||
* when linking. *)
|
||||
List.iter begin fun syntax ->
|
||||
flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
|
||||
flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
|
||||
flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
|
||||
flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
|
||||
end (find_syntaxes ());
|
||||
|
||||
(* The default "thread" tag is not compatible with ocamlfind.
|
||||
* Indeed, the default rules add the "threads.cma" or "threads.cmxa"
|
||||
* options when using this tag. When using the "-linkpkg" option with
|
||||
* ocamlfind, this module will then be added twice on the command line.
|
||||
*
|
||||
* To solve this, one approach is to add the "-thread" option when using
|
||||
* the "threads" package using the previous plugin.
|
||||
*)
|
||||
flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
|
||||
flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]);
|
||||
flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
|
||||
flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
|
||||
|
||||
| _ ->
|
||||
()
|
||||
|
||||
end
|
||||
|
||||
module MyOCamlbuildBase = struct
|
||||
(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
|
||||
|
||||
(** Base functions for writing myocamlbuild.ml
|
||||
@author Sylvain Le Gall
|
||||
*)
|
||||
|
||||
|
||||
|
||||
open Ocamlbuild_plugin
|
||||
module OC = Ocamlbuild_pack.Ocaml_compiler
|
||||
|
||||
type dir = string
|
||||
type file = string
|
||||
type name = string
|
||||
type tag = string
|
||||
|
||||
(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
|
||||
|
||||
type t =
|
||||
{
|
||||
lib_ocaml: (name * dir list) list;
|
||||
lib_c: (name * dir * file list) list;
|
||||
flags: (tag list * (spec OASISExpr.choices)) list;
|
||||
(* Replace the 'dir: include' from _tags by a precise interdepends in
|
||||
* directory.
|
||||
*)
|
||||
includes: (dir * dir list) list;
|
||||
}
|
||||
|
||||
let env_filename =
|
||||
Pathname.basename
|
||||
BaseEnvLight.default_filename
|
||||
|
||||
let dispatch_combine lst =
|
||||
fun e ->
|
||||
List.iter
|
||||
(fun dispatch -> dispatch e)
|
||||
lst
|
||||
|
||||
let tag_libstubs nm =
|
||||
"use_lib"^nm^"_stubs"
|
||||
|
||||
let nm_libstubs nm =
|
||||
nm^"_stubs"
|
||||
|
||||
let dispatch t e =
|
||||
let env =
|
||||
BaseEnvLight.load
|
||||
~filename:env_filename
|
||||
~allow_empty:true
|
||||
()
|
||||
in
|
||||
match e with
|
||||
| Before_options ->
|
||||
let no_trailing_dot s =
|
||||
if String.length s >= 1 && s.[0] = '.' then
|
||||
String.sub s 1 ((String.length s) - 1)
|
||||
else
|
||||
s
|
||||
in
|
||||
List.iter
|
||||
(fun (opt, var) ->
|
||||
try
|
||||
opt := no_trailing_dot (BaseEnvLight.var_get var env)
|
||||
with Not_found ->
|
||||
Printf.eprintf "W: Cannot get variable %s" var)
|
||||
[
|
||||
Options.ext_obj, "ext_obj";
|
||||
Options.ext_lib, "ext_lib";
|
||||
Options.ext_dll, "ext_dll";
|
||||
]
|
||||
|
||||
| After_rules ->
|
||||
(* Declare OCaml libraries *)
|
||||
List.iter
|
||||
(function
|
||||
| nm, [] ->
|
||||
ocaml_lib nm
|
||||
| nm, dir :: tl ->
|
||||
ocaml_lib ~dir:dir (dir^"/"^nm);
|
||||
List.iter
|
||||
(fun dir ->
|
||||
List.iter
|
||||
(fun str ->
|
||||
flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir]))
|
||||
["compile"; "infer_interface"; "doc"])
|
||||
tl)
|
||||
t.lib_ocaml;
|
||||
|
||||
(* Declare directories dependencies, replace "include" in _tags. *)
|
||||
List.iter
|
||||
(fun (dir, include_dirs) ->
|
||||
Pathname.define_context dir include_dirs)
|
||||
t.includes;
|
||||
|
||||
(* Declare C libraries *)
|
||||
List.iter
|
||||
(fun (lib, dir, headers) ->
|
||||
(* Handle C part of library *)
|
||||
flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib]
|
||||
(S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib";
|
||||
A("-l"^(nm_libstubs lib))]);
|
||||
|
||||
flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib]
|
||||
(S[A"-cclib"; A("-l"^(nm_libstubs lib))]);
|
||||
|
||||
flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib]
|
||||
(S[A"-dllib"; A("dll"^(nm_libstubs lib))]);
|
||||
|
||||
(* When ocaml link something that use the C library, then one
|
||||
need that file to be up to date.
|
||||
*)
|
||||
dep ["link"; "ocaml"; "program"; tag_libstubs lib]
|
||||
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
|
||||
|
||||
dep ["compile"; "ocaml"; "program"; tag_libstubs lib]
|
||||
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
|
||||
|
||||
(* TODO: be more specific about what depends on headers *)
|
||||
(* Depends on .h files *)
|
||||
dep ["compile"; "c"]
|
||||
headers;
|
||||
|
||||
(* Setup search path for lib *)
|
||||
flag ["link"; "ocaml"; "use_"^lib]
|
||||
(S[A"-I"; P(dir)]);
|
||||
)
|
||||
t.lib_c;
|
||||
|
||||
(* Add flags *)
|
||||
List.iter
|
||||
(fun (tags, cond_specs) ->
|
||||
let spec =
|
||||
BaseEnvLight.var_choose cond_specs env
|
||||
in
|
||||
flag tags & spec)
|
||||
t.flags
|
||||
| _ ->
|
||||
()
|
||||
|
||||
let dispatch_default t =
|
||||
dispatch_combine
|
||||
[
|
||||
dispatch t;
|
||||
MyOCamlbuildFindlib.dispatch;
|
||||
]
|
||||
|
||||
end
|
||||
|
||||
|
||||
# 476 "myocamlbuild.ml"
|
||||
open Ocamlbuild_plugin;;
|
||||
let package_default =
|
||||
{
|
||||
MyOCamlbuildBase.lib_ocaml =
|
||||
[
|
||||
("containers", []);
|
||||
("containers_thread", []);
|
||||
("containers_lwt", []);
|
||||
("containers_cgi", [])
|
||||
];
|
||||
lib_c = [];
|
||||
flags = [];
|
||||
includes = [];
|
||||
}
|
||||
;;
|
||||
|
||||
let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
|
||||
|
||||
# 496 "myocamlbuild.ml"
|
||||
(* OASIS_STOP *)
|
||||
Ocamlbuild_plugin.dispatch dispatch_default;;
|
||||
63
setup.data
Normal file
63
setup.data
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
ocamlfind="/home/simon/.opam/system/bin/ocamlfind"
|
||||
ocamlc="/usr/bin/ocamlc.opt"
|
||||
ocamlopt="/usr/bin/ocamlopt.opt"
|
||||
ocamlbuild="/usr/bin/ocamlbuild"
|
||||
pkg_name="containers"
|
||||
pkg_version="0.1"
|
||||
os_type="Unix"
|
||||
system="linux"
|
||||
architecture="amd64"
|
||||
ccomp_type="cc"
|
||||
ocaml_version="4.00.1"
|
||||
standard_library_default="/usr/lib/ocaml"
|
||||
standard_library="/usr/lib/ocaml"
|
||||
standard_runtime="/usr/bin/ocamlrun"
|
||||
bytecomp_c_compiler="gcc -fno-defer-pop -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT -fPIC"
|
||||
native_c_compiler="gcc -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT"
|
||||
model="default"
|
||||
ext_obj=".o"
|
||||
ext_asm=".s"
|
||||
ext_lib=".a"
|
||||
ext_dll=".so"
|
||||
default_executable_name="a.out"
|
||||
systhread_supported="true"
|
||||
prefix="/usr/local"
|
||||
exec_prefix="$prefix"
|
||||
bindir="$exec_prefix/bin"
|
||||
sbindir="$exec_prefix/sbin"
|
||||
libexecdir="$exec_prefix/libexec"
|
||||
sysconfdir="$prefix/etc"
|
||||
sharedstatedir="$prefix/com"
|
||||
localstatedir="$prefix/var"
|
||||
libdir="$exec_prefix/lib"
|
||||
datarootdir="$prefix/share"
|
||||
datadir="$datarootdir"
|
||||
infodir="$datarootdir/info"
|
||||
localedir="$datarootdir/locale"
|
||||
mandir="$datarootdir/man"
|
||||
docdir="$datarootdir/doc/$pkg_name"
|
||||
htmldir="$docdir"
|
||||
dvidir="$docdir"
|
||||
pdfdir="$docdir"
|
||||
psdir="$docdir"
|
||||
findlib_version="1.4"
|
||||
is_native="true"
|
||||
suffix_program=""
|
||||
rm="rm -f"
|
||||
rmdir="rm -rf"
|
||||
debug="true"
|
||||
profile="false"
|
||||
native_dynlink="true"
|
||||
ocamlbuildflags=""
|
||||
cgi="false"
|
||||
lwt="false"
|
||||
thread="true"
|
||||
bench="false"
|
||||
docs="true"
|
||||
tests="false"
|
||||
ocaml_version_ge_4_00_1="4.00.1"
|
||||
pkg_unix="/usr/lib/ocaml"
|
||||
pkg_threads="/usr/lib/ocaml"
|
||||
ocamldoc="/usr/bin/ocamldoc"
|
||||
pkg_bench="/home/simon/.opam/system/lib/bench"
|
||||
pkg_ounit="/home/simon/.opam/system/lib/oUnit"
|
||||
341
toWeb.ml
Normal file
341
toWeb.ml
Normal file
|
|
@ -0,0 +1,341 @@
|
|||
|
||||
(*
|
||||
copyright (c) 2013, simon cruanes
|
||||
all rights reserved.
|
||||
|
||||
redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
redistributions of source code must retain the above copyright notice, this
|
||||
list of conditions and the following disclaimer. redistributions in binary
|
||||
form must reproduce the above copyright notice, this list of conditions and the
|
||||
following disclaimer in the documentation and/or other materials provided with
|
||||
the distribution.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
|
||||
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
|
||||
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
|
||||
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
|
||||
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
*)
|
||||
|
||||
(** {1 Expose the State of a Program to the Web}
|
||||
|
||||
We export some values (and associated functions for converting them to
|
||||
html, and update them) as a FastCGI interface.
|
||||
|
||||
This module depends on CamlGI.
|
||||
*)
|
||||
|
||||
(** {2 Some combinators to build HTML documents} *)
|
||||
|
||||
module HTML = struct
|
||||
type t =
|
||||
| Str of string (* content *)
|
||||
| List of t list
|
||||
| Url of url
|
||||
| Img of image
|
||||
| Concat of t list
|
||||
| H of int * t
|
||||
| Link of link
|
||||
| Tag of string * t
|
||||
and url = {
|
||||
url_alt : string option;
|
||||
url_url : string;
|
||||
url_descr : string;
|
||||
}
|
||||
and image = {
|
||||
img_alt : string option;
|
||||
img_url : string;
|
||||
}
|
||||
and link = {
|
||||
link_rel : string;
|
||||
link_url : string;
|
||||
}
|
||||
|
||||
let str s = Str s
|
||||
|
||||
let bprintf format =
|
||||
let buffer = Buffer.create 64 in
|
||||
Printf.kbprintf
|
||||
(fun fmt -> str (Buffer.contents buffer))
|
||||
buffer
|
||||
format
|
||||
|
||||
let bprintf format =
|
||||
let buffer = Buffer.create 64 in
|
||||
Printf.ksprintf
|
||||
str
|
||||
format
|
||||
|
||||
let list l = List l
|
||||
|
||||
let url ?alt ~url ~descr = Url {
|
||||
url_alt = alt;
|
||||
url_url = url;
|
||||
url_descr = descr;
|
||||
}
|
||||
|
||||
let img ?alt url = Img {
|
||||
img_alt = alt;
|
||||
img_url = url;
|
||||
}
|
||||
|
||||
let append a b = Concat [a; b]
|
||||
|
||||
let concat l = Concat l
|
||||
|
||||
let h1 x = H (1, x)
|
||||
|
||||
let h2 x = H (2, x)
|
||||
|
||||
let h3 x = H (3, x)
|
||||
|
||||
let h n x = H (n, x)
|
||||
|
||||
let link ~rel ~url = Link {
|
||||
link_rel = rel;
|
||||
link_url = url;
|
||||
}
|
||||
|
||||
let head x = Tag ("head", x)
|
||||
|
||||
let body x = Tag ("body", x)
|
||||
|
||||
let html x = Tag ("html", x)
|
||||
|
||||
(* XXX UGLY: I copied code from CamlGI because it doesn't provide a way
|
||||
to encode strings with HTML conventions. Bad bad bad. *)
|
||||
module Encode = struct
|
||||
(* Use a table lookup for speed. *)
|
||||
let char_of_hex =
|
||||
let hex = [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9';
|
||||
'A'; 'B'; 'C'; 'D'; 'E'; 'F' |] in
|
||||
fun i -> Array.unsafe_get hex i
|
||||
|
||||
|
||||
let encode_wrt is_special s0 =
|
||||
let len = String.length s0 in
|
||||
let encoded_length = ref len in
|
||||
for i = 0 to len - 1 do
|
||||
if is_special(String.unsafe_get s0 i) then
|
||||
encoded_length := !encoded_length + 2
|
||||
done;
|
||||
let s = String.create !encoded_length in
|
||||
let rec do_enc i0 i = (* copy the encoded string in s *)
|
||||
if i0 < len then begin
|
||||
let s0i0 = String.unsafe_get s0 i0 in
|
||||
if is_special s0i0 then begin
|
||||
let c = Char.code s0i0 in
|
||||
let i1 = succ i in
|
||||
let i2 = succ i1 in
|
||||
String.unsafe_set s i '%';
|
||||
String.unsafe_set s i1 (char_of_hex (c lsr 4));
|
||||
String.unsafe_set s i2 (char_of_hex (c land 0x0F));
|
||||
do_enc (succ i0) (succ i2)
|
||||
end
|
||||
else if s0i0 = ' ' then begin
|
||||
String.unsafe_set s i '+';
|
||||
do_enc (succ i0) (succ i)
|
||||
end
|
||||
else begin
|
||||
String.unsafe_set s i s0i0;
|
||||
do_enc (succ i0) (succ i)
|
||||
end
|
||||
end in
|
||||
do_enc 0 0;
|
||||
s
|
||||
|
||||
|
||||
(* Unreserved characters consist of all alphanumeric chars and the
|
||||
following limited set of punctuation marks and symbols: '-' | '_' |
|
||||
'.' | '!' | '~' | '*' | '\'' | '(' | ')'. According to RFC 2396,
|
||||
they should not be escaped unless the context requires it. *)
|
||||
let special_rfc2396 = function
|
||||
| ';' | '/' | '?' | ':' | '@' | '&' | '=' | '+' | '$' | ',' (* Reserved *)
|
||||
| '\000' .. '\031' | '\127' .. '\255' (* Control chars and non-ASCII *)
|
||||
| '<' | '>' | '#' | '%' | '"' (* delimiters *)
|
||||
| '{' | '}' | '|' | '\\' | '^' | '[' | ']' | '`' (* unwise *)
|
||||
-> true
|
||||
| _ -> false
|
||||
(* ' ' must also be encoded but its encoding '+' takes a single char. *)
|
||||
|
||||
let encode = encode_wrt special_rfc2396
|
||||
end
|
||||
|
||||
(* real rendering is always into a buffer (for now) *)
|
||||
let rec to_buf buf x =
|
||||
match x with
|
||||
| Str s -> Buffer.add_string buf (Encode.encode s)
|
||||
| List l ->
|
||||
Buffer.add_string buf "<ul>";
|
||||
List.iter
|
||||
(fun y -> Printf.bprintf buf "<li>%a</li>" to_buf y)
|
||||
l;
|
||||
Buffer.add_string buf "</ul>"
|
||||
| Url url ->
|
||||
begin match url.url_alt with
|
||||
| None ->
|
||||
Printf.bprintf buf "<a href=\"%s\">%s</a>" url.url_url
|
||||
(Encode.encode url.url_descr)
|
||||
| Some alt ->
|
||||
Printf.bprintf buf "<a href=\"%s\" alt=\"%s\">%s</a>"
|
||||
url.url_url (Encode.encode alt) (Encode.encode url.url_descr)
|
||||
end
|
||||
| Img i -> failwith "img: not implemented"
|
||||
| Concat l -> List.iter (to_buf buf) l
|
||||
| H (n, y) ->
|
||||
Printf.bprintf buf "<h%i> %a </h%i>" n to_buf y n
|
||||
| Link _ -> failwith "link: not implemented"
|
||||
| Tag (str, y) -> Printf.bprintf buf "<%s> %a </%s>" str to_buf y str
|
||||
|
||||
let render x =
|
||||
let buf = Buffer.create 256 in
|
||||
to_buf buf x;
|
||||
Buffer.contents buf
|
||||
|
||||
let to_chan oc x =
|
||||
let buf = Buffer.create 256 in
|
||||
to_buf buf x;
|
||||
Buffer.output_buffer oc buf
|
||||
end
|
||||
|
||||
(** {2 Stateful Object on the Web} *)
|
||||
|
||||
module State = struct
|
||||
type 'a t = {
|
||||
mutable content : 'a;
|
||||
mutable callbacks : ('a -> unit) list;
|
||||
id : ('a -> string) option;
|
||||
export : 'a -> HTML.t;
|
||||
update : (string * string) list -> 'a -> 'a;
|
||||
} (** A value that can be exposed to the Web.
|
||||
The [export] function is used to print the current state of
|
||||
the object into HTML (when requested).
|
||||
The [update] optional function can be used to update
|
||||
the value, given a query with parameters. *)
|
||||
|
||||
type wrap = Wrap : 'a t -> wrap
|
||||
(** Hides the type parameter in a GADT. *)
|
||||
|
||||
let create ?(update=fun _ x -> x) ?id ~export content = {
|
||||
content;
|
||||
export;
|
||||
id;
|
||||
callbacks = [];
|
||||
update;
|
||||
}
|
||||
|
||||
let on_change st f =
|
||||
st.callbacks <- f :: st.callbacks
|
||||
|
||||
let handle_request st req =
|
||||
let cgi = new CamlGI.Cgi.cgi req in
|
||||
(* update value? *)
|
||||
try
|
||||
let x = st.content in
|
||||
let params = cgi#params in
|
||||
(* update [x] using the parameters? *)
|
||||
let y = st.update params x in
|
||||
let changed = match st.id with
|
||||
| None -> x != y
|
||||
| Some id -> id x <> id y
|
||||
in
|
||||
(* notify callbacks that we have a new object *)
|
||||
if changed then
|
||||
List.iter (fun f -> f y) st.callbacks;
|
||||
(* now print [y] *)
|
||||
(* TODO: add a head, declaration, etc. *)
|
||||
let html = st.export y in
|
||||
let final_output = HTML.render html in
|
||||
(* render output *)
|
||||
let template = object
|
||||
method output f = f final_output
|
||||
end in
|
||||
cgi#template template
|
||||
with e ->
|
||||
let msg = Printf.sprintf "error: %s" (Printexc.to_string e) in
|
||||
cgi#log msg
|
||||
end
|
||||
|
||||
(** {2 Routing} *)
|
||||
|
||||
module Router = struct
|
||||
type t = {
|
||||
mutable default : State.wrap;
|
||||
log : out_channel option;
|
||||
tbl : (string, State.wrap) Hashtbl.t;
|
||||
}
|
||||
|
||||
let __default =
|
||||
State.Wrap (State.create ~export:HTML.str "<no default handler>")
|
||||
|
||||
let _log router fmt = match router.log with
|
||||
| None ->
|
||||
Printf.ifprintf stdout fmt
|
||||
| Some oc ->
|
||||
Printf.kfprintf
|
||||
(fun oc ->
|
||||
output_char oc '\n';
|
||||
flush oc)
|
||||
oc
|
||||
fmt
|
||||
|
||||
let create ?(default=__default) ?log () =
|
||||
let router = {
|
||||
default;
|
||||
log;
|
||||
tbl = Hashtbl.create 15;
|
||||
} in
|
||||
_log router "new router created";
|
||||
router
|
||||
|
||||
let default router default =
|
||||
router.default <- default
|
||||
|
||||
let unregister router name =
|
||||
Hashtbl.remove router.tbl name
|
||||
|
||||
let register ?(weak=false) router name state =
|
||||
if Hashtbl.mem router.tbl name
|
||||
then failwith "Router: name already registered"
|
||||
else begin
|
||||
Hashtbl.add router.tbl name state;
|
||||
if weak then match state with
|
||||
| State.Wrap st ->
|
||||
Gc.finalise (fun _ -> unregister router name) st.State.content
|
||||
end
|
||||
|
||||
let add_list router l =
|
||||
List.iter
|
||||
(fun (name, state) -> register router name state)
|
||||
l
|
||||
|
||||
let to_list router =
|
||||
Hashtbl.fold
|
||||
(fun name state acc -> (name,state) :: acc)
|
||||
router.tbl []
|
||||
|
||||
let random_id () =
|
||||
CamlGI.Cgi.random_sessionid ()
|
||||
|
||||
let handle_request router req =
|
||||
let cgi = new CamlGI.Cgi.cgi req in
|
||||
let url = cgi#url () in
|
||||
let st =
|
||||
try
|
||||
let last_part_i = String.rindex url '/' in
|
||||
let last_part = String.sub url (last_part_i+1) (String.length url -last_part_i-1) in
|
||||
_log router "received request for url /%s" last_part;
|
||||
Hashtbl.find router.tbl last_part
|
||||
with Not_found ->
|
||||
router.default
|
||||
in
|
||||
match st with
|
||||
| State.Wrap st -> State.handle_request st req
|
||||
end
|
||||
192
toWeb.mli
Normal file
192
toWeb.mli
Normal file
|
|
@ -0,0 +1,192 @@
|
|||
|
||||
(*
|
||||
copyright (c) 2013, simon cruanes
|
||||
all rights reserved.
|
||||
|
||||
redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
redistributions of source code must retain the above copyright notice, this
|
||||
list of conditions and the following disclaimer. redistributions in binary
|
||||
form must reproduce the above copyright notice, this list of conditions and the
|
||||
following disclaimer in the documentation and/or other materials provided with
|
||||
the distribution.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
|
||||
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
|
||||
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
|
||||
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
|
||||
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
*)
|
||||
|
||||
(** {1 Expose the State of a Program to the Web}
|
||||
|
||||
We export some values (and associated functions for converting them to
|
||||
html, and update them) as a FastCGI interface.
|
||||
|
||||
This module depends on CamlGI.
|
||||
*)
|
||||
|
||||
(** {2 Some combinators to build HTML documents} *)
|
||||
|
||||
module HTML : sig
|
||||
type t
|
||||
(** A html document. Encoding is assumed to be UTF8 for now. *)
|
||||
|
||||
val str : string -> t
|
||||
(** Simple string *)
|
||||
|
||||
val bprintf : ('a, Buffer.t, unit, string) format4 -> t
|
||||
(** Use a buffer printer to render a string. Shortcut for {!str} *)
|
||||
|
||||
val sprintf : ('a, unit, string) format -> t
|
||||
(** Use a string printer to render into a string. Shortcut for {!str} *)
|
||||
|
||||
val list : t list -> t
|
||||
(** Build a list of items *)
|
||||
|
||||
val url : ?alt:string -> url:string -> descr:string -> t
|
||||
(** build an URL tag. *)
|
||||
|
||||
val img : ?alt:string -> string -> t
|
||||
(** Link to an image *)
|
||||
|
||||
val append : t -> t -> t
|
||||
(** Concatenation of two documents *)
|
||||
|
||||
val concat : t list -> t
|
||||
(** Concatenation of html documents *)
|
||||
|
||||
val h1 : t -> t
|
||||
|
||||
val h2 : t -> t
|
||||
|
||||
val h3 : t -> t
|
||||
|
||||
val h : int -> t -> t
|
||||
(** Title of level parametrized by the integer *)
|
||||
|
||||
val link : rel:string -> url:string -> t
|
||||
(** Link (for head) *)
|
||||
|
||||
val head : t -> t
|
||||
(** Head part of a document *)
|
||||
|
||||
val body : t -> t
|
||||
(** Body part of a document *)
|
||||
|
||||
val html : t -> t
|
||||
(** The whole document *)
|
||||
|
||||
val render : t -> string
|
||||
(** Print into a string *)
|
||||
|
||||
val to_buf : Buffer.t -> t -> unit
|
||||
(** Print in the buffer *)
|
||||
|
||||
val to_chan : out_channel -> t -> unit
|
||||
(** Print on the channel *)
|
||||
end
|
||||
|
||||
(** {2 Stateful Object on the Web} *)
|
||||
|
||||
(** This module defines how to bundle an OCaml value (possibly
|
||||
stateful) with functions that export it to HTML,
|
||||
and possibly update it from a CGI request.
|
||||
*)
|
||||
|
||||
module State : sig
|
||||
type 'a t
|
||||
(** A value that can be exposed to the web. *)
|
||||
|
||||
type wrap = Wrap : 'a t -> wrap
|
||||
(** Hides the type parameter in a GADT. Useful for {!Router}. *)
|
||||
|
||||
val create : ?update:((string*string) list -> 'a -> 'a) ->
|
||||
?id:('a -> string) ->
|
||||
export:('a -> HTML.t) ->
|
||||
'a ->
|
||||
'a t
|
||||
(** Create a value that can be exposed to the Web.
|
||||
@param export function used to print the current state of
|
||||
the object into HTML (when requested).
|
||||
@param update optional function that can be used to update
|
||||
the value, given a query with parameters.
|
||||
@param id optional function that maps a value to a (unique)
|
||||
string. Can be used to obtain a unique URL for this value. *)
|
||||
|
||||
val on_change : 'a t -> ('a -> unit) -> unit
|
||||
(** Register a callback that will be called everytime the value
|
||||
is updated. Physical equality is used to determine whether
|
||||
the value changed if no [id] function was provided;
|
||||
otherwise, [id] is used to check whether the old and the new
|
||||
strings are equal. *)
|
||||
|
||||
val handle_request : 'a t -> CamlGI.Cgi.Request.t -> unit
|
||||
(** Handle the incoming request. It replies to the request by
|
||||
possibly updating the local state, and
|
||||
object. *)
|
||||
end
|
||||
|
||||
|
||||
(** {2 Routing} *)
|
||||
|
||||
module Router : sig
|
||||
type t
|
||||
(** An URL router. It dispatches incoming requests to registered
|
||||
{!State.t} values depending on the request's URL. *)
|
||||
|
||||
val create : ?default:State.wrap -> ?log:out_channel -> unit -> t
|
||||
(** New router.
|
||||
@param log a channel on which to log events (incoming requests)
|
||||
@param default a default object to expose, for incorrect routes
|
||||
*)
|
||||
|
||||
val default : t -> State.wrap -> unit
|
||||
(** Set the default handler, for incorrect routes (for which no
|
||||
object is registered) or for routing the root url *)
|
||||
|
||||
val register : ?weak:bool -> t -> string -> State.wrap -> unit
|
||||
(** Register a state object (see {!State}) under a given path.
|
||||
Right now routing only dispatches at one level, there is no
|
||||
tree-like structure, only a flat "directory" of objects.
|
||||
|
||||
@param weak (default false) if true, the object will unregister itself
|
||||
when it's garbage collected. Only works if the type of the wrapped
|
||||
object is heap allocated.
|
||||
|
||||
@raise Failure if the name is already taken
|
||||
@raise Invalid_argument if [weak] is true and no finalizer can be
|
||||
registered. *)
|
||||
|
||||
val unregister : t -> string -> unit
|
||||
(** Remove a stateful value *)
|
||||
|
||||
val add_list : t -> (string * State.wrap) list -> unit
|
||||
(** Register several handlers.
|
||||
@raise Failure if it meets an already registered handler *)
|
||||
|
||||
val to_list : t -> (string * State.wrap) list
|
||||
(** Currently registered objects *)
|
||||
|
||||
val random_id : unit -> string
|
||||
(** Fresh, random ID that can be used for registering temporary objects *)
|
||||
|
||||
val handle_request : t -> CamlGI.Cgi.Request.t -> unit
|
||||
(** Handle the incoming request, by routing to an appropriate
|
||||
object. *)
|
||||
end
|
||||
|
||||
(** {2 Main interface} *)
|
||||
|
||||
val serve_state : ?sockaddr:Unix.sockaddr -> 'a State.t -> unit
|
||||
(** Serve incoming requests using a single object. *)
|
||||
|
||||
val serve_router : ?sockaddr:Unix.sockaddr -> Router.t -> unit
|
||||
(** Shortcut. It calls {!CamlGI.Cgi.register_script} with a callback
|
||||
that forwards requests to the given Router. *)
|
||||
Loading…
Add table
Reference in a new issue