diff --git a/.exrc b/.exrc new file mode 100644 index 0000000..97b700e --- /dev/null +++ b/.exrc @@ -0,0 +1,208 @@ +if &cp | set nocp | endif +let s:cpo_save=&cpo +set cpo&vim +inoremap (neocomplcache_start_omni_complete)  +inoremap (neocomplcache_start_auto_complete_no_select)  +inoremap (neocomplcache_start_auto_complete) =neocomplcache#mappings#popup_post() +inoremap (neocomplcache_start_unite_quick_match) unite#sources#neocomplcache#start_quick_match() +inoremap (neocomplcache_start_unite_complete) unite#sources#neocomplcache#start_complete() +inoremap neocomplcache#smart_close_popup()."\" +noremap  h +nmap  :NERDTreeToggle +noremap j +noremap  k +noremap  l +nmap OD h +nmap OC l +nmap OB j +nmap OA k +vnoremap = :call OcpIndentRange() +map == :call OcpIndentRange() +xmap S VSurround +nmap [xx unimpaired_line_xml_encode +xmap [x unimpaired_xml_encode +nmap [x unimpaired_xml_encode +nmap [uu unimpaired_line_url_encode +xmap [u unimpaired_url_encode +nmap [u unimpaired_url_encode +nmap [yy unimpaired_line_string_encode +xmap [y unimpaired_string_encode +nmap [y unimpaired_string_encode +nmap [p unimpairedPutAbove +nnoremap [ox :set cursorline cursorcolumn +nnoremap [ow :set wrap +nnoremap [os :set spell +nnoremap [or :set relativenumber +nnoremap [on :set number +nnoremap [ol :set list +nnoremap [oi :set ignorecase +nnoremap [oh :set hlsearch +nnoremap [od :diffthis +nnoremap [ou :set cursorcolumn +nnoremap [oc :set cursorline +xmap [e unimpairedMoveUp +nmap [e unimpairedMoveUp +nmap [ unimpairedBlankUp +omap [n unimpairedContextPrevious +nmap [n unimpairedContextPrevious +nmap [o unimpairedOPrevious +nmap [f unimpairedDirectoryPrevious +nmap [T unimpairedTFirst +nmap [t unimpairedTPrevious +nmap [ unimpairedQPFile +nmap [Q unimpairedQFirst +nmap [q unimpairedQPrevious +nmap [ unimpairedLPFile +nmap [L unimpairedLFirst +nmap [l unimpairedLPrevious +nmap [B unimpairedBFirst +nmap [b unimpairedBPrevious +nmap [A unimpairedAFirst +nmap [a unimpairedAPrevious +nnoremap \i :call OcpIndentBuffer() +vnoremap \i :call OcpIndentRange() +vmap \t :call Ocaml_print_type("visual") `< +nmap \t :call Ocaml_print_type("normal") +omap \t :call Ocaml_print_type("normal") +map \S :call OCaml_switch(1) +map \s :call OCaml_switch(0) +nmap \\u CommentaryUndo +nmap \\\ CommentaryLine +nmap \\ Commentary +xmap \\ Commentary +map \bta :!/usr/local/bin/ctags -R . +map \ta :TlistToggle +nmap ]xx unimpaired_line_xml_decode +xmap ]x unimpaired_xml_decode +nmap ]x unimpaired_xml_decode +nmap ]uu unimpaired_line_url_decode +xmap ]u unimpaired_url_decode +nmap ]u unimpaired_url_decode +nmap ]yy unimpaired_line_string_decode +xmap ]y unimpaired_string_decode +nmap ]y unimpaired_string_decode +nmap ]p unimpairedPutBelow +nnoremap ]ox :set nocursorline nocursorcolumn +nnoremap ]ow :set nowrap +nnoremap ]os :set nospell +nnoremap ]or :set norelativenumber +nnoremap ]on :set nonumber +nnoremap ]ol :set nolist +nnoremap ]oi :set noignorecase +nnoremap ]oh :set nohlsearch +nnoremap ]od :diffoff +nnoremap ]ou :set nocursorcolumn +nnoremap ]oc :set nocursorline +xmap ]e unimpairedMoveDown +nmap ]e unimpairedMoveDown +nmap ] unimpairedBlankDown +omap ]n unimpairedContextNext +nmap ]n unimpairedContextNext +nmap ]o unimpairedONext +nmap ]f unimpairedDirectoryNext +nmap ]T unimpairedTLast +nmap ]t unimpairedTNext +nmap ] unimpairedQNFile +nmap ]Q unimpairedQLast +nmap ]q unimpairedQNext +nmap ] unimpairedLNFile +nmap ]L unimpairedLLast +nmap ]l unimpairedLNext +nmap ]B unimpairedBLast +nmap ]b unimpairedBNext +nmap ]A unimpairedALast +nmap ]a unimpairedANext +nnoremap cox :set =&cursorline && &cursorcolumn ? 'nocursorline nocursorcolumn' : 'cursorline cursorcolumn'  +nnoremap cod :=&diff ? 'diffoff' : 'diffthis'  +nmap cs Csurround +nmap ds Dsurround +nmap gx NetrwBrowseX +nmap gcu CommentaryUndo +nmap gcc CommentaryLine +nmap gc Commentary +xmap gc Commentary +xmap gS VgSurround +nmap ySS YSsurround +nmap ySs YSsurround +nmap yss Yssurround +nmap yS YSurround +nmap ys Ysurround +nnoremap NetrwBrowseX :call netrw#NetrwBrowseX(expand(""),0) +nnoremap (vimshell_create) :VimShellCreate +nnoremap (vimshell_switch) :VimShell +xnoremap unimpairedMoveDown :exe 'exe "normal! m`"|''<,''>move''>+'.v:count1 `` +xnoremap unimpairedMoveUp :exe 'exe "normal! m`"|''<,''>move--'.v:count1 `` +nmap unimpairedOPrevious unimpairedDirectoryPrevious:echohl WarningMSG|echo "[o is deprecated. Use [f"|echohl NONE +nmap unimpairedONext unimpairedDirectoryNext:echohl WarningMSG|echo "]o is deprecated. Use ]f"|echohl NONE +nnoremap unimpairedTLast :exe "".(v:count ? v:count : "")."tlast" +nnoremap unimpairedTFirst :exe "".(v:count ? v:count : "")."tfirst" +nnoremap unimpairedTNext :exe "".(v:count ? v:count : "")."tnext" +nnoremap unimpairedTPrevious :exe "".(v:count ? v:count : "")."tprevious" +nnoremap unimpairedQNFile :exe "".(v:count ? v:count : "")."cnfile" +nnoremap unimpairedQPFile :exe "".(v:count ? v:count : "")."cpfile" +nnoremap unimpairedQLast :exe "".(v:count ? v:count : "")."clast" +nnoremap unimpairedQFirst :exe "".(v:count ? v:count : "")."cfirst" +nnoremap unimpairedQNext :exe "".(v:count ? v:count : "")."cnext" +nnoremap unimpairedQPrevious :exe "".(v:count ? v:count : "")."cprevious" +nnoremap unimpairedLNFile :exe "".(v:count ? v:count : "")."lnfile" +nnoremap unimpairedLPFile :exe "".(v:count ? v:count : "")."lpfile" +nnoremap unimpairedLLast :exe "".(v:count ? v:count : "")."llast" +nnoremap unimpairedLFirst :exe "".(v:count ? v:count : "")."lfirst" +nnoremap unimpairedLNext :exe "".(v:count ? v:count : "")."lnext" +nnoremap unimpairedLPrevious :exe "".(v:count ? v:count : "")."lprevious" +nnoremap unimpairedBLast :exe "".(v:count ? v:count : "")."blast" +nnoremap unimpairedBFirst :exe "".(v:count ? v:count : "")."bfirst" +nnoremap unimpairedBNext :exe "".(v:count ? v:count : "")."bnext" +nnoremap unimpairedBPrevious :exe "".(v:count ? v:count : "")."bprevious" +nnoremap unimpairedALast :exe "".(v:count ? v:count : "")."last" +nnoremap unimpairedAFirst :exe "".(v:count ? v:count : "")."first" +nnoremap unimpairedANext :exe "".(v:count ? v:count : "")."next" +nnoremap unimpairedAPrevious :exe "".(v:count ? v:count : "")."previous" +nnoremap SurroundRepeat . +nnoremap :call UpdateTags() +inoremap  neocomplcache#cancel_popup() +imap S ISurround +imap s Isurround +inoremap  neocomplcache#undo_completion() +inoremap  neocomplcache#smart_close_popup()."\" +inoremap  pumvisible() ? "\" : "\ " +inoremap  neocomplcache#complete_common_string() +imap  Isurround +inoremap  neocomplcache#close_popup() +imap OD hi +imap OC li +imap OB ji +imap OA ki +let &cpo=s:cpo_save +unlet s:cpo_save +set autoindent +set autoread +set backspace=2 +set completefunc=neocomplcache#complete#manual_complete +set completeopt=menuone +set noequalalways +set expandtab +set fileencodings=ucs-bom,utf-8,default,latin1 +set helplang=en +set history=50 +set hlsearch +set ignorecase +set incsearch +set laststatus=2 +set omnifunc=merlin#Complete +set printoptions=paper:a4 +set ruler +set runtimepath=~/.vim/bundle/vundle,~/.vim/bundle/vim-pathogen,~/.vim/bundle/vim-colors-solarized,~/.vim/bundle/vim-fugitive,~/.vim/bundle/nerdtree,~/.vim/bundle/vim-surround,~/.vim/bundle/tabular,~/.vim/bundle/vim-unimpaired,~/.vim/bundle/vim-endwise,~/.vim/bundle/syntastic,~/.vim/bundle/gist-vim,~/.vim/bundle/grep.vim,~/.vim/bundle/vim-commentary,~/.vim/bundle/minibufexpl.vim,~/.vim/bundle/OmniCppComplete,~/.vim/bundle/c.vim,~/.vim/bundle/vim-diff,~/.vim/bundle/detectindent,~/.vim/bundle/vimshell.vim,~/.vim/bundle/neocomplcache,~/.vim,/var/lib/vim/addons,/usr/share/vim/vimfiles,/usr/share/vim/vim73,/usr/share/vim/vimfiles/after,/var/lib/vim/addons/after,~/.vim/after,~/.vim/bundle/vundle/,~/.vim/bundle/vundle/after,~/.vim/bundle/vim-pathogen/after,~/.vim/bundle/vim-colors-solarized/after,~/.vim/bundle/vim-fugitive/after,~/.vim/bundle/nerdtree/after,~/.vim/bundle/vim-surround/after,~/.vim/bundle/tabular/after,~/.vim/bundle/vim-unimpaired/after,~/.vim/bundle/vim-endwise/after,~/.vim/bundle/syntastic/after,~/.vim/bundle/gist-vim/after,~/.vim/bundle/grep.vim/after,~/.vim/bundle/vim-commentary/after,~/.vim/bundle/minibufexpl.vim/after,~/.vim/bundle/OmniCppComplete/after,~/.vim/bundle/c.vim/after,~/.vim/bundle/vim-diff/after,~/.vim/bundle/detectindent/after,~/.vim/bundle/vimshell.vim/after,~/.vim/bundle/neocomplcache/after,~/.opam/4.00.1/share/ocamlmerlin/vim,~/.opam/4.00.1/share/ocamlmerlin/vimbufsync +set shiftwidth=2 +set smartcase +set smarttab +set softtabstop=2 +set statusline=\ %{HasPaste()}%<%-15.25(%f%)%m%r%h\ %w\ \ \ \ \ [%{&ff}/%Y]\ \ \ %<%20.30(%{hostname()}:%{CurDir()}%)\ %=%-10.(%l,%c%V%)\ %p%%/%L +set suffixes=.bak,~,.swp,.o,.info,.aux,.log,.dvi,.bbl,.blg,.brf,.cb,.ind,.idx,.ilg,.inx,.out,.toc +set textwidth=80 +set timeoutlen=500 +set title +set titlestring=%F\ -\ Vim +set updatetime=1500 +set wildignore=*.o,*.class,*.pdf,*._aux,*.aux,*.bbl,*.big,*.brf,*.blg,*.dvi,*.div,*.ilg,*.lof,*.log,*._log,*.nlo,*.nls,*.out,*.ps,*.tdo,*.tex.project.vim,*.toc +" vim: set ft=vim : diff --git a/.merlin b/.merlin new file mode 100644 index 0000000..7314802 --- /dev/null +++ b/.merlin @@ -0,0 +1,5 @@ +PKG lwt mirage mirage-net cstruct ipaddr +S ./lib +S ./controller +S ./switch +B _build/lib diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 0000000..6932fe1 --- /dev/null +++ b/.ocp-indent @@ -0,0 +1 @@ +syntax = lwt diff --git a/Makefile b/Makefile index f292318..d6399bb 100644 --- a/Makefile +++ b/Makefile @@ -4,45 +4,58 @@ all: build NAME=openflow J=4 -LWT ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-lwt; fi) -MIRAGE ?= $(shell if ocamlfind query mirage-net >/dev/null 2>&1; then echo --enable-mirage; fi) -ifeq ($(MIRAGE_OS),xen) -XEN ?= --enable-xen -endif +UNIX ?= $(shell if [ $(MIRAGE_OS) = "unix" ]; then echo --enable-unix; else echo --disable-unix; fi) +DIRECT ?= $(shell if [ $(MIRAGE_NET) = "direct" ]; then echo --enable-direct; else echo --disable-direct; fi) +XEN ?= $(shell if [ $(MIRAGE_OS) = "xen" ]; then echo --enable-xen; else echo --disable-xen; fi) +caml_path ?= $(shell ocamlfind printconf path) + +# MIRAGE = --enable-mirage -include Makefile.config -clean: setup.data - ./setup.bin -clean $(OFLAGS) - rm -f setup.data setup.log setup.bin +setup.ml: _oasis + oasis setup + +setup.data: setup.ml + ocaml setup.ml -configure $(UNIX) $(XEN) $(DIRECT) + +clean: setup.data + ocaml setup.ml -clean $(OFLAGS) + rm -f setup.data setup.log setup.ml -distclean: setup.data - ./setup.bin -distclean $(OFLAGS) - rm -f setup.data setup.log setup.bin +distclean: setup.ml setup.data + ocaml setup.ml -distclean $(OFLAGS) + rm -f setup.data setup.log setup.ml setup: setup.data build: setup.data $(wildcard lib/*.ml) - ./setup.bin -build -j $(J) $(OFLAGS) - -doc: setup.data setup.bin - ./setup.bin -doc -j $(J) $(OFLAGS) + ocaml setup.ml -build -cflags -bin-annot -j $(J) $(OFLAGS) $(DR) +ifeq ($(MIRAGE_OS), xen) + ld -d -nostdlib -m elf_x86_64 -T $(caml_path)/mirage-xen/mirage-x86_64.lds \ + $(caml_path)/mirage-xen/x86_64.o _build/switch/xen_switch.nobj.o \ + $(caml_path)/mirage-xen/libocaml.a $(caml_path)/mirage-xen/libxen.a \ + $(caml_path)/mirage-xen/libxencaml.a $(caml_path)/mirage-xen/libdiet.a \ + $(caml_path)/mirage-xen/libm.a $(caml_path)/mirage-xen/longjmp.o \ + -o ofswitch.xen + + ld -d -nostdlib -m elf_x86_64 -T $(caml_path)/mirage-xen/mirage-x86_64.lds \ + $(caml_path)/mirage-xen/x86_64.o _build/controller/xen_controller.nobj.o \ + $(caml_path)/mirage-xen/libocaml.a $(caml_path)/mirage-xen/libxen.a \ + $(caml_path)/mirage-xen/libxencaml.a $(caml_path)/mirage-xen/libdiet.a \ + $(caml_path)/mirage-xen/libm.a $(caml_path)/mirage-xen/longjmp.o \ + -o ofcontroller.xen + +endif + +doc: setup.data setup.ml + ocaml setup.ml -doc -j $(J) $(OFLAGS) install: ocamlfind remove $(NAME) - ./setup.bin -install $(OFLAGS) + ocaml setup.ml -install $(OFLAGS) test: build - ./setup.bin -test - -## + ocaml setup.ml -test -setup.bin: setup.ml - ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< - rm -f setup.cmx setup.cmi setup.o setup.cmo - -setup.ml: _oasis - oasis setup -setup.data: setup.bin - ./setup.bin -configure $(LWT) $(MIRAGE) $(XEN) --enable-tests diff --git a/Makefile.config b/Makefile.config deleted file mode 100644 index a4cb71f..0000000 --- a/Makefile.config +++ /dev/null @@ -1 +0,0 @@ -OFLAGS ?= -classic-display diff --git a/README.md b/README.md index 2396251..4a8f352 100644 --- a/README.md +++ b/README.md @@ -13,17 +13,19 @@ switches in a network. Each OpenFlow switch has three parts: Following this standard model, the implementation comprises three parts: -+ `switch.ml`, containing a skeleton OpenFlow switch; -+ `controller.ml`, containing a skeleton OpenFlow controller; and -+ `ofpacket.ml`, containing `Bitstring` parsers/writers for the - OpenFlow protocol. +* `Openflow` library, contains a complete parsing library in pure Ocaml and a + minimal controller library using an event-driven model. +* `Openflow.switch` library, provides a skeleton OpenFlow switch supporting most + elementary switch functionality. +* `Openflow.flv` library, implements a basic FLowVisor reimplementation in + ocaml. __N.B.__ _There are two versions of the OpenFlow protocol: v1.0.0 (`0x01` on the wire) and v1.1.0 (`0x02` on the wire). The implementation supports wire protocol `0x01` as this is what is implemented in [Open vSwitch][ovs-1.2], used for debugging._ -ofpacket.ml +Openflow.Ofpacket ----------- The file begins with some utility functions, operators, types. The @@ -116,7 +118,16 @@ the request and response messages that transport them. [of-1.1]: http://www.openflow.org/documents/openflow-spec-v1.1.0.pdf [ovs-1.2]: http://openvswitch.org/releases/openvswitch-1.2.2.tar.gz -controller.ml +Openflow.Ofsocket +------------- + +A simple module to create an openflow channel abstraction over a serires of +different transport mechanisms. At the moment the library contains support of +Channel.t connections and Lwt_stream streams. The protocol ensures to read from +the socket full Openflow pdus and transform them to appropriate Ofpacket +structures. + +Openflow.Ofontroller ------------- Initially modelled after [NOX][], this is a skeleton controller @@ -131,43 +142,51 @@ corresponding to basic switch operation: + `PACKET_IN`, representing the forwarding of a packet to the controller, whether through an explicit action corresponding to a flow match, or simply as the default when flow match is found. - ++ `FLOW_REMOVED`, i.e., representing the switch notification regarding the + removal of a flow from the flow table. ++ `FLOW_STATS_REPLY`, i.e., represents the replies transmitted by the switch + after a flow_stats_req. ++ `AGGR_FLOW_STATS_REPLY`, i.e., representing the reply transmitted by the switch +to an aggr_flow_stats_req. ++ ` DESC_STATS_REPLY`, i.e., representing the reply of a switch to desc_stats + request. ++ `PORT_STATS_REPLY`, i.e., representing the replt of a switch to a port_stats + request providing port level counter and the state of the switch. ++ `TABLE_STATS_REPLY`, i.e., representing the reply of a switch to a + table_stats request. ++ `PORT_STATUS_REPLY`, i.e., representing the notification send by the switch + when the state of a port of the switch is changed. + The controller state is mutable and modelled as: + A list of callbacks per event, each taking the current state, the originating datapath, and the event; + Mappings from switch (`datapath_id`) to a Mirage communications channel (`Channel.t`); and -+ Mappings from channel (`endhost` comprising an IPv4 address and - port) tp datapath (`datapath_id`). The main work of the controller is carried out in `process_of_packet` which processes each received packet within the context given by the current state of the switch: this is where the OpenFlow state machine is implemented. -The controller entry point is via the `listen` function which -effectively creates a receiving channel to parse OpenFlow packets, and -pass them to `process_of_packet` which handles a range of standard -protocol-level interactions, e.g., `ECHO_REQ`, `FEATURES_RESP`, -generating Mirage events as appropriate. Specifically, `controller` -is passed as callback to `Channel.listen`, and recursively evaluates -`echo` to read the incoming packet and pass it to -`process_of_packet`. +The controller entry point is via the `listen`, `local_connect` or `connect` +function which effectively creates a receiving channel to parse OpenFlow +packets, and pass them to `process_of_packet` which handles a range of standard +protocol-level interactions, e.g., `ECHO_REQ`, `FEATURES_RESP`, generating +Mirage events as appropriate. Specifically, `controller` is passed as callback +to the respective connection method, and recursively evaluates `read_packet` to +read the incoming packet and pass it to `process_of_packet`. [nox]: http://noxrepo.org/ -switch.ml +Openflow.Switch.Ofswitch --------- -__N.B.__ _This is unwritten as yet, awaiting the new device model being -applied to the network stack._ - -An OpenFlow _switch_ or _datapath_ consists of one or more _flow tables_, a -_group table_ (in later versions, not supported in v1.0.0), and a _secure -channel_ back to the controller. Communication over the channel is via the -OpenFlow protocol, and is how the controller manages the switch. +An OpenFlow _switch_ or _datapath_ consists of a _flow table_, a _group table_ +(in later versions, not supported in v1.0.0), and a _channel_ back to the +controller. Communication over the channel is via the OpenFlow protocol, and is +how the controller manages the switch. In short, each table contains flow entries consisting of _match fields_, _counters_, and _instructions_ to apply to packets. Starting with the first @@ -176,13 +195,14 @@ and the instructions carried out. If no entry in the first table matches, (part of) the packet is forwarded to the controller, or it is dropped, or it proceeds to the next flow table. +At the current point the switch doesn't support any queue principles. + Skeleton code is as follows: ### Entry Represents a single flow table entry. Each entry consists of: -+ _fields_, against which to match (`Ofpacket.Match.t list`);; + _counters_, to keep statistics per-table, -flow, -port, -queue (`Entry.table_counter list`, `Entry.flow_counter list`, `Entry.port_counter list`, `Entry.queue_counter list`); and @@ -191,7 +211,9 @@ Represents a single flow table entry. Each entry consists of: ### Table A simple module representing a table of flow entries. Currently just an id -(`tid`) and a list of entries (`Entry.t list`). +(`tid`) , a hashtbl of entries (`(OP.Match.t, Entry.t) Hashtbl.t`), a list of +exact match entries to reduce the lookup time for wildcard entries and a the +table counter. ### Switch diff --git a/USAGE.md b/USAGE.md new file mode 100644 index 0000000..f293d82 --- /dev/null +++ b/USAGE.md @@ -0,0 +1,83 @@ +API +=== + +The source code contains 3 main libraries: Openflow, Openflow.Switch and +Openflow.Flv. + +The Openflow module contains all the code to parse, print and generate openflow +messages, as well as, a basic openflow control platform. The ofcontroller +implements an openflow controller library. The library is event driven. The +programmer can access any openflow message by registering event callback during +the init phase of the code for every connected switch. The parsing uses cstruct.t objects. + +The Openflow.Switch module implements an openflow switch. The module exposes a simple API through +which a user can add and remove ports to the controller and run the default openflow +processing switch functionality. In addition, the module contains an +out-of-channel mechanism to modify the state of the switch using a json-rpc +mechanism and insert, delete and view flow entries or enable or disable network +ports. Finally, the switch provides a standalone mode, when the controller +becomes unavailable, using a local learning switch logic, implemented in module +Openflow.Switch.Ofswitch_standalone. Standalone functionality can be initiated +through the Ofswitch.standalone_connect method. + +Additionally the library contains a small number of helper functions that enhance the +functionality of openflow application. Ofswitch_config is a daemon that exposes a json +API through which other apps can have configure the ports of the switch and access the +content of the datapath table, using a simple tcp socket. Ofswitch_standalone is a minimum +learning switch implementation over openflow that can be enabled on the switch module when +no controller is accessible. + +The Openflow.Flv library reimplements the functionality provided by the flowvisor +switch virtualisation software. FLowvisor is able to aggregate multiple switches +and expose them to controller as a single switch, aggregating all the ports of +the switches. The module provides elementary slicing +functionality using wildcards. Additionally, the module implements a simple +switch topology discovery mechanism using the lldp protocol. The functionality +of this module is currently experimental and the library is not fully +functional (e.g. OP.Port.Flood output actions are not supported by the module ). + +Programs +======= + +The source code of the library contains a number of small appliances that provide simple +examples over the functionality of the library. + +lwt_switch +================ + +This is a unix backend implementation of an openflow switch. The application exposes both +the json config web service and uses the standalone embedded controller. The application +tries to connect to locahost in order to connect to controller and also run the json-based +configuration daemon on port 6634. + +lwt_controller +========== + +An openflow controller that implements a simple openflow-based learning switch. +The program listens on port 6633. + +ofswitch_ctrl +============ + +This is a simple implementation of a configuration client for the switch code. +The application has a lot of similarities with the syntax of the ovs-vsctl code. +Users can access and modify the state of the switch with the following command +line parameters: + +* dump-flows intf tupple: this command will match all flows on the forwardign + table of the switch and return a dump of the matching flows to the + provided tupple. +* del-flows intf tupple: delete matching flows. +* add-flows intf tupple: adding a tupple to the flow table. +* add-port intf network_device : adding a port under the control of the openflow switch. +* del-port intf network_device : remove a port from the control of the switch. + +ofswitch.xen +=============== + +A unikernel appliance of the lwt_switch for the xen backend. + +ofcontroller.xen +============== + +A unikernel application of the lwt_controller for the xen backend. diff --git a/_oasis b/_oasis index 891f5c6..d3280b5 100644 --- a/_oasis +++ b/_oasis @@ -1,96 +1,99 @@ OASISFormat: 0.3 -OCamlVersion: >= 3.12 +OCamlVersion: >= 4.00.1 Name: openflow Version: 0.3.0 Authors: Charalampos Rotsos, Richard Mortier, Anil Madhavappedy, Balraj Singh License: ISC -Synopsis: OpenFlow protocol and switch implementations in pure OCaml -Plugins: META (0.2) +Synopsis: OpenFlow controller, switch and flowvisor implementation in pure OCaml +Plugins: META (0.3) BuildTools: ocamlbuild -Flag lwt - Description: build the Lwt library +Flag direct + Description: build things over the direct xen net Default: false -Flag xen - Description: build the Xen tests - Default: false - -Flag mirage - Description: build the Mirage library +Flag unix + Description: build programs with a depency on lwt.unix Default: false -Flag nettests - Description: run the internet-using tests +Flag xen + Description: build xen applications Default: false - Library openflow Path: lib Findlibname: openflow - Modules: Ofpacket, Ofcontroller, Ofswitch + CompiledObject: native + Modules: Ofpacket, Ofcontroller, Ofsocket Pack: True - BuildDepends: cstruct, cstruct.syntax, mirage, mirage-net (>= 0.4.0) + BuildDepends: ipaddr, cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0) Document openflow Title: OpenFlow docs Type: ocamlbuild (0.2) BuildTools+: ocamldoc XOCamlbuildPath: lib - XOCamlbuildModules: Ofpacket, Ofcontroller, Ofswitch - -Executable learning_switch_lwt - Path: controller - MainIs: learning_switch.ml - Build$: flag(lwt) - Custom: true - CompiledObject: best - Install: false - BuildDepends: cstruct, cstruct.syntax, openflow + XOCamlbuildModules: Ofpacket, Ofcontroller, Ofsocket -Executable basic_switch_lwt - Path: switch - MainIs: basic_switch.ml - Build$: flag(lwt) - Custom: true - CompiledObject: best - Install: false - BuildDepends: openflow +Library flv + Path: lib + Findlibname: flv + Findlibparent: openflow + CompiledObject: native + Modules: Flowvisor, Lldp, Flowvisor_topology + Pack: True -Executable learning_switch_mirage_unix - Path: controller - MainIs: learning_switch.ml - Build$: flag(mirage) - Custom: true +Library switch + Path: lib + Findlibname: switch + Findlibparent: openflow + Build$: flag(direct) + Install$: flag(direct) CompiledObject: native - Install: false - BuildDepends: cstruct, cstruct.syntax, openflow + Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone + Pack: True + BuildDepends: re.str, tuntap -Executable basic_switch_mirage_unix - Path: switch - MainIs: basic_switch.ml - Build$: flag(mirage) - Custom: true +Library switch_model + Path: lib + Findlibname: switch_model + Findlibparent: openflow + Build$: flag(direct) + Install$: flag(direct) CompiledObject: native - Install: false - BuildDepends: openflow + Modules: Ofswitch_model + Pack: True + BuildDepends: re.str, tuntap -Executable learning_switch_mirage +Executable ofcontroller_lwt Path: controller - MainIs: learning_switch.ml - Build$: flag(mirage) && flag(xen) + MainIs: lwt_controller.ml + Build: false Custom: true CompiledObject: native - Target: xen - Install: false - BuildDepends: cstruct, cstruct.syntax, openflow + Install$: flag(unix) + BuildDepends: openflow,tuntap -Executable basic_switch_mirage +Executable ofswitch_lwt Path: switch - MainIs: basic_switch.ml - Build$: flag(mirage) && flag(xen) + MainIs: lwt_switch.ml Custom: true + Build: false CompiledObject: native - Target: xen + BuildDepends: openflow, openflow.switch,tuntap + +Executable ofswitch + Path: switch + MainIs: xen_switch.ml + Build$: flag(xen) + CompiledObject: native_object + Install: false + BuildDepends: openflow, re.str + +Executable ofcontroller + Path: controller + MainIs: xen_controller.ml + Build$: flag(xen) + CompiledObject: native_object Install: false - BuildDepends: openflow + BuildDepends: openflow, re.str diff --git a/_tags b/_tags index aefb461..1025e80 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: e6423545a758a97078de25025cc8648e) +# DO NOT EDIT (digest: 2e93c3b498a48aeea27e4bda67fc628e) # 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 @@ -17,51 +17,94 @@ "lib/openflow.cmxs": use_openflow "lib/ofpacket.cmx": for-pack(Openflow) "lib/ofcontroller.cmx": for-pack(Openflow) -"lib/ofswitch.cmx": for-pack(Openflow) +"lib/ofsocket.cmx": for-pack(Openflow) +: pkg_ipaddr : pkg_cstruct : pkg_cstruct.syntax +: pkg_rpclib +: pkg_rpclib.json : pkg_mirage : pkg_mirage-net -# Executable learning_switch_lwt -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_mirage -: pkg_mirage-net -: custom -# Executable basic_switch_lwt -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_mirage -: pkg_mirage-net -: custom -# Executable learning_switch_mirage_unix -# Executable basic_switch_mirage_unix -# Executable learning_switch_mirage -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_mirage -: pkg_mirage-net -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_mirage -: pkg_mirage-net -: custom -# Executable basic_switch_mirage -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_mirage -: pkg_mirage-net +# Library flv +"lib/flv.cmxs": use_flv +"lib/flowvisor.cmx": for-pack(Flv) +"lib/lldp.cmx": for-pack(Flv) +"lib/flowvisor_topology.cmx": for-pack(Flv) +# Library switch +"lib/switch.cmxs": use_switch +"lib/ofswitch.cmx": for-pack(Switch) +"lib/ofswitch_config.cmx": for-pack(Switch) +"lib/ofswitch_standalone.cmx": for-pack(Switch) +# Library switch_model +"lib/switch_model.cmxs": use_switch_model +"lib/ofswitch_model.cmx": for-pack(Switch_model) +: pkg_re.str +: pkg_tuntap +# Executable ofcontroller_lwt +"controller/lwt_controller.native": use_openflow +"controller/lwt_controller.native": pkg_tuntap +"controller/lwt_controller.native": pkg_ipaddr +"controller/lwt_controller.native": pkg_cstruct +"controller/lwt_controller.native": pkg_cstruct.syntax +"controller/lwt_controller.native": pkg_rpclib +"controller/lwt_controller.native": pkg_rpclib.json +"controller/lwt_controller.native": pkg_mirage +"controller/lwt_controller.native": pkg_mirage-net +: pkg_tuntap +"controller/lwt_controller.native": custom +# Executable ofswitch_lwt +"switch/lwt_switch.native": use_openflow +"switch/lwt_switch.native": use_switch +"switch/lwt_switch.native": pkg_re.str +"switch/lwt_switch.native": pkg_tuntap +"switch/lwt_switch.native": pkg_ipaddr +"switch/lwt_switch.native": pkg_cstruct +"switch/lwt_switch.native": pkg_cstruct.syntax +"switch/lwt_switch.native": pkg_rpclib +"switch/lwt_switch.native": pkg_rpclib.json +"switch/lwt_switch.native": pkg_mirage +"switch/lwt_switch.native": pkg_mirage-net +: use_switch +: pkg_tuntap +"switch/lwt_switch.native": custom +# Executable ofswitch +"switch/xen_switch.nobj.o": use_openflow +"switch/xen_switch.nobj.o": pkg_re.str +"switch/xen_switch.nobj.o": pkg_ipaddr +"switch/xen_switch.nobj.o": pkg_cstruct +"switch/xen_switch.nobj.o": pkg_cstruct.syntax +"switch/xen_switch.nobj.o": pkg_rpclib +"switch/xen_switch.nobj.o": pkg_rpclib.json +"switch/xen_switch.nobj.o": pkg_mirage +"switch/xen_switch.nobj.o": pkg_mirage-net : use_openflow +: pkg_re.str +: pkg_ipaddr : pkg_cstruct : pkg_cstruct.syntax +: pkg_rpclib +: pkg_rpclib.json : pkg_mirage : pkg_mirage-net -: custom +# Executable ofcontroller +"controller/xen_controller.nobj.o": use_openflow +"controller/xen_controller.nobj.o": pkg_re.str +"controller/xen_controller.nobj.o": pkg_ipaddr +"controller/xen_controller.nobj.o": pkg_cstruct +"controller/xen_controller.nobj.o": pkg_cstruct.syntax +"controller/xen_controller.nobj.o": pkg_rpclib +"controller/xen_controller.nobj.o": pkg_rpclib.json +"controller/xen_controller.nobj.o": pkg_mirage +"controller/xen_controller.nobj.o": pkg_mirage-net +: use_openflow +: pkg_re.str +: pkg_ipaddr +: pkg_cstruct +: pkg_cstruct.syntax +: pkg_rpclib +: pkg_rpclib.json +: pkg_mirage +: pkg_mirage-net # OASIS_STOP true: annot : syntax_camlp4o @@ -72,3 +115,4 @@ true: annot : pkg_lwt.syntax : syntax_camlp4o : pkg_lwt.syntax +true: bin_annot diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index 4af60d7..d7cf5da 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -16,7 +16,6 @@ (* Simple openflow controller that listens on port 6633 and replies with echo request on every packet_in event *) - open Lwt open Printf open Net @@ -24,55 +23,44 @@ open Net.Nettypes let resolve t = Lwt.on_success t (fun _ -> ()) -module OP = Ofpacket -module OC = Ofcontroller -module OE = Ofcontroller.Event +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event let pp = Printf.printf let sp = Printf.sprintf -(* TODO this the mapping is incorrect. the datapath must be moved to the key - * of the hashtbl *) type mac_switch = { - addr: OP.eaddr; + addr: Macaddr.t; switch: OP.datapath_id; } type switch_state = { -(* mutable mac_cache: (mac_switch, OP.Port.t) Hashtbl.t; *) - mutable mac_cache: (OP.eaddr, OP.Port.t) Hashtbl.t; - mutable dpid: OP.datapath_id list; - mutable of_ctrl: OC.t list; + mutable mac_cache: (Macaddr.t, OP.Port.t) Hashtbl.t; req_count: int ref; } let switch_data = - { mac_cache = Hashtbl.create 0;dpid = []; - of_ctrl = []; req_count=(ref 0);} + { mac_cache = Hashtbl.create 2048; (* dpid = []; + of_ctrl = []; *) req_count=(ref 0);} let datapath_join_cb controller dpid evt = let dp = match evt with - | OE.Datapath_join (c) -> c + | OE.Datapath_join (c, _) -> c | _ -> invalid_arg "bogus datapath_join event match!" in - switch_data.dpid <- switch_data.dpid @ [dp]; +(* switch_data.dpid <- switch_data.dpid @ [dp]; *) return (pp "+ datapath:0x%012Lx\n" dp) let req_count = (ref 0) -let add_entry_in_hashtbl mac_cache ix in_port = - if not (Hashtbl.mem mac_cache ix ) then - Hashtbl.add mac_cache ix in_port - else - Hashtbl.replace mac_cache ix in_port - let packet_in_cb controller dpid evt = incr switch_data.req_count; let (in_port, buffer_id, data, dp) = match evt with - | OE.Packet_in (inp, buf, dat, dp) -> (inp, buf, dat, dp) + | OE.Packet_in (inp, _, buf, dat, dp) -> (inp, buf, dat, dp) | _ -> invalid_arg "bogus datapath_join event match!" in (* Parse Ethernet header *) @@ -84,9 +72,8 @@ let packet_in_cb controller dpid evt = (* check if I know the output port in order to define what type of message * we need to send *) - let broadcast = String.make 6 '\255' in let ix = m.OP.Match.dl_dst in - if ( (ix = broadcast) + if ( (ix = Macaddr.broadcast) || (not (Hashtbl.mem switch_data.mac_cache ix)) ) then ( let bs = @@ -95,7 +82,7 @@ let packet_in_cb controller dpid evt = (OP.Packet_out.create ~buffer_id:buffer_id ~actions:[ OP.(Flow.Output(Port.All , 2000))] - ~data:data ~in_port:in_port () )) (OS.Io_page.get ()) in + ~data:data ~in_port:in_port () )) (Cstruct.of_bigarray (OS.Io_page.get 1)) in OC.send_of_data controller dpid bs ) else ( let out_port = (Hashtbl.find switch_data.mac_cache ix) in @@ -109,7 +96,8 @@ let packet_in_cb controller dpid evt = (OP.Packet_out.create ~buffer_id:buffer_id ~actions:[ OP.(Flow.Output(out_port, 2000))] - ~data:data ~in_port:in_port () )) (OS.Io_page.get ()) in + ~data:data ~in_port:in_port () )) + (Cstruct.of_bigarray (OS.Io_page.get 1)) in OC.send_of_data controller dpid bs else return () @@ -120,13 +108,11 @@ let packet_in_cb controller dpid evt = (OP.Flow_mod.create m 0_L OP.Flow_mod.ADD ~hard_timeout:0 ~idle_timeout:0 ~buffer_id:(Int32.to_int buffer_id) ~flags [OP.Flow.Output(out_port, 2000)] ())) - (OS.Io_page.get ()) in + (Cstruct.of_bigarray (OS.Io_page.get 1)) in OC.send_of_data controller dpid pkt ) let init controller = - if (not (List.mem controller switch_data.of_ctrl)) then - switch_data.of_ctrl <- (([controller] @ switch_data.of_ctrl)); pp "test controller register datapath cb\n"; OC.register_cb controller OE.DATAPATH_JOIN datapath_join_cb; pp "test controller register packet_in cb\n"; @@ -137,13 +123,10 @@ let port = 6633 let run () = Net.Manager.create (fun mgr interface id -> try_lwt - let ip = - (ipv4_addr_of_tuple (10l,0l,0l,3l), - ipv4_addr_of_tuple (255l,255l,255l,0l), []) in + let ip = Ipaddr.V4.(make 10l 20l 0l 4l, Prefix.mask 24, []) in lwt _ = Manager.configure interface (`IPv4 ip) in - OC.listen mgr (None, port) init + OC.listen mgr ~verbose:true (None, port) init with | e -> return (Printf.eprintf "Unexpected exception : %s" (Printexc.to_string e)) ) -let _ = OS.Main.run (run ()) diff --git a/controller/lwt_controller.ml b/controller/lwt_controller.ml new file mode 100644 index 0000000..206fb5d --- /dev/null +++ b/controller/lwt_controller.ml @@ -0,0 +1,26 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * 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 _ = OS.Main.run ( + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap9" () in + let _ = Tuntap.set_ipv4 ~devname:("tap9") ~ipv4:"10.20.0.3" + ~netmask:"255.255.255.0" () in + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + Learning_switch.run () + +) + diff --git a/controller/xen_controller.ml b/controller/xen_controller.ml new file mode 100644 index 0000000..6289c68 --- /dev/null +++ b/controller/xen_controller.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * 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 _ = OS.Main.run(Learning_switch.run ()) diff --git a/lib/META b/lib/META index 8e1e4ee..8f31813 100644 --- a/lib/META +++ b/lib/META @@ -1,12 +1,48 @@ # OASIS_START -# DO NOT EDIT (digest: f5e8b8a6695871d05a454bbedcc5779a) +# DO NOT EDIT (digest: 27751d9b328e9b59d215c02667dc4f29) version = "0.3.0" -description = "OpenFlow protocol and switch implementations in pure OCaml" -requires = "cstruct cstruct.syntax mirage mirage-net" +description = +"OpenFlow controller, switch and flowvisor implementation in pure OCaml" +requires = +"ipaddr cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net" archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" archive(native, plugin) = "openflow.cmxs" -exists_if = "openflow.cma" +exists_if = "openflow.cmxa" +package "switch_model" ( + version = "0.3.0" + description = + "OpenFlow controller, switch and flowvisor implementation in pure OCaml" + requires = "re.str tuntap" + archive(byte) = "switch_model.cma" + archive(byte, plugin) = "switch_model.cma" + archive(native) = "switch_model.cmxa" + archive(native, plugin) = "switch_model.cmxs" + exists_if = "switch_model.cmxa" +) + +package "switch" ( + version = "0.3.0" + description = + "OpenFlow controller, switch and flowvisor implementation in pure OCaml" + requires = "re.str tuntap" + archive(byte) = "switch.cma" + archive(byte, plugin) = "switch.cma" + archive(native) = "switch.cmxa" + archive(native, plugin) = "switch.cmxs" + exists_if = "switch.cmxa" +) + +package "flv" ( + version = "0.3.0" + description = + "OpenFlow controller, switch and flowvisor implementation in pure OCaml" + archive(byte) = "flv.cma" + archive(byte, plugin) = "flv.cma" + archive(native) = "flv.cmxa" + archive(native, plugin) = "flv.cmxs" + exists_if = "flv.cmxa" +) # OASIS_STOP diff --git a/lib/bitv.ml b/lib/bitv.ml new file mode 100644 index 0000000..d565d66 --- /dev/null +++ b/lib/bitv.ml @@ -0,0 +1,622 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*i $Id: bitv.ml,v 1.18 2008/04/01 09:59:03 filliatr Exp $ i*) + +(*s Bit vectors. The interface and part of the code are borrowed from the + [Array] module of the ocaml standard library (but things are simplified + here since we can always initialize a bit vector). This module also + provides bitwise operations. *) + +(*s We represent a bit vector by a vector of integers (field [bits]), + and we keep the information of the size of the bit vector since it + can not be found out with the size of the array (field [length]). *) + +type t = { + length : int; + bits : int array } + +let length v = v.length + +(*s Each element of the array is an integer containing [bpi] bits, where + [bpi] is determined according to the machine word size. Since we do not + use the sign bit, [bpi] is 30 on a 32-bits machine and 62 on a 64-bits + machines. We maintain the following invariant: + {\em The unused bits of the last integer are always + zeros.} This is ensured by [create] and maintained in other functions + using [normalize]. [bit_j], [bit_not_j], [low_mask] and [up_mask] + are arrays used to extract and mask bits in a single integer. *) + +let bpi = Sys.word_size - 2 + +let max_length = Sys.max_array_length * bpi + +let bit_j = Array.init bpi (fun j -> 1 lsl j) +let bit_not_j = Array.init bpi (fun j -> max_int - bit_j.(j)) + +let low_mask = Array.create (succ bpi) 0 +let _ = + for i = 1 to bpi do low_mask.(i) <- low_mask.(i-1) lor bit_j.(pred i) done + +let keep_lowest_bits a j = a land low_mask.(j) + +let high_mask = Array.init (succ bpi) (fun j -> low_mask.(j) lsl (bpi-j)) + +let keep_highest_bits a j = a land high_mask.(j) + +(*s Creating and normalizing a bit vector is easy: it is just a matter of + taking care of the invariant. Copy is immediate. *) + +let create n b = + let initv = if b then max_int else 0 in + let r = n mod bpi in + if r = 0 then + { length = n; bits = Array.create (n / bpi) initv } + else begin + let s = n / bpi in + let b = Array.create (succ s) initv in + b.(s) <- b.(s) land low_mask.(r); + { length = n; bits = b } + end + +let normalize v = + let r = v.length mod bpi in + if r > 0 then + let b = v.bits in + let s = Array.length b in + b.(s-1) <- b.(s-1) land low_mask.(r) + +let copy v = { length = v.length; bits = Array.copy v.bits } + +(*s Access and assignment. The [n]th bit of a bit vector is the [j]th + bit of the [i]th integer, where [i = n / bpi] and [j = n mod + bpi]. Both [i] and [j] and computed by the function [pos]. + Accessing a bit is testing whether the result of the corresponding + mask operation is non-zero, and assigning it is done with a + bitwiwe operation: an {\em or} with [bit_j] to set it, and an {\em + and} with [bit_not_j] to unset it. *) + +let pos n = + let i = n / bpi and j = n mod bpi in + if j < 0 then (i - 1, j + bpi) else (i,j) + +let unsafe_get v n = + let (i,j) = pos n in + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 + +let unsafe_set v n b = + let (i,j) = pos n in + if b then + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) + else + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) + +(*s The corresponding safe operations test the validiy of the access. *) + +let get v n = + if n < 0 or n >= v.length then invalid_arg "Bitv.get"; + let (i,j) = pos n in + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 + +let set v n b = + if n < 0 or n >= v.length then invalid_arg "Bitv.set"; + let (i,j) = pos n in + if b then + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) + else + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) + +(*s [init] is implemented naively using [unsafe_set]. *) + +let init n f = + let v = create n false in + for i = 0 to pred n do + unsafe_set v i (f i) + done; + v + +(*s Handling bits by packets is the key for efficiency of functions + [append], [concat], [sub] and [blit]. + We start by a very general function [blit_bits a i m v n] which blits + the bits [i] to [i+m-1] of a native integer [a] + onto the bit vector [v] at index [n]. It assumes that [i..i+m-1] and + [n..n+m-1] are respectively valid subparts of [a] and [v]. + It is optimized when the bits fit the lowest boundary of an integer + (case [j == 0]). *) + +let blit_bits a i m v n = + let (i',j) = pos n in + if j == 0 then + Array.unsafe_set v i' + ((keep_lowest_bits (a lsr i) m) lor + (keep_highest_bits (Array.unsafe_get v i') (bpi - m))) + else + let d = m + j - bpi in + if d > 0 then begin + Array.unsafe_set v i' + (((keep_lowest_bits (a lsr i) (bpi - j)) lsl j) lor + (keep_lowest_bits (Array.unsafe_get v i') j)); + Array.unsafe_set v (succ i') + ((keep_lowest_bits (a lsr (i + bpi - j)) d) lor + (keep_highest_bits (Array.unsafe_get v (succ i')) (bpi - d))) + end else + Array.unsafe_set v i' + (((keep_lowest_bits (a lsr i) m) lsl j) lor + ((Array.unsafe_get v i') land (low_mask.(j) lor high_mask.(-d)))) + +(*s [blit_int] implements [blit_bits] in the particular case when + [i=0] and [m=bpi] i.e. when we blit all the bits of [a]. *) + +let blit_int a v n = + let (i,j) = pos n in + if j == 0 then + Array.unsafe_set v i a + else begin + Array.unsafe_set v i + ( (keep_lowest_bits (Array.unsafe_get v i) j) lor + ((keep_lowest_bits a (bpi - j)) lsl j)); + Array.unsafe_set v (succ i) + ((keep_highest_bits (Array.unsafe_get v (succ i)) (bpi - j)) lor + (a lsr (bpi - j))) + end + +(*s When blitting a subpart of a bit vector into another bit vector, there + are two possible cases: (1) all the bits are contained in a single integer + of the first bit vector, and a single call to [blit_bits] is the + only thing to do, or (2) the source bits overlap on several integers of + the source array, and then we do a loop of [blit_int], with two calls + to [blit_bits] for the two bounds. *) + +let unsafe_blit v1 ofs1 v2 ofs2 len = + if len > 0 then + let (bi,bj) = pos ofs1 in + let (ei,ej) = pos (ofs1 + len - 1) in + if bi == ei then + blit_bits (Array.unsafe_get v1 bi) bj len v2 ofs2 + else begin + blit_bits (Array.unsafe_get v1 bi) bj (bpi - bj) v2 ofs2; + let n = ref (ofs2 + bpi - bj) in + for i = succ bi to pred ei do + blit_int (Array.unsafe_get v1 i) v2 !n; + n := !n + bpi + done; + blit_bits (Array.unsafe_get v1 ei) 0 (succ ej) v2 !n + end + +let blit v1 ofs1 v2 ofs2 len = + if len < 0 or ofs1 < 0 or ofs1 + len > v1.length + or ofs2 < 0 or ofs2 + len > v2.length + then invalid_arg "Bitv.blit"; + unsafe_blit v1.bits ofs1 v2.bits ofs2 len + +(*s Extracting the subvector [ofs..ofs+len-1] of [v] is just creating a + new vector of length [len] and blitting the subvector of [v] inside. *) + +let sub v ofs len = + if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.sub"; + let r = create len false in + unsafe_blit v.bits ofs r.bits 0 len; + r + +(*s The concatenation of two bit vectors [v1] and [v2] is obtained by + creating a vector for the result and blitting inside the two vectors. + [v1] is copied directly. *) + +let append v1 v2 = + let l1 = v1.length + and l2 = v2.length in + let r = create (l1 + l2) false in + let b1 = v1.bits in + let b2 = v2.bits in + let b = r.bits in + for i = 0 to Array.length b1 - 1 do + Array.unsafe_set b i (Array.unsafe_get b1 i) + done; + unsafe_blit b2 0 b l1 l2; + r + +(*s The concatenation of a list of bit vectors is obtained by iterating + [unsafe_blit]. *) + +let concat vl = + let size = List.fold_left (fun sz v -> sz + v.length) 0 vl in + let res = create size false in + let b = res.bits in + let pos = ref 0 in + List.iter + (fun v -> + let n = v.length in + unsafe_blit v.bits 0 b !pos n; + pos := !pos + n) + vl; + res + +(*s Filling is a particular case of blitting with a source made of all + ones or all zeros. Thus we instanciate [unsafe_blit], with 0 and + [max_int]. *) + +let blit_zeros v ofs len = + if len > 0 then + let (bi,bj) = pos ofs in + let (ei,ej) = pos (ofs + len - 1) in + if bi == ei then + blit_bits 0 bj len v ofs + else begin + blit_bits 0 bj (bpi - bj) v ofs; + let n = ref (ofs + bpi - bj) in + for i = succ bi to pred ei do + blit_int 0 v !n; + n := !n + bpi + done; + blit_bits 0 0 (succ ej) v !n + end + +let blit_ones v ofs len = + if len > 0 then + let (bi,bj) = pos ofs in + let (ei,ej) = pos (ofs + len - 1) in + if bi == ei then + blit_bits max_int bj len v ofs + else begin + blit_bits max_int bj (bpi - bj) v ofs; + let n = ref (ofs + bpi - bj) in + for i = succ bi to pred ei do + blit_int max_int v !n; + n := !n + bpi + done; + blit_bits max_int 0 (succ ej) v !n + end + +let fill v ofs len b = + if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.fill"; + if b then blit_ones v.bits ofs len else blit_zeros v.bits ofs len + +(*s All the iterators are implemented as for traditional arrays, using + [unsafe_get]. For [iter] and [map], we do not precompute [(f + true)] and [(f false)] since [f] is likely to have + side-effects. *) + +let iter f v = + for i = 0 to v.length - 1 do f (unsafe_get v i) done + +let map f v = + let l = v.length in + let r = create l false in + for i = 0 to l - 1 do + unsafe_set r i (f (unsafe_get v i)) + done; + r + +let iteri f v = + for i = 0 to v.length - 1 do f i (unsafe_get v i) done + +let mapi f v = + let l = v.length in + let r = create l false in + for i = 0 to l - 1 do + unsafe_set r i (f i (unsafe_get v i)) + done; + r + +let fold_left f x v = + let r = ref x in + for i = 0 to v.length - 1 do + r := f !r (unsafe_get v i) + done; + !r + +let fold_right f v x = + let r = ref x in + for i = v.length - 1 downto 0 do + r := f (unsafe_get v i) !r + done; + !r + +let foldi_left f x v = + let r = ref x in + for i = 0 to v.length - 1 do + r := f !r i (unsafe_get v i) + done; + !r + +let foldi_right f v x = + let r = ref x in + for i = v.length - 1 downto 0 do + r := f i (unsafe_get v i) !r + done; + !r + +let iteri_true f v = + Array.iteri + (fun i n -> if n != 0 then begin + let i_bpi = i * bpi in + for j = 0 to bpi - 1 do + if n land (Array.unsafe_get bit_j j) > 0 then f (i_bpi + j) + done + end) + v.bits + +(*s Bitwise operations. It is straigthforward, since bitwise operations + can be realized by the corresponding bitwise operations over integers. + However, one has to take care of normalizing the result of [bwnot] + which introduces ones in highest significant positions. *) + +let bw_and v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_and"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) land b2.(i) + done; + { length = l; bits = a } + +let bw_or v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_or"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) lor b2.(i) + done; + { length = l; bits = a } + +let bw_xor v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_xor"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) lxor b2.(i) + done; + { length = l; bits = a } + +let bw_not v = + let b = v.bits in + let n = Array.length b in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- max_int land (lnot b.(i)) + done; + let r = { length = v.length; bits = a } in + normalize r; + r + +(*s Shift operations. It is easy to reuse [unsafe_blit], although it is + probably slightly less efficient than a ad-hoc piece of code. *) + +let rec shiftl v d = + if d == 0 then + copy v + else if d < 0 then + shiftr v (-d) + else begin + let n = v.length in + let r = create n false in + if d < n then unsafe_blit v.bits 0 r.bits d (n - d); + r + end + +and shiftr v d = + if d == 0 then + copy v + else if d < 0 then + shiftl v (-d) + else begin + let n = v.length in + let r = create n false in + if d < n then unsafe_blit v.bits d r.bits 0 (n - d); + r + end + +(*s Testing for all zeros and all ones. *) + +let all_zeros v = + let b = v.bits in + let n = Array.length b in + let rec test i = + (i == n) || ((Array.unsafe_get b i == 0) && test (succ i)) + in + test 0 + +let all_ones v = + let b = v.bits in + let n = Array.length b in + let rec test i = + if i == n - 1 then + let m = v.length mod bpi in + (Array.unsafe_get b i) == (if m == 0 then max_int else low_mask.(m)) + else + ((Array.unsafe_get b i) == max_int) && test (succ i) + in + test 0 + +(*s Conversions to and from strings. *) + +let to_string v = + let n = v.length in + let s = String.make n '0' in + for i = 0 to n - 1 do + if unsafe_get v i then s.[i] <- '1' + done; + s + +let print fmt v = Format.pp_print_string fmt (to_string v) + +let of_string s = + let n = String.length s in + let v = create n false in + for i = 0 to n - 1 do + let c = String.unsafe_get s i in + if c = '1' then + unsafe_set v i true + else + if c <> '0' then invalid_arg "Bitv.of_string" + done; + v + +(*s Iteration on all bit vectors of length [n] using a Gray code. *) + +let first_set v n = + let rec lookup i = + if i = n then raise Not_found ; + if unsafe_get v i then i else lookup (i + 1) + in + lookup 0 + +let gray_iter f n = + let bv = create n false in + let rec iter () = + f bv; + unsafe_set bv 0 (not (unsafe_get bv 0)); + f bv; + let pos = succ (first_set bv n) in + if pos < n then begin + unsafe_set bv pos (not (unsafe_get bv pos)); + iter () + end + in + if n > 0 then iter () + + +(*s Coercions to/from lists of integers *) + +let of_list l = + let n = List.fold_left max 0 l in + let b = create (succ n) false in + let add_element i = + (* negative numbers are invalid *) + if i < 0 then invalid_arg "Bitv.of_list"; + unsafe_set b i true + in + List.iter add_element l; + b + +let of_list_with_length l len = + let b = create len false in + let add_element i = + if i < 0 || i >= len then invalid_arg "Bitv.of_list_with_length"; + unsafe_set b i true + in + List.iter add_element l; + b + +let to_list b = + let n = length b in + let rec make i acc = + if i < 0 then acc + else make (pred i) (if unsafe_get b i then i :: acc else acc) + in + make (pred n) [] + + +(*s To/from integers. *) + +(* [int] *) +let of_int_us i = + { length = bpi; bits = [| i land max_int |] } +let to_int_us v = + if v.length < bpi then invalid_arg "Bitv.to_int_us"; + v.bits.(0) + +let of_int_s i = + { length = succ bpi; bits = [| i land max_int; (i lsr bpi) land 1 |] } +let to_int_s v = + if v.length < succ bpi then invalid_arg "Bitv.to_int_s"; + v.bits.(0) lor (v.bits.(1) lsl bpi) + +(* [Int32] *) +let of_int32_us i = match Sys.word_size with + | 32 -> { length = 31; + bits = [| (Int32.to_int i) land max_int; + let hi = Int32.shift_right_logical i 30 in + (Int32.to_int hi) land 1 |] } + | 64 -> { length = 31; bits = [| (Int32.to_int i) land 0x7fffffff |] } + | _ -> assert false +let to_int32_us v = + if v.length < 31 then invalid_arg "Bitv.to_int32_us"; + match Sys.word_size with + | 32 -> + Int32.logor (Int32.of_int v.bits.(0)) + (Int32.shift_left (Int32.of_int (v.bits.(1) land 1)) 30) + | 64 -> + Int32.of_int (v.bits.(0) land 0x7fffffff) + | _ -> assert false + +(* this is 0xffffffff (ocaml >= 3.08 checks for literal overflow) *) +let ffffffff = (0xffff lsl 16) lor 0xffff + +let of_int32_s i = match Sys.word_size with + | 32 -> { length = 32; + bits = [| (Int32.to_int i) land max_int; + let hi = Int32.shift_right_logical i 30 in + (Int32.to_int hi) land 3 |] } + | 64 -> { length = 32; bits = [| (Int32.to_int i) land ffffffff |] } + | _ -> assert false +let to_int32_s v = + if v.length < 32 then invalid_arg "Bitv.to_int32_s"; + match Sys.word_size with + | 32 -> + Int32.logor (Int32.of_int v.bits.(0)) + (Int32.shift_left (Int32.of_int (v.bits.(1) land 3)) 30) + | 64 -> + Int32.of_int (v.bits.(0) land ffffffff) + | _ -> assert false + +(* [Int64] *) +let of_int64_us i = match Sys.word_size with + | 32 -> { length = 63; + bits = [| (Int64.to_int i) land max_int; + (let mi = Int64.shift_right_logical i 30 in + (Int64.to_int mi) land max_int); + let hi = Int64.shift_right_logical i 60 in + (Int64.to_int hi) land 1 |] } + | 64 -> { length = 63; + bits = [| (Int64.to_int i) land max_int; + let hi = Int64.shift_right_logical i 62 in + (Int64.to_int hi) land 1 |] } + | _ -> assert false +let to_int64_us v = failwith "todo" + +let of_int64_s i = failwith "todo" +let to_int64_s v = failwith "todo" + +(* [Nativeint] *) +let select_of f32 f64 = match Sys.word_size with + | 32 -> (fun i -> f32 (Nativeint.to_int32 i)) + | 64 -> (fun i -> f64 (Int64.of_nativeint i)) + | _ -> assert false +let of_nativeint_s = select_of of_int32_s of_int64_s +let of_nativeint_us = select_of of_int32_us of_int64_us +let select_to f32 f64 = match Sys.word_size with + | 32 -> (fun i -> Nativeint.of_int32 (f32 i)) + | 64 -> (fun i -> Int64.to_nativeint (f64 i)) + | _ -> assert false +let to_nativeint_s = select_to to_int32_s to_int64_s +let to_nativeint_us = select_to to_int32_us to_int64_us + + diff --git a/lib/bitv.mli b/lib/bitv.mli new file mode 100644 index 0000000..69421df --- /dev/null +++ b/lib/bitv.mli @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*s {\bf Module Bitv}. + This module implements bit vectors, as an abstract datatype [t]. + Since bit vectors are particular cases of arrays, this module provides + the same operations as the module [Array] (Sections~\ref{barray} + up to \ref{earray}). It also provides bitwise operations + (Section~\ref{bitwise}). In the following, [false] stands for the bit 0 + and [true] for the bit 1. *) + +type t + +(*s {\bf Creation, access and assignment.} \label{barray} + [(Bitv.create n b)] creates a new bit vector of length [n], + initialized with [b]. + [(Bitv.init n f)] returns a fresh vector of length [n], + with bit number [i] initialized to the result of [(f i)]. + [(Bitv.set v n b)] sets the [n]th bit of [v] to the value [b]. + [(Bitv.get v n)] returns the [n]th bit of [v]. + [Bitv.length] returns the length (number of elements) of the given + vector. *) + +val create : int -> bool -> t + +val init : int -> (int -> bool) -> t + +val set : t -> int -> bool -> unit + +val get : t -> int -> bool + +val length : t -> int + +(*s [max_length] is the maximum length of a bit vector (System dependent). *) + +val max_length : int + +(*s {\bf Copies and concatenations.} + [(Bitv.copy v)] returns a copy of [v], + that is, a fresh vector containing the same elements as + [v]. [(Bitv.append v1 v2)] returns a fresh vector containing the + concatenation of the vectors [v1] and [v2]. [Bitv.concat] is + similar to [Bitv.append], but catenates a list of vectors. *) + +val copy : t -> t + +val append : t -> t -> t + +val concat : t list -> t + +(*s {\bf Sub-vectors and filling.} + [(Bitv.sub v start len)] returns a fresh + vector of length [len], containing the bits number [start] to + [start + len - 1] of vector [v]. Raise [Invalid_argument + "Bitv.sub"] if [start] and [len] do not designate a valid + subvector of [v]; that is, if [start < 0], or [len < 0], or [start + + len > Bitv.length a]. + + [(Bitv.fill v ofs len b)] modifies the vector [v] in place, + storing [b] in elements number [ofs] to [ofs + len - 1]. Raise + [Invalid_argument "Bitv.fill"] if [ofs] and [len] do not designate + a valid subvector of [v]. + + [(Bitv.blit v1 o1 v2 o2 len)] copies [len] elements from vector + [v1], starting at element number [o1], to vector [v2], starting at + element number [o2]. It {\em does not work} correctly if [v1] and [v2] are + the same vector with the source and destination chunks overlapping. + Raise [Invalid_argument "Bitv.blit"] if [o1] and [len] do not + designate a valid subvector of [v1], or if [o2] and [len] do not + designate a valid subvector of [v2]. *) + +val sub : t -> int -> int -> t + +val fill : t -> int -> int -> bool -> unit + +val blit : t -> int -> t -> int -> int -> unit + +(*s {\bf Iterators.} \label{earray} + [(Bitv.iter f v)] applies function [f] in turn to all + the elements of [v]. Given a function [f], [(Bitv.map f v)] applies + [f] to all + the elements of [v], and builds a vector with the results returned + by [f]. [Bitv.iteri] and [Bitv.mapi] are similar to [Bitv.iter] + and [Bitv.map] respectively, but the function is applied to the + index of the element as first argument, and the element itself as + second argument. + + [(Bitv.fold_left f x v)] computes [f (... (f (f x (get v 0)) (get + v 1)) ...) (get v (n-1))], where [n] is the length of the vector + [v]. + + [(Bitv.fold_right f a x)] computes [f (get v 0) (f (get v 1) + ( ... (f (get v (n-1)) x) ...))], where [n] is the length of the + vector [v]. *) + +val iter : (bool -> unit) -> t -> unit +val map : (bool -> bool) -> t -> t + +val iteri : (int -> bool -> unit) -> t -> unit +val mapi : (int -> bool -> bool) -> t -> t + +val fold_left : ('a -> bool -> 'a) -> 'a -> t -> 'a +val fold_right : (bool -> 'a -> 'a) -> t -> 'a -> 'a +val foldi_left : ('a -> int -> bool -> 'a) -> 'a -> t -> 'a +val foldi_right : (int -> bool -> 'a -> 'a) -> t -> 'a -> 'a + +(*s [gray_iter f n] iterates function [f] on all bit vectors + of length [n], once each, using a Gray code. The order in which + bit vectors are processed is unspecified. *) + +val gray_iter : (t -> unit) -> int -> unit + +(*s {\bf Bitwise operations.} \label{bitwise} [bwand], [bwor] and + [bwxor] implement logical and, or and exclusive or. They return + fresh vectors and raise [Invalid_argument "Bitv.xxx"] if the two + vectors do not have the same length (where \texttt{xxx} is the + name of the function). [bwnot] implements the logical negation. + It returns a fresh vector. + [shiftl] and [shiftr] implement shifts. They return fresh vectors. + [shiftl] moves bits from least to most significant, and [shiftr] + from most to least significant (think [lsl] and [lsr]). + [all_zeros] and [all_ones] respectively test for a vector only + containing zeros and only containing ones. *) + +val bw_and : t -> t -> t +val bw_or : t -> t -> t +val bw_xor : t -> t -> t +val bw_not : t -> t + +val shiftl : t -> int -> t +val shiftr : t -> int -> t + +val all_zeros : t -> bool +val all_ones : t -> bool + +(*s {\bf Conversions to and from strings.} + Least significant bit comes first. *) + +val to_string : t -> string +val of_string : string -> t +val print : Format.formatter -> t -> unit + +(*s {\bf Conversions to and from lists of integers.} + The list gives the indices of bits which are set (ie [true]). *) + +val to_list : t -> int list +val of_list : int list -> t +val of_list_with_length : int list -> int -> t + +(*s Interpretation of bit vectors as integers. Least significant bit + comes first (ie is at index 0 in the bit vector). + [to_xxx] functions truncate when the bit vector is too wide, + and raise [Invalid_argument] when it is too short. + Suffix [_s] indicates that sign bit is kept, + and [_us] that it is discarded. *) + +(* type [int] (length 31/63 with sign, 30/62 without) *) +val of_int_s : int -> t +val to_int_s : t -> int +val of_int_us : int -> t +val to_int_us : t -> int +(* type [Int32.t] (length 32 with sign, 31 without) *) +val of_int32_s : Int32.t -> t +val to_int32_s : t -> Int32.t +val of_int32_us : Int32.t -> t +val to_int32_us : t -> Int32.t +(* type [Int64.t] (length 64 with sign, 63 without) *) +val of_int64_s : Int64.t -> t +val to_int64_s : t -> Int64.t +val of_int64_us : Int64.t -> t +val to_int64_us : t -> Int64.t +(* type [Nativeint.t] (length 32/64 with sign, 31/63 without) *) +val of_nativeint_s : Nativeint.t -> t +val to_nativeint_s : t -> Nativeint.t +val of_nativeint_us : Nativeint.t -> t +val to_nativeint_us : t -> Nativeint.t + +(*s Only if you know what you are doing... *) + +val unsafe_set : t -> int -> bool -> unit +val unsafe_get : t -> int -> bool diff --git a/lib/blocks.ml b/lib/blocks.ml new file mode 100644 index 0000000..4b410cc --- /dev/null +++ b/lib/blocks.ml @@ -0,0 +1,919 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Common implementation to persistent and imperative graphs. *) + +open Sig +open Util + +let first_value_for_cpt_vertex = 0 +let cpt_vertex = ref first_value_for_cpt_vertex + (* global counter for abstract vertex *) + +(* [max_cpt t1 t2] returns the maximum of [t1] and [t2] wrt the total ordering + induced by tags creation. This ordering is defined as follow: + forall tags t1 t2, + t1 <= t2 iff + t1 is before t2 in the finite sequence + [0; 1; ..; max_int; min_int; min_int-1; -1] *) +let max_cpt c1 c2 = max (c1 + min_int) (c2 + min_int) - min_int + +(* This function must be called after the unserialisation of any abstract + vertex if you want to create new vertices. *) +let after_unserialization serialized_cpt_vertex = + cpt_vertex := max_cpt serialized_cpt_vertex !cpt_vertex + +(* ************************************************************************* *) +(** {2 Association table builder} *) +(* ************************************************************************* *) + +(** Common signature to an imperative/persistent association table *) +module type HM = sig + type 'a return + type 'a t + type key + val create : ?size:int -> unit -> 'a t + val create_from : 'a t -> 'a t + val empty : 'a return + val clear: 'a t -> unit + val is_empty : 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val remove : key -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val find : key -> 'a t -> 'a + val find_and_raise : key -> 'a t -> string -> 'a + (** [find_and_raise k t s] is equivalent to [find k t] but + raises [Invalid_argument s] when [find k t] raises [Not_found] *) + val iter : (key -> 'a -> unit) -> 'a t -> unit + val map : (key -> 'a -> key * 'a) -> 'a t -> 'a t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val copy : 'a t -> 'a t +end + +module type TBL_BUILDER = functor(X: COMPARABLE) -> HM with type key = X.t + +(** [HM] implementation using hashtbl. *) +module Make_Hashtbl(X: COMPARABLE) = struct + + include Hashtbl.Make(X) + + type 'a return = unit + let empty = () + (* never call and not visible for the user thank's to signature + constraints *) + + let create_from h = create (length h) + let create ?(size=97) () = create size + + let is_empty h = (length h = 0) + + let find_and_raise k h s = try find h k with Not_found -> invalid_arg s + + let map f h = + let h' = create_from h in + iter (fun k v -> let k, v = f k v in add h' k v) h; + h' + + let add k v h = replace h k v; h + let remove k h = remove h k; h + let mem k h = mem h k + let find k h = find h k + +end + +(** [HM] implementation using map *) +module Make_Map(X: COMPARABLE) = struct + include Map.Make(X) + type 'a return = 'a t + let is_empty m = (m = empty) + let create ?size () = assert false + (* never call and not visible for the user thank's to + signature constraints *) + let create_from _ = empty + let copy m = m + let map f m = fold (fun k v m -> let k, v = f k v in add k v m) m empty + let find_and_raise k h s = try find k h with Not_found -> invalid_arg s + let clear _ = assert false + (* never call and not visible for the user thank's to + signature constraints *) +end + +(* ************************************************************************* *) +(** {2 Blocks builder} *) +(* ************************************************************************* *) + +(** Common implementation to all (directed) graph implementations. *) +module Minimal(S: Set.S)(HM: HM) = struct + + type vertex = HM.key + + let is_directed = true + let empty = HM.empty + let create = HM.create + let is_empty = HM.is_empty + let copy = HM.copy + let clear = HM.clear + + let nb_vertex g = HM.fold (fun _ _ -> succ) g 0 + let nb_edges g = HM.fold (fun _ s n -> n + S.cardinal s) g 0 + let out_degree g v = + S.cardinal + (try HM.find v g with Not_found -> invalid_arg "[ocamlgraph] out_degree") + + let mem_vertex g v = HM.mem v g + + let unsafe_add_vertex g v = HM.add v S.empty g + let unsafe_add_edge g v1 v2 = HM.add v1 (S.add v2 (HM.find v1 g)) g + + let add_vertex g v = if HM.mem v g then g else unsafe_add_vertex g v + + let iter_vertex f = HM.iter (fun v _ -> f v) + let fold_vertex f = HM.fold (fun v _ -> f v) + +end + +(** All the predecessor operations from the iterators on the edges *) +module Pred + (S: sig + module PV: COMPARABLE + module PE: EDGE with type vertex = PV.t + type t + val mem_vertex : PV.t -> t -> bool + val iter_edges : (PV.t -> PV.t -> unit) -> t -> unit + val fold_edges : (PV.t -> PV.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_edges_e : (PE.t -> unit) -> t -> unit + val fold_edges_e : (PE.t -> 'a -> 'a) -> t -> 'a -> 'a + end) = +struct + + open S + + let iter_pred f g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] iter_pred"; + iter_edges (fun v1 v2 -> if PV.equal v v2 then f v1) g + + let fold_pred f g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] fold_pred"; + fold_edges (fun v1 v2 a -> if PV.equal v v2 then f v1 a else a) g + + let pred g v = fold_pred (fun v l -> v :: l) g v [] + + let in_degree g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] in_degree"; + fold_pred (fun v n -> n + 1) g v 0 + + let iter_pred_e f g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] iter_pred_e"; + iter_edges_e (fun e -> if PV.equal v (PE.dst e) then f e) g + + let fold_pred_e f g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] fold_pred_e"; + fold_edges_e (fun e a -> if PV.equal v (PE.dst e) then f e a else a) g + + let pred_e g v = fold_pred_e (fun v l -> v :: l) g v [] + +end + +(** Common implementation to all the unlabeled (directed) graphs. *) +module Unlabeled(V: COMPARABLE)(HM: HM with type key = V.t) = struct + + module S = Set.Make(V) + + module E = struct + type vertex = V.t + include OTProduct(V)(V) + let src = fst + let dst = snd + type label = unit + let label _ = () + let create v1 () v2 = v1, v2 + end + type edge = E.t + + let mem_edge g v1 v2 = + try S.mem v2 (HM.find v1 g) + with Not_found -> false + + let mem_edge_e g (v1, v2) = mem_edge g v1 v2 + + let find_edge g v1 v2 = if mem_edge g v1 v2 then v1, v2 else raise Not_found + let find_all_edges g v1 v2 = try [ find_edge g v1 v2 ] with Not_found -> [] + + let unsafe_remove_edge g v1 v2 = HM.add v1 (S.remove v2 (HM.find v1 g)) g + let unsafe_remove_edge_e g (v1, v2) = unsafe_remove_edge g v1 v2 + + let remove_edge g v1 v2 = + if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge"; + HM.add + v1 (S.remove v2 (HM.find_and_raise v1 g "[ocamlgraph] remove_edge")) g + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + let iter_succ f g v = + S.iter f (HM.find_and_raise v g "[ocamlgraph] iter_succ") + + let fold_succ f g v = + S.fold f (HM.find_and_raise v g "[ocamlgraph] fold_succ") + + let iter_succ_e f g v = iter_succ (fun v2 -> f (v, v2)) g v + let fold_succ_e f g v = fold_succ (fun v2 -> f (v, v2)) g v + + let succ g v = S.elements (HM.find_and_raise v g "[ocamlgraph] succ") + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map (fun v s -> f v, S.fold (fun v s -> S.add (f v) s) s S.empty) + + module I = struct + type t = S.t HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v -> S.iter (f v)) + let fold_edges f = HM.fold (fun v -> S.fold (f v)) + let iter_edges_e f = iter_edges (fun v1 v2 -> f (v1, v2)) + let fold_edges_e f = fold_edges (fun v1 v2 a -> f (v1, v2) a) + end + include I + + include Pred(struct include I let mem_vertex = HM.mem end) + +end + +(** Common implementation to all the labeled (directed) graphs. *) +module Labeled(V: COMPARABLE)(E: ORDERED_TYPE)(HM: HM with type key = V.t) = +struct + + module VE = OTProduct(V)(E) + module S = Set.Make(VE) + + module E = struct + type vertex = V.t + type label = E.t + type t = vertex * label * vertex + let src (v, _, _) = v + let dst (_, _, v) = v + let label (_, l, _) = l + let create v1 l v2 = v1, l, v2 + module C = OTProduct(V)(VE) + let compare (x1, x2, x3) (y1, y2, y3) = + C.compare (x1, (x3, x2)) (y1, (y3, y2)) + end + type edge = E.t + + let mem_edge g v1 v2 = + try S.exists (fun (v2', _) -> V.equal v2 v2') (HM.find v1 g) + with Not_found -> false + + let mem_edge_e g (v1, l, v2) = + try + let ve = v2, l in + S.exists (fun ve' -> VE.compare ve ve' = 0) (HM.find v1 g) + with Not_found -> + false + + exception Found of edge + let find_edge g v1 v2 = + try + S.iter + (fun (v2', l) -> if V.equal v2 v2' then raise (Found (v1, l, v2'))) + (HM.find v1 g); + raise Not_found + with Found e -> + e + + let find_all_edges g v1 v2 = + try + S.fold + (fun (v2', l) acc -> + if V.equal v2 v2' then (v1, l, v2') :: acc else acc) + (HM.find v1 g) + [] + with Not_found -> + [] + + let unsafe_remove_edge g v1 v2 = + HM.add + v1 + (S.filter (fun (v2', _) -> not (V.equal v2 v2')) (HM.find v1 g)) + g + + let unsafe_remove_edge_e g (v1, l, v2) = + HM.add v1 (S.remove (v2, l) (HM.find v1 g)) g + + let remove_edge g v1 v2 = + if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge"; + HM.add + v1 + (S.filter + (fun (v2', _) -> not (V.equal v2 v2')) + (HM.find_and_raise v1 g "[ocamlgraph] remove_edge")) + g + + let remove_edge_e g (v1, l, v2) = + if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge_e"; + HM.add + v1 + (S.remove (v2, l) (HM.find_and_raise v1 g "[ocamlgraph] remove_edge_e")) + g + + let iter_succ f g v = + S.iter (fun (w, _) -> f w) (HM.find_and_raise v g "[ocamlgraph] iter_succ") + let fold_succ f g v = + S.fold (fun (w, _) -> f w) (HM.find_and_raise v g "[ocamlgraph] fold_succ") + + let iter_succ_e f g v = + S.iter + (fun (w, l) -> f (v, l, w)) + (HM.find_and_raise v g "[ocamlgraph] iter_succ_e") + + let fold_succ_e f g v = + S.fold + (fun (w, l) -> f (v, l, w)) + (HM.find_and_raise v g "[ocamlgraph] fold_succ_e") + + let succ g v = fold_succ (fun w l -> w :: l) g v [] + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map + (fun v s -> f v, S.fold (fun (v, l) s -> S.add (f v, l) s) s S.empty) + + module I = struct + type t = S.t HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v -> S.iter (fun (w, _) -> f v w)) + let fold_edges f = HM.fold (fun v -> S.fold (fun (w, _) -> f v w)) + let iter_edges_e f = + HM.iter (fun v -> S.iter (fun (w, l) -> f (v, l, w))) + let fold_edges_e f = + HM.fold (fun v -> S.fold (fun (w, l) -> f (v, l, w))) + end + include I + + include Pred(struct include I let mem_vertex = HM.mem end) + +end + +(** The vertex module and the vertex table for the concrete graphs. *) +module ConcreteVertex(F : TBL_BUILDER)(V: COMPARABLE) = struct + module V = struct + include V + type label = t + let label v = v + let create v = v + end + module HM = F(V) +end + +module Make_Abstract + (G: sig + module HM: HM + module S: Set.S + include G with type t = S.t HM.t and type V.t = HM.key + val remove_edge: t -> vertex -> vertex -> t + val remove_edge_e: t -> edge -> t + val unsafe_add_vertex: t -> vertex -> t + val unsafe_add_edge: t -> vertex -> S.elt -> t + val unsafe_remove_edge: t -> vertex -> vertex -> t + val unsafe_remove_edge_e: t -> edge -> t + val create: ?size:int -> unit -> t + val clear: t -> unit + end) = +struct + + module I = struct + type t = { edges : G.t; mutable size : int } + (* BE CAREFUL: [size] is only mutable in the imperative version. As + there is no extensible records in current ocaml version, and for + genericity purpose, [size] is mutable in both imperative and + persistent implementations. + Do not modify size in the persistent implementation! *) + + type vertex = G.vertex + type edge = G.edge + + module PV = G.V + module PE = G.E + + let iter_edges f g = G.iter_edges f g.edges + let fold_edges f g = G.fold_edges f g.edges + let iter_edges_e f g = G.iter_edges_e f g.edges + let fold_edges_e f g = G.fold_edges_e f g.edges + let mem_vertex v g = G.mem_vertex g.edges v + let create ?size () = { edges = G.create ?size (); size = 0 } + let clear g = G.clear g.edges; g.size <- 0 + end + include I + + include Pred(I) + + (* optimisations *) + + let is_empty g = g.size = 0 + let nb_vertex g = g.size + + (* redefinitions *) + module V = G.V + module E = G.E + module HM = G.HM + module S = G.S + + let unsafe_add_edge = G.unsafe_add_edge + let unsafe_remove_edge = G.unsafe_remove_edge + let unsafe_remove_edge_e = G.unsafe_remove_edge_e + let is_directed = G.is_directed + + let remove_edge g = G.remove_edge g.edges + let remove_edge_e g = G.remove_edge_e g.edges + + let out_degree g = G.out_degree g.edges + let in_degree g = G.in_degree g.edges + + let nb_edges g = G.nb_edges g.edges + let succ g = G.succ g.edges + let mem_vertex g = G.mem_vertex g.edges + let mem_edge g = G.mem_edge g.edges + let mem_edge_e g = G.mem_edge_e g.edges + let find_edge g = G.find_edge g.edges + let find_all_edges g = G.find_all_edges g.edges + + let iter_vertex f g = G.iter_vertex f g.edges + let fold_vertex f g = G.fold_vertex f g.edges + let iter_succ f g = G.iter_succ f g.edges + let fold_succ f g = G.fold_succ f g.edges + let succ_e g = G.succ_e g.edges + let iter_succ_e f g = G.iter_succ_e f g.edges + let fold_succ_e f g = G.fold_succ_e f g.edges + let map_vertex f g = { g with edges = G.map_vertex f g.edges } + + (* reimplementation *) + + let copy g = + let h = HM.create () in + let vertex v = + try + HM.find v h + with Not_found -> + let v' = V.create (V.label v) in + let h' = HM.add v v' h in + assert (h == h'); + v' + in + map_vertex vertex g + +end + +(** Support for explicitly maintaining edge set of + predecessors. Crucial for algorithms that do a lot of backwards + traversal. *) + +module BidirectionalMinimal(S:Set.S)(HM:HM) = struct + + type vertex = HM.key + + let is_directed = true + let empty = HM.empty + let create = HM.create + let clear = HM.clear + let is_empty = HM.is_empty + let copy = HM.copy + + let nb_vertex g = HM.fold (fun _ _ -> succ) g 0 + let nb_edges g = HM.fold (fun _ (_,s) n -> n + S.cardinal s) g 0 + let out_degree g v = + S.cardinal + (snd (try HM.find v g + with Not_found -> invalid_arg "[ocamlgraph] out_degree")) + + let mem_vertex g v = HM.mem v g + + let unsafe_add_vertex g v = HM.add v (S.empty, S.empty) g + let add_vertex g v = if HM.mem v g then g else unsafe_add_vertex g v + + let iter_vertex f = HM.iter (fun v _ -> f v) + let fold_vertex f = HM.fold (fun v _ -> f v) + +end + +module BidirectionalUnlabeled(V:COMPARABLE)(HM:HM with type key = V.t) = struct + + module S = Set.Make(V) + + module E = struct + type vertex = V.t + include OTProduct(V)(V) + let src = fst + let dst = snd + type label = unit + let label _ = () + let create v1 () v2 = v1, v2 + end + type edge = E.t + + let mem_edge g v1 v2 = + try S.mem v2 (snd (HM.find v1 g)) + with Not_found -> false + + let mem_edge_e g (v1,v2) = mem_edge g v1 v2 + + let find_edge g v1 v2 = if mem_edge g v1 v2 then v1, v2 else raise Not_found + let find_all_edges g v1 v2 = try [ find_edge g v1 v2 ] with Not_found -> [] + + let unsafe_remove_edge g v1 v2 = + let in_set, out_set = HM.find v1 g in + let g = HM.add v1 (in_set, S.remove v2 out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (S.remove v1 in_set, out_set) g + + let unsafe_remove_edge_e g (v1,v2) = unsafe_remove_edge g v1 v2 + + let remove_edge g v1 v2 = + if not (HM.mem v2 g && HM.mem v1 g) then + invalid_arg "[ocamlgraph] remove_edge"; + unsafe_remove_edge g v1 v2 + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + let iter_succ f g v = + S.iter f (snd (HM.find_and_raise v g "[ocamlgraph] iter_succ")) + + let fold_succ f g v = + S.fold f (snd (HM.find_and_raise v g "[ocamlgraph] fold_succ")) + + let iter_succ_e f g v = iter_succ (fun v2 -> f (v, v2)) g v + let fold_succ_e f g v = fold_succ (fun v2 -> f (v, v2)) g v + + let succ g v = S.elements (snd (HM.find_and_raise v g "[ocamlgraph] succ")) + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map + (fun v (s1,s2) -> + f v, + (S.fold (fun v s -> S.add (f v) s) s1 S.empty, + S.fold (fun v s -> S.add (f v) s) s2 S.empty)) + + module I = struct + (* we keep sets for both incoming and outgoing edges *) + type t = (S.t (* incoming *) * S.t (* outgoing *)) HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v (_, outset) -> S.iter (f v) outset) + let fold_edges f = HM.fold (fun v (_, outset) -> S.fold (f v) outset) + let iter_edges_e f = iter_edges (fun v1 v2 -> f (v1, v2)) + let fold_edges_e f = fold_edges (fun v1 v2 a -> f (v1, v2) a) + end + include I + + let iter_pred f g v = + S.iter f (fst (HM.find_and_raise v g "[ocamlgraph] iter_pred")) + + let fold_pred f g v = + S.fold f (fst (HM.find_and_raise v g "[ocamlgraph] fold_pred")) + + let pred g v = S.elements (fst (HM.find_and_raise v g "[ocamlgraph] pred")) + + let in_degree g v = + S.cardinal + (fst (try HM.find v g + with Not_found -> invalid_arg "[ocamlgraph] in_degree")) + + let iter_pred_e f g v = iter_pred (fun v2 -> f (v2, v)) g v + let fold_pred_e f g v = fold_pred (fun v2 -> f (v2, v)) g v + + let pred_e g v = fold_pred_e (fun e l -> e :: l) g v [] + +end + +module BidirectionalLabeled + (V:COMPARABLE)(E:ORDERED_TYPE)(HM:HM with type key = V.t) = +struct + + module VE = OTProduct(V)(E) + module S = Set.Make(VE) + + module E = struct + type vertex = V.t + type label = E.t + type t = vertex * label * vertex + let src (v, _, _) = v + let dst (_, _, v) = v + let label (_, l, _) = l + let create v1 l v2 = v1, l, v2 + module C = OTProduct(V)(VE) + let compare (x1, x2, x3) (y1, y2, y3) = + C.compare (x1, (x3, x2)) (y1, (y3, y2)) + end + type edge = E.t + + let mem_edge g v1 v2 = + try S.exists (fun (v2', _) -> V.equal v2 v2') (snd (HM.find v1 g)) + with Not_found -> false + + let mem_edge_e g (v1, l, v2) = + try + let ve = v2, l in + S.exists (fun ve' -> VE.compare ve ve' = 0) (snd (HM.find v1 g)) + with Not_found -> + false + + exception Found of edge + let find_edge g v1 v2 = + try + S.iter + (fun (v2', l) -> if V.equal v2 v2' then raise (Found (v1, l, v2'))) + (snd (HM.find v1 g)); + raise Not_found + with Found e -> + e + + let find_all_edges g v1 v2 = + try + S.fold + (fun (v2', l) acc -> + if V.equal v2 v2' then (v1, l, v2') :: acc else acc) + (snd (HM.find v1 g)) + [] + with Not_found -> + [] + + let unsafe_remove_edge g v1 v2 = + let in_set, out_set = HM.find v1 g in + let del v set = S.filter (fun (v', _) -> not (V.equal v v')) set in + let g = HM.add v1 (in_set, del v2 out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (del v1 in_set, out_set) g + + let unsafe_remove_edge_e g (v1, l, v2) = + let in_set, out_set = HM.find v1 g in + let g = HM.add v1 (in_set, S.remove (v2, l) out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (S.remove (v1, l) in_set, out_set) g + + let remove_edge g v1 v2 = +(* if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge";*) + let in_set, out_set = HM.find_and_raise v1 g "[ocamlgraph] remove_edge" in + let del v set = S.filter (fun (v', _) -> not (V.equal v v')) set in + let g = HM.add v1 (in_set, del v2 out_set) g in + let in_set, out_set = HM.find_and_raise v2 g "[ocamlgraph] remove_edge" in + HM.add v2 (del v1 in_set, out_set) g + + let remove_edge_e g (v1, l, v2) = +(* if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge_e";*) + let in_set, out_set = HM.find_and_raise v1 g "[ocamlgraph] remove_edge_e" in + let g = HM.add v1 (in_set, S.remove (v2, l) out_set) g in + let in_set, out_set = HM.find_and_raise v2 g "[ocamlgraph] remove_edge_e" in + HM.add v2 (S.remove (v1, l) in_set, out_set) g + + let iter_succ f g v = + S.iter + (fun (w, _) -> f w) + (snd (HM.find_and_raise v g "[ocamlgraph] iter_succ")) + + let fold_succ f g v = + S.fold + (fun (w, _) -> f w) + (snd (HM.find_and_raise v g "[ocamlgraph] fold_succ")) + + let iter_succ_e f g v = + S.iter + (fun (w, l) -> f (v, l, w)) + (snd (HM.find_and_raise v g "[ocamlgraph] iter_succ_e")) + + let fold_succ_e f g v = + S.fold + (fun (w, l) -> f (v, l, w)) + (snd (HM.find_and_raise v g "[ocamlgraph] fold_succ_e")) + + let succ g v = fold_succ (fun w l -> w :: l) g v [] + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map + (fun v (s1,s2) -> + f v, + (S.fold (fun (v, l) s -> S.add (f v, l) s) s1 S.empty, + S.fold (fun (v, l) s -> S.add (f v, l) s) s2 S.empty)) + + module I = struct + type t = (S.t * S.t) HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v (_,outset) -> + S.iter (fun (w, _) -> f v w) outset) + let fold_edges f = HM.fold (fun v (_,outset) -> + S.fold (fun (w, _) -> f v w) outset) + let iter_edges_e f = HM.iter (fun v (_,outset) -> + S.iter (fun (w, l) -> f (v, l, w)) outset) + let fold_edges_e f = HM.fold (fun v (_,outset) -> + S.fold (fun (w, l) -> f (v, l, w)) outset) + end + include I + + let iter_pred f g v = + S.iter + (fun (w, _) -> f w) + (fst (HM.find_and_raise v g "[ocamlgraph] iter_pred")) + + let fold_pred f g v = + S.fold + (fun (w, _) -> f w) + (fst (HM.find_and_raise v g "[ocamlgraph] fold_pred")) + + let in_degree g v = + S.cardinal + (fst (try HM.find v g + with Not_found -> invalid_arg "[ocamlgraph] in_degree")) + + let iter_pred_e f g v = + S.iter + (fun (w, l) -> f (w, l, v)) + (fst (HM.find_and_raise v g "[ocamlgraph] iter_pred_e")) + + let fold_pred_e f g v = + S.fold + (fun (w, l) -> f (w, l, v)) + (fst (HM.find_and_raise v g "[ocamlgraph] fold_pred_e")) + + let pred g v = fold_pred (fun w l -> w :: l) g v [] + let pred_e g v = fold_pred_e (fun e l -> e :: l) g v [] + +end + +(** Build persistent (resp. imperative) graphs from a persistent (resp. + imperative) association table *) +module Make(F : TBL_BUILDER) = struct + + module Digraph = struct + + module Concrete(V: COMPARABLE) = struct + + include ConcreteVertex(F)(V) + include Unlabeled(V)(HM) + include Minimal(S)(HM) + + let add_edge g v1 v2 = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge g v1 v2 + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + end + + module ConcreteBidirectional(V: COMPARABLE) = struct + + include ConcreteVertex(F)(V) + include BidirectionalUnlabeled(V)(HM) + include BidirectionalMinimal(S)(HM) + + let unsafe_add_edge g v1 v2 = + let in_set, out_set = HM.find v1 g in + let g = HM.add v1 (in_set,S.add v2 out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (S.add v1 in_set,out_set) g + + let add_edge g v1 v2 = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge g v1 v2 + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + end + + module ConcreteLabeled(V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = struct + + include ConcreteVertex(F)(V) + include Labeled(V)(Edge)(HM) + include Minimal(S)(HM) + + let add_edge_e g (v1, l, v2) = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge g v1 (v2, l) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + end + + module ConcreteBidirectionalLabeled + (V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = + struct + + include ConcreteVertex(F)(V) + include BidirectionalLabeled(V)(Edge)(HM) + include BidirectionalMinimal(S)(HM) + + let unsafe_add_edge_e g (v1, l, v2) = + let in_set, out_set = HM.find v1 g in + let g = HM.add v1 (in_set,S.add (v2,l) out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (S.add (v1,l) in_set,out_set) g + + let unsafe_add_edge g v1 v2 = + unsafe_add_edge_e g (v1, Edge.default, v2) + + let add_edge_e g (v1, l, v2) = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge_e g (v1, l, v2) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + end + + module Abstract(V: VERTEX) = struct + module G = struct + module V = V + module HM = F(V) + include Unlabeled(V)(HM) + include Minimal(S)(HM) + end + include Make_Abstract(G) + end + + module AbstractLabeled(V: VERTEX)(E: ORDERED_TYPE_DFT) = struct + module G = struct + module V = V + module HM = F(V) + include Labeled(V)(E)(HM) + include Minimal(S)(HM) + end + include Make_Abstract(G) + end + + end + +end + +(** Implementation of undirected graphs from implementation of directed + graphs. *) +module Graph + (G: sig + include Sig.G + val create: ?size:int -> unit -> t + val clear: t -> unit + val copy: t -> t + type return + val add_vertex: t -> vertex -> return + val remove_vertex: t -> vertex -> return + end) = +struct + + include G + + let is_directed = false + + (* Redefine iterators and [nb_edges]. *) + + let iter_edges f = + iter_edges (fun v1 v2 -> if V.compare v1 v2 >= 0 then f v1 v2) + + let fold_edges f = + fold_edges + (fun v1 v2 acc -> if V.compare v1 v2 >= 0 then f v1 v2 acc else acc) + + let iter_edges_e f = + iter_edges_e (fun e -> if V.compare (E.src e) (E.dst e) >= 0 then f e) + + let fold_edges_e f = + fold_edges_e + (fun e acc -> + if V.compare (E.src e) (E.dst e) >= 0 then f e acc else acc) + + let nb_edges g = fold_edges_e (fun _ -> (+) 1) g 0 + + (* Redefine operations on predecessors: + predecessors are successors in an undirected graph. *) + + let pred = succ + let in_degree = out_degree + let iter_pred = iter_succ + let fold_pred = fold_succ + let pred_e = succ_e + let iter_pred_e = iter_succ_e + let fold_pred_e = fold_succ_e + +end + +(* +Local Variables: +compile-command: "make -C .." +End: +*) diff --git a/lib/components.ml b/lib/components.ml new file mode 100644 index 0000000..04de431 --- /dev/null +++ b/lib/components.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: components.ml,v 1.9 2004-10-22 14:42:06 signoles Exp $ *) + +open Util + +module type G = sig + type t + module V : Sig.COMPARABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit +end + +module Make(G: G) = struct + + module H = Hashtbl.Make(G.V) + + let scc g = + let root = H.create 997 in + let hashcomp = H.create 997 in + let stack = ref [] in + let numdfs = ref 0 in + let numcomp = ref 0 in + let rec pop x = function + | (y, w) :: l when y > x -> + H.add hashcomp w !numcomp; + pop x l + | l -> l + in + let rec visit v = + if not (H.mem root v) then begin + let n = incr numdfs; !numdfs in + H.add root v n; + G.iter_succ + (fun w -> + visit w; + if not (H.mem hashcomp w) then + H.replace root v (min (H.find root v) (H.find root w))) + g v; + if H.find root v = n then begin + H.add hashcomp v !numcomp; + let s = pop n !stack in + stack:= s; + incr numcomp + end else + stack := (n,v) :: !stack; + end + in + G.iter_vertex visit g; + !numcomp, (fun v -> H.find hashcomp v) + + let scc_array g = + let n,f = scc g in + let t = Array.make n [] in + G.iter_vertex (fun v -> let i = f v in t.(i) <- v :: t.(i)) g; + t + + let scc_list g = + let _,scc = scc g in + let tbl = Hashtbl.create 97 in + G.iter_vertex + (fun v -> + let n = scc v in + try + let l = Hashtbl.find tbl n in + l := v :: !l + with Not_found -> + Hashtbl.add tbl n (ref [ v ])) + g; + Hashtbl.fold (fun _ v l -> !v :: l) tbl [] + +end diff --git a/lib/components.mli b/lib/components.mli new file mode 100644 index 0000000..b1e380c --- /dev/null +++ b/lib/components.mli @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: components.mli,v 1.12 2004-10-22 14:42:06 signoles Exp $ *) + +(** Strongly connected components. *) + +(** Minimal graph signature required by {!Make}. + Sub-signature of {!Sig.G}. *) +module type G = sig + type t + module V : Sig.COMPARABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit +end + +(** Functor providing functions to compute strongly connected components of a + graph. *) +module Make (G: G) : sig + + val scc : G.t -> int * (G.V.t -> int) + (** [scc g] computes the strongly connected components of [g]. + The result is a pair [(n,f)] where [n] is the number of + components. Components are numbered from [0] to [n-1], and + [f] is a function mapping each vertex to its component + number. In particular, [f u = f v] if and only if [u] and + [v] are in the same component. Another property of the + numbering is that components are numbered in a topological + order: if there is an arc from [u] to [v], then [f u >= f u] + + Not tail-recursive. + Complexity: O(V+E) + The function returned has complexity O(1) *) + + val scc_array : G.t -> G.V.t list array + (** [scc_array] computes the strongly connected components of [g]. + Components are stored in the resulting array, indexed with a + numbering with the same properties as for [scc] above. *) + + val scc_list : G.t -> G.V.t list list + (** [scc_list] computes the strongly connected components of [g]. + The result is a partition of the set of the vertices of [g]. *) + +end diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml new file mode 100644 index 0000000..a83bedb --- /dev/null +++ b/lib/flowvisor.ml @@ -0,0 +1,792 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Lwt +open Net + +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event +module OSK = Openflow.Ofsocket +open OP +open OP.Flow +open OP.Flow_mod +open OP.Match + +let sp = Printf.sprintf +let cp = OS.Console.log +let to_port = OP.Port.port_of_int +let of_port = OP.Port.int_of_port + +exception Ofcontroller_error of int32 * OP.error_code * OP.t +exception Ofswitch_error of int64 * int32 * OP.error_code * OP.t + +(* fake switch state to be exposed to controllers *) +type port = { + port_id: int; + port_name: string; + phy: OP.Port.phy; + origin_dpid: int64; + origin_port_id: int; +} + +type cached_reply = + | Flows of OP.Flow.stats list + | Aggr of OP.Stats.aggregate + | Table of OP.Stats.table + | Port of OP.Port.stats list + | No_reply + +type xid_state = { + xid : int32; + src : int64; + mutable dst : int64 list; + ts : float; + mutable cache : cached_reply; +} + +type t = { + verbose : bool; + (* counters *) + mutable errornum : int32; + mutable portnum : int; + mutable xid_count : int32; + mutable buffer_id_count: int32; + + (* controller and switch storage *) + mutable controllers : (int64 * OP.Match.t *Openflow.Ofsocket.conn_state ) list; + switches : (int64, OC.t) Hashtbl.t; + + (* Mapping transients id values *) + xid_map : (int32, xid_state) Hashtbl.t; + port_map : (int, (int64 * int * OP.Port.phy)) Hashtbl.t; + buffer_id_map : (int32, (OP.Packet_in.t * int64)) Hashtbl.t; + + (* topology managment module *) + flv_topo: Flowvisor_topology.t; +} + +(* timeout pending queries after 3 minutes *) +let timeout = 180. + +let supported_actions () = + OP.Switch.( + {output=true;set_vlan_id=true;set_vlan_pcp=true;strip_vlan=true; + set_dl_src=true; set_dl_dst=true; set_nw_src=true; set_nw_dst=true; + set_nw_tos=true; set_tp_src=true; set_tp_dst=true; enqueue=false; + vendor=false; }) + +let supported_capabilities () = + OP.Switch.({flow_stats=true;table_stats=true;port_stats=true;stp=false; + ip_reasm=false;queue_stats=false;arp_match_ip=true;}) + +let switch_features datapath_id ports = + OP.Switch.({datapath_id; n_buffers=0l; n_tables=(char_of_int 1); + capabilities=(supported_capabilities ()); + actions=(supported_actions ()); ports;}) + +let init_flowvisor verbose flv_topo = + {verbose; errornum=0l; portnum=10; xid_count=0l; + port_map=(Hashtbl.create 64); + controllers=[]; buffer_id_map=(Hashtbl.create 64); + buffer_id_count=0l; xid_map=(Hashtbl.create 64); + switches=(Hashtbl.create 64); flv_topo; } + +(* xid buffer controller functions *) +let match_dpid_buffer_id st dpid buffer_id = + try + let (_, dst_dpid) = Hashtbl.find st.buffer_id_map buffer_id in + (dpid = dst_dpid) + with Not_found -> false +let get_new_xid old_xid st src dst cache = + let xid = st.xid_count in + let _ = st.xid_count <- Int32.add st.xid_count 1l in + let r = {xid; src; dst; ts=(OS.Clock.time ()); cache;} in + let _ = Hashtbl.replace st.xid_map xid r in + xid + +let handle_xid flv st xid_st = + match xid_st.cache with + | Flows flows -> + let stats = OP.Stats.({st_ty=FLOW; more=true;}) in + let (_, _, t) = List.find ( + fun (dpid, _, _) -> dpid = xid_st.src ) + flv.controllers in + lwt (_, flows) = + Lwt_list. fold_right_s ( + fun fl (sz, flows) -> + let fl_sz = OP.Flow.flow_stats_len fl in + if (sz + fl_sz > 0xffff) then + let r = OP.Stats.Flow_resp(stats, flows) in + let h = OP.Header.create ~xid:(xid_st.xid) OP.Header.STATS_RESP 0 in + lwt _ = Openflow.Ofsocket.send_packet t (OP.Stats_resp (h, r)) in + return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) + else + return ((sz + fl_sz), (fl::flows)) ) + flows ((OP.Header.get_len + OP.Stats.get_resp_hdr_size), []) in + let stats = OP.Stats.({st_ty=FLOW; more=false;}) in + let r = OP.Stats.Flow_resp(stats, flows) in + let h = OP.Header.create ~xid:xid_st.xid OP.Header.STATS_RESP 0 in + Openflow.Ofsocket.send_packet t (OP.Stats_resp (h, r)) + | _ -> return () + +let timeout_xid flv st = + while_lwt true do + let time = OS.Clock.time () in + let xid = + Hashtbl.fold ( + fun xid r ret -> + if (r.ts+.timeout>time) then + let _ = Hashtbl.remove st.xid_map xid in + r :: ret + else ret + ) st.xid_map [] in + lwt _ = Lwt_list.iter_p (handle_xid flv st) xid in + OS.Time.sleep 600. + done + +(* communication primitives *) +let switch_dpid flv = Hashtbl.fold (fun dpid _ r -> r@[dpid]) flv.switches [] +let switch_chan_dpid flv = Hashtbl.fold (fun dpid ch r -> (dpid,ch)::r) flv.switches [] +let dpid_of_port st inp = + try + let (in_dpid, _, _) = Hashtbl.find st.port_map (of_port inp) in + in_dpid + with Not_found -> 0L +let port_of_port st inp = + try + let (_, inp, _) = Hashtbl.find st.port_map (of_port inp) in + OP.Port.Port(inp) + with Not_found -> OP.Port.No_port +let dpid_port_of_port_exn st inp xid msg = + try + let (dpid, p, _) = Hashtbl.find st.port_map (of_port inp) in + (dpid, OP.Port.Port(p)) + with Not_found -> + raise (Ofcontroller_error (xid, OP.ACTION_BAD_OUT_PORT, msg) ) + + + +let send_all_switches st msg = + Lwt_list.iter_p ( + fun (dpid, ch) -> OC.send_data ch dpid msg) + (Hashtbl.fold (fun dpid ch c -> c @[(dpid, ch)]) st.switches []) +let send_switch st dpid msg = + try_lwt + let ch = Hashtbl.find st.switches dpid in + OC.send_data ch dpid msg + with Not_found -> return (cp (sp "[flowvisor] unregister dpid %Ld\n%!" dpid)) + +let send_controller t msg = OSK.send_packet t msg +let inform_controllers flv m msg = + (* find the controller that should handle the packet in *) + Lwt_list.iter_p + (fun (_, rule, t) -> + if (OP.Match.flow_match_compare rule m rule.OP.Match.wildcards) then + Openflow.Ofsocket.send_packet t msg + else return ()) flv.controllers + +(************************************************* +* Switch OpenFlow control channel + *************************************************) +let packet_out_create st msg xid inp bid data actions = + let data = + match (bid) with + | -1l -> data + (* if no buffer id included, send the data section of the + * packet_out*) + | bid when (Hashtbl.mem st.buffer_id_map bid) -> + (* if we have a buffer id in cache, use those data *) + let (pkt, _ ) = Hashtbl.find st.buffer_id_map bid in + let _ = Hashtbl.remove st.buffer_id_map bid in + pkt.OP.Packet_in.data + | _ -> raise (Ofcontroller_error(xid, OP.REQUEST_BUFFER_UNKNOWN, msg) ) + in + let in_port = port_of_port st inp in + let m = OP.Packet_out.create ~buffer_id:(-1l) + ~actions ~in_port ~data () in + let h = OP.Header.(create ~xid PACKET_OUT 0) in + OP.Packet_out (h,m) + + let rec pkt_out_process st xid inp bid data msg acts = function + | (OP.Flow.Output(OP.Port.All, len))::tail + | (OP.Flow.Output(OP.Port.Flood, len))::tail -> begin + let actions = acts @ [OP.Flow.Output(OP.Port.Flood, len)] in + (* OP.Port.None is not the appropriate way to handle this. Need to find the + * port that connects the two switches probably. *) + let in_dpid = dpid_of_port st inp in +(* let _ = pp "sending packet from port %d to port %d\n%!" + * (OP.Port.int_of_port inp) (in_p) in *) + let msg = packet_out_create st msg xid OP.Port.No_port (-1l) data actions in + lwt _ = + Lwt_list.iter_p ( + fun (dpid, ch) -> + if (dpid = in_dpid) then + OC.send_data ch dpid + (packet_out_create st msg xid inp (-1l) data actions) + else + OC.send_data ch dpid msg + ) (Hashtbl.fold (fun dpid ch c -> c @[(dpid, ch)]) st.switches []) in + pkt_out_process st xid inp bid data msg acts tail + end + | (OP.Flow.Output(OP.Port.In_port, len))::tail -> begin + (* output packet to the last hop of the path *) + let (dpid, out_p) = dpid_port_of_port_exn st inp xid msg in + let actions = acts @ [OP.Flow.Output(OP.Port.In_port, len)] in + lwt _ = send_switch st dpid + (packet_out_create st msg xid out_p bid data actions) in + pkt_out_process st xid inp bid data msg acts tail + end + | (OP.Flow.Output(OP.Port.Port(p), len))::tail -> begin + (* output packet to the last hop of the path *) + let (dpid, out_p) = dpid_port_of_port_exn st (to_port p) xid msg in + let actions = acts @ [OP.Flow.Output(out_p, len)] in + let msg = packet_out_create st msg xid inp bid data actions in + lwt _ = send_switch st dpid + (packet_out_create st msg xid inp bid data actions) in + pkt_out_process st xid inp bid data msg acts tail + end + | (OP.Flow.Output(OP.Port.Controller, len))::tail + | (OP.Flow.Output(OP.Port.Table, len))::tail + | (OP.Flow.Output(OP.Port.Local, len))::tail + | (OP.Flow.Output(OP.Port.No_port, len))::tail + | (OP.Flow.Output(OP.Port.Normal, len))::tail -> + raise (Ofcontroller_error (xid, OP.REQUEST_BAD_STAT, msg) ) + | a :: tail -> + (* for the non-output action, populate the new action list *) + pkt_out_process st xid inp bid data msg (acts @ [a]) tail + | [] -> return () + +let map_path flv in_dpid in_port out_dpid out_port = +(* let _ = pp "[flowvisor-switch] mapping a path between %Ld:%s - %Ld:%s\n%!" + in_dpid (OP.Port.string_of_port in_port) + out_dpid (OP.Port.string_of_port out_port) in *) + if (in_dpid = out_dpid) then [(out_dpid, in_port, out_port)] + else + Flowvisor_topology.find_dpid_path flv.flv_topo + in_dpid in_port out_dpid out_port +(* let path = List.rev path in *) +(* let _ = + List.iter ( + fun (dp, in_p, out_p) -> + pp "%s:%Ld:%s -> " + (OP.Port.string_of_port in_p) + dp (OP.Port.string_of_port out_p) + ) path in + let _ = pp "\n%!" in + path *) + +(* TODO fixme!!!! *) +let map_spanning_tree flv in_dpid in_port = [] + +let rec send_flow_mod_to_path st xid msg pkt len actions path = + let h = OP.Header.create ~xid OP.Header.FLOW_MOD 0 in + match path with + | [] -> return () + | [(dpid, in_port, out_port)] -> begin + let actions = actions @ [OP.Flow.Output(out_port, len)] in + let _ = pkt.of_match.in_port <- in_port in + let fm = OP.Flow_mod.( + {pkt with buffer_id=(-1l);out_port=(OP.Port.No_port);actions;}) in + lwt _ = send_switch st dpid (OP.Flow_mod(h, fm)) in + match (pkt.buffer_id) with + | -1l -> return () + | bid when (Hashtbl.mem st.buffer_id_map bid) -> + (* if we have a buffer id in cache, use those data *) + let (pkt, _ ) = Hashtbl.find st.buffer_id_map bid in + let msg = packet_out_create st msg xid (OP.Port.No_port) + (-1l) (pkt.OP.Packet_in.data) actions in + lwt _ = send_switch st dpid msg in + return () + | _ -> + (* if buffer id is unknown, send error *) + raise (Ofcontroller_error(xid, OP.REQUEST_BUFFER_UNKNOWN, msg)) + end + | ((dpid, in_port, out_port)::rest) -> begin + let _ = pkt.of_match.in_port <- in_port in + let fm = OP.Flow_mod.( + {pkt with buffer_id=(-1l);out_port=(OP.Port.No_port); + actions=( [OP.Flow.Output(out_port, len)] );}) in + lwt _ = send_switch st dpid (OP.Flow_mod(h, fm)) in + send_flow_mod_to_path st xid msg pkt len actions rest + end + +let rec flow_mod_translate_inner st msg xid pkt in_dpid in_port acts = function + | (OP.Flow.Output(OP.Port.All, len))::tail + | (OP.Flow.Output(OP.Port.Flood, len))::tail -> + (* Need a spanning tree maybe for this? *) + lwt _ = send_flow_mod_to_path st xid msg pkt len acts + (map_spanning_tree st in_dpid in_port) in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + | (OP.Flow.Output(OP.Port.In_port, len))::tail -> + lwt _ = send_flow_mod_to_path st xid msg pkt len acts + [(in_dpid, OP.Port.Port(in_port), OP.Port.In_port)] in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + | (OP.Flow.Output(OP.Port.Controller, len))::tail -> + lwt _ = send_flow_mod_to_path st xid msg pkt len acts + [(in_dpid, OP.Port.Port(in_port), OP.Port.Controller)] in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + | (OP.Flow.Output(OP.Port.Port(p), len))::tail -> + let (out_dpid, out_port) = dpid_port_of_port_exn st (to_port p) xid msg in + lwt _ = send_flow_mod_to_path st xid msg pkt len acts + (map_path st in_dpid (OP.Port.Port(in_port) ) + out_dpid out_port) in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + | (OP.Flow.Output(OP.Port.Table, _))::_ + | (OP.Flow.Output(OP.Port.Local, _))::_ + | (OP.Flow.Output(OP.Port.Normal, _))::_ -> + raise (Ofcontroller_error (xid, OP.REQUEST_BAD_STAT, msg) ) + | a :: tail -> flow_mod_translate_inner st msg xid pkt in_dpid in_port (acts@[a]) tail + | [] -> return () + +let flow_mod_add_translate st msg xid pkt = + let (in_dpid, in_port) = dpid_port_of_port_exn st pkt.of_match.in_port xid msg in + flow_mod_translate_inner st msg xid pkt in_dpid (of_port in_port) [] pkt.actions + +let flow_mod_del_translate st msg xid pkt = + match (pkt.of_match.OP.Match.wildcards.OP.Wildcards.in_port, + pkt.of_match.OP.Match.in_port, pkt.OP.Flow_mod.out_port) with + | (false, OP.Port.Local, OP.Port.No_port) + | (true, _, OP.Port.No_port) -> + let h = OP.Header.(create ~xid FLOW_MOD 0) in + send_all_switches st (OP.Flow_mod(h, pkt)) + | (false, OP.Port.Port(p), OP.Port.No_port) -> + let (dpid, port) = dpid_port_of_port_exn st (to_port p) xid msg in + let _ = pkt.of_match.in_port <- port in + let h = OP.Header.(create ~xid FLOW_MOD 0) in + send_switch st dpid (OP.Flow_mod(h, pkt)) + | (false, OP.Port.Port(in_p), OP.Port.Port(out_p)) -> + let (in_dpid, in_port) = dpid_port_of_port_exn st + pkt.of_match.OP.Match.in_port xid msg in + let (out_dpid, out_port) = dpid_port_of_port_exn st + pkt.OP.Flow_mod.out_port xid msg in + lwt _ = send_flow_mod_to_path st xid msg pkt 0 [] + (map_path st in_dpid in_port out_dpid out_port) in + return () + | _ -> raise (Ofcontroller_error (xid, OP.REQUEST_BAD_STAT, msg) ) + +let process_openflow st dpid t msg = + let _ = if st.verbose then cp (sp "[flowvisor-switch] %s\n%!" (OP.to_string msg)) in + match msg with + | OP.Hello (h) -> return () + | OP.Echo_req (h) -> (* Reply to ECHO requests *) + let open OP.Header in + send_controller t (OP.Echo_resp (create ECHO_RESP ~xid:h.xid get_len)) + | OP.Features_req (h) -> + let h = OP.Header.(create FEATURES_RESP ~xid:h.xid 0) in + let f = switch_features dpid + (Hashtbl.fold (fun _ (_, _, p) r -> p::r) + st.port_map []) in + send_controller t (OP.Features_resp(h, f)) + | OP.Stats_req(h, req) -> begin + (* TODO Need to translate the xid here *) + match req with + | OP.Stats.Desc_req(req) -> + let open OP.Stats in + let desc = { imfr_desc="Mirage"; hw_desc="Mirage"; + sw_desc="Mirage_flowvisor"; serial_num="0.1"; + dp_desc="Mirage";} in + let resp_h = {st_ty=DESC;more=false;} in + send_controller t + (OP.Stats_resp(h, (Desc_resp(resp_h,desc)))) + | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> begin + (*TODO Need to consider the table_id and the out_port and + * split reply over multiple openflow packets if they don't + * fit a single packet. *) + match (of_match.OP.Match.wildcards.OP.Wildcards.in_port, + (of_match.OP.Match.in_port)) with + | (false, OP.Port.Port(p)) -> + let (dst_dpid, out_port) = dpid_port_of_port_exn st + of_match.OP.Match.in_port h.OP.Header.xid msg in + let xid = get_new_xid h.OP.Header.xid st dst_dpid [dpid] (Flows [])in + let h = OP.Header.(create STATS_RESP ~xid 0) in + let of_match = OP.Match.translate_port of_match out_port in + (* TODO out_port needs processing. if dpid are between + * different switches need to define the outport + * as the port of the interconnection link *) + let req = OP.Stats.( + Flow_req(req_h, of_match, table_id, out_port)) in + send_switch st dst_dpid (OP.Stats_req(h, req)) + | (_, _) -> + let req = OP.Stats.(Flow_req(req_h, of_match,table_id, out_port)) in + let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) (Flows []) in + let h = OP.Header.(create STATS_RESP ~xid 0) in + send_all_switches st (OP.Stats_req(h, req)) + end + | OP.Stats.Aggregate_req (req_h, of_match, table_id, out_port) -> + begin + let open OP.Stats in + let open OP.Header in + let cache = Aggr ({packet_count=0L; byte_count=0L;flow_count=0l;}) in + match OP.Match.(of_match.wildcards.OP.Wildcards.in_port,(of_match.in_port)) with + | (false, OP.Port.Port(p)) -> + let (dst_dpid, port) = dpid_port_of_port_exn st of_match.in_port h.xid msg in + let xid = get_new_xid h.xid st dpid [dst_dpid] cache in + let h = { h with xid;} in + let _ = of_match.in_port <- port in + (* TODO out_port needs processing. if dpid are between + * different switches need to define the outport as the + * port of the interconnection link *) + let m = Aggregate_req(req_h, of_match, table_id, out_port) in + send_switch st dst_dpid (OP.Stats_req(h, m)) + | (_, _) -> + let open OP.Header in + let h = {h with xid=(get_new_xid h.xid st dpid + (switch_dpid st) cache);} in + send_all_switches st (OP.Stats_req(h, req)) + end + | OP.Stats.Table_req(req_h) -> + let open OP.Header in + let cache = Table OP.Stats.(init_table_stats (OP.Stats.table_id_of_int 1) + "mirage" (OP.Wildcards.full_wildcard ()) ) in + let xid = get_new_xid h.xid st dpid (switch_dpid st) cache in + let h = {h with xid;} in + send_all_switches st (OP.Stats_req(h, req)) + | OP.Stats.Port_req(req_h, port) -> begin + match port with + | OP.Port.No_port -> + let open OP.Header in + let xid = get_new_xid h.xid st dpid (switch_dpid st) (Port []) in + let h = ({h with xid;}) in + send_all_switches st (OP.Stats_req(h, req)) + | OP.Port.Port(_) -> + let open OP.Header in + let (dst_dpid, port) = dpid_port_of_port_exn st port h.xid msg in + let xid = get_new_xid h.xid st dpid [dst_dpid] (Port []) in + let h = {h with xid;} in + let m = OP.Stats.(Port_req(req_h, port)) in + send_all_switches st (OP.Stats_req(h, m)) + | _ -> + raise (Ofcontroller_error (h.OP.Header.xid, OP.QUEUE_OP_BAD_PORT, msg)) + end + | _ -> + raise (Ofcontroller_error (h.OP.Header.xid, OP.REQUEST_BAD_STAT, msg)) + end + | OP.Get_config_req(h) -> + (* TODO make a custom reply tothe query *) + let h = OP.Header.({h with ty=FEATURES_RESP}) in + send_controller t (OP.Get_config_resp(h, OP.Switch.init_switch_config)) + | OP.Barrier_req(h) -> + (* TODO just reply for now. need to check this with all switches *) +(* let xid = get_new_xid dpid in *) + let _ = cp (sp "BARRIER_REQ: %s\n%!" (OP.Header.header_to_string h)) in + send_controller t (OP.Barrier_resp (OP.Header.({h with ty=BARRIER_RESP;})) ) + | OP.Packet_out(h, pkt) -> begin + let _ = if st.verbose then cp (sp "[flowvisor-switch] PACKET_OUT: %s\n%!" + (OP.Packet_out.packet_out_to_string pkt)) in + (* Check if controller has the right to send traffic on the specific subnet *) + try_lwt + OP.Packet_out.(pkt_out_process st h.OP.Header.xid pkt.in_port + pkt.buffer_id pkt.data msg [] pkt.actions ) + with exn -> + return (cp (sp "[flowvisor-switch] packet_out message error %s\n%!" + (Printexc.to_string exn))) + end + | OP.Flow_mod(h,fm) -> begin + let _ = if st.verbose then cp (sp "[flowvisor-switch] FLOW_MOD: %s\n%!" + (OP.Flow_mod.flow_mod_to_string fm)) in + let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) No_reply in + match (fm.OP.Flow_mod.command) with + | OP.Flow_mod.ADD + | OP.Flow_mod.MODIFY + | OP.Flow_mod.MODIFY_STRICT -> + flow_mod_add_translate st msg xid fm + | OP.Flow_mod.DELETE + | OP.Flow_mod.DELETE_STRICT -> + flow_mod_del_translate st msg xid fm + end + (*Unsupported switch actions *) + | OP.Port_mod (h, _) + | OP.Queue_get_config_resp (h, _, _) + | OP.Queue_get_config_req (h, _) + | OP.Set_config (h, _) (* -> + send_controller t + (OP.marshal_error OP.REQUEST_BAD_TYPE bits h.OP.Header.xid) *) + (* Message that should not be received by a switch *) + | OP.Port_status (h, _) + | OP.Flow_removed (h, _) + | OP.Packet_in (h, _) + | OP.Get_config_resp (h, _) + | OP.Barrier_resp h + | OP.Stats_resp (h, _) + | OP.Features_resp (h, _) + | OP.Vendor (h, _) + | OP.Echo_resp (h) + | OP.Error (h, _, _) -> + let h = OP.Header.(create ~xid:h.xid OP.Header.ERROR 0) in + let bits = OP.marshal msg in + send_controller t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits) ) + +let switch_channel st dpid of_m sock = + let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in + lwt _ = Openflow.Ofsocket.send_packet sock (OP.Hello h) in + let _ = st.controllers <- (dpid, of_m, sock)::st.controllers in + let continue = ref true in + while_lwt !continue do + try_lwt + lwt ofp = Openflow.Ofsocket.read_packet sock in + process_openflow st dpid sock ofp + with + | Nettypes.Closed -> + let _ = continue := false in + return (cp (sp "[flowvisor-switch] control channel closed\n%!") ) + | OP.Unparsed (m, bs) -> + return (cp (sp "[flowvisor-switch] # unparsed! m=%s\n %!" m)) + | Ofcontroller_error (xid, error, msg)-> + let h = OP.Header.create ~xid OP.Header.ERROR 0 in + send_switch st dpid (OP.Error(h, error, (OP.marshal msg))) + | exn -> return (cp (sp "[flowvisor-switch] ERROR:%s\n" + (Printexc.to_string exn))) + done + +(* + * openflow controller threads + * *) +let add_flowvisor_port flv dpid port = + let port_id = flv.portnum in + let _ = flv.portnum <- flv.portnum + 1 in + let phy = OP.Port.translate_port_phy port port_id in + let _ = Hashtbl.add flv.port_map port_id + (dpid, port.OP.Port.port_no, phy) in + lwt _ = Flowvisor_topology.add_port flv.flv_topo dpid port.OP.Port.port_no + port.OP.Port.hw_addr in + let h = OP.Header.(create PORT_STATUS 0 ) in + let status = OP.Port_status(h, (OP.Port.({reason=OP.Port.ADD; desc=phy;}))) in + Lwt_list.iter_p + (fun (dpid, _, conn) -> + Openflow.Ofsocket.send_packet conn status ) flv.controllers + +(* + * openflow controller threads + **) +let del_flowvisor_port flv desc = + let h = OP.Header.(create PORT_STATUS 0 ) in + let status = OP.Port_status(h, (OP.Port.({reason=OP.Port.ADD;desc;}))) in + Lwt_list.iter_p + (fun (dpid, _, conn) -> + Openflow.Ofsocket.send_packet conn status ) flv.controllers + +let map_flv_port flv dpid port = + (* map the new port *) + let p = + Hashtbl.fold ( + fun flv_port (sw_dpid, sw_port, _) r -> + if ((dpid = sw_dpid) && + (sw_port = port)) then flv_port + else r ) flv.port_map (-1) in + if (p < 0) then OP.Port.Port(port) + else OP.Port.Port (p) + +let translate_stat flv dpid f = + (* Translate match *) + let _ = + match (f.OP.Flow.of_match.OP.Match.wildcards.OP.Wildcards.in_port, + f.OP.Flow.of_match.OP.Match.in_port) with + | (false, OP.Port.Port(p) ) -> + f.OP.Flow.of_match.OP.Match.in_port <- map_flv_port flv dpid p + | _ -> () + in + + let _ = + f.OP.Flow.action <- List.map + (fun act -> + match act with + | OP.Flow.Output(OP.Port.Port(p), len ) -> + let p = map_flv_port flv dpid p in + OP.Flow.Output(p, len ) + | _ -> act) f.OP.Flow.action in + (* Translate actions *) + f + +let process_switch_channel flv st dpid e = + try_lwt + let _ = if (flv.verbose) then cp (sp "[flowvisor-ctrl] %s\n%!" (OE.string_of_event e)) in + match e with + | OE.Datapath_join(dpid, ports) -> + let _ = cp (sp "[flowvisor-ctrl]+ switch dpid:%Ld\n%!" dpid) in + let _ = Flowvisor_topology.add_channel flv.flv_topo dpid st in + (* Update local state *) + let _ = Hashtbl.replace flv.switches dpid st in + Lwt_list.iter_p (add_flowvisor_port flv dpid) ports + | OE.Datapath_leave(dpid) -> + let _ = (cp(sp "[flowvisor-ctrl]- switch dpid:%Ld\n%!" dpid)) in + let _ = Flowvisor_topology.remove_dpid flv.flv_topo dpid in + (* Need to remove ports and port mapping and disard any state + * pending for replies. *) + Lwt_list.iter_p (del_flowvisor_port flv) + ( Hashtbl.fold (fun vp (dp, _, phy) r -> + if (dp = dpid) then + let _ = Hashtbl.remove flv.port_map vp in + phy::r else r) flv.port_map []) + | OE.Packet_in(in_port, reason, buffer_id, data, dpid) -> begin + let m = OP.Match.raw_packet_to_match in_port data in + match (in_port, m.OP.Match.dl_type) with + | (OP.Port.Port(p), 0x88cc) -> begin + match (Flowvisor_topology.process_lldp_packet + flv.flv_topo dpid p data) with + | true -> return () + | false -> + let in_port = map_flv_port flv dpid p in + let h = OP.Header.(create PACKET_IN 0) in + let pkt = OP.Packet_in.({buffer_id=(-1l);in_port;reason;data;}) in + inform_controllers flv m (OP.Packet_in(h, pkt)) + end + | (OP.Port.Port(p), _) when + not (Flowvisor_topology.is_transit_port flv.flv_topo dpid p) -> begin + (* translate the buffer id information *) + let buffer_id = flv.buffer_id_count in + flv.buffer_id_count <- Int32.succ flv.buffer_id_count; + + (* generate packet bits *) + let in_port = map_flv_port flv dpid p in + let h = OP.Header.(create PACKET_IN 0) in + let pkt = OP.Packet_in.({buffer_id;in_port;reason;data;}) in + let _ = Hashtbl.add flv.buffer_id_map buffer_id (pkt, dpid) in + inform_controllers flv m (OP.Packet_in(h, pkt)) + end + | (OP.Port.Port(p), _) -> return () + | _ -> + let _ = cp (sp "[flowvisor-ctrl] Invalid port on Packet_in\n%!") in + let h = OP.Header.(create ERROR 0) in + inform_controllers flv m + (OP.Error(h, OP.REQUEST_BAD_STAT, (Cstruct.create 0))) + end + | OE.Flow_removed(of_match, r, dur_s, dur_ns, pkts, bytes, dpid) -> + (* translate packet *) + let new_in_p = map_flv_port flv dpid (of_port of_match.OP.Match.in_port) in + (* TODO need to pass cookie id, idle, and priority *) + let _ = of_match.OP.Match.in_port <- new_in_p in + let pkt = + OP.Flow_removed.( + {of_match; cookie=0L;reason=r; priority=0;idle_timeout=0; + duration_sec=dur_s; duration_nsec=dur_ns; packet_count=pkts; + byte_count=bytes;}) in + let h = OP.Header.(create FLOW_REMOVED 0) in + inform_controllers flv of_match (OP.Flow_removed(h, pkt)) + (* TODO: Need to write code to handle stats replies *) + | OE.Flow_stats_reply(xid, more, flows, dpid) -> begin + if Hashtbl.mem flv.xid_map xid then ( + let xid_st = Hashtbl.find flv.xid_map xid in + match xid_st.cache with + | Flows fl -> + (* Group reply separation *) + xid_st.cache <- (Flows (fl @ flows)); + let flows = List.map (translate_stat flv dpid) flows in + let _ = + if not more then + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst + in + if (List.length xid_st.dst = 0 ) then + let _ = Hashtbl.remove flv.xid_map xid in + handle_xid flv st xid_st + else + return (Hashtbl.replace flv.xid_map xid xid_st) + | _ -> return () + ) else + return (cp (sp "[flowvisor-ctrl] Unknown stats reply xid\n%!")) + end + | OE.Aggr_flow_stats_reply(xid, pkts, bytes, flows, dpid) -> begin + if (Hashtbl.mem flv.xid_map xid) then ( + let xid_st = Hashtbl.find flv.xid_map xid in + match xid_st.cache with + | Aggr aggr -> + (* Group reply separation *) + let aggr = + OP.Stats.({packet_count=(Int64.add pkts aggr.packet_count); + byte_count=(Int64.add bytes aggr.byte_count); + flow_count=(Int32.add flows aggr.flow_count);}) in + let _ = xid_st.cache <- (Aggr aggr) in + let _ = + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst + in + if (List.length xid_st.dst = 0 ) then + let _ = Hashtbl.remove flv.xid_map xid in + handle_xid flv st xid_st + else + return (Hashtbl.replace flv.xid_map xid xid_st) + | _ -> return () + ) else return () + end + | OE.Port_stats_reply(xid, more, ports, dpid) -> begin + if (Hashtbl.mem flv.xid_map xid) then ( + let xid_st = Hashtbl.find flv.xid_map xid in + match xid_st.cache with + | Port p -> + (* Group reply separation *) + let ports = List.map (fun port -> + let port_id = map_flv_port flv dpid port.OP.Port.port_id in + OP.Port.({port with port_id=(OP.Port.int_of_port port_id);})) ports in + let _ = xid_st.cache <- (Port (p @ ports)) in + let _ = if not more then + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst in + if (List.length xid_st.dst = 0 ) then + let _ = Hashtbl.remove flv.xid_map xid in + handle_xid flv st xid_st + else + let _ = Hashtbl.replace flv.xid_map xid xid_st in + return () + | _ -> return () + ) else return () + end + | OE.Table_stats_reply(xid, more, tables, dpid) -> + return () + | OE.Port_status(reason, port, dpid) -> + (* TODO: send a port withdrawal to all controllers *) + add_flowvisor_port flv dpid port + | _ -> return (cp "[flowvisor-ctrl] Unsupported event\n%!") + with Not_found -> return (cp(sp "[flowvisor-ctrl] ignore pkt of non existing state\n%!")) + + let init flv st = + (* register all the required handlers *) + let fn = process_switch_channel flv in + OC.register_cb st OE.DATAPATH_JOIN fn; + OC.register_cb st OE.DATAPATH_LEAVE fn; + OC.register_cb st OE.PACKET_IN fn; + OC.register_cb st OE.FLOW_REMOVED fn; + OC.register_cb st OE.FLOW_STATS_REPLY fn; + OC.register_cb st OE.AGGR_FLOW_STATS_REPLY fn; + OC.register_cb st OE.PORT_STATUS_CHANGE fn; + OC.register_cb st OE.TABLE_STATS_REPLY fn + +let create_flowvisor ?(verbose=false) () = + let ret = init_flowvisor verbose (Flowvisor_topology.init_topology ()) in + let _ = ignore_result (Flowvisor_topology.discover ret.flv_topo) in + ret + +let add_slice mgr flv of_m dst dpid = + ignore_result ( + while_lwt true do + let switch_connect (addr, port) t = + let rs = Ipaddr.V4.to_string addr in + try_lwt + let _ = cp (sp "[flowvisor-switch]+ switch %s:%d\n%!" rs port) in + (* Trigger the dance between the 2 nodes *) + let sock = Openflow.Ofsocket.init_socket_conn_state t in + switch_channel flv dpid of_m sock + with exn -> + return (cp(sp "[flowvisorswitch]- switch %s:%d %s\n%!" rs port (Printexc.to_string exn))) + in + Net.Channel.connect mgr ( `TCPv4 (None, dst, (switch_connect dst) ) ) + done) + +let listen st mgr loc = OC.listen mgr loc (init st) +let local_listen st conn = + OC.local_connect (OC.init_controller (init st)) conn + +let remove_slice _ _ = () +let add_local_slice flv of_m conn dpid = + ignore_result ( switch_channel flv dpid of_m conn) + (* TODO Need to store thread for termination on remove_slice *) diff --git a/lib/flowvisor.mli b/lib/flowvisor.mli new file mode 100644 index 0000000..83d8c55 --- /dev/null +++ b/lib/flowvisor.mli @@ -0,0 +1,48 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Lwt +open Net +open Net.Nettypes + +type t + +(* + * TODO: + * + * expose read write permissions to slices + * *) + +(** initialize required state for a flowvisor instance *) +val create_flowvisor: ?verbose:bool -> unit -> t + +(** switch listening daemons *) + +val listen: t -> Manager.t -> ipv4_src -> unit Lwt.t +val local_listen: t -> Openflow.Ofsocket.conn_state -> unit Lwt.t + +(** slice management methods *) + +(** connect to a local control socket and expose a slice of the network control + * traffic *) +val add_local_slice : t -> Openflow.Ofpacket.Match.t -> + Openflow.Ofsocket.conn_state -> int64 -> unit +(** connect to a remote controller and expose a slice of the network control + * traffic *) +val add_slice : Net.Manager.t -> t -> Openflow.Ofpacket.Match.t -> + ipv4_dst -> int64 -> unit +(** stop exposing a control slice *) +val remove_slice : t -> Openflow.Ofpacket.Match.t -> unit diff --git a/lib/flowvisor_topology.ml b/lib/flowvisor_topology.ml new file mode 100644 index 0000000..e1b0533 --- /dev/null +++ b/lib/flowvisor_topology.ml @@ -0,0 +1,208 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Lwt +open Printf +open Net +open Net.Nettypes +open Lldp + +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event +module OSK = Openflow.Ofsocket +open OP + +let sp = Printf.sprintf +let cp = OS.Console.log + +module V = struct + type t = int64 + let compare = Int64.compare + let hash = Hashtbl.hash + let equal = (=) +end +module E = struct + type t = (int64 * int * int64 * int * int) + let compare v1 v2 = + let (src1_dpid, src1_port, dst1_dpid, dst1_port, _) = v1 in + let (src2_dpid, src2_port, dst2_dpid, dst2_port, _) = v2 in + if ((src1_dpid = src2_dpid) && (src1_port = src2_port) && + (dst1_dpid = dst2_dpid) && (dst1_port = dst2_port)) || + ((src1_dpid = dst2_dpid) && (src1_port = dst2_port) && + (dst1_dpid = src2_dpid) && (dst1_port = src2_port)) then + 0 + else + Pervasives.compare v1 v2 + let default = (0L, 0, 0L, 0, 1) +end + +module Graph = Imperative.Graph.ConcreteLabeled(V)(E) + +module W = struct + type t = float + type label = (int64 * int * int64 * int * int) + let weight (_, _, _, _, rate) = 1.0 /. (float_of_int rate) + let compare = Pervasives.compare + let add = (+.) + let zero = 0.0 +end + +module Dijkstra = Path.Dijkstra(Graph)(W) + +type t = { + ports : (int64 * int, Macaddr.t * bool) Hashtbl.t; + channels : (int64, OC.t) Hashtbl.t; + topo : Graph.t; +} + +let init_topology () = + let topo = Graph.create () in + {ports=(Hashtbl.create 64); channels=(Hashtbl.create 64); + topo;} + +let add_channel t dpid ch = Hashtbl.replace t.channels dpid ch + +let generate_lldp_discovery dpid src_mac port = + let bits = OS.Io_page.to_cstruct (OS.Io_page.get 1) in + let _ = Cstruct.BE.set_uint64 bits 0 dpid in + let dpid = Cstruct.to_string (Cstruct.sub bits 0 8) in + let bits = OS.Io_page.to_cstruct (OS.Io_page.get 1) in + let _ = Cstruct.BE.set_uint16 bits 0 port in + let port = Cstruct.(to_string (sub bits 0 2)) in + marshal_and_sub (marsal_lldp_tlvs src_mac + [Tlv_chassis_id_mac(src_mac); + Tlv_port_id_port_comp(port); + Tlv_ttl(120); + Tlv(LLDP_TYPE_SYSTEM_DESCR, dpid); + Tlv_end;]) + (OS.Io_page.to_cstruct (OS.Io_page.get 1)) + +let send_port_lldp t dpid port mac = + let data = generate_lldp_discovery dpid mac port in + let h = OP.Header.(create PACKET_OUT 0) in + let m = OP.Packet_out.create ~actions:[(OP.Flow.Output(OP.Port.Port(port), 2000))] + ~data ~in_port:(OP.Port.No_port) () in + let ch = Hashtbl.find t.channels dpid in + OC.send_data ch dpid (OP.Packet_out(h, m)) + +let add_port t dpid port mac = + let _ = cp (sp "[flowvisor-topo] adding port %Ld:%d\n%!" dpid port) in + let _ = Hashtbl.replace t.ports (dpid, port) (mac, false) in + send_port_lldp t dpid port mac + +let mark_port_down t dpid port down = + let fmac = Macaddr.broadcast in + try + let (mac, _) = Hashtbl.find t.ports (dpid, port) in + Hashtbl.replace t.ports (dpid, port) (mac, down) + with Not_found -> Hashtbl.add t.ports (dpid, port) (fmac, down) + +let discover t = + while_lwt true do + let ports = + Hashtbl.fold + (fun (dpid, port) (mac, _) r -> (dpid, port, mac)::r) + t.ports [] in + + lwt _ = Lwt_list.iter_p ( + fun (dpid, port, mac) -> send_port_lldp t dpid port mac) ports in + lwt _ = OS.Time.sleep 120.0 in + return () + done + +let print_graph t = + Graph.iter_edges_e ( + fun (_, (sdpid, sport, ddpid, dport, len), _) -> + printf "%06Lx:%d - %06Lx:%d = %d\n%!" sdpid sport ddpid dport len + ) t.topo + +let process_lldp_packet t src_dpid src_port pkt = + let tlvs = parse_lldp_tlvs pkt in + let (dst_dpid, dst_port, mac) = + List.fold_right ( + fun tlv (dpid, port, mac) -> + match tlv with + | Tlv_chassis_id_mac (mac) -> + (dpid, port, mac) + | Tlv_port_id_port_comp(bits) -> + let port_id = ref 0 in + let _ = String.iter ( + fun c -> + port_id := (!port_id lsl 8) + (int_of_char c) + ) bits in + (dpid, !port_id, mac) + | Tlv(LLDP_TYPE_SYSTEM_DESCR, bits) -> + let dpid = ref 0L in + let _ = String.iter ( + fun c -> + dpid := Int64.add (Int64.shift_left !dpid 8) + (Int64.of_int (int_of_char c)) + ) bits in + (!dpid, port, mac) + | _ -> (dpid, port, mac) + ) tlvs (0L, 0, Macaddr.broadcast ) in + match (Hashtbl.mem t.channels dst_dpid) with + | false -> false + | true -> + let v = (src_dpid, (src_dpid, src_port, dst_dpid, dst_port, 1), dst_dpid) in + let _ = cp (sp "[flowvisor-topo] adding link %Ld:%d-%Ld:%d\n%!" + src_dpid src_port dst_dpid dst_port) in + let _ = Graph.add_edge_e t.topo v in + let _ = mark_port_down t src_dpid src_port true in + let _ = mark_port_down t dst_dpid dst_port true in + true + +let remove_dpid t dpid = + let _ = Graph.remove_vertex t.topo dpid in + let _ = + Hashtbl.iter ( + fun (dp, p) _ -> + if (dpid = dp) then + Hashtbl.remove t.ports (dp, p)) t.ports in + Hashtbl.remove t.channels dpid + +let is_transit_port t dpid port = + try + let (_, down) = Hashtbl.find t.ports (dpid, port) in down + with Not_found -> false + + +let find_dpid_path t src_dpid src_port dst_dpid dst_port = +(* let _ = printf "[flowvisor-topo] looking for path %Ld:%s - %Ld:%s\n%!" + src_dpid (OP.Port.string_of_port src_port) + dst_dpid (OP.Port.string_of_port dst_port) in *) + let (path, w) = Dijkstra.shortest_path t.topo src_dpid dst_dpid in + let (path, dpid, port) = List.fold_right ( + fun (sdp, (dp_1, port_1, dp_2, port_2, _), ddp) (p, curr_dp, curr_p) -> +(* let _ = printf "[flowvisor-topo] found link %Ld:%d-%Ld:%d\n%!" + dp_1 port_1 dp_2 port_2 in *) + let (hop, curr_dp, curr_p) = + match (curr_dp) with + | dp when dp = dp_1 -> + let hop = (curr_dp, OP.Port.Port(port_1), + curr_p) in + (hop, dp_2, port_2) + | dp when dp = dp_2 -> + let hop = (curr_dp, + OP.Port.Port(port_2), curr_p) in + (hop, dp_1, port_1) + | _ -> + failwith (sp "Unknwk dpid %Ld" curr_dp) + in + ((hop :: p), curr_dp, OP.Port.Port(curr_p)) + ) path ([], dst_dpid, dst_port) in + (src_dpid, src_port, port) :: path diff --git a/lib/flowvisor_topology.mli b/lib/flowvisor_topology.mli new file mode 100644 index 0000000..93439fe --- /dev/null +++ b/lib/flowvisor_topology.mli @@ -0,0 +1,44 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Net.Nettypes + +type t + +(** FlowVisor topology discovery *) + + +(** Initialize a topology struct *) +val init_topology: unit -> t + +(** Add to the structure a new switch and the relevant controller channel *) +val add_channel: t -> int64 -> Openflow.Ofcontroller.t -> unit +(** Add a new port on a switch *) +val add_port: t -> int64 -> int -> Macaddr.t -> unit Lwt.t +(** run a daemon which broadcasts lldp packet every 120 seconds in order to + * discover physical connectivity between switches *) +val discover: t-> unit Lwt.t + +(** parse and process an lldp packet *) +val process_lldp_packet: t -> int64 -> int -> Cstruct.t -> bool +(** discover a path between two ports of connected switches *) +val find_dpid_path: t -> int64 -> Openflow.Ofpacket.Port.t -> int64 -> + Openflow.Ofpacket.Port.t -> (int64 * Openflow.Ofpacket.Port.t * Openflow.Ofpacket.Port.t) list +(** remove all ports of a specific switch *) +val remove_dpid: t -> int64 -> unit +(** reports if a link function a a transit link between two adjacent switches *) +val is_transit_port : t -> int64 -> int -> bool + diff --git a/lib/flv.mlpack b/lib/flv.mlpack new file mode 100644 index 0000000..499b55f --- /dev/null +++ b/lib/flv.mlpack @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: 1ee3b02f2e7271b683bd994a941b7777) +Flowvisor +Lldp +Flowvisor_topology +# OASIS_STOP diff --git a/lib/heap.ml b/lib/heap.ml new file mode 100644 index 0000000..0079109 --- /dev/null +++ b/lib/heap.ml @@ -0,0 +1,236 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +module type Ordered = sig + type t + val compare : t -> t -> int +end + +exception EmptyHeap + +(*s Imperative implementation *) + +module Imperative(X : Ordered) = struct + + (* The heap is encoded in the array [data], where elements are stored + from [0] to [size - 1]. From an element stored at [i], the left + (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) + + type t = { mutable size : int; mutable data : X.t array } + + (* When [create n] is called, we cannot allocate the array, since there is + no known value of type [X.t]; we'll wait for the first addition to + do it, and we remember this situation with a negative size. *) + + let create n = + if n <= 0 then invalid_arg "create"; + { size = -n; data = [||] } + + let is_empty h = h.size <= 0 + + (* [resize] doubles the size of [data] *) + + let resize h = + let n = h.size in + assert (n > 0); + let n' = 2 * n in + let d = h.data in + let d' = Array.create n' d.(0) in + Array.blit d 0 d' 0 n; + h.data <- d' + + let add h x = + (* first addition: we allocate the array *) + if h.size < 0 then begin + h.data <- Array.create (- h.size) x; h.size <- 0 + end; + let n = h.size in + (* resizing if needed *) + if n == Array.length h.data then resize h; + let d = h.data in + (* moving [x] up in the heap *) + let rec moveup i = + let fi = (i - 1) / 2 in + if i > 0 && X.compare d.(fi) x < 0 then begin + d.(i) <- d.(fi); + moveup fi + end else + d.(i) <- x + in + moveup n; + h.size <- n + 1 + + let maximum h = + if h.size <= 0 then raise EmptyHeap; + h.data.(0) + + let remove h = + if h.size <= 0 then raise EmptyHeap; + let n = h.size - 1 in + h.size <- n; + let d = h.data in + let x = d.(n) in + (* moving [x] down in the heap *) + let rec movedown i = + let j = 2 * i + 1 in + if j < n then + let j = + let j' = j + 1 in + if j' < n && X.compare d.(j') d.(j) > 0 then j' else j + in + if X.compare d.(j) x > 0 then begin + d.(i) <- d.(j); + movedown j + end else + d.(i) <- x + else + d.(i) <- x + in + movedown 0 + + let pop_maximum h = let m = maximum h in remove h; m + + let iter f h = + let d = h.data in + for i = 0 to h.size - 1 do f d.(i) done + + let fold f h x0 = + let n = h.size in + let d = h.data in + let rec foldrec x i = + if i >= n then x else foldrec (f d.(i) x) (succ i) + in + foldrec x0 0 + +end + + +(*s Functional implementation *) + +module type FunctionalSig = sig + type elt + type t + val empty : t + val add : elt -> t -> t + val maximum : t -> elt + val remove : t -> t + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a +end + +module Functional(X : Ordered) = struct + + (* Heaps are encoded as complete binary trees, i.e., binary trees + which are full expect, may be, on the bottom level where it is filled + from the left. + These trees also enjoy the heap property, namely the value of any node + is greater or equal than those of its left and right subtrees. + + There are 4 kinds of complete binary trees, denoted by 4 constructors: + [FFF] for a full binary tree (and thus 2 full subtrees); + [PPF] for a partial tree with a partial left subtree and a full + right subtree; + [PFF] for a partial tree with a full left subtree and a full right subtree + (but of different heights); + and [PFP] for a partial tree with a full left subtree and a partial + right subtree. *) + + type elt = X.t + + type t = + | Empty + | FFF of t * X.t * t (* full (full, full) *) + | PPF of t * X.t * t (* partial (partial, full) *) + | PFF of t * X.t * t (* partial (full, full) *) + | PFP of t * X.t * t (* partial (full, partial) *) + + let empty = Empty + + (* smart constructors for insertion *) + let p_f l x r = match l with + | Empty | FFF _ -> PFF (l, x, r) + | _ -> PPF (l, x, r) + + let pf_ l x = function + | Empty | FFF _ as r -> FFF (l, x, r) + | r -> PFP (l, x, r) + + let rec add x = function + | Empty -> + FFF (Empty, x, Empty) + (* insertion to the left *) + | FFF (l, y, r) | PPF (l, y, r) -> + if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r + (* insertion to the right *) + | PFF (l, y, r) | PFP (l, y, r) -> + if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r) + + let maximum = function + | Empty -> raise EmptyHeap + | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x + + (* smart constructors for removal; note that they are different + from the ones for insertion! *) + let p_f l x r = match l with + | Empty | FFF _ -> FFF (l, x, r) + | _ -> PPF (l, x, r) + + let pf_ l x = function + | Empty | FFF _ as r -> PFF (l, x, r) + | r -> PFP (l, x, r) + + let rec remove = function + | Empty -> + raise EmptyHeap + | FFF (Empty, _, Empty) -> + Empty + | PFF (l, _, Empty) -> + l + (* remove on the left *) + | PPF (l, x, r) | PFF (l, x, r) -> + let xl = maximum l in + let xr = maximum r in + let l' = remove l in + if X.compare xl xr >= 0 then + p_f l' xl r + else + p_f l' xr (add xl (remove r)) + (* remove on the right *) + | FFF (l, x, r) | PFP (l, x, r) -> + let xl = maximum l in + let xr = maximum r in + let r' = remove r in + if X.compare xl xr > 0 then + pf_ (add xr (remove l)) xl r' + else + pf_ l xr r' + + let rec iter f = function + | Empty -> + () + | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + iter f l; f x; iter f r + + let rec fold f h x0 = match h with + | Empty -> + x0 + | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + fold f l (fold f r (f x x0)) + +end diff --git a/lib/heap.mli b/lib/heap.mli new file mode 100644 index 0000000..701a4b5 --- /dev/null +++ b/lib/heap.mli @@ -0,0 +1,99 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + + +module type Ordered = sig + type t + val compare : t -> t -> int +end + +exception EmptyHeap + +(*S Imperative implementation. *) + +module Imperative(X: Ordered) : sig + + (* Type of imperative heaps. + (In the following [n] refers to the number of elements in the heap) *) + + type t + + (* [create c] creates a new heap, with initial capacity of [c] *) + val create : int -> t + + (* [is_empty h] checks the emptiness of [h] *) + val is_empty : t -> bool + + (* [add x h] adds a new element [x] in heap [h]; size of [h] is doubled + when maximum capacity is reached; complexity $O(log(n))$ *) + val add : t -> X.t -> unit + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> X.t + + (* [remove h] removes the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(log(n))$ *) + val remove : t -> unit + + (* [pop_maximum h] removes the maximum element of [h] and returns it; + raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) + val pop_maximum : t -> X.t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (X.t -> unit) -> t -> unit + + val fold : (X.t -> 'a -> 'a) -> t -> 'a -> 'a + +end + +(*S Functional implementation. *) + +module type FunctionalSig = sig + + (* heap elements *) + type elt + + (* Type of functional heaps *) + type t + + (* The empty heap *) + val empty : t + + (* [add x h] returns a new heap containing the elements of [h], plus [x]; + complexity $O(log(n))$ *) + val add : elt -> t -> t + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> elt + + (* [remove h] returns a new heap containing the elements of [h], except + the maximum of [h]; raises [EmptyHeap] when [h] is empty; + complexity $O(log(n))$ *) + val remove : t -> t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (elt -> unit) -> t -> unit + + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + +end + +module Functional(X: Ordered) : FunctionalSig with type elt = X.t diff --git a/lib/imperative.ml b/lib/imperative.ml new file mode 100644 index 0000000..d18c944 --- /dev/null +++ b/lib/imperative.ml @@ -0,0 +1,665 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +open Sig +open Blocks + +module type S = sig + + (** Imperative Unlabeled Graphs *) + module Concrete (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + and type E.label = unit + + (** Abstract Imperative Unlabeled Graphs *) + module Abstract(V: sig type t end) : + Sig.IM with type V.label = V.t and type E.label = unit + and type E.label = unit + + (** Imperative Labeled Graphs *) + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : + Sig.I with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + + (** Abstract Imperative Labeled Graphs *) + module AbstractLabeled (V: sig type t end)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + +end + +module I = Make(Make_Hashtbl) + +type 'a abstract_vertex = { tag : int; label : 'a; mutable mark : int } + +(* Implement module type [MARK]. *) +module Make_Mark + (X: sig + type graph + type label + val iter_vertex : (label abstract_vertex -> unit) -> graph -> unit + end) = +struct + type vertex = X.label abstract_vertex + type graph = X.graph + let get v = v.mark + let set v m = v.mark <- m + let clear g = X.iter_vertex (fun v -> set v 0) g +end + +(* Vertex for abstract imperative graphs: + comparing to vertex for abstract **persistent** graphs, marks are added. *) +module AbstractVertex(V: sig type t end) = struct + type label = V.t + type t = label abstract_vertex + let compare x y = Pervasives.compare x.tag y.tag + let hash x = x.tag + let equal x y = x.tag = y.tag + let label x = x.label + let create l = + if !cpt_vertex = first_value_for_cpt_vertex - 1 then + invalid_arg "Too much vertices"; + incr cpt_vertex; + { tag = !cpt_vertex; label = l; mark = 0 } +end + +module Digraph = struct + + module Concrete(V: COMPARABLE) = struct + include I.Digraph.Concrete(V) + let add_vertex g v = ignore (add_vertex g v) + let add_edge g v1 v2 = ignore (add_edge g v1 v2) + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + let add_edge_e g e = ignore (add_edge_e g e) + let remove_vertex g v = + if HM.mem v g then begin + ignore (HM.remove v g); + HM.iter (fun k s -> ignore (HM.add k (S.remove v s) g)) g + end + end + + module ConcreteLabeled(V: COMPARABLE)(E: ORDERED_TYPE_DFT) = struct + include I.Digraph.ConcreteLabeled(V)(E) + let add_vertex g v = ignore (add_vertex g v) + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + let add_edge_e g e = ignore (add_edge_e g e) + let add_edge g v1 v2 = ignore (add_edge g v1 v2) + let remove_vertex g v = + if HM.mem v g then begin + ignore (HM.remove v g); + let remove v = S.filter (fun (v2, _) -> not (V.equal v v2)) in + HM.iter (fun k s -> ignore (HM.add k (remove v s) g)) g + end + end + + module ConcreteBidirectional(V: COMPARABLE) = struct + + include I.Digraph.ConcreteBidirectional(V) + + let add_vertex g v = ignore (add_vertex g v) + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g v1 v2) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + let remove_vertex g v = + if HM.mem v g then begin + iter_pred_e (fun e -> remove_edge_e g e) g v; + iter_succ_e (fun e -> remove_edge_e g e) g v; + ignore (HM.remove v g) + end + + end + + module ConcreteBidirectionalLabeled(V:COMPARABLE)(E:ORDERED_TYPE_DFT) = struct + + include I.Digraph.ConcreteBidirectionalLabeled(V)(E) + + let add_vertex g v = ignore (add_vertex g v) + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g v1 v2) + + let add_edge_e g (v1, l, v2) = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge_e g (v1, l, v2)) + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + let remove_vertex g v = + if HM.mem v g then begin + iter_pred_e (fun e -> remove_edge_e g e) g v; + iter_succ_e (fun e -> remove_edge_e g e) g v; + ignore (HM.remove v g) + end + + end + + module Abstract(V: sig type t end) = struct + + include I.Digraph.Abstract(AbstractVertex(V)) + + let add_vertex g v = + if not (HM.mem v g.edges) then begin + g.size <- Pervasives.succ g.size; + ignore (G.unsafe_add_vertex g.edges v) + end + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g.edges v1 v2) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_vertex g v = + if HM.mem v g.edges then + let e = g.edges in + ignore (HM.remove v e); + HM.iter (fun k s -> ignore (HM.add k (S.remove v s) e)) e; + g.size <- Pervasives.pred g.size + + module Mark = + Make_Mark + (struct + type graph = t + type label = V.label + let iter_vertex = iter_vertex + end) + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + end + + module AbstractLabeled(V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct + + include I.Digraph.AbstractLabeled(AbstractVertex(V))(Edge) + + let add_vertex g v = + if not (HM.mem v g.edges) then begin + g.size <- Pervasives.succ g.size; + ignore (G.unsafe_add_vertex g.edges v) + end + + let add_edge_e g (v1, l, v2) = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g.edges v1 (v2, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_vertex g v = + if HM.mem v g.edges then + let remove s = + S.fold + (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) + s S.empty + in + let e = g.edges in + ignore (HM.remove v e); + HM.iter (fun k s -> ignore (HM.add k (remove s) e)) e; + g.size <- Pervasives.pred g.size + + module Mark = + Make_Mark + (struct + type graph = t + type label = V.label + let iter_vertex = iter_vertex + end) + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + end + +end + +module Graph = struct + + module Concrete(V: COMPARABLE) = struct + + module G = struct include Digraph.Concrete(V) type return = unit end + include Graph(G) + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_add_edge g v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + + module ConcreteLabeled (V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = struct + + module G = struct + include Digraph.ConcreteLabeled(V)(Edge) + type return = unit + end + include Graph(G) + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge_e g (v1, l, v2 as e) = + G.add_edge_e g e; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_add_edge g v2 (v1, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, l, v2 as e) = + G.remove_edge_e g e; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge_e g (v2, l, v1)) + + end + + module Abstract(V: sig type t end) = struct + + module G = struct include Digraph.Abstract(V) type return = unit end + include Graph(G) + + (* Export some definitions of [G] *) + module Mark = G.Mark + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_add_edge g.G.edges v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge g.G.edges v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + + module AbstractLabeled (V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct + + module G = struct + include Digraph.AbstractLabeled(V)(Edge) + type return = unit + end + include Graph(G) + + (* Export some definitions of [G] *) + module Mark = G.Mark + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge_e g (v1, l, v2 as e) = + G.add_edge_e g e; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_add_edge g.G.edges v2 (v1, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge g.G.edges v2 v1) + + let remove_edge_e g (v1, l, v2 as e) = + ignore (G.remove_edge_e g e); + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge_e g.G.edges (v2, l, v1)) + + end + +end + +module Matrix = struct + + module type S = sig + include Sig.I with type V.t = int and type V.label = int + and type E.t = int * int + val make : int -> t + end + + module Digraph = struct + + module V = struct + type t = int + type label = int + let compare : t -> t -> int = Pervasives.compare + let hash = Hashtbl.hash + let equal = (==) + let create i = i + let label i = i + end + + module E = struct + type t = V.t * V.t + type vertex = V.t + let compare : t -> t -> int = Pervasives.compare + type label = unit + let create v1 _ v2 = (v1, v2) + let src = fst + let dst = snd + let label _ = () + end + + type t = Bitv.t array + type vertex = V.t + type edge = E.t + + let create ?size () = + failwith + "[ocamlgraph] do not use Matrix.create; please use Matrix.make instead" + + let make n = + if n < 0 then invalid_arg "[ocamlgraph] Matrix.make"; + Array.init n (fun _ -> Bitv.create n false) + + let is_directed = true + + let nb_vertex = Array.length + let is_empty g = nb_vertex g = 0 + let nb_edges = + Array.fold_left (Bitv.fold_left (fun n b -> if b then n+1 else n)) 0 + + let mem_vertex g v = 0 <= v && v < nb_vertex g + let mem_edge g i j = Bitv.get g.(i) j + let mem_edge_e g (i,j) = Bitv.get g.(i) j + let find_edge g i j = if mem_edge g i j then i, j else raise Not_found + let find_all_edges g i j = try [ find_edge g i j ] with Not_found -> [] + + (* constructors *) + let add_edge g i j = Bitv.set g.(i) j true + let add_edge_e g (i,j) = Bitv.set g.(i) j true + + let remove_edge g i j = Bitv.set g.(i) j false + let remove_edge_e g (i,j) = Bitv.set g.(i) j false + + let unsafe_add_edge g i j = + Bitv.unsafe_set (Array.unsafe_get g i) j true + let unsafe_remove_edge g i j = + Bitv.unsafe_set (Array.unsafe_get g i) j false + + let remove_vertex g _ = () + let add_vertex g _ = () + + let clear g = + Array.iter (fun b -> Bitv.iteri (fun j _ -> Bitv.set b j false) b) g + + let copy g = Array.init (nb_vertex g) (fun i -> Bitv.copy g.(i)) + + (* iter/fold on all vertices/edges of a graph *) + let iter_vertex f g = + for i = 0 to nb_vertex g - 1 do f i done + + let iter_edges f g = + for i = 0 to nb_vertex g - 1 do + Bitv.iteri (fun j b -> if b then f i j) g.(i) + done + + let fold_vertex f g a = + let n = nb_vertex g in + let rec fold i a = if i = n then a else fold (i+1) (f i a) in fold 0 a + + let fold_edges f g a = + fold_vertex + (fun i a -> + Bitv.foldi_right (fun j b a -> if b then f i j a else a) g.(i) a) + g a + + (* successors and predecessors of a vertex *) + let succ g i = + Bitv.foldi_left (fun l j b -> if b then j::l else l) [] g.(i) + + let pred g i = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then j :: a else a) + g [] + + (* iter/fold on all successor/predecessor of a vertex. *) + let iter_succ f g i = + let si = g.(i) in + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get si j then f j done + (* optimization w.r.t. + [Bitv.iteri (fun j b -> if b then f j) g.(i)] + *) + + let iter_pred f g i = + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get g.(j) i then f j done + + let fold_succ f g i a = + Bitv.foldi_right (fun j b a -> if b then f j a else a) g.(i) a + + let fold_pred f g i a = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then f j a else a) + g a + + (* degree *) + let out_degree g i = fold_succ (fun _ n -> n + 1) g i 0 + + let in_degree g i = fold_pred (fun _ n -> n + 1) g i 0 + + (* map iterator on vertex *) + let map_vertex f g = + let n = nb_vertex g in + let g' = make n in + iter_edges + (fun i j -> + let fi = f i in + let fj = f j in + if fi < 0 || fi >= n || fj < 0 || fj >= n then + invalid_arg "[ocamlgraph] map_vertex"; + Bitv.unsafe_set g'.(fi) fj true) + g; + g' + + (* labeled edges going from/to a vertex *) + (* successors and predecessors of a vertex *) + let succ_e g i = + Bitv.foldi_left (fun l j b -> if b then (i,j)::l else l) [] g.(i) + + let pred_e g i = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then (j,i) :: a else a) + g [] + + (* iter/fold on all labeled edges of a graph *) + let iter_edges_e f g = + for i = 0 to nb_vertex g - 1 do + Bitv.iteri (fun j b -> if b then f (i,j)) g.(i) + done + + let fold_edges_e f g a = + fold_vertex + (fun i a -> + Bitv.foldi_right (fun j b a -> if b then f (i,j) a else a) g.(i) a) + g a + + (* iter/fold on all edges going from/to a vertex *) + let iter_succ_e f g i = + let si = g.(i) in + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get si j then f (i,j) done + + let iter_pred_e f g i = + for j = 0 to nb_vertex g - 1 do + if Bitv.unsafe_get g.(j) i then f (j,i) + done + + let fold_succ_e f g i a = + Bitv.foldi_right (fun j b a -> if b then f (i,j) a else a) g.(i) a + + let fold_pred_e f g i a = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then f (j,i) a else a) + g a + + end + + module Graph = struct + + module G = struct include Digraph type return = unit end + include Blocks.Graph(G) + + (* Export some definitions of [G] *) + let make = G.make + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + ignore (G.unsafe_add_edge g v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + +end + +(* Faster implementations when vertices are not shared between graphs. *) +(**** + +module UV = struct + + let cpt_vertex = ref min_int + + type ('label, 'succ) vertex = { + tag : int; + label : 'label; + mutable mark : int; + mutable succ : 'succ; + } + + module Digraph = struct + + module Abstract(L: ANY_TYPE) : + Sig.IM with type V.label = L.t and type E.label = unit + = + struct + + module rec V : + VERTEX with type label = L.t and type t = (L.t, S.t) vertex = + struct + type label = L.t + type t = (L.t, S.t) vertex + + let compare x y = compare x.tag y.tag + let hash x = Hashtbl.hash x.tag + let equal x y = x.tag = y.tag + let label x = x.label + + let create l = + assert (!cpt_vertex < max_int); + incr cpt_vertex; + { tag = !cpt_vertex; label = l; mark = 0; succ = S.empty } + end + and S : Set.S with type elt = V.t = Set.Make(V) + + type vertex = V.t + + module E = struct + type t = V.t * V.t + type vertex = V.t + let compare = Pervasives.compare + type label = unit + let create v1 _ v2 = (v1, v2) + let src = fst + let dst = snd + let label _ = () + end + + type edge = E.t + + type t = { + mutable vertices : S.t; + } + + let create ?size () = { vertices = S.empty } + let is_directed = true + let is_empty g = S.is_empty g.vertices + let nb_vertex g = S.cardinal g.vertices + let out_degree _ v = S.cardinal v.succ + + let add_vertex g v = g.vertices <- S.add v g.vertices + let mem_vertex g v = S.mem v g.vertices + let iter_vertex f g = S.iter f g.vertices + let fold_vertex f g = S.fold f g.vertices + let succ _ v = S.elements v.succ + + end + + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + = + AbstractLabeled + (V)(struct type t = unit let compare _ _ = 0 let default = () end) + + end + + module Graph = struct + + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + + end + +end +*****) + +(* +Local Variables: +compile-command: "make -C .." +End: +*) diff --git a/lib/imperative.mli b/lib/imperative.mli new file mode 100644 index 0000000..60196a6 --- /dev/null +++ b/lib/imperative.mli @@ -0,0 +1,159 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Imperative Graph Implementations. *) + +open Sig + +(** Signature of imperative graphs. *) +module type S = sig + + (** Edges may be labeled or not: + - Unlabeled: there is no label on edges + - Labeled: you have to provide a label implementation as a functor + parameter. + + Vertices may be concrete or abstract: + - Concrete: type of vertex labels and type of vertices are identified. + - Abstract: type of vertices is abstract (in particular it is not equal + to type of vertex labels + + How to choose between concrete and abstract vertices for my graph + implementation? + + Usually, if you fall into one of the following cases, use abstract + vertices: + - you cannot provide efficient comparison/hash functions for vertices; or + - you wish to get two different vertices with the same label. + + In other cases, it is certainly easier to use concrete vertices. *) + + (** Imperative Unlabeled Graphs. *) + module Concrete (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + and type E.label = unit + + (** Abstract Imperative Unlabeled Graphs. *) + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + (** Imperative Labeled Graphs. *) + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : + Sig.I with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + + (** Abstract Imperative Labeled Graphs. *) + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + +end + +(** Imperative Directed Graphs. *) +module Digraph : sig + + include S + + (** {2 Bidirectional graphs} + + Bidirectional graphs use more memory space (at worse the double) that + standard concrete directional graphs. But accessing predecessors is in + O(1) amortized instead of O(max(|V|,|E|)) and removing a vertex is in + O(D*ln(D)) instead of O(|V|*ln(D)). D is the maximal degree of the + graph. *) + + (** Imperative Unlabeled, bidirectional graph. *) + module ConcreteBidirectional (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + and type E.label = unit + + (** Imperative Labeled and bidirectional graph. *) + module ConcreteBidirectionalLabeled(V:COMPARABLE)(E:ORDERED_TYPE_DFT) : + Sig.I with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + +end + +(** Imperative Undirected Graphs. *) +module Graph : S + +(** Imperative graphs implemented as adjacency matrices. *) +module Matrix : sig + + module type S = sig + + (** Vertices are integers in [0..n-1]. + A vertex label is the vertex itself. + Edges are unlabeled. *) + + include Sig.I with type V.t = int and type V.label = int + and type E.t = int * int + + (** Creation. graphs are not resizeable: size is given at creation time. + Thus [make] must be used instead of [create]. *) + val make : int -> t + + (** Note: [add_vertex] and [remove_vertex] have no effect. + [clear] only removes edges, not vertices. *) + + end + + module Digraph : S + (** Imperative Directed Graphs implemented with adjacency matrices. *) + + module Graph : S + (** Imperative Undirected Graphs implemented with adjacency matrices. *) + +end + +(**** +(** Faster implementations for abstract (un)labeled (di)graphs + when vertices are _not shared_ between different graphs. + This means that, when using the following implementations, two different + graphs (created with two calls to [create]) must have disjoint sets of + vertices. *) +module UV : sig + + (** directed graphs *) + module Digraph : sig + + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + + end + + (** undirected graphs *) + module Graph : sig + + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + + end + +end +****) + +(* +Local Variables: +compile-command: "make -C .." +End: +*) diff --git a/lib/lldp.ml b/lib/lldp.ml new file mode 100644 index 0000000..393f0fb --- /dev/null +++ b/lib/lldp.ml @@ -0,0 +1,369 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Cstruct +open Printf +open Net +open Net.Nettypes + +exception Unparsable of Cstruct.t + +(*cenum lldp_tlv_types { + LLDP_TYPE_END = 0; + LLDP_TYPE_CHASSIS_ID = 1; + LLDP_TYPE_PORT_ID = 2; + LLDP_TYPE_TTL = 3; + LLDP_TYPE_PORT_DESCR = 4; + LLDP_TYPE_SYSTEM_NAME = 5; + LLDP_TYPE_SYSTEM_DESCR = 6; + LLDP_TYPE_SYSTEM_CAP = 7; + LLDP_TYPE_MGMT_ADDR = 8 +} as uint8_t + +cenum lldp_chassis_id_subtype { + LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE = 1; + LLDP_CHASSIS_INTF_ALIAS_SUBTYPE = 2; + LLDP_CHASSIS_PORT_COMP_SUBTYPE = 3; + LLDP_CHASSIS_MAC_ADDR_SUBTYPE = 4; + LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE = 5; + LLDP_CHASSIS_INTF_NAME_SUBTYPE = 6; + LLDP_CHASSIS_LOCAL_SUBTYPE = 8 +} as uint8_t + +cenum lldp_port_id_subtype { + LLDP_PORT_INTF_ALIAS_SUBTYPE = 1; + LLDP_PORT_PORT_COMP_SUBTYPE = 2; + LLDP_PORT_MAC_ADDR_SUBTYPE = 3; + LLDP_PORT_NETWORK_ADDR_SUBTYPE = 4; + LLDP_PORT_INTF_NAME_SUBTYPE = 5; + LLDP_PORT_AGENT_CIRC_ID_SUBTYPE = 6; + LLDP_PORT_LOCAL_SUBTYPE = 7 +} as uint8_t*) + +cstruct ethernet { + uint8_t dst[6]; + uint8_t src[6]; + uint16_t ethertype +} as big_endian + + +type lldp_tlv_types = + LLDP_TYPE_END + | LLDP_TYPE_CHASSIS_ID + | LLDP_TYPE_PORT_ID + | LLDP_TYPE_TTL + | LLDP_TYPE_PORT_DESCR + | LLDP_TYPE_SYSTEM_NAME + | LLDP_TYPE_SYSTEM_DESCR + | LLDP_TYPE_SYSTEM_CAP + | LLDP_TYPE_MGMT_ADDR + +let lldp_tlv_types_of_int = + function + | 0 -> Some LLDP_TYPE_END + | 1 -> Some LLDP_TYPE_CHASSIS_ID + | 2 -> Some LLDP_TYPE_PORT_ID + | 3 -> Some LLDP_TYPE_TTL + | 4 -> Some LLDP_TYPE_PORT_DESCR + | 5 -> Some LLDP_TYPE_SYSTEM_NAME + | 6 -> Some LLDP_TYPE_SYSTEM_DESCR + | 7 -> Some LLDP_TYPE_SYSTEM_CAP + | 8 -> Some LLDP_TYPE_MGMT_ADDR + | _ -> None + +let lldp_tlv_types_to_int = + function + | LLDP_TYPE_END -> 0 + | LLDP_TYPE_CHASSIS_ID -> 1 + | LLDP_TYPE_PORT_ID -> 2 + | LLDP_TYPE_TTL -> 3 + | LLDP_TYPE_PORT_DESCR -> 4 + | LLDP_TYPE_SYSTEM_NAME -> 5 + | LLDP_TYPE_SYSTEM_DESCR -> 6 + | LLDP_TYPE_SYSTEM_CAP -> 7 + | LLDP_TYPE_MGMT_ADDR -> 8 + +let lldp_tlv_types_to_string = + function + | LLDP_TYPE_END -> "LLDP_TYPE_END" + | LLDP_TYPE_CHASSIS_ID -> "LLDP_TYPE_CHASSIS_ID" + | LLDP_TYPE_PORT_ID -> "LLDP_TYPE_PORT_ID" + | LLDP_TYPE_TTL -> "LLDP_TYPE_TTL" + | LLDP_TYPE_PORT_DESCR -> "LLDP_TYPE_PORT_DESCR" + | LLDP_TYPE_SYSTEM_NAME -> "LLDP_TYPE_SYSTEM_NAME" + | LLDP_TYPE_SYSTEM_DESCR -> "LLDP_TYPE_SYSTEM_DESCR" + | LLDP_TYPE_SYSTEM_CAP -> "LLDP_TYPE_SYSTEM_CAP" + | LLDP_TYPE_MGMT_ADDR -> "LLDP_TYPE_MGMT_ADDR" + +type lldp_chassis_id_subtype = + LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE + | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE + | LLDP_CHASSIS_PORT_COMP_SUBTYPE + | LLDP_CHASSIS_MAC_ADDR_SUBTYPE + | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE + | LLDP_CHASSIS_INTF_NAME_SUBTYPE + | LLDP_CHASSIS_LOCAL_SUBTYPE + +let lldp_chassis_id_subtype_of_int = + function + | 1 -> Some LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE + | 2 -> Some LLDP_CHASSIS_INTF_ALIAS_SUBTYPE + | 3 -> Some LLDP_CHASSIS_PORT_COMP_SUBTYPE + | 4 -> Some LLDP_CHASSIS_MAC_ADDR_SUBTYPE + | 5 -> Some LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE + | 6 -> Some LLDP_CHASSIS_INTF_NAME_SUBTYPE + | 8 -> Some LLDP_CHASSIS_LOCAL_SUBTYPE + | _ -> None + +let lldp_chassis_id_subtype_to_int = + function + | LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE -> 1 + | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE -> 2 + | LLDP_CHASSIS_PORT_COMP_SUBTYPE -> 3 + | LLDP_CHASSIS_MAC_ADDR_SUBTYPE -> 4 + | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE -> 5 + | LLDP_CHASSIS_INTF_NAME_SUBTYPE -> 6 + | LLDP_CHASSIS_LOCAL_SUBTYPE -> 8 + +let lldp_chassis_id_subtype_to_string = + function + | LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE -> "LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE" + | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE -> "LLDP_CHASSIS_INTF_ALIAS_SUBTYPE" + | LLDP_CHASSIS_PORT_COMP_SUBTYPE -> "LLDP_CHASSIS_PORT_COMP_SUBTYPE" + | LLDP_CHASSIS_MAC_ADDR_SUBTYPE -> "LLDP_CHASSIS_MAC_ADDR_SUBTYPE" + | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE -> "LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE" + | LLDP_CHASSIS_INTF_NAME_SUBTYPE -> "LLDP_CHASSIS_INTF_NAME_SUBTYPE" + | LLDP_CHASSIS_LOCAL_SUBTYPE -> "LLDP_CHASSIS_LOCAL_SUBTYPE" + +type lldp_port_id_subtype = + LLDP_PORT_INTF_ALIAS_SUBTYPE + | LLDP_PORT_PORT_COMP_SUBTYPE + | LLDP_PORT_MAC_ADDR_SUBTYPE + | LLDP_PORT_NETWORK_ADDR_SUBTYPE + | LLDP_PORT_INTF_NAME_SUBTYPE + | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE + | LLDP_PORT_LOCAL_SUBTYPE + +let lldp_port_id_subtype_of_int = + function + | 1 -> Some LLDP_PORT_INTF_ALIAS_SUBTYPE + | 2 -> Some LLDP_PORT_PORT_COMP_SUBTYPE + | 3 -> Some LLDP_PORT_MAC_ADDR_SUBTYPE + | 4 -> Some LLDP_PORT_NETWORK_ADDR_SUBTYPE + | 5 -> Some LLDP_PORT_INTF_NAME_SUBTYPE + | 6 -> Some LLDP_PORT_AGENT_CIRC_ID_SUBTYPE + | 7 -> Some LLDP_PORT_LOCAL_SUBTYPE + | _ -> None + +let lldp_port_id_subtype_to_int = + function + | LLDP_PORT_INTF_ALIAS_SUBTYPE -> 1 + | LLDP_PORT_PORT_COMP_SUBTYPE -> 2 + | LLDP_PORT_MAC_ADDR_SUBTYPE -> 3 + | LLDP_PORT_NETWORK_ADDR_SUBTYPE -> 4 + | LLDP_PORT_INTF_NAME_SUBTYPE -> 5 + | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE -> 6 + | LLDP_PORT_LOCAL_SUBTYPE -> 7 + +let lldp_port_id_subtype_to_string = + function + | LLDP_PORT_INTF_ALIAS_SUBTYPE -> "LLDP_PORT_INTF_ALIAS_SUBTYPE" + | LLDP_PORT_PORT_COMP_SUBTYPE -> "LLDP_PORT_PORT_COMP_SUBTYPE" + | LLDP_PORT_MAC_ADDR_SUBTYPE -> "LLDP_PORT_MAC_ADDR_SUBTYPE" + | LLDP_PORT_NETWORK_ADDR_SUBTYPE -> "LLDP_PORT_NETWORK_ADDR_SUBTYPE" + | LLDP_PORT_INTF_NAME_SUBTYPE -> "LLDP_PORT_INTF_NAME_SUBTYPE" + | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE -> "LLDP_PORT_AGENT_CIRC_ID_SUBTYPE" + | LLDP_PORT_LOCAL_SUBTYPE -> "LLDP_PORT_LOCAL_SUBTYPE" + + +type lldp_tvl = + | Tlv_chassis_id_chassis_comp of string + | Tlv_chassis_id_intf_alias of string + | Tlv_chassis_id_port_comp of string + | Tlv_chassis_id_mac of Macaddr.t + | Tlv_chassis_id_net of Ipaddr.V4.t + | Tlv_chassis_id_intf_name of string + | Tlv_chassis_id_local of string + | Tlv_port_id_intf_alias of string + | Tlv_port_id_port_comp of string + | Tlv_port_id_mac of Macaddr.t + | Tlv_port_id_net of Ipaddr.V4.t + | Tlv_port_id_intf_name of string + | Tlv_port_id_circ_id of string + | Tlv_port_id_local of string + | Tlv_ttl of int + | Tlv_end + | Tlv of lldp_tlv_types * string + | Tlv_unk of int * string + +let parse_lldp_tlv bits = + let tlv_type_len = Cstruct.BE.get_uint16 bits 0 in + let tlv_type = tlv_type_len lsr 9 in + let tlv_len = tlv_type_len land 0x01FF in + let tlv = + match (lldp_tlv_types_of_int tlv_type) with + | Some(LLDP_TYPE_END) -> Tlv_end + | Some(LLDP_TYPE_CHASSIS_ID) -> begin + let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in + let chassis_id_subtype = Cstruct.get_uint8 bits 2 in + match (lldp_chassis_id_subtype_of_int chassis_id_subtype) with + | Some(LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE)-> + Tlv_chassis_id_chassis_comp(data) + | Some(LLDP_CHASSIS_INTF_ALIAS_SUBTYPE) -> + Tlv_chassis_id_intf_alias(data) + | Some(LLDP_CHASSIS_PORT_COMP_SUBTYPE) -> + Tlv_chassis_id_port_comp(data) + | Some(LLDP_CHASSIS_MAC_ADDR_SUBTYPE) -> begin + match (Macaddr.of_bytes data) with + | None -> raise (Unparsable bits) + | Some addr -> (Tlv_chassis_id_mac addr) + end + | Some(LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE)-> + let ip = Ipaddr.V4.of_int32 + (Cstruct.BE.get_uint32 bits 3) in + Tlv_chassis_id_net(ip) + | Some(LLDP_CHASSIS_INTF_NAME_SUBTYPE) -> + Tlv_chassis_id_intf_name(data) + | Some(LLDP_CHASSIS_LOCAL_SUBTYPE) -> + Tlv_chassis_id_local(data) + | None -> + raise (Unparsable(bits)) + end + | Some(LLDP_TYPE_PORT_ID) -> begin + let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in + let port_id_subtype = Cstruct.get_uint8 bits 2 in + match (lldp_port_id_subtype_of_int port_id_subtype) with + | Some(LLDP_PORT_INTF_ALIAS_SUBTYPE) -> + Tlv_port_id_intf_alias(data) + | Some(LLDP_PORT_PORT_COMP_SUBTYPE) -> + Tlv_port_id_port_comp(data) + | Some(LLDP_PORT_MAC_ADDR_SUBTYPE) -> begin + match (Macaddr.of_bytes data) with + | None -> raise (Unparsable(bits)) + | Some addr -> Tlv_port_id_mac(addr) + end + | Some(LLDP_PORT_NETWORK_ADDR_SUBTYPE) -> + let ip = Ipaddr.V4.of_int32 + (Cstruct.BE.get_uint32 bits 3) in + Tlv_port_id_net(ip) + | Some(LLDP_PORT_INTF_NAME_SUBTYPE) -> + Tlv_port_id_intf_name(data) + | Some(LLDP_PORT_AGENT_CIRC_ID_SUBTYPE)-> + Tlv_port_id_circ_id(data) + | Some(LLDP_PORT_LOCAL_SUBTYPE) -> + Tlv_port_id_local(data) + | None -> raise (Unparsable(bits)) + end + | Some(LLDP_TYPE_TTL) -> + let ttl = Cstruct.BE.get_uint16 bits 3 in + Tlv_ttl(ttl) + | Some(typ) -> + let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in + Tlv(typ, data) + | None -> + let data = Cstruct.to_string (Cstruct.sub bits 2 tlv_len) in + Tlv_unk(tlv_type, data) + in + (tlv_len + 2, tlv) + +let parse_lldp_tlvs bits = + (* Ignore ethernet headers for now *) + let bits = Cstruct.shift bits sizeof_ethernet in + let rec parse_lldp_tlvs_inner bits = + match (Cstruct.len bits) with + | 0 -> [] + | _ -> + let (len, tlv) = parse_lldp_tlv bits in + if(tlv = Tlv_end) then + [tlv] + else + let bits = Cstruct.shift bits len in + [tlv] @ (parse_lldp_tlvs_inner bits) + in + parse_lldp_tlvs_inner bits + +let set_lldp_tlv_typ_subtyp_data bits typ subtyp data = + let typ = typ lsl 9 in + let len = ((String.length data) + 1) land 0x1ff in + let typ_len = typ + len in + let _ = Cstruct.BE.set_uint16 bits 0 typ_len in + let _ = Cstruct.set_uint8 bits 2 subtyp in + let _ = Cstruct.blit_from_string data 0 bits 3 (String.length data) in + len + 2 + +let set_lldp_tlv_typ_data bits typ data = + let typ = typ lsl 9 in + let len = (String.length data) land 0x1ff in + let typ_len = typ + len in + let _ = Cstruct.BE.set_uint16 bits 0 typ_len in + let _ = Cstruct.blit_from_string data 0 bits 2 (String.length data) in + len + 2 + +let marsal_lldp_tlv tlv bits = + match tlv with + (* chassis id *) + | Tlv_chassis_id_chassis_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 1 1 data + | Tlv_chassis_id_intf_alias(data) -> set_lldp_tlv_typ_subtyp_data bits 1 2 data + | Tlv_chassis_id_port_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 1 3 data + | Tlv_chassis_id_mac(mac) -> set_lldp_tlv_typ_subtyp_data bits 1 4 + (Macaddr.to_bytes mac) + | Tlv_chassis_id_net(ip) -> + let _ = Cstruct.BE.set_uint16 bits 0 0x205 in + let _ = Cstruct.set_uint8 bits 2 5 in + let _ = Cstruct.BE.set_uint32 bits 3 (Ipaddr.V4.to_int32 ip) in + 7 + | Tlv_chassis_id_intf_name(data) -> set_lldp_tlv_typ_subtyp_data bits 1 6 data + | Tlv_chassis_id_local(data) -> set_lldp_tlv_typ_subtyp_data bits 1 8 data + (* Port id *) + | Tlv_port_id_intf_alias(data) -> set_lldp_tlv_typ_subtyp_data bits 2 1 data + | Tlv_port_id_port_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 2 2 data + | Tlv_port_id_mac(mac) -> set_lldp_tlv_typ_subtyp_data bits 2 3 + (Macaddr.to_bytes mac) + | Tlv_port_id_net(ip) -> + let _ = Cstruct.BE.set_uint16 bits 0 0x405 in + let _ = Cstruct.set_uint8 bits 2 4 in + let _ = Cstruct.BE.set_uint32 bits 3 (Ipaddr.V4.to_int32 ip) in + 7 + | Tlv_port_id_intf_name(data) -> set_lldp_tlv_typ_subtyp_data bits 2 5 data + | Tlv_port_id_circ_id(data) -> set_lldp_tlv_typ_subtyp_data bits 2 6 data + | Tlv_port_id_local(data) -> set_lldp_tlv_typ_subtyp_data bits 2 7 data + | Tlv_ttl(ttl) -> + let _ = Cstruct.BE.set_uint16 bits 0 0x602 in + let _ = Cstruct.BE.set_uint16 bits 2 ttl in + 4 + | Tlv_end -> + let _ = Cstruct.BE.set_uint16 bits 0 0x000 in + 2 + | Tlv(typ, data) -> + set_lldp_tlv_typ_data bits (lldp_tlv_types_to_int typ) data + | Tlv_unk (typ, data) -> set_lldp_tlv_typ_data bits typ data + +let marsal_lldp_tlvs mac tlvs bits = + let _ = set_ethernet_dst "\x01\x80\xc2\x00\x00\x0e" 0 bits in + let _ = set_ethernet_src (Macaddr.to_bytes mac) + 0 bits in + let _ = set_ethernet_ethertype bits 0x88cc in + let bits = Cstruct.shift bits sizeof_ethernet in + let rec marsal_lldp_tlvs_inner tlvs bits = + match tlvs with + | [] -> 0 + | h::t -> + let len = marsal_lldp_tlv h bits in + let bits = Cstruct.shift bits len in + let rest = marsal_lldp_tlvs_inner t bits in + len + rest + in + sizeof_ethernet + marsal_lldp_tlvs_inner tlvs bits diff --git a/lib/lldp.mli b/lib/lldp.mli new file mode 100644 index 0000000..054e8e6 --- /dev/null +++ b/lib/lldp.mli @@ -0,0 +1,55 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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. + *) + +exception Unparsable of Cstruct.t + +(** LLDP basic message tbl types *) + +type lldp_tlv_types = + | LLDP_TYPE_END + | LLDP_TYPE_CHASSIS_ID + | LLDP_TYPE_PORT_ID + | LLDP_TYPE_TTL + | LLDP_TYPE_PORT_DESCR + | LLDP_TYPE_SYSTEM_NAME + | LLDP_TYPE_SYSTEM_DESCR + | LLDP_TYPE_SYSTEM_CAP + | LLDP_TYPE_MGMT_ADDR + +type lldp_tvl = + | Tlv_chassis_id_chassis_comp of string + | Tlv_chassis_id_intf_alias of string + | Tlv_chassis_id_port_comp of string + | Tlv_chassis_id_mac of Macaddr.t + | Tlv_chassis_id_net of Ipaddr.V4.t + | Tlv_chassis_id_intf_name of string + | Tlv_chassis_id_local of string + | Tlv_port_id_intf_alias of string + | Tlv_port_id_port_comp of string + | Tlv_port_id_mac of Macaddr.t + | Tlv_port_id_net of Ipaddr.V4.t + | Tlv_port_id_intf_name of string + | Tlv_port_id_circ_id of string + | Tlv_port_id_local of string + | Tlv_ttl of int + | Tlv_end + | Tlv of lldp_tlv_types * string + | Tlv_unk of int * string + +(** [parse_lldp_tlvs bits] extract an lldp packet from a raw packet*) +val parse_lldp_tlvs: Cstruct.t -> lldp_tvl list +(** [marshal_lldp_tlvs mac tlvs bits] marshal lldp tlvs to bits memory address *) +val marsal_lldp_tlvs: Macaddr.t -> lldp_tvl list -> Cstruct.t -> int diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index ffa6de9..fa4e43a 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -15,22 +15,14 @@ *) open Lwt -open Lwt_list -(* open Openflow_net_lwt *) open Net -open Printexc +open Ofsocket let sp = Printf.sprintf -let pp = Printf.printf -let ep = Printf.eprintf -let cp = Printf.printf "%s\n%!" +let cp = OS.Console.log module OP = Ofpacket -let resolve t = Lwt.on_success t (fun _ -> ()) - -exception ReadError - module Event = struct type t = | DATAPATH_JOIN | DATAPATH_LEAVE | PACKET_IN | FLOW_REMOVED @@ -38,27 +30,30 @@ module Event = struct | PORT_STATS_REPLY | TABLE_STATS_REPLY | PORT_STATUS_CHANGE type e = - | Datapath_join of OP.datapath_id + | Datapath_join of OP.datapath_id * OP.Port.phy list | Datapath_leave of OP.datapath_id - | Packet_in of OP.Port.t * int32 * Cstruct.buf * OP.datapath_id + | Packet_in of OP.Port.t * OP.Packet_in.reason * + int32 * Cstruct.t * OP.datapath_id | Flow_removed of OP.Match.t * OP.Flow_removed.reason * int32 * int32 * int64 * int64 * OP.datapath_id | Flow_stats_reply of int32 * bool * OP.Flow.stats list * OP.datapath_id | Aggr_flow_stats_reply of int32 * int64 * int64 * int32 * OP.datapath_id - | Port_stats_reply of int32 * OP.Port.stats list * OP.datapath_id - | Table_stats_reply of int32 * OP.Stats.table list * OP.datapath_id + | Port_stats_reply of int32 * bool * OP.Port.stats list * OP.datapath_id + | Table_stats_reply of int32 * bool * OP.Stats.table list * OP.datapath_id | Desc_stats_reply of string * string * string * string * string * OP.datapath_id | Port_status of OP.Port.reason * OP.Port.phy * OP.datapath_id let string_of_event = function - | Datapath_join dpid -> sp "Datapath_join: dpid:0x%012Lx" dpid + | Datapath_join (dpid, _) -> sp "Datapath_join: dpid:0x%012Lx" dpid | Datapath_leave dpid -> sp "Datapath_leave: dpid:0x%012Lx" dpid - | Packet_in (port, buffer_id, bs, dpid) - -> (sp "Packet_in: port:%s ... dpid:0x%012Lx buffer_id:%ld" - (OP.Port.string_of_port port) dpid buffer_id ) + | Packet_in (port, r, buffer_id, bs, dpid) -> + (sp "Packet_in: port:%s reason:%s dpid:0x%012Lx buffer_id:%ld" + (OP.Port.string_of_port port) + (OP.Packet_in.string_of_reason r) + dpid buffer_id ) | Flow_removed (flow, reason, duration_sec, duration_usec, packet_count, byte_count, dpid) -> (sp "Flow_removed: flow: %s reason:%s duration:%ld.%ld packets:%s \ @@ -74,10 +69,10 @@ module Event = struct -> (sp "aggr flow stats reply: dpid:%012Lx packets:%Ld bytes:%Ld \ flows:%ld xid:%ld" dpid packet_count byte_count flow_count xid) - | Port_stats_reply (xid, ports, dpid) + | Port_stats_reply (xid, _, ports, dpid) -> (sp "port stats reply: dpid:%012Lx ports:%d xid%ld" dpid (List.length ports) xid) - | Table_stats_reply (xid, tables, dpid) + | Table_stats_reply (xid, _, tables, dpid) -> (sp "table stats reply: dpid:%012Lx tables:%d xid%ld" dpid (List.length tables) xid) | Desc_stats_reply (mfr_desc, hw_desc, sw_desc, serial_num, dp_desc, dpid) @@ -90,8 +85,7 @@ module Event = struct end type t = { - mutable dp_db: (OP.datapath_id, Channel.t) Hashtbl.t; - mutable channel_dp: ((Nettypes.ipv4_addr * int) , OP.datapath_id) Hashtbl.t; + mutable dp_db: (OP.datapath_id, conn_state) Hashtbl.t; mutable datapath_join_cb: (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; mutable datapath_leave_cb: @@ -112,6 +106,7 @@ type t = { (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; mutable port_status_cb: (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; + verbose : bool; } let register_cb controller e cb = @@ -148,205 +143,132 @@ let register_cb controller e cb = -> controller.port_status_cb <- controller.port_status_cb @ [cb] ) -let process_of_packet state (remote_addr, remote_port) ofp t = +let process_of_packet state conn ofp = + let _ = if state.verbose then cp (sp "[controller] rcv: %s\n%!" (OP.to_string ofp)) in OP.( - let ep = (remote_addr, remote_port) in match ofp with - | Hello (h) (* Reply to HELLO with a HELLO and a feature request *) - -> ( cp "HELLO"; - let bits = OP.marshal_and_sub (Header.marshal_header h) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - let bits = OP.marshal_and_sub (OP.build_features_req 1l) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - ) - - | Echo_req (h, bs) (* Reply to ECHO requests *) - -> ((* cp "ECHO_REQ"; *) - Channel.write_buffer t (build_echo_resp h bs (OS.Io_page.get ())); - Channel.flush t - ) - - | Features_resp (h, sfs) (* Generate a datapath join event *) - -> ((* cp "FEATURES_RESP";*) - let dpid = sfs.Switch.datapath_id in - let evt = Event.Datapath_join dpid in - if (Hashtbl.mem state.dp_db dpid) then ( - Printf.printf "Deleting old state \n%!"; - Hashtbl.remove state.dp_db dpid; - Hashtbl.remove state.channel_dp ep - ); - Hashtbl.add state.dp_db dpid t; - Hashtbl.add state.channel_dp ep dpid; - Lwt_list.iter_p (fun cb -> cb state dpid evt) state.datapath_join_cb - ) - - | Packet_in (h, p) (* Generate a packet_in event *) - -> ( - cp (sp "+ %s|%s" - (OP.Header.header_to_string h) - (OP.Packet_in.packet_in_to_string p)); - let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Packet_in ( - p.Packet_in.in_port, p.Packet_in.buffer_id, - p.Packet_in.data, dpid) - in - iter_p (fun cb -> cb state dpid evt) - state.packet_in_cb - ) - - | Flow_removed (h, p) - -> ((* cp (sp "+ %s|%s" - (OP.Header.string_of_h h) - (OP.Flow_removed.string_of_flow_removed p)); *) - let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Flow_removed ( - p.Flow_removed.of_match, p.Flow_removed.reason, - p.Flow_removed.duration_sec, p.Flow_removed.duration_nsec, - p.Flow_removed.packet_count, p.Flow_removed.byte_count, dpid) - in - Lwt_list.iter_p (fun cb -> cb state dpid evt) state.flow_removed_cb - ) - - | Stats_resp(h, resp) - -> ((* cp (sp "+ %s|%s" (OP.Header.string_of_h h) - (OP.Stats.string_of_stats resp)); *) - match resp with - | OP.Stats.Flow_resp(resp_h, flows) -> - (let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Flow_stats_reply( - h.Header.xid, resp_h.Stats.more_to_follow, flows, dpid) + | Hello (h) -> (* Reply to HELLO with a HELLO and a feature request *) + lwt _ = send_packet conn (OP.Hello (h)) in + let h = OP.Header.create OP.Header.FEATURES_REQ OP.Header.get_len in + send_packet conn (OP.Features_req (h) ) + | Echo_req h -> (* Reply to ECHO requests *) + send_packet conn (OP.Echo_resp OP.Header.(create ~xid:h.xid ECHO_RESP get_len)) + | Echo_resp h -> return () (* At the moment ignore echo responses *) + | Features_resp (h, sfs) -> begin (* Generate a datapath join event *) + let open OP.Switch in + let _ = conn.dpid <- sfs.datapath_id in + let evt = Event.Datapath_join (sfs.datapath_id, sfs.ports) in + let _ = + if (Hashtbl.mem state.dp_db sfs.datapath_id) then + cp (sp "[controller] Deleting old state for %Lx\n%!" conn.dpid) + in + let _ = Hashtbl.replace state.dp_db sfs.datapath_id conn in + Lwt_list.iter_p (fun cb -> cb state sfs.datapath_id evt) + state.datapath_join_cb + end + | OP.Packet_in (h, p) -> begin (* Generate a packet_in event *) + let open OP.Packet_in in + let evt = + Event.Packet_in (p.in_port, p.reason, p.buffer_id, p.data, conn.dpid) in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb + end + | OP.Flow_removed (h, p) -> + let open OP.Flow_removed in + let evt = Event.Flow_removed ( + p.of_match, p.reason, p.duration_sec, p.duration_nsec, + p.packet_count, p.byte_count, conn.dpid) in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb + | Stats_resp(h, resp) -> begin + match resp with + | OP.Stats.Flow_resp(resp_h, flows) -> begin + let evt = Event.Flow_stats_reply( + h.Header.xid, resp_h.OP.Stats.more, flows, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_stats_reply_cb - ) - | OP.Stats.Aggregate_resp(resp_h, aggr) -> - (let dpid = Hashtbl.find state.channel_dp ep in + end + | OP.Stats.Aggregate_resp(resp_h, aggr) -> begin let evt = Event.Aggr_flow_stats_reply( - h.Header.xid, aggr.Stats.packet_count, - aggr.Stats.byte_count, aggr.Stats.flow_count, dpid) + h.Header.xid, aggr.OP.Stats.packet_count, + aggr.OP.Stats.byte_count, aggr.OP.Stats.flow_count, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.aggr_flow_stats_reply_cb - ) - | OP.Stats.Desc_resp (resp_h, aggr) -> - (let dpid = Hashtbl.find state.channel_dp ep in + end + | OP.Stats.Desc_resp (resp_h, aggr) -> begin let evt = Event.Desc_stats_reply( - aggr.Stats.imfr_desc, aggr.Stats.hw_desc, - aggr.Stats.sw_desc, aggr.Stats.serial_num, - aggr.Stats.dp_desc, dpid) + aggr.OP.Stats.imfr_desc, aggr.OP.Stats.hw_desc, + aggr.OP.Stats.sw_desc, aggr.OP.Stats.serial_num, + aggr.OP.Stats.dp_desc, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.desc_stats_reply_cb - ) + end - | OP.Stats.Port_resp (resp_h, ports) -> - (let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Port_stats_reply(h.Header.xid, ports, dpid) + | OP.Stats.Port_resp (resp_h, ports) -> begin + let evt = + Event.Port_stats_reply(h.Header.xid, resp_h.OP.Stats.more, + ports, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_stats_reply_cb - ) + end - | OP.Stats.Table_resp (resp_h, tables) -> - (let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Table_stats_reply(h.Header.xid, tables, dpid) - in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + | OP.Stats.Table_resp (resp_h, tables) -> begin + let evt = + Event.Table_stats_reply(h.Header.xid, resp_h.OP.Stats.more, + tables, conn.dpid) in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.table_stats_reply_cb - ) - | _ -> cp "New stats response received"; return (); - ) - - | Port_status(h, st) - -> ( (* cp (sp "+ %s|%s" (OP.Header.string_of_h h) - (OP.Port.string_of_status st)); *) - let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Port_status (st.Port.reason, st.Port.desc, dpid) - in - Lwt_list.iter_p (fun cb -> cb state dpid evt) state.port_status_cb - ) + end + | _ -> return (cp "[controller] unsupported stats response ") + end - | _ -> cp "New packet received"; return () + | Port_status(h, st) -> begin + let evt = Event.Port_status (st.OP.Port.reason, st.OP.Port.desc, conn.dpid) in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb + end + | ofp -> return (cp (sp "[controller] Unsupported %s" (OP.to_string ofp))) ) -let send_of_data controller dpid bits = - let t = Hashtbl.find controller.dp_db dpid in - match (Cstruct.len bits) with - | l when l <= 1400 -> - let _ = Channel.write_buffer t bits in - Channel.flush t - | _ -> - let buf = Cstruct.sub_buffer bits 0 1400 in - let _ = Channel.write_buffer t buf in - let buf = Cstruct.sub_buffer bits 1400 ((Cstruct.len bits) - 1400) in - let _ = Channel.write_buffer t buf in - lwt _ = Channel.flush t in - return () -(* let _ = Channel.write_buffer t.ch data in -Channel.flush t.ch *) +let send_of_data controller dpid bits = + Ofsocket.send_data_raw (Hashtbl.find controller.dp_db dpid ) bits -let mem_dbg name = -(* Gc.compact (); *) - let s = Gc.stat () in - Printf.printf "blocks %s: l=%d f=%d \n %!" name s.Gc.live_blocks s.Gc.free_blocks +let send_data controller dpid ofp = + Ofsocket.send_packet (Hashtbl.find controller.dp_db dpid ) ofp -let terminate st = - Hashtbl.iter (fun _ ch -> resolve (Channel.close ch) ) st.dp_db; - Printf.printf "Terminating controller...\n" - -let controller init st (remote_addr, remote_port) t = - let rs = Nettypes.ipv4_addr_to_string remote_addr in - let cached_socket = Ofsocket.create_socket t in - pp "OpenFlow Controller %s:%d\n%!" rs remote_port; - let _ = init st in - let echo () = - try_lwt - lwt hbuf = Ofsocket.read_data cached_socket OP.Header.sizeof_ofp_header in - let ofh = OP.Header.parse_header hbuf in - let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in - lwt dbuf = Ofsocket.read_data cached_socket dlen in - let ofp = OP.parse ofh dbuf in - lwt () = process_of_packet st (remote_addr, remote_port) ofp t in - return true +let controller_run st conn = + lwt _ = + try_lwt + while_lwt true do + read_packet conn >>= process_of_packet st conn + done with - | Nettypes.Closed -> begin - let dpid = Hashtbl.find st.channel_dp (remote_addr, remote_port) in - let evt = Event.Datapath_leave (dpid) in - lwt _ = Lwt_list.iter_p (fun cb -> cb st dpid evt) - st.datapath_leave_cb in - let _ = Hashtbl.remove st.channel_dp (remote_addr, remote_port) in - let _ = Hashtbl.remove st.dp_db dpid in - return false - end - | OP.Unparsed(m, bs) - | OP.Unparsable(m, bs) -> - cp (sp "# unparsed! m=%s" m); - Cstruct.hexdump bs; - return true - | Not_found -> - Printf.printf "Error: Not found %s\n%!" (Printexc.get_backtrace ()); - return true - | exn -> - pp "{OpenFlow-controller} ERROR:%s\n%s\n%!" (Printexc.to_string exn) - (Printexc.get_backtrace ()); - return false + | Nettypes.Closed -> return (cp "[controller] switch disconnected\n%!") + | OP.Unparsed(m, bs) + | OP.Unparsable(m, bs) -> + let _ = cp (sp "# unparsed! m=%s" m) in + return (Cstruct.hexdump bs) + | exn -> return (cp (sp "[controller] ERROR:%s\n%!" (Printexc.to_string exn))) + in + if (conn.dpid > 0L) then + let evt = Event.Datapath_leave (conn.dpid) in + lwt _ = Lwt_list.iter_p (fun cb -> cb st conn.dpid evt) + st.datapath_leave_cb in + let _ = Hashtbl.remove st.dp_db conn.dpid in + return () + else + return () + +let socket_controller st (remote_addr, remote_port) t = + let rs = Ipaddr.V4.to_string remote_addr in + let _ = cp (sp "[controller]+ Controller %s:%d\n%!" rs remote_port) in + let conn = init_socket_conn_state t in + controller_run st conn - in - let continue = ref true in - let count = (ref 0) in - while_lwt !continue do - incr count; - lwt x = echo () in - continue := x; - return () - done - -let init_controller () = - { dp_db = Hashtbl.create 0; - channel_dp = Hashtbl.create 0; +let init_controller ?(verbose=false) init = + let t = { verbose; + dp_db = Hashtbl.create 0; datapath_join_cb = []; datapath_leave_cb = []; packet_in_cb = []; @@ -356,13 +278,17 @@ let init_controller () = desc_stats_reply_cb = []; port_stats_reply_cb = []; table_stats_reply_cb = []; - port_status_cb = [];} + port_status_cb = []; } in + let _ = init t in + t + +let listen mgr ?(verbose=false) loc init = + let st = init_controller ~verbose init in + (Channel.listen mgr (`TCPv4 (loc, (socket_controller st) ))) -let listen mgr loc init = - let st = init_controller () in - (Channel.listen mgr (`TCPv4 (loc, (controller init st) ))) +let connect mgr ?(verbose=false) loc init = + let st = init_controller ~verbose init in + Net.Channel.connect mgr (`TCPv4 (None, loc, + (socket_controller st loc) )) -let connect mgr loc init = - let st = init_controller () in - Channel.connect mgr (`TCPv4 (None, loc, - (controller init st loc) )) +let local_connect st conn = controller_run st conn diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index 96ab82b..2a897d9 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -20,6 +20,7 @@ open Net module Event : sig open Ofpacket + (** Event messages *) type t = DATAPATH_JOIN | DATAPATH_LEAVE @@ -33,26 +34,51 @@ module Event : sig | PORT_STATUS_CHANGE type e = - Datapath_join of datapath_id + Datapath_join of datapath_id * Ofpacket.Port.phy list | Datapath_leave of datapath_id - | Packet_in of Port.t * int32 * Cstruct.buf * datapath_id + | Packet_in of Port.t * Packet_in.reason * int32 * + Cstruct.t * datapath_id | Flow_removed of Match.t * Flow_removed.reason * int32 * int32 * int64 * int64 * datapath_id | Flow_stats_reply of int32 * bool * Flow.stats list * datapath_id | Aggr_flow_stats_reply of int32 * int64 * int64 * int32 * datapath_id - | Port_stats_reply of int32 * Port.stats list * datapath_id - | Table_stats_reply of int32 * Stats.table list * datapath_id + | Port_stats_reply of int32 * bool * Port.stats list * datapath_id + | Table_stats_reply of int32 * bool * Stats.table list * datapath_id | Desc_stats_reply of string * string * string * string * string * datapath_id | Port_status of Port.reason * Port.phy * datapath_id + + (** convert a controller event to a string representation *) val string_of_event : e -> string end -type t +type t + +(** [register_cb ctrl evt fn] registers a callback for a specific event on + * controller ctrl *) val register_cb : t -> Event.t -> (t -> Ofpacket.datapath_id -> Event.e -> unit Lwt.t) -> unit -val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.buf -> unit Lwt.t -val terminate : t -> unit -val mem_dbg : string -> unit -val listen : Manager.t -> Nettypes.ipv4_src -> + +(** Controll channel packet transmission *) + +(** [send_of_data ctrl dpid bits] send a byte packet to the switch with datapath + * dpid throught the ctrl controller *) +val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.t -> unit Lwt.t +(** [send_data ctrl dpid pkt] send the pkt OpenFlow message to the switch with datapath + * dpid throught the ctrl controller *) +val send_data : t -> Ofpacket.datapath_id -> Ofpacket.t -> unit Lwt.t + +(** Controller daemon setup *) + +(** [init_controller init] create the state for an openflow controller and + * initialize it using the init method *) +val init_controller : ?verbose:bool -> (t -> 'a) -> t +(** [listen mgr addr init] listen on addr for connection switches. Intialize the + * state for each control channel unsing the init method. *) +val listen : Manager.t -> ?verbose:bool -> Nettypes.ipv4_src -> (t -> 'a) -> unit Lwt.t -val connect : Manager.t -> Nettypes.ipv4_dst -> +(** [connect mgr addr init] connect to the switch on addr. Intialize the + * state of the control channel unsing the init method. *) +val connect : Manager.t -> ?verbose:bool -> Nettypes.ipv4_dst -> (t -> 'a) -> unit Lwt.t + (** [local_connect ctrl conn] connect to the switch using a local OpenFlow + * socket. *) +val local_connect : t -> Ofsocket.conn_state -> unit Lwt.t diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 644bac5..0c14c8c 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -17,53 +17,34 @@ open Printf open Lwt open Int32 -(* open Cstruct *) - let sp = Printf.sprintf let pp = Printf.printf let ep = Printf.eprintf -exception Unparsable of string * Cstruct.buf -exception Unparsed of string * Cstruct.buf +exception Unparsable of string * Cstruct.t +exception Unparsed of string * Cstruct.t exception Unsupported of string -let resolve t = Lwt.on_success t (fun _ -> ()) let (|>) x f = f x (* pipe *) let (>>) f g x = g (f x) (* functor pipe *) let (||>) l f = List.map f l (* element-wise pipe *) -let (+++) x y = Int32.add x y - -let (&&&) x y = Int32.logand x y -let (|||) x y = Int32.logor x y -let (^^^) x y = Int32.logxor x y -let (<<<) x y = Int32.shift_left x y -let (>>>) x y = Int32.shift_right_logical x y - -let join c l = String.concat c l -let stop (x, bits) = x (* drop remainder to stop parsing and demuxing *) - -type int16 = int - (* XXX of dubious merit - but we don't do arithmetic so prefer the documentation benefits for now *) type uint8 = char type uint16 = int +type int16 = int type uint32 = int32 type uint64 = int64 let uint8_of_int i = Char.chr i -(* XXX network specific types that should have a proper home *) - -type ipv4 = uint32 -let ipv4_to_string i = - sp "%ld.%ld.%ld.%ld" - ((i &&& 0x0_ff000000_l) >>> 24) ((i &&& 0x0_00ff0000_l) >>> 16) - ((i &&& 0x0_0000ff00_l) >>> 8) ((i &&& 0x0_000000ff_l) ) +let zero_mac = Macaddr.of_bytes_exn "\x00\x00\x00\x00\x00\x00" +let zero_ip = Ipaddr.V4.of_int32 0l +(* XXX network specific types that should have a proper home *) type byte = uint8 let byte (i:int) : byte = Char.chr i let int_of_byte b = int_of_char b @@ -71,27 +52,9 @@ let int32_of_byte b = b |> int_of_char |> Int32.of_int let int32_of_int (i:int) = Int32.of_int i type bytes = string -type eaddr = bytes let bytes_to_hex_string bs = bs |> Array.map (fun b -> sp "%02x." (int_of_byte b)) -let eaddr_to_string s = - let l = String.length s in - let hp s i = sp "%02x" (int_of_char s.[i]) in - String.concat ":" (Array.init l (fun i -> hp s i) |> Array.to_list) - -(* let bitstring_of_eaddr s = - (BITSTRING{s:48:string}) *) - -let eaddr_is_broadcast s = - match s with - | "\xFF\xFF\xFF\xFF\xFF\xFF" -> true - | _ -> false - -let ipv4_addr_of_bytes bs = - ((bs.[0] |> int32_of_byte <<< 24) ||| (bs.[1] |> int32_of_byte <<< 16) - ||| (bs.[2] |> int32_of_byte <<< 8) ||| (bs.[3] |> int32_of_byte)) - (*********************************************************************** *) (* for readability *) @@ -99,32 +62,25 @@ type vendor = uint32 type queue_id = uint32 type datapath_id = uint64 -let contain_exc l v = - try - Some (v ()) - with exn -> - eprintf "ofpacket %s exn: %s\n%!" l (Printexc.to_string exn); - None - (* * bit manipulation functions for 32-bit integers * *) let int_of_bool = function | true -> 1 | false -> 0 -let get_int32_bit f off = (Int32.logand f (Int32.shift_left 1l off)) > 0l +let get_int32_bit f off = (Int32.logand f (shift_left 1l off)) > 0l let set_int32_bit f off v = - logor f (Int32.shift_left (Int32.of_int(int_of_bool v)) off) + logor f (shift_left (Int32.of_int(int_of_bool v)) off) let get_int32_byte f off = - let ret = Int32.shift_left (f logand (Int32.shift_left 13l off)) off in + let ret = shift_left (f logand (shift_left 13l off)) off in char_of_int (0x00ff land (Int32.to_int ret)) let set_int32_byte f off v = let value = Int32.of_int ((int_of_char v) lsl off) in logor f value let get_int32_nw_mask f off = - let ret = Int32.shift_left (logand f (Int32.shift_left 13l off)) off in + let ret = shift_right (logand f (shift_left 0x3fl off)) off in char_of_int (0x003f land (Int32.to_int ret)) let set_int32_nw_mask f off v = let value = Int32.of_int ((0x3f land v) lsl off) in @@ -135,14 +91,13 @@ let set_int_bit f off v = f lor ((int_of_bool v) lsl off) let marshal_and_sub fn bits = let len = fn bits in - Cstruct.sub bits 0 len + Cstruct.sub bits 0 len let marshal_and_shift fn bits = let len = fn bits in - (len, (Cstruct.shift bits len)) + (len, (Cstruct.shift bits len)) module Header = struct - cstruct ofp_header { uint8_t version; uint8_t typ; @@ -155,7 +110,7 @@ module Header = struct ERROR = 1; ECHO_REQ = 2; ECHO_RESP = 3; - VENDOR = 4; + VENDOR_MSG = 4; FEATURES_REQ = 5; FEATURES_RESP = 6; GET_CONFIG_REQ = 7; @@ -175,33 +130,33 @@ module Header = struct QUEUE_GET_CONFIG_RESP = 21 } as uint8_t - type h = { +type h = { ver: uint8; ty: msg_code; len: uint16; xid: uint32; } - let get_len = 8 + let get_len = sizeof_ofp_header let parse_header bits = match ((get_ofp_header_version bits), (int_to_msg_code (get_ofp_header_typ bits))) with - | (1, Some(ty)) - -> let ret = - { ver=(char_of_int (get_ofp_header_version bits)); + | (1, Some(ty)) -> + let ret = + { ver=(char_of_int (get_ofp_header_version bits)); ty; len=(get_ofp_header_length bits); xid=(get_ofp_header_xid bits); } in - let _ = Cstruct.shift bits sizeof_ofp_header in + let _ = Cstruct.shift bits sizeof_ofp_header in ret - | (_, _) -> raise (Unparsable ("parse_h", bits)) - + | (_, _) -> raise (Unparsable ("parse_h", bits)) + let header_to_string h = sp "ver:%d type:%s len:%d xid:0x%08lx" (int_of_byte h.ver) (msg_code_to_string h.ty) h.len h.xid - let create ty len xid = + let create ?(xid=Random.int32 Int32.max_int) ty len = { ver=byte 1; ty; len; xid } let marshal_header h bits = @@ -209,7 +164,7 @@ module Header = struct let _ = set_ofp_header_typ bits (msg_code_to_int h.ty) in let _ = set_ofp_header_length bits h.len in let _ = set_ofp_header_xid bits h.xid in - sizeof_ofp_header + sizeof_ofp_header end module Queue = struct @@ -225,7 +180,10 @@ module Port = struct | Max | In_port | Table | Normal | Flood | All | Controller | Local | No_port | Port of int16 - + + let is_num value = + try let _ = int_of_string value in true with _ -> false + let port_of_int = function | 0xff00 -> Max | 0xfff8 -> In_port @@ -259,7 +217,19 @@ module Port = struct | Local -> sp "LOCAL" | No_port -> sp "NO_PORT" | Port p -> sp "PORT(%d)" p - + and port_of_string = function + | "MAX" -> Some(Max) + | "IN_PORT" -> Some(In_port) + | "TABLE" -> Some(Table) + | "NORMAL" -> Some(Normal) + | "FLOOD" -> Some(Flood) + | "ALL" -> Some(All) + | "CONTROLLER" -> Some(Controller) + | "LOCAL" -> Some(Local) + | "NO_PORT" -> Some(No_port) + | num when (is_num num) -> Some(Port(int_of_string num)) + | _ -> None + type config = { port_down: bool; no_stp: bool; @@ -288,7 +258,7 @@ module Port = struct let ret = set_int32_bit ret 4 config.no_flood in let ret = set_int32_bit ret 5 config.no_fwd in let ret = set_int32_bit ret 6 config.no_packet_in in - ret + ret let init_port_config = {port_down=false; no_stp=false; no_recv=false; no_recv_stp=false; @@ -338,10 +308,10 @@ module Port = struct } let get_link_down f = (logand f 1l) > 0l - let get_stp_listen f = (logand f (Int32.shift_left 0l 8)) > 0l - let get_stp_learn f = (logand f (Int32.shift_left 1l 8)) > 0l - let get_stp_forward f = (logand f (Int32.shift_left 2l 8)) > 0l - let get_stp_block f = (logand f (Int32.shift_left 3l 8)) > 0l + let get_stp_listen f = (logand f (shift_left 0l 8)) > 0l + let get_stp_learn f = (logand f (shift_left 1l 8)) > 0l + let get_stp_forward f = (logand f (shift_left 2l 8)) > 0l + let get_stp_block f = (logand f (shift_left 3l 8)) > 0l (*TODO this parsing is incorrect. use get_int32_bit and I think * set_stp_forward is a byte *) @@ -368,7 +338,7 @@ module Port = struct type phy = { port_no: uint16; - hw_addr: eaddr; + hw_addr: Macaddr.t; name: string; config: config; state: state; @@ -394,7 +364,7 @@ module Port = struct let phy_len = 48 let parse_phy bits = let port_no = (get_ofp_phy_port_port_no bits) in - let hw_addr=(Cstruct.to_string (get_ofp_phy_port_hw_addr bits)) in + let hw_addr=Macaddr.of_bytes_exn (Cstruct.to_string (get_ofp_phy_port_hw_addr bits)) in let name=(Cstruct.to_string (get_ofp_phy_port_name bits)) in let config = (parse_config (get_ofp_phy_port_config bits)) in let state = (parse_state (get_ofp_phy_port_state bits)) in @@ -417,30 +387,38 @@ module Port = struct in aux [] bits - let init_port_phy ?(port_no = 0) ?(hw_addr="\x11\x11\x11\x11\x11\x11") + let init_port_phy ?(port_no = 0) ?(hw_addr=Macaddr.broadcast) ?(name="") () = {port_no; hw_addr; name; config=init_port_config; state=init_port_state; curr=init_port_features; advertised=init_port_features; supported=init_port_features; peer=init_port_features;} - let marshal_phy phy bits = - let _ = set_ofp_phy_port_port_no bits phy.port_no in - let _ = set_ofp_phy_port_hw_addr phy.hw_addr 0 bits in - let name = String.make 16 (char_of_int 0) in - let _ = String.blit phy.name 0 name 0 (String.length phy.name) in - let _ = set_ofp_phy_port_name name 0 bits in - let _ = set_ofp_phy_port_config bits 0l in - let _ = set_ofp_phy_port_state bits 0l in - let _ = set_ofp_phy_port_curr bits 0l in - let _ = set_ofp_phy_port_advertised bits 0l in - let _ = set_ofp_phy_port_supported bits 0l in - let _ = set_ofp_phy_port_peer bits 0l in - Cstruct.shift bits sizeof_ofp_phy_port + let translate_port_phy port new_port_id = + {port_no=new_port_id; hw_addr=port.hw_addr; + name=port.name; config=port.config; + state=port.state; curr=port.curr; + advertised=port.advertised; supported=port.supported; + peer=port.peer;} + + + let marshal_phy phy bits = + let _ = set_ofp_phy_port_port_no bits phy.port_no in + let _ = set_ofp_phy_port_hw_addr (Macaddr.to_bytes phy.hw_addr) 0 bits in + let name = String.make 16 (char_of_int 0) in + let _ = String.blit phy.name 0 name 0 (String.length phy.name) in + let _ = set_ofp_phy_port_name name 0 bits in + let _ = set_ofp_phy_port_config bits 0l in + let _ = set_ofp_phy_port_state bits 0l in + let _ = set_ofp_phy_port_curr bits 0l in + let _ = set_ofp_phy_port_advertised bits 0l in + let _ = set_ofp_phy_port_supported bits 0l in + let _ = set_ofp_phy_port_peer bits 0l in + Cstruct.shift bits sizeof_ofp_phy_port let string_of_phy ph = (sp "port_no:%d,hw_addr:%s,name:%s" - ph.port_no (eaddr_to_string ph.hw_addr) ph.name) + ph.port_no (Macaddr.to_string ph.hw_addr) ph.name) type stats = { mutable port_id: uint16; @@ -492,7 +470,7 @@ module Port = struct rx_over_err=(get_ofp_port_stats_rx_over_err bits); rx_crc_err=(get_ofp_port_stats_rx_crc_err bits); collisions=(get_ofp_port_stats_collisions bits);}] in - let _ = Cstruct.shift_left bits sizeof_ofp_port_stats in + let _ = Cstruct.shift bits sizeof_ofp_port_stats in record @ (parse_port_stats_reply (bits) ) let rec string_of_port_stats_reply ports = @@ -515,21 +493,6 @@ module Port = struct MOD = 2 } as uint8_t -(* type reason = ADD | DEL | MOD - let reason_of_int = function - | 0 -> ADD - | 1 -> DEL - | 2 -> MOD - | _ -> invalid_arg "reason_of_int" - and int_of_reason = function - | ADD -> 0 - | DEL -> 1 - | MOD -> 2 - and string_of_reason = function - | ADD -> sp "ADD" - | DEL -> sp "DEL" - | MOD -> sp "MOD"*) - type status = { reason: reason; desc: phy; @@ -540,6 +503,10 @@ module Port = struct uint8_t pad[7] } as big_endian + let create_port_status reason desc = + ((Header.(create PORT_STATUS (get_len + sizeof_ofp_port_status)) ), + {reason; desc;}) + let string_of_status st = (sp "Port status,reason:%s,%s" (reason_to_string st.reason) (string_of_phy st.desc) ) @@ -550,9 +517,17 @@ module Port = struct | Some(reason) -> reason | None -> raise(Unparsable("reason_of_int", bits)) in - let _ = Cstruct.shift_left bits sizeof_ofp_port_status in + let bits = Cstruct.shift bits sizeof_ofp_port_status in {reason; desc=(parse_phy bits)} + let marshal_port_status ?(xid=0l) status bits = + let len = Header.get_len + sizeof_ofp_port_status + phy_len in + let header = Header.create ~xid Header.PORT_STATUS len in + let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in + let _ = set_ofp_port_status_reason bits (reason_to_int status.reason) in + let bits = Cstruct.shift bits sizeof_ofp_port_status in + let _ = marshal_phy status.desc bits in + len end module Switch = struct @@ -657,12 +632,16 @@ module Switch = struct | head :: tail -> let bits = Port.marshal_phy head bits in marshal_phy_ports tail bits + let get_len t = + Header.get_len + sizeof_ofp_switch_features + + ((List.length t.ports) * Port.phy_len) + let marshal_reply_features xid feat bits = let ports_count = (List.length feat.ports) in let len = Header.get_len + sizeof_ofp_switch_features + ports_count*Port.phy_len in - let header = Header.create Header.FEATURES_RESP len xid in + let header = Header.create ~xid Header.FEATURES_RESP len in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let _ = set_ofp_switch_features_datapath_id bits feat.datapath_id in let _ = set_ofp_switch_features_n_buffers bits feat.n_buffers in @@ -694,63 +673,76 @@ module Switch = struct miss_send_len: uint16; } - let init_switch_config = - {drop=true; reasm=true;miss_send_len=1000;} + let init_switch_config = {drop=true; + reasm=true;miss_send_len=1000;} cstruct ofp_switch_config { uint16_t flags; uint16_t miss_send_len } as big_endian + let config_get_len = Header.get_len + sizeof_ofp_switch_config + let marshal_switch_config xid config bits = - let header = (Header.create Header.GET_CONFIG_RESP - (Header.get_len + sizeof_ofp_switch_config) xid) in + let header = (Header.create ~xid Header.GET_CONFIG_RESP + (Header.get_len + sizeof_ofp_switch_config)) in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let _ = set_ofp_switch_config_flags bits 0 in let _ = set_ofp_switch_config_miss_send_len bits config.miss_send_len in (Header.sizeof_ofp_header + sizeof_ofp_switch_config) + let parse_switch_config bits = + let _ = get_ofp_switch_config_flags bits in + let miss_send_len = get_ofp_switch_config_miss_send_len bits in + {drop=false; reasm=false; miss_send_len} + end module Wildcards = struct type t = { - in_port: bool; - dl_vlan: bool; - dl_src: bool; - dl_dst: bool; - dl_type: bool; - nw_proto: bool; - tp_src: bool; - tp_dst: bool; - nw_src: byte; (* XXX *) - nw_dst: byte; (* XXX *) - dl_vlan_pcp: bool; - nw_tos: bool; + mutable in_port: bool; + mutable dl_vlan: bool; + mutable dl_src: bool; + mutable dl_dst: bool; + mutable dl_type: bool; + mutable nw_proto: bool; + mutable tp_src: bool; + mutable tp_dst: bool; + mutable nw_src: byte; (* XXX *) + mutable nw_dst: byte; (* XXX *) + mutable dl_vlan_pcp: bool; + mutable nw_tos: bool; } - let full_wildcard = + let in_port_match () = + { in_port=false; dl_vlan=true; dl_src=true; + dl_dst=true; dl_type=true; nw_proto=true; + tp_src=true; tp_dst=true; nw_src=(char_of_int 32); + nw_dst=(char_of_int 32); dl_vlan_pcp=true; nw_tos=true; + } + let full_wildcard () = { in_port=true; dl_vlan=true; dl_src=true; dl_dst=true; dl_type=true; nw_proto=true; tp_src=true; tp_dst=true; nw_src=(char_of_int 32); nw_dst=(char_of_int 32); dl_vlan_pcp=true; nw_tos=true; } - let exact_match = + let exact_match () = { in_port=false; dl_vlan=false; dl_src=false; dl_dst=false; dl_type=false; nw_proto=false; tp_src=false; tp_dst=false; nw_src=(char_of_int 0); nw_dst=(char_of_int 0); dl_vlan_pcp=false; nw_tos=false; } - let l2_match = + let l2_match () = { in_port=false;dl_vlan=false;dl_src=false;dl_dst=false; dl_type=false;nw_proto=true;tp_src=true;tp_dst=true; nw_src=(char_of_int 32);nw_dst=(char_of_int 32);dl_vlan_pcp=false; nw_tos=true } - let l3_match = + let l3_match () = { in_port=false;dl_vlan=false;dl_vlan_pcp=false;dl_src=false; dl_dst=false;dl_type=false;nw_proto=false;nw_tos=false; nw_src=(char_of_int 0);nw_dst=(char_of_int 0);tp_src=true;tp_dst=true; } - let arp_match = + let arp_match () = { in_port=false;dl_vlan=false;dl_vlan_pcp=false;dl_src=false; dl_dst=false;dl_type=false;nw_proto=false;nw_tos=true; nw_src=(char_of_int 32);nw_dst=(char_of_int 32);tp_src=true;tp_dst=true; @@ -801,20 +793,34 @@ end module Match = struct type t = { - wildcards: Wildcards.t; - in_port: Port.t; - dl_src: eaddr; - dl_dst: eaddr; - dl_vlan: uint16; - dl_vlan_pcp: byte; - dl_type: uint16; - nw_src: uint32; - nw_dst: uint32; - nw_tos: byte; - nw_proto: byte; - tp_src: uint16; - tp_dst: uint16; - } + mutable wildcards: Wildcards.t; + mutable in_port: Port.t; + mutable dl_src: Macaddr.t; + mutable dl_dst: Macaddr.t; + mutable dl_vlan: uint16; + mutable dl_vlan_pcp: byte; + mutable dl_type: uint16; + mutable nw_src: Ipaddr.V4.t; + mutable nw_dst: Ipaddr.V4.t; + mutable nw_tos: byte; + mutable nw_proto: byte; + mutable tp_src: uint16; + mutable tp_dst: uint16; + } + + let wildcard () = + {wildcards=(Wildcards.full_wildcard ()); in_port=Port.No_port; + dl_src=zero_mac; dl_dst=zero_mac; + dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; + nw_src=zero_ip; nw_dst=zero_ip; + nw_tos='\000';nw_proto='\000';tp_src=0; tp_dst=0;} + let arp () = + {wildcards=(Wildcards.full_wildcard ()); in_port=Port.No_port; + dl_src=zero_mac; dl_dst=zero_mac; + dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; nw_src=zero_ip; + nw_dst=zero_ip; nw_tos='\000';nw_proto='\000';tp_src=0; + tp_dst=0;} + cstruct ofp_match { uint32_t wildcards; @@ -839,15 +845,15 @@ module Match = struct let _ = set_ofp_match_wildcards bits (Wildcards.marshal_wildcard m.wildcards) in let _ = set_ofp_match_in_port bits (Port.int_of_port m.in_port) in - let _ = set_ofp_match_dl_src m.dl_src 0 bits in - let _ = set_ofp_match_dl_dst m.dl_dst 0 bits in + let _ = set_ofp_match_dl_src (Macaddr.to_bytes m.dl_src) 0 bits in + let _ = set_ofp_match_dl_dst (Macaddr.to_bytes m.dl_dst) 0 bits in let _ = set_ofp_match_dl_vlan bits m.dl_vlan in let _ = set_ofp_match_dl_vlan_pcp bits (int_of_char m.dl_vlan_pcp) in let _ = set_ofp_match_dl_type bits m.dl_type in let _ = set_ofp_match_nw_tos bits (int_of_char m.nw_tos) in let _ = set_ofp_match_nw_proto bits (int_of_char m.nw_proto) in - let _ = set_ofp_match_nw_src bits m.nw_src in - let _ = set_ofp_match_nw_dst bits m.nw_dst in + let _ = set_ofp_match_nw_src bits (Ipaddr.V4.to_int32 m.nw_src) in + let _ = set_ofp_match_nw_dst bits (Ipaddr.V4.to_int32 m.nw_dst) in let _ = set_ofp_match_tp_src bits m.tp_src in let _ = set_ofp_match_tp_dst bits m.tp_dst in sizeof_ofp_match @@ -855,15 +861,15 @@ module Match = struct let parse_match bits = let wildcards = Wildcards.parse_wildcards (get_ofp_match_wildcards bits) in let in_port = Port.port_of_int (get_ofp_match_in_port bits) in - let dl_src = Cstruct.to_string (get_ofp_match_dl_src bits) in - let dl_dst = Cstruct.to_string (get_ofp_match_dl_dst bits) in + let dl_src = Macaddr.of_bytes_exn (Cstruct.to_string (get_ofp_match_dl_src bits)) in + let dl_dst = Macaddr.of_bytes_exn (Cstruct.to_string (get_ofp_match_dl_dst bits)) in let dl_vlan = get_ofp_match_dl_vlan bits in let dl_vlan_pcp = char_of_int (get_ofp_match_dl_vlan_pcp bits) in let dl_type = get_ofp_match_dl_type bits in let nw_tos = char_of_int (get_ofp_match_nw_tos bits) in let nw_proto = char_of_int (get_ofp_match_nw_proto bits) in - let nw_src = get_ofp_match_nw_src bits in - let nw_dst = get_ofp_match_nw_dst bits in + let nw_src = Ipaddr.V4.of_int32 (get_ofp_match_nw_src bits) in + let nw_dst = Ipaddr.V4.of_int32 (get_ofp_match_nw_dst bits) in let tp_src = get_ofp_match_tp_src bits in let tp_dst = get_ofp_match_tp_dst bits in let _ = Cstruct.shift bits sizeof_ofp_match in @@ -871,13 +877,11 @@ module Match = struct dl_type; nw_tos; nw_proto; nw_src; nw_dst; tp_src; tp_dst;} (* Check if the flow object is include in flow_def match *) - let null_eaddr = "\x00\x00\x00\x00\x00\x00" let create_flow_match wildcards - ?(in_port = 0) ?(dl_src=null_eaddr) ?(dl_dst=null_eaddr) + ?(in_port = 0) ?(dl_src=zero_mac) ?(dl_dst=zero_mac) ?(dl_vlan=0xffff) ?(dl_vlan_pcp=(char_of_int 0)) ?(dl_type=0) - ?(nw_tos=(char_of_int 0)) - ?(nw_proto=(char_of_int 0)) - ?(nw_src=(Int32.of_int 0)) ?(nw_dst=(Int32.of_int 0)) + ?(nw_tos=(char_of_int 0)) ?(nw_proto=(char_of_int 0)) + ?(nw_src=zero_ip) ?(nw_dst=zero_ip) ?(tp_src=0) ?(tp_dst=0) () = { wildcards; in_port=(Port.port_of_int in_port); @@ -885,6 +889,47 @@ module Match = struct nw_src; nw_dst; nw_tos; nw_proto; tp_src; tp_dst; } + let create_match ?(in_port=None) ?(dl_vlan=None) ?(dl_src=None) ?(dl_dst=None) + ?(dl_type=None) ?(nw_proto=None) ?(tp_dst=None) ?(tp_src=None) + ?(nw_dst=None) ?(nw_dst_len=32) ?(nw_src=None) ?(nw_src_len=32) + ?(dl_vlan_pcp=None) ?(nw_tos=None) () = + + let is_none = function + | None -> true + | Some _ -> false + in + let option_default v d = + match v with + | None -> d + | Some v -> v + in + let flow_wild = Wildcards.({ + in_port=(is_none in_port); dl_vlan=(is_none dl_vlan); + dl_src=(is_none dl_src); dl_dst=(is_none dl_dst); + dl_type=(is_none dl_type); nw_proto=(is_none nw_proto); + tp_dst=(is_none tp_dst); tp_src=(is_none tp_src); + nw_dst=(char_of_int nw_dst_len); nw_src=(char_of_int nw_src_len); + dl_vlan_pcp=(is_none dl_vlan_pcp); nw_tos=(is_none nw_tos);}) in + create_flow_match flow_wild + ~in_port:(option_default in_port 0) + ~dl_src:(option_default dl_src zero_mac) + ~dl_dst:(option_default dl_dst zero_mac) + ~dl_vlan:(option_default dl_vlan 0xffff) + ~dl_vlan_pcp:(option_default dl_vlan_pcp (char_of_int 0)) + ~dl_type:(option_default dl_type 0) + ~nw_tos:(option_default nw_tos (char_of_int 0)) + ~nw_proto:(option_default nw_proto (char_of_int 0)) + ~nw_src:(option_default nw_src zero_ip ) + ~nw_dst:(option_default nw_dst zero_ip ) + ~tp_src:(option_default tp_src 0) + ~tp_dst:(option_default tp_dst 0) () + + let translate_port m p = + {wildcards=m.wildcards; in_port=p; dl_src=m.dl_src; dl_dst=m.dl_dst; + dl_vlan=m.dl_vlan; dl_vlan_pcp=m.dl_vlan_pcp; dl_type=m.dl_type; + nw_tos=m.nw_tos; nw_proto=m.nw_proto; nw_src=m.nw_src; nw_dst=m.nw_dst; + tp_src=m.tp_src; tp_dst=m.tp_dst;} + cstruct dl_header { uint8_t dl_dst[6]; uint8_t dl_src[6]; @@ -926,14 +971,15 @@ module Match = struct } as big_endian let raw_packet_to_match in_port bits = - let dl_dst = Cstruct.to_string (get_dl_header_dl_dst bits) in - let dl_src = Cstruct.to_string (get_dl_header_dl_src bits) in + let dl_dst = Macaddr.of_bytes_exn (Cstruct.to_string (get_dl_header_dl_dst bits)) in + let dl_src = Macaddr.of_bytes_exn (Cstruct.to_string (get_dl_header_dl_src + bits)) in let dl_type = get_dl_header_dl_type bits in let bits = Cstruct.shift bits sizeof_dl_header in match (dl_type) with | 0x0800 -> begin - let nw_src = get_nw_header_nw_src bits in - let nw_dst = get_nw_header_nw_dst bits in + let nw_src = Ipaddr.V4.of_int32 (get_nw_header_nw_src bits) in + let nw_dst = Ipaddr.V4.of_int32 (get_nw_header_nw_dst bits) in let nw_proto = get_nw_header_nw_proto bits in let nw_tos = char_of_int (get_nw_header_nw_tos bits) in let len = (get_nw_header_hlen_version bits) land 0xf in @@ -941,66 +987,70 @@ module Match = struct match (nw_proto) with | 17 | 6 -> - {wildcards=Wildcards.exact_match; + {wildcards=(Wildcards.exact_match ()); in_port; dl_src; dl_dst; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0);dl_type; nw_src; nw_dst; nw_tos; nw_proto=(char_of_int nw_proto); tp_src=(get_tp_header_tp_src bits); tp_dst=(get_tp_header_tp_dst bits);} | 1 -> - { wildcards =Wildcards.exact_match; + { wildcards =(Wildcards.exact_match ()); in_port;dl_src; dl_dst; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0);dl_type; nw_src; nw_dst; nw_tos; nw_proto=(char_of_int nw_proto); tp_src=(get_icmphdr_typ bits); tp_dst=(get_icmphdr_code bits); } | _ -> - { wildcards =Wildcards.l3_match; + { wildcards =(Wildcards.l3_match ()); in_port;dl_src; dl_dst; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0);dl_type; nw_src; nw_dst; nw_tos; nw_proto=(char_of_int nw_proto); tp_src=0; tp_dst=0; } end | 0x0806 -> - {wildcards=Wildcards.arp_match; + let nw_src = Ipaddr.V4.of_int32 (get_nw_header_nw_src bits) in + let nw_dst = Ipaddr.V4.of_int32 (get_nw_header_nw_dst bits) in + {wildcards=(Wildcards.arp_match ()); in_port; dl_src; dl_dst; dl_type; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0); - nw_src=(get_arphdr_nw_src bits); - nw_dst=(get_arphdr_nw_dst bits); + nw_src; nw_dst; nw_proto=( char_of_int (get_arphdr_ar_op bits)); nw_tos=(char_of_int 0); tp_src=0; tp_dst=0} | _ -> - {wildcards=Wildcards.l2_match; + {wildcards=(Wildcards.l2_match ()); in_port; dl_src; dl_dst; dl_type; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0); - nw_src=0l; nw_dst=0l; + nw_src=zero_ip; nw_dst=zero_ip; nw_tos=(char_of_int 0); nw_proto=(char_of_int 0); tp_src=0; tp_dst=0} - let match_to_string m = - match (m.dl_type, (int_of_char m.nw_proto)) with - | (0x0800, 17) - -> (sp "in_port:%s,dl_src:%s,dl_dst:%s,dl_type:ip,nw_src:%s/%d,nw_dst:%s/%d,\ - nw_tos:%d,nw_proto:%d,tp_dst:%d,tp_src:%d" - (Port.string_of_port m.in_port) (eaddr_to_string m.dl_src) - (eaddr_to_string m.dl_dst) (ipv4_to_string m.nw_src) (int_of_char m.wildcards.Wildcards.nw_src) - (ipv4_to_string m.nw_dst) (int_of_char m.wildcards.Wildcards.nw_dst) (Char.code m.nw_tos) - (Char.code m.nw_proto) m.tp_dst m.tp_src - ) - | (0x0800, _) - -> (sp "in_port:%s,dl_src:%s,dl_dst:%s,dl_type:ip,nw_src:%s/%d,\ - nw_dst:%s/%d,nw_tos:%d,nw_proto:%d" - (Port.string_of_port m.in_port) (eaddr_to_string m.dl_src) - (eaddr_to_string m.dl_dst) (ipv4_to_string m.nw_src) (int_of_char m.wildcards.Wildcards.nw_src) - (ipv4_to_string m.nw_dst) (int_of_char m.wildcards.Wildcards.nw_dst) (Char.code m.nw_tos) - (Char.code m.nw_proto) - ) - | (_, _) -> (sp "in_port:%s,dl_src:%s,dl_dst:%s,dl_type:0x%x" - (Port.string_of_port m.in_port) (eaddr_to_string m.dl_src) - (eaddr_to_string m.dl_dst) m.dl_type - ) + let print_field flag name value = + if (flag) then + "" + else + sprintf "%s:%s," name value + + let match_to_string m = + sprintf + "%s%s%s%s%s%s%s%s%s%s%s%s" + (print_field m.wildcards.Wildcards.in_port "in_port" (Port.string_of_port m.in_port)) + (print_field m.wildcards.Wildcards.dl_src "dl_src" (Macaddr.to_string m.dl_src)) + (print_field m.wildcards.Wildcards.dl_dst "dl_dst" (Macaddr.to_string m.dl_dst)) + (print_field m.wildcards.Wildcards.dl_vlan "dl_vlan" (string_of_int m.dl_vlan)) + (print_field m.wildcards.Wildcards.dl_vlan_pcp "dl_pcp" + (string_of_int (int_of_char m.dl_vlan_pcp) )) + (print_field m.wildcards.Wildcards.dl_type "dl_type" (string_of_int m.dl_type)) + (print_field (m.wildcards.Wildcards.nw_src >= '\x20') "nw_src" + (sprintf "%s/%d" (Ipaddr.V4.to_string m.nw_src) (int_of_char m.wildcards.Wildcards.nw_src) )) + (print_field (m.wildcards.Wildcards.nw_dst >= '\x20') "nw_dst" + (sprintf "%s/%d" (Ipaddr.V4.to_string m.nw_dst) (int_of_char m.wildcards.Wildcards.nw_dst) )) + (print_field m.wildcards.Wildcards.nw_tos "nw_tos" (string_of_int (int_of_char m.nw_tos))) + (print_field m.wildcards.Wildcards.nw_proto "nw_proto" (string_of_int (int_of_char m.nw_proto))) + (print_field m.wildcards.Wildcards.tp_src "tp_src" (string_of_int m.tp_src)) + (print_field m.wildcards.Wildcards.tp_dst "tp_dst" (string_of_int m.tp_dst)) + let flow_match_compare flow flow_def wildcard = -(* Printf.printf "comparing flows %s \n%s\n%s \n%!" (Wildcards.string_of_wildcard wildcard) +(* Printf.printf "comparing flows %s \n%s\n%s \n%!" (Wildcards.wildcard_to_string wildcard) (match_to_string flow) (match_to_string flow_def); Printf.printf "in_port:%s,dl_vlan:%s,dl_src:%s(%d %d),dl_dst:%s,dl_type:%s,\ nw_proto:%s,tp_src:%s(%d %d),tp_dst:%s,nw_src:%s,nw_dst:%s,\ @@ -1024,23 +1074,25 @@ module Match = struct (string_of_bool ((wildcard.Wildcards.nw_tos) || (flow.nw_tos == flow_def.nw_tos)) ) (string_of_bool ((wildcard.Wildcards.dl_vlan_pcp) || flow.dl_vlan_pcp == flow_def.dl_vlan_pcp));*) - - (((wildcard.Wildcards.in_port)|| ((Port.int_of_port flow.in_port) == (Port.int_of_port flow_def.in_port))) && - ((wildcard.Wildcards.dl_vlan) || (flow.dl_vlan == flow_def.dl_vlan)) && + let nw_src_mask = 0x20 - (int_of_char wildcard.Wildcards.nw_src) in + let nw_dst_mask = 0x20 - (int_of_char wildcard.Wildcards.nw_dst) in + (((wildcard.Wildcards.in_port)|| ((Port.int_of_port flow.in_port) = (Port.int_of_port flow_def.in_port))) && +(* ((wildcard.Wildcards.dl_vlan) || (flow.dl_vlan == flow_def.dl_vlan)) + * &&*) ((wildcard.Wildcards.dl_src) || (flow.dl_src = flow_def.dl_src)) && ((wildcard.Wildcards.dl_dst) || (flow.dl_dst = flow_def.dl_dst)) && - ((wildcard.Wildcards.dl_type) || (flow.dl_type== flow_def.dl_type)) && - ((wildcard.Wildcards.nw_proto)|| (flow.nw_proto==flow_def.nw_proto)) && - ((wildcard.Wildcards.tp_src) || (flow.tp_src == flow_def.tp_src)) && - ((wildcard.Wildcards.tp_dst) || (flow.tp_dst == flow_def.tp_dst)) && - ((wildcard.Wildcards.nw_src >= '\x20') || - (Int32.shift_right_logical flow.nw_src (int_of_char wildcard.Wildcards.nw_src)) = - (Int32.shift_right_logical flow_def.nw_src (int_of_char wildcard.Wildcards.nw_src))) && - ((wildcard.Wildcards.nw_dst >= '\x20') || - (Int32.shift_right_logical flow.nw_dst (int_of_char wildcard.Wildcards.nw_dst)) = - (Int32.shift_right_logical flow_def.nw_dst (int_of_char wildcard.Wildcards.nw_dst))) && - ((wildcard.Wildcards.nw_tos) || (flow.nw_tos == flow_def.nw_tos)) && - ((wildcard.Wildcards.dl_vlan_pcp) || flow.dl_vlan_pcp == + ((wildcard.Wildcards.dl_type) || (flow.dl_type= flow_def.dl_type)) && + ((wildcard.Wildcards.nw_proto)|| (flow.nw_proto = flow_def.nw_proto)) && + ((wildcard.Wildcards.tp_src) || (flow.tp_src = flow_def.tp_src)) && + ((wildcard.Wildcards.tp_dst) || (flow.tp_dst = flow_def.tp_dst)) && + ((nw_src_mask <= 0) || + (Int32.shift_right_logical (Ipaddr.V4.to_int32 flow.nw_src) nw_src_mask) = + (Int32.shift_right_logical (Ipaddr.V4.to_int32 flow_def.nw_src) nw_src_mask)) && + ((nw_dst_mask <= 0) || + (Int32.shift_right_logical (Ipaddr.V4.to_int32 flow.nw_dst) nw_dst_mask) = + (Int32.shift_right_logical (Ipaddr.V4.to_int32 flow_def.nw_dst) nw_dst_mask)) && + ((wildcard.Wildcards.nw_tos) || (flow.nw_tos = flow_def.nw_tos)) && + ((wildcard.Wildcards.dl_vlan_pcp) || flow.dl_vlan_pcp = flow_def.dl_vlan_pcp)) end @@ -1051,10 +1103,10 @@ module Flow = struct | Set_vlan_vid of int | Set_vlan_pcp of int | STRIP_VLAN - | Set_dl_src of eaddr - | Set_dl_dst of eaddr - | Set_nw_src of ipv4 - | Set_nw_dst of ipv4 + | Set_dl_src of Macaddr.t + | Set_dl_dst of Macaddr.t + | Set_nw_src of Ipaddr.V4.t + | Set_nw_dst of Ipaddr.V4.t | Set_nw_tos of byte | Set_tp_src of int16 | Set_tp_dst of int16 @@ -1066,10 +1118,10 @@ module Flow = struct | 1 -> Set_vlan_vid(0xffff) | 2 -> Set_vlan_pcp(0) | 3 -> STRIP_VLAN - | 4 -> Set_dl_src("\xff\xff\xff\xff\xff\xff") - | 5 -> Set_dl_dst("\xff\xff\xff\xff\xff\xff") - | 6 -> Set_nw_src(0xFFFFFFFFl) - | 7 -> Set_nw_dst(0xFFFFFFFFl) + | 4 -> Set_dl_src(Macaddr.broadcast) + | 5 -> Set_dl_dst(Macaddr.broadcast) + | 6 -> Set_nw_src(Ipaddr.V4.broadcast) + | 7 -> Set_nw_dst(Ipaddr.V4.broadcast) | 8 -> Set_nw_tos(char_of_int 0) | 9 -> Set_tp_src (0) | 10 -> Set_tp_dst (0) @@ -1096,10 +1148,10 @@ module Flow = struct | Set_vlan_vid vlan -> sp "SET_VLAN_VID %d" vlan | Set_vlan_pcp (pcp) -> sp "SET_VLAN_PCP %d" pcp | STRIP_VLAN -> sp "STRIP_VLAN" - | Set_dl_src(eaddr) -> (sp "SET_DL_SRC %s" (eaddr_to_string eaddr)) - | Set_dl_dst(eaddr) -> (sp "SET_DL_DST %s" (eaddr_to_string eaddr)) - | Set_nw_src (ip) -> sp "SET_NW_SRC %s" (ipv4_to_string ip) - | Set_nw_dst (ip) -> sp "SET_NW_DST %s" (ipv4_to_string ip) + | Set_dl_src(eaddr) -> (sp "SET_DL_SRC %s" (Macaddr.to_string eaddr)) + | Set_dl_dst(eaddr) -> (sp "SET_DL_DST %s" (Macaddr.to_string eaddr)) + | Set_nw_src (ip) -> sp "SET_NW_SRC %s" (Ipaddr.V4.to_string ip) + | Set_nw_dst (ip) -> sp "SET_NW_DST %s" (Ipaddr.V4.to_string ip) | Set_nw_tos (tos) -> sp "SET_NW_TOS %d" (int_of_char tos) | Set_tp_src (port) -> sp "SET_TP_SRC %d" port | Set_tp_dst (port) -> sp "SET_TP_DST %d" port @@ -1207,13 +1259,13 @@ module Flow = struct | Set_dl_dst(eaddr) -> let _ = set_ofp_action_dl_addr_typ bits (int_of_action m) in let _ = set_ofp_action_dl_addr_len bits 16 in - let _ = set_ofp_action_dl_addr_dl_addr eaddr 0 bits in + let _ = set_ofp_action_dl_addr_dl_addr (Macaddr.to_bytes eaddr) 0 bits in sizeof_ofp_action_dl_addr | Set_nw_src (ip) | Set_nw_dst (ip) -> let _ = set_ofp_action_nw_addr_typ bits (int_of_action m) in - let _ = set_ofp_action_nw_addr_len bits 16 in - let _ = set_ofp_action_nw_addr_nw_addr bits ip in + let _ = set_ofp_action_nw_addr_len bits 8 in + let _ = set_ofp_action_nw_addr_nw_addr bits (Ipaddr.V4.to_int32 ip) in sizeof_ofp_action_nw_addr | Set_nw_tos (tos) -> let _ = set_ofp_action_nw_tos_typ bits (int_of_action m) in @@ -1262,18 +1314,20 @@ module Flow = struct | STRIP_VLAN -> (sizeof_ofp_action_header, STRIP_VLAN) | Set_dl_src( _ ) -> - let eaddr = Cstruct.to_string - (get_ofp_action_dl_addr_dl_addr bits) in + let eaddr = Macaddr.of_bytes_exn ( + Cstruct.to_string ( + get_ofp_action_dl_addr_dl_addr bits)) in (sizeof_ofp_action_dl_addr, Set_dl_src(eaddr)) | Set_dl_dst( _ ) -> - let eaddr = Cstruct.to_string - (get_ofp_action_dl_addr_dl_addr bits) in + let eaddr = Macaddr.of_bytes_exn + (Cstruct.to_string + (get_ofp_action_dl_addr_dl_addr bits)) in (sizeof_ofp_action_dl_addr, Set_dl_dst(eaddr)) | Set_nw_src( _ ) -> - let ip = get_ofp_action_nw_addr_nw_addr bits in + let ip = Ipaddr.V4.of_int32 (get_ofp_action_nw_addr_nw_addr bits) in (sizeof_ofp_action_nw_addr, Set_nw_src( ip )) | Set_nw_dst( _ ) -> - let ip = get_ofp_action_nw_addr_nw_addr bits in + let ip = Ipaddr.V4.of_int32 (get_ofp_action_nw_addr_nw_addr bits) in (sizeof_ofp_action_nw_addr, Set_nw_dst( ip )) | Set_nw_tos( _ ) -> let tos = char_of_int (get_ofp_action_nw_tos_nw_tos bits) in @@ -1302,20 +1356,11 @@ module Flow = struct printf "len of action cstruct %d\n%!" (Cstruct.len bits); raise (Unparsable("parse_actions", bits)) - type reason = IDLE_TIMEOUT | HARD_TIMEOUT | DELETE - let reason_of_int = function - | 0 -> IDLE_TIMEOUT - | 1 -> HARD_TIMEOUT - | 2 -> DELETE - | _ -> invalid_arg "reason_of_int" - and int_of_reason = function - | IDLE_TIMEOUT -> 0 - | HARD_TIMEOUT -> 1 - | DELETE -> 2 - and string_of_reason = function - | IDLE_TIMEOUT -> 0 - | HARD_TIMEOUT -> 1 - | DELETE -> 2 + cenum reason { + IDLE_TIMEOUT =00; + HARD_TIMEOUT =1; + DELETE = 2 + } as uint8_t type stats = { mutable table_id: byte; @@ -1420,7 +1465,7 @@ module Packet_out = struct buffer_id: uint32; in_port: Port.t; actions: Flow.action list; - data : Cstruct.buf; + data : Cstruct.t; } cstruct ofp_packet_out { @@ -1440,17 +1485,19 @@ module Packet_out = struct let bits = Cstruct.shift bits sizeof_ofp_packet_out in let action_bits = Cstruct.sub bits 0 act_len in let (_, actions) = Flow.parse_actions action_bits in - let data = Cstruct.shift bits act_len in - { buffer_id; in_port; actions; data; } + let data = Cstruct.shift bits act_len in + { buffer_id; in_port; actions; data; } let create ?(xid=0l) ?(buffer_id =(-1l)) ?(actions = [] ) ~data ~in_port () = {buffer_id; in_port; actions; data;} - let marshal_packet_out m bits = - let size = (Header.sizeof_ofp_header + sizeof_ofp_packet_out + - (Flow.actions_len m.actions) + (Cstruct.len m.data)) in - let of_header=(Header.(create PACKET_OUT size 0l)) in + let get_len t = Header.sizeof_ofp_header + sizeof_ofp_packet_out + + (Flow.actions_len t.actions) + (Cstruct.len t.data) + + let marshal_packet_out ?(xid=Random.int32 Int32.max_int) m bits = + let size = get_len m in + let of_header=Header.(create ~xid PACKET_OUT size) in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_packet_out_buffer_id bits m.buffer_id in @@ -1458,7 +1505,7 @@ module Packet_out = struct let _ = set_ofp_packet_out_actions_len bits (Flow.actions_len m.actions) in let bits = Cstruct.shift bits sizeof_ofp_packet_out in let (act_len, bits) = marshal_and_shift (Flow.marshal_actions m.actions) bits in - let _ = Cstruct.blit_buffer m.data 0 bits 0 (Cstruct.len m.data) in + let _ = Cstruct.blit m.data 0 bits 0 (Cstruct.len m.data) in size end @@ -1480,7 +1527,7 @@ module Packet_in = struct buffer_id: uint32; in_port: Port.t; reason: reason; - data: Cstruct.buf; + data: Cstruct.t; } cstruct ofp_packet_in { @@ -1496,16 +1543,20 @@ module Packet_in = struct let total_len = get_ofp_packet_in_total_len bits in let in_port = Port.port_of_int (get_ofp_packet_in_in_port bits) in let reason = reason_of_int (get_ofp_packet_in_reason bits) in - let data = Cstruct.sub bits sizeof_ofp_packet_in - (total_len - sizeof_ofp_packet_in) in + let data = Cstruct.sub bits sizeof_ofp_packet_in total_len in { buffer_id; in_port; reason; data} let packet_in_to_string p = sp "Packet_in: buffer_id:%ld in_port:%s reason:%s" p.buffer_id (Port.string_of_port p.in_port) (string_of_reason p.reason) - let create_pkt_in ?(buffer_id=(-1l)) ~in_port ~reason ~data = - {buffer_id; in_port; reason; data;} + let get_len t = Header.get_len + sizeof_ofp_packet_in + + (Cstruct.len t.data) + + let create_pkt_in ?(buffer_id=(-1l)) ~in_port ~reason ~data = + let pkt_in = {buffer_id; in_port; reason; data;} in + let h = Header.create Header.PACKET_IN (get_len pkt_in) in + (h, pkt_in) let marshal_pkt_in ?(xid=(Random.int32 Int32.max_int)) ?(data_len=0) t bits = @@ -1519,14 +1570,14 @@ module Packet_in = struct Cstruct.len t.data ) in - let h = Header.create Header.PACKET_IN (Header.sizeof_ofp_header + - sizeof_ofp_packet_in + data_len) xid in + let h = Header.create ~xid Header.PACKET_IN (Header.sizeof_ofp_header + + sizeof_ofp_packet_in + data_len) in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header h) bits in let _ = set_ofp_packet_in_buffer_id bits t.buffer_id in - let _ = set_ofp_packet_in_total_len bits (sizeof_ofp_packet_in + data_len) in + let _ = set_ofp_packet_in_total_len bits data_len in let _ = set_ofp_packet_in_in_port bits (Port.int_of_port t.in_port) in let _ = set_ofp_packet_in_reason bits (int_of_reason t.reason) in - let _ = Cstruct.blit_buffer t.data 0 bits sizeof_ofp_packet_in + let _ = Cstruct.blit t.data 0 bits sizeof_ofp_packet_in data_len in ofp_len + sizeof_ofp_packet_in + data_len end @@ -1576,18 +1627,18 @@ module Flow_mod = struct {send_flow_rem; overlap; emerg; } type t = { - of_match: Match.t; + mutable of_match: Match.t; cookie: uint64; command: command; - idle_timeout: uint16; - hard_timeout: uint16; - priority: uint16; + mutable idle_timeout: uint16; + mutable hard_timeout: uint16; + mutable priority: uint16; buffer_id: int32; out_port: Port.t; flags: flags; - actions: Flow.action list; + mutable actions: Flow.action list; } - + (* {of_m with of_match=x; } *) cstruct ofp_flow_mod { uint64_t cookie; uint16_t command; @@ -1603,21 +1654,13 @@ module Flow_mod = struct ?(idle_timeout = 60) ?(hard_timeout = 0) ?(buffer_id = -1 ) ?(out_port = Port.No_port) ?(flags ={send_flow_rem=false;emerg=false;overlap=false;}) actions () = - - let size = ref (sizeof_ofp_flow_mod + Header.sizeof_ofp_header + - Match.sizeof_ofp_match) in - (List.iter (fun a -> size:= !size + (Flow.len_of_action a)) actions); - { -(* of_header=(Header.(create FLOW_MOD !size (Int32.of_int 0))); *) - of_match=flow_match; cookie; command=command; - idle_timeout; hard_timeout; priority; - buffer_id=(Int32.of_int buffer_id); out_port;flags; actions; - } + {of_match=flow_match; cookie; command=command; idle_timeout; hard_timeout; + priority; buffer_id=(Int32.of_int buffer_id); out_port;flags; actions;} let marshal_flow_mod ?(xid=(Random.int32 Int32.max_int)) m bits = let len = Header.sizeof_ofp_header + Match.sizeof_ofp_match + sizeof_ofp_flow_mod + (Flow.actions_len m.actions) in - let header = Header.create Header.FLOW_MOD len xid in + let header = Header.create ~xid Header.FLOW_MOD len in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let (_, bits) = marshal_and_shift (Match.marshal_match m.of_match) bits in let _ = set_ofp_flow_mod_cookie bits m.cookie in @@ -1719,10 +1762,12 @@ module Flow_removed = struct {of_match; cookie; priority; reason; duration_sec; duration_nsec; idle_timeout; packet_count; byte_count;} + let get_len = Header.sizeof_ofp_header + Match.sizeof_ofp_match + + sizeof_ofp_flow_removed + let marshal_flow_removed ?(xid=(Random.int32 Int32.max_int)) m bits = - let len = Header.sizeof_ofp_header + Match.sizeof_ofp_match + - sizeof_ofp_flow_removed in - let header = Header.create Header.FLOW_REMOVED len xid in + let len = get_len in + let header = Header.create ~xid Header.FLOW_REMOVED len in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let (_, bits) = marshal_and_shift (Match.marshal_match m.of_match) bits in let _ = set_ofp_flow_removed_cookie bits m.cookie in @@ -1746,7 +1791,7 @@ end module Port_mod = struct type t = { port_no: Port.t; - hw_addr: eaddr; + hw_addr: Macaddr.t; config: Port.config; mask: Port.config; advertise: Port.features; @@ -1771,9 +1816,9 @@ module Stats = struct type aggregate = { - packet_count: uint64; - byte_count: uint64; - flow_count: uint32; + mutable packet_count: uint64; + mutable byte_count: uint64; + mutable flow_count: uint32; } type table = { @@ -1786,6 +1831,10 @@ module Stats = struct mutable matched_count: uint64; } + let init_table_stats table_id name wildcards = + {table_id; name; wildcards; max_entries=0l;active_count=0l; + lookup_count=(0L); matched_count=(0L);} + type queue = { port_no: uint16; queue_id: uint32; @@ -1842,14 +1891,7 @@ module Stats = struct | 6 -> VENDOR | v -> raise(Unsupported("req_type_of_int")) - let get_len = function - | FLOW -> (Header.sizeof_ofp_header + 4 + Match.sizeof_ofp_match + 4 ) - | AGGREGATE -> (Header.sizeof_ofp_header + 4 + Match.sizeof_ofp_match + 4 ) - | PORT -> (Header.sizeof_ofp_header + 12) - | QUEUE -> (Header.sizeof_ofp_header + 12) - | _ -> (Header.sizeof_ofp_header + 4) - - cstruct ofp_stats_request { + cstruct ofp_stats_request { uint16_t typ; uint16_t flags } as big_endian @@ -1860,40 +1902,68 @@ module Stats = struct uint16_t out_port } as big_endian - let create_flow_stat_req flow_match ?(table_id=0xff) ?(out_port=(Port.No_port)) -(* ?(xid=0l) bits () = *) - ?(xid=(Random.int32 Int32.max_int)) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request + - Match.sizeof_ofp_match + - sizeof_ofp_flow_stats_request ) - xid in - let _ = Header.marshal_header header bits in + cstruct ofp_queue_stats_request { + uint16_t port_no; + uint8_t pad[2]; + uint32_t queue_id + } as big_endian + + cstruct ofp_port_stats_request { + uint16_t port_no; + uint8_t pad[6] + } as big_endian + + let get_len = function + | TABLE + | DESC -> Header.sizeof_ofp_header + sizeof_ofp_stats_request + | AGGREGATE + | FLOW -> + (Header.sizeof_ofp_header + sizeof_ofp_stats_request + + Match.sizeof_ofp_match + sizeof_ofp_flow_stats_request ) + | QUEUE -> (Header.sizeof_ofp_header + sizeof_ofp_stats_request + + sizeof_ofp_queue_stats_request) + | PORT -> (Header.sizeof_ofp_header + sizeof_ofp_stats_request + + sizeof_ofp_port_stats_request) + | _ -> (Header.sizeof_ofp_header + 4) + + let create_desc_stat_req ?(xid=(Random.int32 Int32.max_int)) bits = + let len = get_len DESC in + let header = Header.create ~xid Header.STATS_REQ len in + let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits Header.sizeof_ofp_header in + let _ = set_ofp_stats_request_typ bits (int_of_req_type DESC) in + let _ = set_ofp_stats_request_flags bits 0 in + len + + let create_flow_stat_req flow_match ?(table_id=All) ?(out_port=(Port.No_port)) + ?(xid=(Random.int32 Int32.max_int)) bits = + let len = get_len FLOW in + let header = Header.create ~xid Header.STATS_REQ len in + let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type FLOW) in let _ = set_ofp_stats_request_flags bits 0 in - let _ = Cstruct.shift bits sizeof_ofp_stats_request in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = Match.marshal_match flow_match bits in - let _ = set_ofp_flow_stats_request_table_id bits table_id in + let bits = Cstruct.shift bits Match.sizeof_ofp_match in + let _ = set_ofp_flow_stats_request_table_id bits (int_of_table_id table_id) in let _ = set_ofp_flow_stats_request_out_port bits (Port.int_of_port out_port) in - Cstruct.shift bits sizeof_ofp_flow_stats_request + len - let create_aggr_flow_stat_req flow_match ?(table_id=0xff) ?(out_port=Port.No_port) + let create_aggr_flow_stat_req flow_match ?(table_id=All) ?(out_port=Port.No_port) ?(xid=(Random.int32 Int32.max_int)) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request + - Match.sizeof_ofp_match + - sizeof_ofp_flow_stats_request ) - xid in + let len = get_len AGGREGATE in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type AGGREGATE) in let _ = set_ofp_stats_request_flags bits 0 in - let _ = Cstruct.shift bits sizeof_ofp_stats_request in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = Match.marshal_match flow_match bits in - let _ = set_ofp_flow_stats_request_table_id bits table_id in + let bits = Cstruct.shift bits Match.sizeof_ofp_match in + let _ = set_ofp_flow_stats_request_table_id bits (int_of_table_id table_id) in let _ = set_ofp_flow_stats_request_out_port bits (Port.int_of_port out_port) in - Cstruct.shift bits sizeof_ofp_flow_stats_request + len (* struct ofp_vendor_header { uint32_t vendor; @@ -1903,52 +1973,39 @@ module Stats = struct let header = (Header.build_h (Header.create Header.STATS_REQ (get_len VENDOR) snd_xid)) in BITSTRING{(header):(Header.get_len * 8):bitstring; (int_of_req_type DESC):16;0:16}*) - let create_table_stat_req ?(xid=(Random.int32 Int32.max_int)) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request) xid in + let create_table_stat_req ?(xid=(Random.int32 Int32.max_int)) bits = + let len = get_len TABLE in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type TABLE) in let _ = set_ofp_stats_request_flags bits 0 in - Cstruct.shift bits sizeof_ofp_stats_request - - cstruct ofp_queue_stats_request { - uint16_t port_no; - uint8_t pad[2]; - uint32_t queue_id - } as big_endian + len - let create_queue_stat_req ?(xid=(Random.int32 Int32.max_int)) + let create_queue_stat_req ?(xid=(Random.int32 Int32.max_int)) ?(queue_id=0xffffffffl) ?(port=Port.No_port) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request + - sizeof_ofp_queue_stats_request) xid in + let len = get_len QUEUE in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_stats_request_typ bits (int_of_req_type QUEUE) in let _ = set_ofp_stats_request_flags bits 0 in - let _ = Cstruct.shift bits sizeof_ofp_stats_request in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_queue_stats_request_port_no bits (Port.int_of_port port) in let _ = set_ofp_queue_stats_request_queue_id bits queue_id in - Cstruct.shift bits sizeof_ofp_queue_stats_request + len - cstruct ofp_port_stats_request { - uint16_t port_no; - uint8_t pad[6] - } as big_endian - - let create_port_stat_req ?(xid=(Random.int32 Int32.max_int)) - ?(port=Port.No_port) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request + - sizeof_ofp_port_stats_request) xid in + let create_port_stat_req ?(xid=(Random.int32 Int32.max_int)) + ?(port=Port.No_port) bits = + let len = get_len PORT in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_stats_request_typ bits (int_of_req_type PORT) in let _ = set_ofp_stats_request_flags bits 0 in - let _ = Cstruct.shift bits sizeof_ofp_stats_request in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_port_stats_request_port_no bits (Port.int_of_port port) in - Cstruct.shift bits sizeof_ofp_port_stats_request + len type req = | Desc_req of req_hdr @@ -1959,6 +2016,21 @@ module Stats = struct | Queue_req of req_hdr * Port.t * queue_id | Vendor_req of req_hdr + let marshal_stats_req ?(xid=Random.int32 Int32.max_int) req bits = + match req with + | Desc_req _ -> create_desc_stat_req ~xid bits + | Table_req _ -> create_table_stat_req ~xid bits + | Flow_req (_, m, table_id, out_port) -> + create_flow_stat_req m ~table_id ~out_port ~xid bits + | Aggregate_req (_, m, table_id, out_port) -> + create_aggr_flow_stat_req m ~table_id ~out_port ~xid bits + | Port_req (_, port) -> + create_port_stat_req ~xid ~port bits + | Queue_req (_, port, queue_id) -> + create_queue_stat_req ~xid ~queue_id ~port bits + | Vendor_req _ -> failwith "Vendor queue req not supported" + + let parse_stats_req bits = let flags = get_ofp_stats_request_flags bits in let ty = get_ofp_stats_request_typ bits in @@ -1987,7 +2059,7 @@ module Stats = struct type resp_hdr = { st_ty: stats_type; - more_to_follow: bool; + more: bool; } let int_of_stats_type = function @@ -2030,22 +2102,19 @@ module Stats = struct } as big_endian let rec parse_table_stats_reply bits = - match (Cstruct.len bits ) with - | 0 -> [] - | l -> - let table_id = table_id_of_int (get_ofp_table_stats_table_id bits) in - let name = get_ofp_table_stats_name bits in - let name = Cstruct.copy_buffer name 0 (Cstruct.len name) in - let wildcards = Wildcards.parse_wildcards (get_ofp_table_stats_wildcards - bits) in - let max_entries = get_ofp_table_stats_max_entries bits in - let active_count = get_ofp_table_stats_active_count bits in - let lookup_count = get_ofp_table_stats_lookup_count bits in - let matched_count = get_ofp_table_stats_matched_count bits in - let ret = {table_id; name; wildcards; max_entries; active_count; lookup_count; - matched_count;} in - let _ = Cstruct.shift bits sizeof_ofp_table_stats in - [ret] @ (parse_table_stats_reply bits) + let table_id = table_id_of_int (get_ofp_table_stats_table_id bits) in + let name = get_ofp_table_stats_name bits in + let name = Cstruct.copy name 0 (Cstruct.len name) in + let wildcards = Wildcards.parse_wildcards + (get_ofp_table_stats_wildcards bits) in + let max_entries = get_ofp_table_stats_max_entries bits in + let active_count = get_ofp_table_stats_active_count bits in + let lookup_count = get_ofp_table_stats_lookup_count bits in + let matched_count = get_ofp_table_stats_matched_count bits in + let ret = {table_id; name; wildcards; max_entries; active_count; + lookup_count; matched_count;} in + let _ = Cstruct.shift bits sizeof_ofp_table_stats in + [ret] @ (parse_table_stats_reply bits) let rec string_of_table_stats_reply tables = match tables with @@ -2062,6 +2131,8 @@ module Stats = struct uint16_t flags } as big_endian + let get_resp_hdr_size = sizeof_ofp_stats_reply + cstruct ofp_desc_stats { uint8_t mfr_desc[256]; uint8_t hw_desc[256]; @@ -2094,20 +2165,31 @@ module Stats = struct uint64_t collisions } as big_endian + let create_desc_stat_resp imfr hw sw serial dp = + let ret = {imfr_desc=(String.create 256); hw_desc=(String.create 256); + sw_desc=(String.create 356); serial_num=(String.create 32); + dp_desc=(String.create 256);} in + let _ = String.blit imfr 0 ret.imfr_desc 0 (String.length imfr) in + let _ = String.blit hw 0 ret.hw_desc 0 (String.length hw) in + let _ = String.blit sw 0 ret.sw_desc 0 (String.length sw) in + let _ = String.blit serial 0 ret.serial_num 0 (String.length serial) in + let _ = String.blit dp 0 ret.dp_desc 0 (String.length dp) in + ret + let parse_stats_resp bits = let typ = stats_type_of_int (get_ofp_stats_reply_typ bits) in - let more_to_follow = ((get_ofp_stats_reply_flags bits) = 1) in - let resp = {st_ty=typ;more_to_follow;} in + let more = ((get_ofp_stats_reply_flags bits) = 1) in + let resp = {st_ty=typ;more;} in let _ = Cstruct.shift bits sizeof_ofp_stats_reply in match typ with | DESC -> - let imfr_desc = Cstruct.copy_buffer (get_ofp_desc_stats_mfr_desc bits) 0 256 in - let hw_desc= Cstruct.copy_buffer (get_ofp_desc_stats_hw_desc bits) 0 256 in - let sw_desc = Cstruct.copy_buffer (get_ofp_desc_stats_sw_desc bits) 0 256 in - let serial_num = Cstruct.copy_buffer (get_ofp_desc_stats_serial_num bits) + let imfr_desc = Cstruct.copy (get_ofp_desc_stats_mfr_desc bits) 0 256 in + let hw_desc= Cstruct.copy (get_ofp_desc_stats_hw_desc bits) 0 256 in + let sw_desc = Cstruct.copy (get_ofp_desc_stats_sw_desc bits) 0 256 in + let serial_num = Cstruct.copy (get_ofp_desc_stats_serial_num bits) 0 32 in - let dp_desc = Cstruct.copy_buffer (get_ofp_desc_stats_dp_desc bits) 0 256 + let dp_desc = Cstruct.copy (get_ofp_desc_stats_dp_desc bits) 0 256 in Desc_resp(resp, {imfr_desc; hw_desc; sw_desc; serial_num; dp_desc;}) @@ -2131,38 +2213,45 @@ module Stats = struct let resp_get_len = function | Desc_resp(_, _) -> Header.sizeof_ofp_header + sizeof_ofp_desc_stats - | Table_resp (_, tables) -> 4 + (List.length tables) *(1+3+32+4+4+4+8+8) + | Flow_resp (_, f) -> + let flow_len = List.fold_right + (fun f l -> l + (Flow.flow_stats_len f) ) f 0 in + Header.get_len + sizeof_ofp_stats_reply +flow_len + | Aggregate_resp _ -> + Header.get_len + sizeof_ofp_stats_reply + + sizeof_ofp_aggregate_stats_reply + | Table_resp (_, tables) -> 4 + (List.length tables) *(1+3+32+4+4+4+8+8) | _ -> failwith "resp_get_len" let marshal_stats_resp xid resp bits = match resp with | Desc_resp(resp_hdr, desc) -> let len = (Header.sizeof_ofp_header + sizeof_ofp_stats_reply + - sizeof_ofp_desc_stats) in - let of_header = Header.create Header.STATS_RESP len xid in + sizeof_ofp_desc_stats) in + let _ = Printf.printf "marshaling description response\n%!" in + let of_header = Header.create ~xid Header.STATS_RESP len in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type DESC) in - let _ = set_ofp_stats_reply_flags bits (int_of_bool - resp_hdr.more_to_follow) in + let _ = set_ofp_stats_reply_flags bits (int_of_bool resp_hdr.more) in let bits = Cstruct.shift bits sizeof_ofp_stats_reply in let _ = set_ofp_desc_stats_mfr_desc desc.imfr_desc 0 bits in let _ = set_ofp_desc_stats_hw_desc desc.hw_desc 0 bits in let _ = set_ofp_desc_stats_sw_desc desc.sw_desc 0 bits in let _ = set_ofp_desc_stats_serial_num desc.serial_num 0 bits in - let _ = set_ofp_desc_stats_dp_desc desc.dp_desc 0 bits in + let _ = set_ofp_desc_stats_dp_desc desc.dp_desc 0 bits in + let _ = Printf.printf "done marshaling description response\n%!" in len | Flow_resp(resp_h, flows) -> let flow_len = List.fold_right (fun f l -> l + (Flow.flow_stats_len f) ) flows 0 in let len = (Header.sizeof_ofp_header + sizeof_ofp_stats_reply + flow_len) in - let of_header = Header.create Header.STATS_RESP len xid in + let of_header = Header.create ~xid Header.STATS_RESP len in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type FLOW) in - let _ = set_ofp_stats_reply_flags bits (int_of_bool - resp_h.more_to_follow) in + let _ = set_ofp_stats_reply_flags bits (int_of_bool resp_h.more) in let bits = Cstruct.shift bits sizeof_ofp_stats_reply in let (flows_len, bits) = marshal_and_shift (Flow.marshal_flow_stats flows) bits in @@ -2171,12 +2260,12 @@ module Stats = struct | Aggregate_resp(resp, stats) -> let len = Header.sizeof_ofp_header + sizeof_ofp_stats_reply + sizeof_ofp_aggregate_stats_reply in - let of_header = Header.create Header.STATS_RESP len xid in + let of_header = Header.create ~xid Header.STATS_RESP len in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type AGGREGATE) in let _ = set_ofp_stats_reply_flags bits (int_of_bool - resp.more_to_follow) in + resp.more) in let bits = Cstruct.shift bits sizeof_ofp_stats_reply in let _ = set_ofp_aggregate_stats_reply_packet_count bits stats.packet_count in let _ = set_ofp_aggregate_stats_reply_byte_count bits stats.byte_count in @@ -2353,34 +2442,36 @@ and string_of_error_code = function uint16_t code } as big_endian -let marshal_error errornum data xid bits = - let req_len = Cstruct.len data in - let req_h = (Header.create Header.ERROR - (Header.get_len + sizeof_ofp_error_msg + req_len) xid) in - let (len, bits) = marshal_and_shift (Header.marshal_header req_h) bits in - let errornum = int_of_error_code errornum in - let _ = set_ofp_error_msg_typ bits - (Int32.to_int (Int32.shift_left errornum 16)) in - let _ = set_ofp_error_msg_code bits - (Int32.to_int (Int32.logand errornum 0xffff0000l)) in - let bits = Cstruct.shift bits sizeof_ofp_error_msg in - let _ = Cstruct.blit_buffer data 0 bits 0 (Cstruct.len data) in - (Header.get_len + sizeof_ofp_error_msg + req_len) +let marshal_error errornum data xid bits = + let req_len = Cstruct.len data in + let req_h = Header.create ~xid Header.ERROR + (Header.get_len + sizeof_ofp_error_msg + req_len) in + let (len, bits) = marshal_and_shift (Header.marshal_header req_h) bits in + let errornum = int_of_error_code errornum in + let _ = set_ofp_error_msg_typ bits + (Int32.to_int (Int32.logand errornum 0xffffl)) in + let _ = set_ofp_error_msg_code bits + (Int32.to_int (Int32.shift_right (Int32.logand errornum 0xffff0000l) 16)) in + let bits = Cstruct.shift bits sizeof_ofp_error_msg in + let _ = Cstruct.blit data 0 bits 0 (Cstruct.len data) in + (Header.get_len + sizeof_ofp_error_msg + req_len) let build_features_req xid bits = - Header.marshal_header (Header.(create FEATURES_REQ 8 xid)) bits + Header.marshal_header (Header.(create ~xid FEATURES_REQ 8)) bits -let build_echo_resp h bs bits = - let _ = Header.(marshal_header (create ECHO_RESP get_len h.xid) bits ) in - let _ = Cstruct.blit_buffer bs 0 bits 0 (Cstruct.len bs) in - Cstruct.shift bits (Cstruct.len bs) +let build_echo_resp h bits = + let len = Header.get_len in + let _ = + Header.(marshal_header + (create ~xid:h.xid ECHO_RESP len ) bits) in + len type t = | Hello of Header.h - | Error of Header.h * error_code - | Echo_req of Header.h * Cstruct.buf - | Echo_resp of Header.h * Cstruct.buf - | Vendor of Header.h * vendor * Cstruct.buf + | Error of Header.h * error_code * Cstruct.t + | Echo_req of Header.h + | Echo_resp of Header.h + | Vendor of Header.h * (* vendor * *) Cstruct.t | Features_req of Header.h | Features_resp of Header.h * Switch.features @@ -2392,7 +2483,7 @@ type t = | Flow_removed of Header.h * Flow_removed.t | Port_status of Header.h * Port.status - | Packet_out of Header.h * Packet_out.t (* Cstruct.buf *) + | Packet_out of Header.h * Packet_out.t (* Cstruct.t *) | Flow_mod of Header.h * Flow_mod.t | Port_mod of Header.h * Port_mod.t @@ -2409,14 +2500,14 @@ let parse h bits = Header.(match h.ty with | HELLO -> Hello (h) | ERROR -> raise (Unparsed ("ERROR", bits)) - | ECHO_REQ -> Echo_req (h, bits) - | ECHO_RESP -> Echo_resp (h, bits) - | VENDOR -> raise (Unparsed ("VENDOR", bits)) + | ECHO_REQ -> Echo_req h + | ECHO_RESP -> Echo_resp h + | VENDOR_MSG -> Vendor(h, bits) | FEATURES_REQ -> Features_req (h) | FEATURES_RESP -> Features_resp (h, Switch.parse_features bits) | GET_CONFIG_REQ -> Get_config_req(h) | GET_CONFIG_RESP -> raise (Unparsed ("GET_CONFIG_RESP", bits)) - | SET_CONFIG -> raise (Unparsed ("SET_CONFIG", bits)) + | SET_CONFIG -> Set_config(h, (Switch.parse_switch_config bits) ) | PACKET_IN -> Packet_in (h, Packet_in.parse_packet_in bits) | PORT_STATUS -> Port_status(h, (Port.parse_status bits)) | FLOW_REMOVED -> Flow_removed(h, (Flow_removed.parse_flow_removed bits)) @@ -2430,13 +2521,68 @@ let parse h bits = | _ -> raise (Unparsed ("_", bits)) ) -(* let new_parse bits = - bitmatch bits with - | { 1:8:int; t:8; len:16; xid:32; body:-1:bitstring } - -> ( - (parse (Header.({ ver=byte 1; ty=(msg_code_of_int t); - len; xid;})) body, - (Bitstring.dropbits (len*8) bits) ) - ) - | { _ } -> raise (Unparsable ("parse_h", bits)) *) +let to_string = function + | Features_req (h) + | Get_config_req (h) + | Barrier_req (h) + | Barrier_resp (h) + | Echo_req (h) + | Echo_resp (h) + | Get_config_req (h) + | Get_config_resp (h, _) + | Set_config (h, _) + | Flow_removed (h, _) + | Packet_in (h, _) + | Features_resp (h, _) + | Port_status (h, _) + | Stats_req (h, _) + | Stats_resp (h, _) + | Error (h, _, _) + | Packet_out (h, _) + | Flow_mod (h, _) + | Hello h -> Header.header_to_string h + | _ -> failwith "Unsupported message" + +let marshal msg = + let marshal = + match msg with + | Features_req (h) + | Get_config_req (h) + | Barrier_req (h) + | Barrier_resp (h) + | Echo_req (h) + | Echo_resp (h) + | Get_config_req (h) + | Vendor(h, _) + | Hello (h) -> Header.marshal_header h + | Flow_removed (h, frm) -> + Flow_removed.marshal_flow_removed ~xid:(h.Header.xid) frm + | Packet_in (h, pkt_in) -> + Packet_in.marshal_pkt_in ~xid:h.Header.xid pkt_in + | Features_resp (h, p) -> + Switch.marshal_reply_features h.Header.xid p + | Get_config_resp (h, c) + | Set_config (h, c) -> + Switch.marshal_switch_config h.Header.xid c + | Port_status (h, p) -> + Port.marshal_port_status ~xid:h.Header.xid p + | Stats_req (h, p) -> + Stats.marshal_stats_req ~xid:h.Header.xid p + | Stats_resp (h, p) -> + Stats.marshal_stats_resp h.Header.xid p + | Error (h, err, bits) -> + marshal_error err bits h.Header.xid + | Packet_out (h, p) -> + Packet_out.marshal_packet_out ~xid:h.Header.xid p + | Flow_mod (h, fm) -> + Flow_mod.marshal_flow_mod ~xid:h.Header.xid fm + | _ -> failwith "Unsupported message" + in + marshal_and_sub marshal (OS.Io_page.to_cstruct (OS.Io_page.get 1)) +(* + | Vendor of Header.h * vendor * Cstruct.t + | Port_mod of Header.h * Port_mod.t + | Queue_get_config_req of Header.h * Port.t + | Queue_get_config_resp of Header.h * Port.t * Queue.t array + *) diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 61d748f..5d87289 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -15,18 +15,16 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -exception Unparsable of string * Cstruct.buf -exception Unparsed of string * Cstruct.buf +exception Unparsable of string * Cstruct.t +exception Unparsed of string * Cstruct.t type int16 = int type uint8 = char type uint16 = int type uint32 = int32 type uint64 = int64 -type ipv4 = uint32 type byte = uint8 type bytes = string -type eaddr = bytes type vendor = uint32 type queue_id = uint32 type datapath_id = uint64 @@ -38,7 +36,7 @@ module Header : | ERROR | ECHO_REQ | ECHO_RESP - | VENDOR + | VENDOR_MSG | FEATURES_REQ | FEATURES_RESP | GET_CONFIG_REQ @@ -56,11 +54,12 @@ module Header : | BARRIER_RESP | QUEUE_GET_CONFIG_REQ | QUEUE_GET_CONFIG_RESP - type h = { ver : uint8; ty : msg_code; len : uint16; xid : uint32; } - val parse_header : Cstruct.buf -> h + type h = {ver:uint8;ty:msg_code;len:uint16;xid:uint32;} + val get_len : int + val parse_header : Cstruct.t -> h val header_to_string : h -> string - val create : msg_code -> uint16 -> uint32 -> h - val marshal_header : h -> Cstruct.buf -> int + val create : ?xid:uint32 -> msg_code -> uint16 -> h + val marshal_header : h -> Cstruct.t -> int val sizeof_ofp_header : int end module Queue : @@ -84,6 +83,7 @@ module Port : val port_of_int : int16 -> t val int_of_port : t -> int16 val string_of_port : t -> string + val port_of_string : string -> t option type config = { port_down : bool; no_stp : bool; @@ -116,7 +116,7 @@ module Port : } type phy = { port_no : uint16; - hw_addr : eaddr; + hw_addr : Macaddr.t; name : string; config : config; state : state; @@ -125,8 +125,9 @@ module Port : supported : features; peer : features; } - val init_port_phy: ?port_no:int -> ?hw_addr:eaddr -> - ?name:string -> unit -> phy + val init_port_phy: ?port_no:int -> ?hw_addr:Macaddr.t -> + ?name:string -> unit -> phy + val translate_port_phy : phy -> int -> phy val string_of_phy : phy -> string type stats = { mutable port_id : uint16; @@ -147,7 +148,9 @@ module Port : type reason = ADD | DEL | MOD val reason_to_string: reason -> string type status = { reason : reason; desc : phy; } + val create_port_status : reason -> phy -> Header.h * status val string_of_status : status -> string + val marshal_port_status : ?xid:int32 -> status -> Cstruct.t -> int end module Switch : sig @@ -183,65 +186,80 @@ module Switch : actions : actions; mutable ports : Port.phy list; } - val marshal_reply_features : int32 -> features -> Cstruct.buf -> int + val marshal_reply_features : int32 -> features -> Cstruct.t -> int + val get_len : features -> int type config = { drop : bool; reasm : bool; miss_send_len : uint16; } val init_switch_config : config - val marshal_switch_config : int32 -> config -> Cstruct.buf -> int + val config_get_len : int + val marshal_switch_config : int32 -> config -> Cstruct.t -> int end module Wildcards : sig type t = { - in_port : bool; - dl_vlan : bool; - dl_src : bool; - dl_dst : bool; - dl_type : bool; - nw_proto : bool; - tp_src : bool; - tp_dst : bool; - nw_src : byte; - nw_dst : byte; - dl_vlan_pcp : bool; - nw_tos : bool; + mutable in_port : bool; + mutable dl_vlan : bool; + mutable dl_src : bool; + mutable dl_dst : bool; + mutable dl_type : bool; + mutable nw_proto : bool; + mutable tp_src : bool; + mutable tp_dst : bool; + mutable nw_src : byte; + mutable nw_dst : byte; + mutable dl_vlan_pcp : bool; + mutable nw_tos : bool; } - val full_wildcard : t - val exact_match : t - val l2_match : t - val l3_match : t - val arp_match : t + val in_port_match : unit -> t + val full_wildcard : unit -> t + val exact_match : unit -> t + val l2_match : unit -> t + val l3_match : unit -> t + val arp_match : unit -> t val wildcard_to_string : t -> string end module Match : sig type t = { - wildcards : Wildcards.t; - in_port : Port.t; - dl_src : eaddr; - dl_dst : eaddr; - dl_vlan : uint16; - dl_vlan_pcp : byte; - dl_type : uint16; - nw_src : uint32; - nw_dst : uint32; - nw_tos : byte; - nw_proto : byte; - tp_src : uint16; - tp_dst : uint16; + mutable wildcards : Wildcards.t; + mutable in_port : Port.t; + mutable dl_src : Macaddr.t; + mutable dl_dst : Macaddr.t; + mutable dl_vlan : uint16; + mutable dl_vlan_pcp : byte; + mutable dl_type : uint16; + mutable nw_src : Ipaddr.V4.t; + mutable nw_dst : Ipaddr.V4.t; + mutable nw_tos : byte; + mutable nw_proto : byte; + mutable tp_src : uint16; + mutable tp_dst : uint16; } - val flow_match_compare : t -> t -> Wildcards.t -> bool + + val wildcard: unit -> t + val create_match : ?in_port:int option -> ?dl_vlan:int option -> + ?dl_src:(* Net.Nettypes.ethernet_mac *) Macaddr.t option -> + ?dl_dst:(* Net.Nettypes.ethernet_mac *) Macaddr.t option -> + ?dl_type:int option -> ?nw_proto:char option -> + ?tp_dst:int option -> ?tp_src:int option -> + ?nw_dst:Ipaddr.V4.t option -> ?nw_dst_len:int -> + ?nw_src:Ipaddr.V4.t option -> ?nw_src_len:int -> + ?dl_vlan_pcp:char option -> ?nw_tos:char option -> unit -> t + + val flow_match_compare : t -> t -> Wildcards.t -> bool val create_flow_match : Wildcards.t -> ?in_port:int16 -> - ?dl_src:eaddr -> - ?dl_dst:eaddr -> + ?dl_src:Macaddr.t -> + ?dl_dst:Macaddr.t -> ?dl_vlan:uint16 -> ?dl_vlan_pcp:byte -> ?dl_type:uint16 -> ?nw_tos:byte -> ?nw_proto:byte -> - ?nw_src:uint32 -> - ?nw_dst:uint32 -> ?tp_src:uint16 -> ?tp_dst:uint16 -> unit -> t - val raw_packet_to_match : Port.t -> Cstruct.buf -> t + ?nw_src:Ipaddr.V4.t -> + ?nw_dst:Ipaddr.V4.t -> ?tp_src:uint16 -> ?tp_dst:uint16 -> unit -> t + val translate_port : t -> Port.t -> t + val raw_packet_to_match : Port.t -> Cstruct.t -> t val match_to_string : t -> string end module Flow : @@ -251,10 +269,10 @@ module Flow : | Set_vlan_vid of int | Set_vlan_pcp of int | STRIP_VLAN - | Set_dl_src of eaddr - | Set_dl_dst of eaddr - | Set_nw_src of ipv4 - | Set_nw_dst of ipv4 + | Set_dl_src of Macaddr.t + | Set_dl_dst of Macaddr.t + | Set_nw_src of Ipaddr.V4.t + | Set_nw_dst of Ipaddr.V4.t | Set_nw_tos of byte | Set_tp_src of int16 | Set_tp_dst of int16 @@ -264,11 +282,12 @@ module Flow : val int_of_action : action -> int val string_of_action : action -> string val string_of_actions : action list -> string - val marshal_action : action -> Cstruct.buf -> int - type reason = IDLE_TIMEOUT | HARD_TIMEOUT | DELETE - val reason_of_int : int -> reason - val int_of_reason : reason -> int - val string_of_reason : reason -> int + val marshal_action : action -> Cstruct.t -> int + cenum reason { + IDLE_TIMEOUT = 0; + HARD_TIMEOUT = 1; + DELETE = 2 + } as uint8_t type stats = { mutable table_id : byte; mutable of_match : Match.t; @@ -282,8 +301,9 @@ module Flow : mutable byte_count : uint64; mutable action : action list; } - val marshal_flow_stats : stats list -> Cstruct.buf -> int + val marshal_flow_stats : stats list -> Cstruct.t -> int val string_of_flow_stat : stats -> string + val flow_stats_len : stats -> int end module Packet_in : sig @@ -295,13 +315,13 @@ module Packet_in : buffer_id : uint32; in_port : Port.t; reason : reason; - data : Cstruct.buf; + data : Cstruct.t; } val packet_in_to_string : t -> string val create_pkt_in : ?buffer_id:uint32 -> in_port:Port.t -> - reason:reason -> data:Cstruct.buf -> t + reason:reason -> data:Cstruct.t -> (Header.h * t) val marshal_pkt_in : ?xid:int32 -> ?data_len:int -> t -> - Cstruct.buf -> int + Cstruct.t -> int end module Packet_out : sig @@ -309,15 +329,15 @@ module Packet_out : buffer_id : uint32; in_port : Port.t; actions : Flow.action list; - data : Cstruct.buf; + data : Cstruct.t; } val create : ?xid:uint32 -> ?buffer_id:uint32 -> ?actions:Flow.action list -> - data:Cstruct.buf -> in_port:Port.t -> + data:Cstruct.t -> in_port:Port.t -> unit -> t - val marshal_packet_out : t -> Cstruct.buf -> int + val marshal_packet_out : ?xid:int32 -> t -> Cstruct.t -> int val packet_out_to_string: t -> string end module Flow_mod : @@ -328,16 +348,16 @@ module Flow_mod : val string_of_command : command -> string type flags = { send_flow_rem : bool; emerg : bool; overlap : bool; } type t = { - of_match : Match.t; + mutable of_match : Match.t; cookie : uint64; command : command; - idle_timeout : uint16; - hard_timeout : uint16; - priority : uint16; + mutable idle_timeout : uint16; + mutable hard_timeout : uint16; + mutable priority : uint16; buffer_id : int32; out_port : Port.t; flags : flags; - actions : Flow.action list; (* array; *) + mutable actions : Flow.action list; (* array; *) } val flow_mod_to_string: t -> string val create : @@ -347,7 +367,7 @@ module Flow_mod : ?hard_timeout:uint16 -> ?buffer_id:int -> ?out_port:Port.t -> ?flags:flags -> Flow.action list -> unit -> t - val marshal_flow_mod : ?xid:int32 -> t -> Cstruct.buf -> int + val marshal_flow_mod : ?xid:int32 -> t -> Cstruct.t -> int end module Flow_removed : sig @@ -355,6 +375,7 @@ module Flow_removed : val reason_of_int : int -> reason val int_of_reason : reason -> int val string_of_reason : reason -> string + val get_len : int type t = { of_match : Match.t; cookie : uint64; @@ -366,8 +387,8 @@ module Flow_removed : packet_count : uint64; byte_count : uint64; } - val parse_flow_removed: Cstruct.buf -> t - val marshal_flow_removed: ?xid:int32 -> t -> Cstruct.buf -> int + val parse_flow_removed: Cstruct.t -> t + val marshal_flow_removed: ?xid:int32 -> t -> Cstruct.t -> int val flow_to_flow_removed: ?reason:reason -> duration_sec:int32 -> duration_nsec:int32 -> packet_count:int64 -> byte_count:int64 -> Flow_mod.t -> t @@ -377,7 +398,7 @@ module Port_mod : sig type t = { port_no : Port.t; - hw_addr : eaddr; + hw_addr : Macaddr.t; config : Port.config; mask : Port.config; advertise : Port.features; @@ -391,9 +412,9 @@ module Stats : val string_of_table_id : table_id -> string type aggregate = { - packet_count : uint64; - byte_count : uint64; - flow_count : uint32; + mutable packet_count : uint64; + mutable byte_count : uint64; + mutable flow_count : uint32; } type table = { mutable table_id : table_id; @@ -404,6 +425,7 @@ module Stats : mutable lookup_count : uint64; mutable matched_count : uint64; } + val init_table_stats : table_id -> string -> Wildcards.t -> table type queue = { port_no : uint16; queue_id : uint32; @@ -423,19 +445,20 @@ module Stats : val int_of_req_type : stats_type -> int val create_flow_stat_req : Match.t -> - ?table_id:int -> - ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> Cstruct.buf + ?table_id:table_id -> + ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.t -> int val create_aggr_flow_stat_req : Match.t -> - ?table_id:int -> - ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> Cstruct.buf -(* val create_vendor_stat_req : ?xid:Int32.t -> Cstruct.buf -> unit *) - val create_table_stat_req : ?xid:Int32.t -> Cstruct.buf -> Cstruct.buf + ?table_id:table_id -> + ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.t -> int +(* val create_vendor_stat_req : ?xid:Int32.t -> Cstruct.t -> unit *) + val create_desc_stat_req : ?xid:Int32.t -> Cstruct.t -> int + val create_table_stat_req : ?xid:Int32.t -> Cstruct.t -> int val create_queue_stat_req : ?xid:Int32.t -> - ?queue_id:int32 -> ?port:Port.t -> Cstruct.buf -> Cstruct.buf + ?queue_id:int32 -> ?port:Port.t -> Cstruct.t -> int val create_port_stat_req : - ?xid:Int32.t -> ?port:Port.t -> Cstruct.buf -> Cstruct.buf + ?xid:Int32.t -> ?port:Port.t -> Cstruct.t -> int type req = Desc_req of req_hdr | Flow_req of req_hdr * Match.t * table_id * Port.t @@ -444,9 +467,12 @@ module Stats : | Port_req of req_hdr * Port.t | Queue_req of req_hdr * Port.t * queue_id | Vendor_req of req_hdr - type resp_hdr = { st_ty : stats_type; more_to_follow : bool; } + val marshal_stats_req : ?xid:int32 -> req -> Cstruct.t -> int + + type resp_hdr = { st_ty : stats_type; more : bool; } val int_of_stats_type : stats_type -> int val stats_type_of_int : int -> stats_type + val get_resp_hdr_size : int type resp = Desc_resp of resp_hdr * desc | Flow_resp of resp_hdr * Flow.stats list @@ -455,7 +481,10 @@ module Stats : | Port_resp of resp_hdr * Port.stats list | Queue_resp of resp_hdr * queue list | Vendor_resp of resp_hdr - val marshal_stats_resp : int32 -> resp -> Cstruct.buf -> int + val resp_get_len : resp -> int + val create_desc_stat_resp : string -> string -> string -> string -> string + -> desc + val marshal_stats_resp : int32 -> resp -> Cstruct.t -> int val string_of_stats : resp -> string end type error_code = @@ -490,21 +519,21 @@ type error_code = | QUEUE_OP_BAD_PORT | QUEUE_OP_BAD_QUEUE | QUEUE_OP_EPERM -val marshal_and_sub : (Cstruct.buf -> int) -> Cstruct.buf -> Cstruct.buf -val marshal_and_shift : (Cstruct.buf -> int) -> Cstruct.buf -> (int * Cstruct.buf) +val marshal_and_sub : (Cstruct.t -> int) -> Cstruct.t -> Cstruct.t +val marshal_and_shift : (Cstruct.t -> int) -> Cstruct.t -> (int * Cstruct.t) (* val contain_exc : string -> `a -> `a option *) val error_code_of_int : int -> error_code val int_of_error_code : error_code -> uint32 val string_of_error_code : error_code -> string -val marshal_error : error_code -> Cstruct.buf -> int32 -> Cstruct.buf -> int -val build_features_req : uint32 -> Cstruct.buf -> int -val build_echo_resp : Header.h -> Cstruct.buf-> Cstruct.buf -> Cstruct.buf +val marshal_error : error_code -> Cstruct.t -> int32 -> Cstruct.t -> int +val build_features_req : uint32 -> Cstruct.t -> int +val build_echo_resp : Header.h -> Cstruct.t -> int type t = Hello of Header.h - | Error of Header.h * error_code - | Echo_req of Header.h * Cstruct.buf - | Echo_resp of Header.h * Cstruct.buf - | Vendor of Header.h * vendor * Cstruct.buf + | Error of Header.h * error_code * Cstruct.t + | Echo_req of Header.h + | Echo_resp of Header.h + | Vendor of Header.h * (* vendor *) Cstruct.t | Features_req of Header.h | Features_resp of Header.h * Switch.features | Get_config_req of Header.h @@ -522,4 +551,6 @@ type t = | Barrier_resp of Header.h | Queue_get_config_req of Header.h * Port.t | Queue_get_config_resp of Header.h * Port.t * Queue.t array -val parse : Header.h -> Cstruct.buf -> t +val parse : Header.h -> Cstruct.t -> t +val marshal : t -> Cstruct.t +val to_string : t -> string diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index 4611863..8b5adf5 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -13,75 +13,114 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -(* open Openflow_net_lwt *) open Net open Lwt -exception ReadError +module OP = Ofpacket -let sp = Printf.sprintf -let pp = Printf.printf -let ep = Printf.eprintf -let cp = pp "%s\n%!" +let resolve t = Lwt.on_success t (fun _ -> ()) + +let get_new_buffer len = + let buf = OS.Io_page.to_cstruct (OS.Io_page.get 1) in + Cstruct.sub buf 0 len + +module Socket = struct type t = { sock: Channel.t; - data_cache: Cstruct.buf list ref; + data_cache: Cstruct.t ref; } let create_socket sock = - { sock; data_cache=(ref []);} + { sock; data_cache=ref (get_new_buffer 0);} + +let write_buffer t bits = + let _ = Channel.write_buffer t.sock bits in + Channel.flush t.sock + +let close t = Channel.close t.sock -let rec read_data t len = -(* Printf.printf "let rec read_data t data_cache %d = \n%!" len; *) - match (len, !(t.data_cache)) with - | (0, _) -> -(* pp "| (0, _) ->\n%!"; *) - return (Cstruct.sub (OS.Io_page.get ()) 0 0 ) - | (_, []) -> -(* pp " | (_, []) ->\n%!"; *) +let read_data t len = + match (len, (Cstruct.len !(t.data_cache) ) ) with + | (0, _) -> return (get_new_buffer 0) + | (_, 0) -> lwt data = Channel.read_some t.sock in - t.data_cache := [data]; - read_data t len - | (_, head::tail) - when ((List.fold_right (fun a b ->b+(Cstruct.len a)) tail (Cstruct.len head))>=len) -> ( -(* pp "| (_, head::tail) when ((List.fold_right (f a b - * ->b+(Cstruct.len b)) tail (Cstruct.len head)) >= len) ->\n%!"; *) - let ret = OS.Io_page.get () in - let ret_len = ref 0 in - let rec read_data_inner = function - | head::tail when ((!ret_len + (Cstruct.len head)) < len) -> - let _ = Cstruct.blit_buffer head 0 ret !ret_len (Cstruct.len head) in - ret_len := !ret_len + (Cstruct.len head); - read_data_inner tail - | head::tail when ((!ret_len + (Cstruct.len head)) = len) -> - let _ = Cstruct.blit_buffer head 0 ret !ret_len (Cstruct.len head) in - ret_len := !ret_len + (Cstruct.len head); - t.data_cache := tail; - return () - | head::tail when ((!ret_len + (Cstruct.len head)) > len) -> - let len_rest = len - !ret_len in - let _ = Cstruct.blit_buffer head 0 ret !ret_len len_rest in - let head = Cstruct.shift head len_rest in - ret_len := !ret_len + len_rest; - t.data_cache := [head] @ tail; - return () - | rest -> - pp "read_data:Invalid state(req_len:%d,read_len:%d,avail_data:%d)\n%!" - len !ret_len (List.fold_right (fun a b -> b + (Cstruct.len a)) rest 0); - raise ReadError - in - lwt _ = read_data_inner !(t.data_cache) in - let ret = Cstruct.sub_buffer ret 0 len in - return (ret) - ) - | (_, head::tail) - when ((List.fold_right (fun a b ->b+(Cstruct.len a)) tail (Cstruct.len head)) < len) -> ( -(* pp "| (_, head::tail) when ((List.fold_right (f a b ->b+(Cstruct.len - * b)) tail (Cstruct.len head)) < len) ->\n%!"; *) + let ret = Cstruct.sub data 0 len in + let _ = t.data_cache := (Cstruct.shift data len) in + return ret + | (_, l) when (l >= len) -> + let ret = Cstruct.sub !(t.data_cache) 0 len in + let _ = t.data_cache := (Cstruct.shift !(t.data_cache) len) in + return ret + | (_, l) when (l < len) -> + let len_rest = len - l in + let ret = Cstruct.set_len !(t.data_cache) len in lwt data = Channel.read_some t.sock in - t.data_cache := !(t.data_cache) @ [data]; - read_data t len) - | (_, _) -> -(* pp "| (_, _) ->\n%!"; *) - Printf.printf "read_data and not match found\n%!"; - return (Cstruct.sub (OS.Io_page.get ()) 0 0 ) + let _ = Cstruct.blit data 0 ret l len_rest in + let _ = t.data_cache := (Cstruct.shift data len_rest) in + return (ret) + | _ -> failwith "invalid read data operation" +end + +type conn_type = + | Socket of Socket.t + | Local of OP.t Lwt_stream.t * (OP.t option -> unit) + +type conn_state = { + mutable dpid : OP.datapath_id; + t : conn_type; +} + +let init_socket_conn_state t = + {dpid=0L;t=(Socket (Socket.create_socket t));} + +let init_local_conn_state () = + let (controller_input, switch_output) = Lwt_stream.create () in + let (switch_input, controller_output) = Lwt_stream.create () in + let ch1 = {dpid=0L;t=(Local (controller_input, controller_output));} in + let ch2 = {dpid=0L;t=(Local (switch_input, switch_output));} in + (ch1, ch2) + +let read_packet conn = + match conn.t with + | Socket t -> + lwt hbuf = Channel.read_exactly t.Socket.sock OP.Header.sizeof_ofp_header in + let ofh = OP.Header.parse_header hbuf in + let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in + lwt dbuf = + if (dlen = 0) then + return (Cstruct.create 0) + else + Channel.read_exactly t.Socket.sock dlen + in + let ofp = OP.parse ofh dbuf in + return ofp + | Local (input, _) -> + match_lwt (Lwt_stream.get input) with + | None -> raise Nettypes.Closed + | Some ofp -> return ofp + +let send_packet conn ofp = + match conn.t with + | Socket t -> Socket.write_buffer t (OP.marshal ofp) + | Local (_, output) -> return (output (Some ofp )) + +let send_data_raw t bits = + match t.t with + | Local _ -> failwith "send_of_data is not supported in Local mode" + | Socket t -> + (* Socket.write_buffer t bits *) + let _ = Channel.write_buffer t.Socket.sock bits in + Channel.flush t.Socket.sock + +let close conn = + match conn.t with + | Socket t -> + resolve ( + try_lwt + Socket.close t + with exn -> + return (OS.Console.log (Printf.sprintf "[socket] close error: %s\n%!" + (Printexc.to_string exn))) + ) + | Local (_, output) -> output None + diff --git a/lib/ofsocket.mli b/lib/ofsocket.mli index c5bc1d6..208cd60 100644 --- a/lib/ofsocket.mli +++ b/lib/ofsocket.mli @@ -14,11 +14,29 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -exception ReadError -type t +(** OpenFlow socket structure *) +type conn_type +type conn_state = { + mutable dpid : Ofpacket.datapath_id; + t : conn_type; +} -(* open Openflow_net_lwt *) -open Net +(** Socket initialization *) -val create_socket: Channel.t -> t -val read_data: t -> int -> Cstruct.buf Lwt.t +(** initialize an OpenFlow socket from a Net.Channel.t socket*) +val init_socket_conn_state : Net.Channel.t -> conn_state +(** create an emulated local socket using Lwt_stream structures *) +val init_local_conn_state: unit -> (conn_state * conn_state) + +(** Socket access methods *) + +(** [read_packet conn] read a complete and parsed OpenFlow packet from the + * control channel socket *) +val read_packet : conn_state -> Ofpacket.t Lwt.t +(** [send_packet conn pkt] send an complete OpenFlow packet over the control + * channel socket *) +val send_packet : conn_state -> Ofpacket.t -> unit Lwt.t +(** [send_data_raw conn bits] send raw bits over the control channel socket *) +val send_data_raw : conn_state -> Cstruct.t -> unit Lwt.t +(** [conn conn] teardown the control channel socket *) +val close : conn_state -> unit diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index ac5332c..b24c02b 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -16,10 +16,11 @@ *) open Lwt -open Net -open Nettypes -module OP = Ofpacket +open Ofswitch_config + +module OP = Openflow.Ofpacket +module OSK = Openflow.Ofsocket exception Packet_type_unknw @@ -34,7 +35,6 @@ type uint16 = OP.uint16 type uint32 = OP.uint32 type uint64 = OP.uint64 type byte = OP.byte -type eaddr = OP.eaddr type port = uint16 type cookie = uint64 @@ -43,6 +43,15 @@ type device = string (* XXX placeholder! *) let resolve t = Lwt.on_success t (fun _ -> ()) +let get_new_buffer len = + let buf = OS.Io_page.to_cstruct (OS.Io_page.get 1) in + Cstruct.sub buf 0 len + +let get_ethif mgr id = + let lst = Net.Manager.get_intfs mgr in + let (_, ethif) = List.find (fun (dev_id,_) -> id = dev_id) lst in + ethif + module Entry = struct type table_counter = { n_active: uint32; @@ -56,10 +65,10 @@ module Entry = struct flags : OP.Flow_mod.flags; priority: uint16; cookie: int64; - insert_sec: uint32; - insert_nsec: uint32; - mutable last_sec: uint32; - mutable last_nsec: uint32; + insert_sec: int; + insert_nsec: int; + mutable last_sec: int; + mutable last_nsec: int; idle_timeout: int; hard_timeout:int; } @@ -71,10 +80,10 @@ module Entry = struct } let init_flow_counters t = - let ts = Int32.of_float (OS.Clock.time ()) in + let ts = int_of_float (OS.Clock.time ()) in {n_packets=0L; n_bytes=0L; priority=t.OP.Flow_mod.priority; - cookie=t.OP.Flow_mod.cookie; insert_sec=ts; insert_nsec=0l; - last_sec=ts;last_nsec=0l; idle_timeout=t.OP.Flow_mod.idle_timeout; + cookie=t.OP.Flow_mod.cookie; insert_sec=ts; insert_nsec=0; + last_sec=ts;last_nsec=0; idle_timeout=t.OP.Flow_mod.idle_timeout; hard_timeout=t.OP.Flow_mod.hard_timeout; flags=t.OP.Flow_mod.flags; } @@ -86,8 +95,7 @@ module Entry = struct let update_flow pkt_len flow = flow.counters.n_packets <- Int64.add flow.counters.n_packets 1L; flow.counters.n_bytes <- Int64.add flow.counters.n_bytes pkt_len; - let ts = OS.Clock.time () in - flow.counters.last_sec <- (Int32.of_float ts) + flow.counters.last_sec <- int_of_float (OS.Clock.time ()) let flow_counters_to_flow_stats of_match table_id flow = @@ -99,8 +107,10 @@ module Entry = struct let byte_count=flow.counters.n_bytes in let action=flow.actions in OP.Flow.({table_id; of_match; - duration_sec=(Int32.sub flow.counters.last_sec flow.counters.insert_sec); - duration_nsec=(Int32.sub flow.counters.last_nsec flow.counters.insert_nsec); + duration_sec = Int32.of_int (flow.counters.last_sec - + flow.counters.insert_sec); + duration_nsec = Int32.of_int (flow.counters.last_nsec - + flow.counters.insert_nsec); priority; idle_timeout; hard_timeout; cookie; packet_count; byte_count; action; }) @@ -109,10 +119,11 @@ end module Table = struct type t = { tid: cookie; - (* This stores entries as they arrive *) + (* This entry stores wildcard and exact match entries as + * transmitted by the controller *) mutable entries: (OP.Match.t, Entry.t) Hashtbl.t; - (* This stores only exact match entries.*) - (* TODO delete an entry from both tables *) + (* Intermediate table to store exact match flos deriving from wildcard + * entries *) mutable cache : (OP.Match.t, Entry.t ref) Hashtbl.t; stats : OP.Stats.table; } @@ -121,25 +132,50 @@ module Table = struct { tid = 0_L; entries = (Hashtbl.create 10000); cache = (Hashtbl.create 10000); stats = OP.Stats.( {table_id=(OP.Stats.table_id_of_int 1); name="main_tbl"; - wildcards=OP.Wildcards.exact_match; max_entries=1024l; active_count=0l; + wildcards=(OP.Wildcards.exact_match ()); max_entries=1024l; active_count=0l; lookup_count=0L; matched_count=0L});} (* TODO fix flow_mod flag support. overlap is not considered *) - let add_flow table t = + let add_flow st table t verbose = (* TODO check if the details are correct e.g. IP type etc. *) - Hashtbl.replace table.entries t.OP.Flow_mod.of_match - (Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); - cache_entries=[];})) + let open OP.Flow_mod in + let open OP.Match in + let _ = + (* max priority for exact match rules *) + if (t.of_match.wildcards=(OP.Wildcards.exact_match ())) then + t.priority <- 0x1001 + in + let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); + cache_entries=[];}) in + let _ = Hashtbl.replace table.entries t.of_match entry in + (* In the fast path table, I need to delete any conflicting entries *) + let _ = + Hashtbl.iter ( + fun a e -> + if ((flow_match_compare a t.of_match t.of_match.wildcards) && + Entry.(entry.counters.priority >= (!e).counters.priority)) then ( + let _ = (!e).Entry.cache_entries <- + List.filter (fun c -> a <> c) (!e).Entry.cache_entries in + let _ = Hashtbl.replace table.cache a (ref entry) in + entry.Entry.cache_entries <- a :: entry.Entry.cache_entries + ) + ) table.cache in + let _ = if (verbose) then + cp (sp "[switch] Adding flow %s" (OP.Match.match_to_string t.of_match)) + in + return () (* check if a list of actions has an output action forwarding packets to - * out_port *) + * out_port. + * Used when removing a port from the switch control in order to clean related + * flows *) let rec is_output_port out_port = function | [] -> false | OP.Flow.Output(port, _)::_ when (port = out_port) -> true | head::tail -> is_output_port out_port tail - let del_flow table ?(xid=(Random.int32 Int32.max_int)) ?(reason=OP.Flow_removed.DELETE) - t tuple out_port = + let del_flow table ?(xid=(Random.int32 Int32.max_int)) + ?(reason=OP.Flow_removed.DELETE) tuple out_port t verbose = (* Delete all matching entries from the flow table*) let remove_flow = Hashtbl.fold ( @@ -148,10 +184,24 @@ module Table = struct tuple.OP.Match.wildcards) && ((out_port = OP.Port.No_port) || (is_output_port out_port flow.Entry.actions))) then ( - Hashtbl.remove table.entries of_match; - ret @ [(of_match, flow)] - ) else - ret + let _ = Hashtbl.remove table.entries of_match in + + (* log removal of flow *) +(* let _ = + match Lwt.get OS.Topology.node_name with + | None -> () + | Some(node_name) -> + let flow_str = OP.Match.match_to_string of_match in + let action_str = OP.Flow.string_of_actions flow.Entry.actions in + let msg = Rpc.Dict [ + ("name", (Rpc.String node_name)); + ("type", (Rpc.String "del")); + ("flow", (Rpc.String flow_str)); + ("action", (Rpc.String action_str));] in + OS.Console.broadcast "flow" (Jsonrpc.to_string msg) + in *) + (of_match, flow)::ret + ) else ret ) table.entries [] in (* Delete all entries from cache *) @@ -163,102 +213,117 @@ module Table = struct (* Check for notification flag in flow and send * flow modification warnings *) - let _ = - List.iter ( - fun (of_match, flow) -> - if (flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) then - let duration_sec = Int32.sub (Int32.of_float (OS.Clock.time ())) + Lwt_list.iter_s ( + fun (of_match, flow) -> + let _ = + if verbose then + cp (sp "[switch] Removing flow %s" (OP.Match.match_to_string of_match)) + in + match(t, flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) with + | (Some t, true) -> + let duration_sec = (int_of_float (OS.Clock.time ())) - flow.Entry.counters.Entry.insert_sec in let fl_rm = OP.Flow_removed.( {of_match; cookie=flow.Entry.counters.Entry.cookie; priority=flow.Entry.counters.Entry.priority; - reason; duration_sec; duration_nsec=0l; + reason; duration_sec=(Int32.of_int duration_sec); duration_nsec=0l; idle_timeout=flow.Entry.counters.Entry.idle_timeout; packet_count=flow.Entry.counters.Entry.n_packets; - byte_count=flow.Entry.counters.Entry.n_bytes;}) in - let bits = OP.marshal_and_sub (OP.Flow_removed.marshal_flow_removed fl_rm) - (OS.Io_page.get ()) in - Channel.write_buffer t bits - ) remove_flow in - Channel.flush t + byte_count=flow.Entry.counters.Entry.n_bytes;}) in + let h = OP.Header.(create ~xid FLOW_REMOVED (OP.Flow_removed.get_len)) in + OSK.send_packet t (OP.Flow_removed (h,fl_rm)) + | _ -> return () + ) remove_flow (* table stat update methods *) - let update_table_found table = - table.stats.OP.Stats.lookup_count <- Int64.add - table.stats.OP.Stats.lookup_count 1L; - table.stats.OP.Stats.matched_count <- - Int64.add table.stats.OP.Stats.matched_count 1L + let update_table_found table = + let open OP.Stats in + table.stats.lookup_count <- Int64.add table.stats.lookup_count 1L; + table.stats.matched_count <- Int64.add table.stats.matched_count 1L let update_table_missed table = - table.stats.OP.Stats.lookup_count <- Int64.add - table.stats.OP.Stats.lookup_count 1L + let open OP.Stats in + table.stats.lookup_count <- Int64.add table.stats.lookup_count 1L (* monitor thread to timeout flows *) - let check_flow_timeout table t = - let ts = (Int32.of_float (OS.Clock.time ())) in - let flows = Hashtbl.fold ( - fun of_match entry ret -> - let hard = Int32.to_int (Int32.sub ts entry.Entry.counters.Entry.insert_sec) in - let idle = Int32.to_int (Int32.sub ts entry.Entry.counters.Entry.last_sec) in - match (hard, idle) with - | (l, _) when ((entry.Entry.counters.Entry.hard_timeout > 0) && - (l >= entry.Entry.counters.Entry.hard_timeout)) -> - ret @ [(of_match, entry, OP.Flow_removed.HARD_TIMEOUT )] - | (_, l) when ((entry.Entry.counters.Entry.idle_timeout > 0) && - (l >= entry.Entry.counters.Entry.idle_timeout)) -> - ret @ [(of_match, entry, OP.Flow_removed.IDLE_TIMEOUT )] - | _ -> ret - ) table.entries [] in - Lwt_list.iter_s ( - fun (of_match, entry, reason) -> - del_flow table ~reason t of_match OP.Port.No_port - ) flows - - - let monitor_flow_timeout table t = + let monitor_flow_timeout table t verbose = + let open Entry in + let check_flow_timeout table t verbose = + let ts = int_of_float (OS.Clock.time ()) in + let flows = Hashtbl.fold ( + fun of_match entry ret -> + let hard = ts - entry.counters.insert_sec in + let idle = ts - entry.counters.last_sec in + match (hard, idle) with + | (l, _) when ((entry.counters.hard_timeout > 0) && + (l >= entry.counters.hard_timeout)) -> + (of_match, entry, OP.Flow_removed.HARD_TIMEOUT )::ret + | (_, l) when ((entry.counters.idle_timeout > 0) && + (l >= entry.counters.idle_timeout)) -> + ret @ [(of_match, entry, OP.Flow_removed.IDLE_TIMEOUT )] + | _ -> ret + ) table.entries [] in + Lwt_list.iter_s ( + fun (of_match, entry, reason) -> + del_flow table ~reason of_match OP.Port.No_port t verbose + ) flows + in while_lwt true do lwt _ = OS.Time.sleep 1.0 in - check_flow_timeout table t + check_flow_timeout table t verbose done end module Switch = struct type port = { - mgr: Manager.t; + mgr: Net.Manager.t; port_id: int; ethif: Net.Manager.id; + netif: OS.Netif.t; port_name: string; counter: OP.Port.stats; phy: OP.Port.phy; + in_queue: Cstruct.t Lwt_stream.t; + in_push : (Cstruct.t option -> unit); + out_queue: Cstruct.t Lwt_stream.t; + out_push : (Cstruct.t option -> unit); + mutable pkt_count : int; } - let init_port mgr port_no ethif = - let name = Manager.get_intf_name mgr ethif in - let hw_addr = Nettypes.ethernet_mac_to_bytes - (Manager.get_intf_mac mgr ethif) in - let counter = OP.Port.( - { port_id=port_no; rx_packets=0L; tx_packets=0L; rx_bytes=0L; - tx_bytes=0L; rx_dropped=0L; tx_dropped=0L; rx_errors=0L; - tx_errors=0L; rx_frame_err=0L; rx_over_err=0L; rx_crc_err=0L; - collisions=0L;}) in + + let init_port mgr port_no id = + + let ethif = Net.Manager.get_ethif ( get_ethif mgr id ) in + let netif = Net.Ethif.get_netif ethif in + let name = OS.Netif.string_of_id (OS.Netif.id (Net.Ethif.get_netif ethif )) in + let hw_addr = Net.Ethif.mac ethif in + let (in_queue, in_push) = Lwt_stream.create () in + let (out_queue, out_push) = Lwt_stream.create () in + let counter = OP.Port.( + { port_id=port_no; rx_packets=0L; tx_packets=0L; rx_bytes=0L; + tx_bytes=0L; rx_dropped=0L; tx_dropped=0L; rx_errors=0L; + tx_errors=0L; rx_frame_err=0L; rx_over_err=0L; rx_crc_err=0L; + collisions=0L;}) in let features = OP.Port.( - {pause_asym=true; pause=true; autoneg=true; fiber=true; - copper=true; f_10GB_FD=true; f_1GB_FD=true; f_1GB_HD=true; - f_100MB_FD=true; f_100MB_HD=true; f_10MB_FD=true; - f_10MB_HD=true;}) in + {pause_asym=true; pause=true; autoneg=true; fiber=true; + copper=true; f_10GB_FD=true; f_1GB_FD=true; f_1GB_HD=true; + f_100MB_FD=true; f_100MB_HD=true; f_10MB_FD=true; + f_10MB_HD=true;}) in let port_config = OP.Port.( - { port_down=false; no_stp=false; no_recv=false; - no_recv_stp=false; no_flood=false; no_fwd=false; - no_packet_in=false;}) in + { port_down=false; no_stp=false; no_recv=false; + no_recv_stp=false; no_flood=false; no_fwd=false; + no_packet_in=false;}) in let port_state = OP.Port.( - {link_down =false; stp_listen =false; stp_learn =false; - stp_forward =false; stp_block =false;}) in + {link_down =false; stp_listen =false; stp_learn =false; + stp_forward =false; stp_block =false;}) in let phy = OP.Port.( - {port_no; hw_addr;name; config= port_config; - state= port_state; curr=features; advertised=features; - supported=features; peer=features;}) in + {port_no; hw_addr;name; config= port_config; + state= port_state; curr=features; advertised=features; + supported=features; peer=features;}) in - {port_id=port_no; mgr; port_name=name; counter; ethif;phy;} + {port_id=port_no; mgr; port_name=name; counter; + ethif=id;netif;phy;in_queue;in_push;pkt_count=0; + out_queue;out_push;} type stats = { mutable n_frags: uint64; @@ -278,20 +343,18 @@ module Switch = struct (* Mapping port ids to port numbers *) mutable int_to_port: (int, port ref) Hashtbl.t; mutable ports : port list; - mutable controllers: (Net.Channel.t) list; + mutable controller: OSK.conn_state option; + mutable last_echo_req : float; + mutable echo_resp_received : bool; table: Table.t; stats: stats; - p_sflow: uint32; (** probability for sFlow sampling *) mutable errornum : uint32; mutable portnum : int; - packet_queue : (Cstruct.buf * Net.Manager.id) Lwt_stream.t; - push_packet : ((Cstruct.buf * Net.Manager.id) option -> unit); - (* TODO: add this in the port definition and make also - * packet output assyncronous *) - mutable queue_len : int; features : OP.Switch.features; mutable packet_buffer: OP.Packet_in.t list; - mutable packet_buffer_id: int32; + mutable packet_buffer_id: int32; + ready : unit Lwt_condition.t ; + verbose : bool; } let supported_actions () = OP.Switch.({ output=true; set_vlan_id=true; set_vlan_pcp=true; strip_vlan=true; @@ -300,56 +363,19 @@ module Switch = struct let supported_capabilities () = OP.Switch.({flow_stats=true;table_stats=true;port_stats=true;stp=true; ip_reasm=false;queue_stats=false;arp_match_ip=true;}) - let switch_features () = - OP.Switch.({datapath_id=1L; n_buffers=0l; n_tables=(char_of_int 1); + let switch_features datapath_id = + OP.Switch.({datapath_id; n_buffers=0l; n_tables=(char_of_int 1); capabilities=(supported_capabilities ()); actions=(supported_actions ()); ports=[];}) let update_port_tx_stats pkt_len port = - port.counter.OP.Port.tx_packets <- (Int64.add - port.counter.OP.Port.tx_packets 1L); - port.counter.OP.Port.tx_bytes <- (Int64.add - port.counter.OP.Port.tx_bytes pkt_len) + OP.Port.(port.counter.tx_packets <- Int64.add port.counter.tx_packets 1L); + OP.Port.(port.counter.tx_bytes <- Int64.add port.counter.tx_bytes pkt_len) let update_port_rx_stats pkt_len port = - port.counter.OP.Port.rx_packets <- (Int64.add - port.counter.OP.Port.rx_packets 1L); - port.counter.OP.Port.rx_bytes <- (Int64.add - port.counter.OP.Port.rx_bytes pkt_len) - - let forward_frame st in_port frame pkt_size = function - | OP.Port.Port(port) -> - if Hashtbl.mem st.int_to_port port then( - let out_p = (!( Hashtbl.find st.int_to_port port)) in - Net.Manager.inject_packet out_p.mgr out_p.ethif frame ) - else - return (Printf.printf "Port %d not registered \n" port) - | OP.Port.No_port -> return () - | OP.Port.Flood - |OP.Port.All -> - Lwt_list.iter_p - (fun port -> - if(port.port_id != (OP.Port.int_of_port in_port)) then ( - update_port_tx_stats (Int64.of_int (Cstruct.len frame)) port; - Net.Manager.inject_packet port.mgr port.ethif frame - ) else - return () - ) st.ports - | OP.Port.In_port -> - let port = (OP.Port.int_of_port in_port) in - if Hashtbl.mem st.int_to_port port then - let out_p = !(Hashtbl.find st.int_to_port port) in - update_port_tx_stats (Int64.of_int (Cstruct.len frame)) out_p; - Net.Manager.inject_packet out_p.mgr out_p.ethif frame - else - return (Printf.printf "Port %d not registered \n" port) - (* | Table - * | Normal - * | Controller -> generate a packet out. - * | Local -> can I inject this frame to the network - * stack? *) - | _ -> return (Printf.printf "Not implemented output port\n") + OP.Port.(port.counter.rx_packets <- Int64.add port.counter.rx_packets 1L); + OP.Port.(port.counter.rx_bytes <- Int64.add port.counter.rx_bytes pkt_len) cstruct dl_header { uint8_t dl_dst[6]; @@ -391,102 +417,212 @@ module Switch = struct uint16_t checksum } as big_endian - (* TODO: Minor util function which I put it here as I have the - * header laready defined. Maybe need to make a new module - * and include this utils. *) - let size_of_raw_packet bits = - let dl_type = get_dl_header_dl_type bits in - let bits = Cstruct.shift bits sizeof_dl_header in - match (dl_type) with - | 0x0800 -> - Some( sizeof_dl_header + (get_nw_header_total_len bits)) - | 0x0806 -> - Some(sizeof_dl_header + sizeof_arphdr) - | _ -> - let _ = ep "dropping packet of ethtype %x\n%!" dl_type in -(* let _ = Cstruct.hexdump bits in *) - None + cstruct tcpv4 { + uint16_t src_port; + uint16_t dst_port; + uint32_t sequence; + uint32_t ack_number; + uint32_t dataoff_flags_window; + uint16_t checksum + } as big_endian + + cstruct pseudo_header { + uint32_t src; + uint32_t dst; + uint8_t res; + uint8_t proto; + uint16_t len + } as big_endian + + let tcp_checksum ~src ~dst = + let pbuf = Cstruct.sub (Cstruct.of_bigarray (OS.Io_page.get 1)) 0 sizeof_pseudo_header in + fun data -> + set_pseudo_header_src pbuf (Ipaddr.V4.to_int32 src); + set_pseudo_header_dst pbuf (Ipaddr.V4.to_int32 dst); + set_pseudo_header_res pbuf 0; + set_pseudo_header_proto pbuf 6; + set_pseudo_header_len pbuf (Cstruct.lenv data); + Net.Checksum.ones_complement_list (pbuf::data) + + let send_packet port bits = + update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; + return (port.out_push (Some bits)) +(* OS.Netif.write port.netif bits *) +(* Net.Manager.inject_packet port.mgr port.ethif bits *) + + + let forward_frame st in_port bits pkt_size checksum port = + let _ = + if ((checksum) && ((get_dl_header_dl_type bits) = 0x800)) then + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let _ = set_nw_header_csum ip_data 0 in + let csm = Net.Checksum.ones_complement (Cstruct.sub ip_data 0 (len*4)) in + let _ = set_nw_header_csum ip_data csm in + let _ = + match (get_nw_header_nw_proto ip_data) with + | 6 (* TCP *) -> + let src = Ipaddr.V4.of_int32 (get_nw_header_nw_src + ip_data) in + let dst = Ipaddr.V4.of_int32 (get_nw_header_nw_dst + ip_data) in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tcpv4_checksum tp_data 0 in + let csm = tcp_checksum ~src ~dst [tp_data] in + set_tcpv4_checksum tp_data csm + | 17 (* UDP *) -> () + | _ -> () + in + () + in + match port with + | OP.Port.Port(port) -> + if Hashtbl.mem st.int_to_port port then + let out_p = (!( Hashtbl.find st.int_to_port port)) in + send_packet out_p bits +(* Net.Manager.inject_packet out_p.mgr out_p.ethif bits *) + else + return (cp (sp "[switch] forward_frame: Port %d not registered\n%!" port)) + | OP.Port.No_port -> return () + | OP.Port.Flood + |OP.Port.All -> + Lwt_list.iter_p + (fun port -> + if(port.port_id != (OP.Port.int_of_port in_port)) then + send_packet port bits + else + return () + ) st.ports + | OP.Port.In_port -> + let port = (OP.Port.int_of_port in_port) in + if Hashtbl.mem st.int_to_port port then + send_packet (!(Hashtbl.find st.int_to_port port)) bits + else + return (cp (sp "[switch] forward_frame: Port %d unregistered\n%!" port)) + | OP.Port.Local -> + let local = OP.Port.int_of_port OP.Port.Local in + if Hashtbl.mem st.int_to_port local then + send_packet !(Hashtbl.find st.int_to_port local) bits + else + return (cp (sp "[switch] forward_frame: Port %d unregistered \n%!" local)) + | OP.Port.Controller -> begin + let size = + if (Cstruct.len bits > pkt_size) then + pkt_size + else + Cstruct.len bits + in + let (h, pkt_in) = + OP.Packet_in.(create_pkt_in ~buffer_id:(-1l) ~in_port + ~reason:ACTION ~data:(Cstruct.sub bits 0 size)) in + match st.controller with + | None -> return () + | Some conn -> OSK.send_packet conn (OP.Packet_in (h, pkt_in)) + end + (* | Table + * | Normal *) + | _ -> + return (cp (sp "[switch] forward_frame: unsupported output port\n")) (* Assumwe that action are valid. I will not get a flow that sets an ip * address unless it defines that the ethType is ip. Need to enforce * these rule in the parsing process of the flow_mod packets *) let apply_of_actions st in_port bits actions = - let apply_of_actions_inner st in_port bits = function - | OP.Flow.Output (port, pkt_size) -> - (* Make a packet copy in case the buffer is modified and multiple - * outputs are defined? *) - forward_frame st in_port bits pkt_size port - | OP.Flow.Set_dl_src(eaddr) -> - return (set_dl_header_dl_src eaddr 6 bits) - | OP.Flow.Set_dl_dst(eaddr) -> - return (set_dl_header_dl_dst eaddr 6 bits) - (* TODO: Add for this actions to check when inserted if - * the flow is an ip flow *) - | OP.Flow.Set_nw_tos(tos) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - return (set_nw_header_nw_tos ip_data (int_of_char tos)) - (* TODO: wHAT ABOUT ARP? - * *) - | OP.Flow.Set_nw_src(ip) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - return (set_nw_header_nw_src ip_data ip) - | OP.Flow.Set_nw_dst(ip) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - return (set_nw_header_nw_dst ip_data ip) - | OP.Flow.Set_tp_src(port) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - let len = (get_nw_header_hlen_version bits) land 0xf in - let tp_data = Cstruct.shift ip_data (len*4) in - return (set_tp_header_tp_src tp_data port) - | OP.Flow.Set_tp_dst(port) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - let len = (get_nw_header_hlen_version bits) land 0xf in - let tp_data = Cstruct.shift ip_data (len*4) in - return (set_tp_header_tp_dst tp_data port ) - | OP.Flow.Enqueue(_, _) - | OP.Flow.Set_vlan_pcp _ - | OP.Flow.Set_vlan_vid _ - | OP.Flow.VENDOR_ACT - | OP.Flow.STRIP_VLAN -> - (* VLAN manupulation actions *) - return (pr "Unsupported action STRIP_VLAN\n") + let apply_of_actions_inner st in_port bits checksum action = + try_lwt + match action with + | OP.Flow.Output (port, pkt_size) -> + (* Make a packet copy in case the buffer is modified and multiple + * outputs are defined? *) + lwt _ = forward_frame st in_port bits pkt_size checksum port in + return false + | OP.Flow.Set_dl_src(eaddr) -> + let _ = set_dl_header_dl_src (Macaddr.to_bytes eaddr) 0 bits in + return checksum + | OP.Flow.Set_dl_dst(eaddr) -> + let _ = set_dl_header_dl_dst (Macaddr.to_bytes eaddr) 0 bits in + return checksum + (* TODO: Add for this actions to check when inserted if + * the flow is an ip flow *) + | OP.Flow.Set_nw_tos(tos) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_tos ip_data (int_of_char tos) in + return true + (* TODO: wHAT ABOUT ARP? + * *) + | OP.Flow.Set_nw_src(ip) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_src ip_data (Ipaddr.V4.to_int32 ip) in + return true + | OP.Flow.Set_nw_dst(ip) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_dst ip_data (Ipaddr.V4.to_int32 ip) in + return true + | OP.Flow.Set_tp_src(port) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tp_header_tp_src tp_data port in + return true + | OP.Flow.Set_tp_dst(port) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tp_header_tp_dst tp_data port in + return true + (* | OP.Flow.Enqueue(_, _) + | OP.Flow.Set_vlan_pcp _ + | OP.Flow.Set_vlan_vid _ + | OP.Flow.VENDOR_ACT + | OP.Flow.STRIP_VLAN *) + | act -> + let _ = cp (sp "[switch] apply_of_actions: Unsupported action %s" + (OP.Flow.string_of_action act)) in + return checksum + with exn -> + let _ = cp(sp "[switch] apply_of_actions: (packet size %d) %s %s\n%!" + (Cstruct.len bits) (OP.Flow.string_of_action action) + (Printexc.to_string exn )) in + return checksum in - let rec apply_of_actions_rec st in_port actions = function - | [] -> return () + let rec apply_of_actions_rec st in_port bits checksum = function + | [] -> return false | head :: actions -> - let _ = apply_of_actions_inner st in_port bits head in - apply_of_actions_rec st in_port bits actions + lwt checksum = apply_of_actions_inner st in_port bits checksum head in + apply_of_actions_rec st in_port bits checksum actions in - apply_of_actions_rec st in_port bits actions - + lwt _ = apply_of_actions_rec st in_port bits false actions in + return () + let lookup_flow st of_match = (* Check first the match table cache * NOTE an exact match flow will be found on this step and thus * return a result immediately, without needing to get to the cache table * and consider flow priorities *) - if (Hashtbl.mem st.table.Table.cache of_match ) then ( - let entry = (Hashtbl.find st.table.Table.cache of_match) in - Found(entry) - ) else ( - (* Check the wilcard card table *) - let lookup_flow flow entry r = - match (r, (OP.Match.flow_match_compare of_match flow - flow.OP.Match.wildcards)) with - | (_, false) -> r - | (None, true) -> Some(flow, entry) - | (Some(f,e), true) when (Entry.(e.counters.priority > entry.counters.priority)) -> r - | (Some(f,e), true) when (Entry.(e.counters.priority <= entry.counters.priority)) -> - Some(flow, entry) - | (_, _) -> r - in - let flow_match = Hashtbl.fold lookup_flow st.table.Table.entries None in - match (flow_match) with - | None -> NOT_FOUND - | Some(f,e) -> - Hashtbl.add st.table.Table.cache of_match (ref e); - e.Entry.cache_entries <- e.Entry.cache_entries @ [of_match]; - Found(ref e) - ) + let open Table in + let open OP.Match in + if (Hashtbl.mem st.table.cache of_match ) then + let entry = (Hashtbl.find st.table.cache of_match) in + Found(entry) + else begin + (* Check the wilcard card table *) + let lookup_flow flow entry r = + match (r, (flow_match_compare of_match flow flow.wildcards)) with + | (_, false) -> r + | (None, true) -> Some(flow, entry) + | (Some(f,e), true) when (Entry.(e.counters.priority > entry.counters.priority)) -> r + | (Some(f,e), true) when (Entry.(e.counters.priority <= entry.counters.priority)) -> + Some(flow, entry) + | (_, _) -> r + in + let flow_match = Hashtbl.fold lookup_flow st.table.entries None in + match (flow_match) with + | None -> NOT_FOUND + | Some(f,e) -> + Hashtbl.add st.table.cache of_match (ref e); + Entry.(e.cache_entries <- of_match :: e.cache_entries); + Found(ref e) + end end type t = Switch.t @@ -494,308 +630,277 @@ type t = Switch.t (********************************************* * Switch OpenFlow data plane *********************************************) - - -(* - * let process_frame_depr intf_name frame = *) -let process_frame_inner st intf frame = - try_lwt - let p = (!(Hashtbl.find st.Switch.dev_to_port intf)) in - let in_port = (OP.Port.port_of_int p.Switch.port_id) in - let tupple = (OP.Match.raw_packet_to_match in_port frame ) in - (* Update port rx statistics *) - let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in - - (* What is the size of the frame? Need to get sub_buffer in order to - * process it *) - let frame = - match (Switch.size_of_raw_packet frame) with - | Some(len) -> - let _ = pr "received packet of size %d (buf len %d)\n%!" - (Cstruct.len frame) len in - Cstruct.sub_buffer frame 0 len - | None -> raise Packet_type_unknw - in - (* Lookup packet flow to existing flows in table *) - let entry = (Switch.lookup_flow st tupple) in - match entry with - | Switch.NOT_FOUND -> - let _ = Table.update_table_missed st.Switch.table in - let buffer_id = st.Switch.packet_buffer_id in +let process_frame_inner st p frame = + let open Switch in + let open OP.Packet_in in + try_lwt + let in_port = (OP.Port.port_of_int p.Switch.port_id) in + let tupple = (OP.Match.raw_packet_to_match in_port frame ) in + (* Update port rx statistics *) + let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in + + (* Lookup packet flow to existing flows in table *) + match (Switch.lookup_flow st tupple) with + | Switch.NOT_FOUND -> begin + Table.update_table_missed st.table; + let buffer_id = st.packet_buffer_id in (*TODO Move this code in the Switch module *) - st.Switch.packet_buffer_id <- Int32.add st.Switch.packet_buffer_id 1l; - let pkt_in = OP.Packet_in.create_pkt_in ~buffer_id ~in_port - ~reason:OP.Packet_in.NO_MATCH ~data:frame in - st.Switch.packet_buffer <- st.Switch.packet_buffer @ [pkt_in]; - let bits = OP.marshal_and_sub (OP.Packet_in.marshal_pkt_in ~data_len:64 pkt_in) - (OS.Io_page.get ()) in - Lwt_list.iter_p - (fun t -> - match (Cstruct.len bits) with - | l when l <= 1400 -> - let _ = Channel.write_buffer t bits in - Channel.flush t - | _ -> - let buf = Cstruct.sub_buffer bits 0 1400 in - let _ = Channel.write_buffer t buf in - let buf = Cstruct.sub_buffer bits 1400 ((Cstruct.len bits) - 1400) in - let _ = Channel.write_buffer t buf in - lwt _ = Channel.flush t in - return () + st.packet_buffer_id <- Int32.add st.packet_buffer_id 1l; + let (h, pkt_in) = create_pkt_in ~buffer_id ~in_port ~reason:NO_MATCH ~data:frame in + st.packet_buffer <- pkt_in::st.packet_buffer; + + (* Disable for now packet trimming for buffered packets *) + let size = + if (Cstruct.len frame > 92) then 92 + else Cstruct.len frame in + let (h, pkt_in) = create_pkt_in ~buffer_id ~in_port ~reason:NO_MATCH + ~data:(Cstruct.sub frame 0 size) in + return ( + match st.Switch.controller with + | None -> () + | Some conn -> ignore_result (OSK.send_packet conn (OP.Packet_in(h,pkt_in))) ) - st.Switch.controllers + end (* generate a packet in event *) - | Switch.Found(entry) -> - let _ = Table.update_table_found st.Switch.table in - let _ = Entry.update_flow (Int64.of_int (Cstruct.len frame)) !entry in - Switch.apply_of_actions st tupple.OP.Match.in_port - frame (!entry).Entry.actions - with exn -> - pp "control channel error: %s\nbt: %s\n%!" - (Printexc.to_string exn) (Printexc.get_backtrace ()); - return () - | Packet_type_unknw -> return () - -let process_frame st intf_name frame = - try_lwt - let p = Hashtbl.find st.Switch.dev_to_port intf_name in - process_frame_inner st intf_name frame -(* if (st.Switch.queue_len < 256) then ( - st.Switch.queue_len <- st.Switch.queue_len + 1; - - return(st.Switch.push_packet (Some(frame, ((!p).Switch.port_id) ))) - ) else ( - pr "dropping packet at the switch\n%!"; - return () - ) *) + | Switch.Found(entry) -> + let _ = Table.update_table_found st.table in + let _ = Entry.update_flow (Int64.of_int (Cstruct.len frame)) !entry in + apply_of_actions st tupple.OP.Match.in_port frame (!entry).Entry.actions + with exn -> + return (cp (sp "[switch] process_frame_inner: control channel error: %s\n" + (Printexc.to_string exn))) + +let check_packets st = + match_lwt (Lwt_list.exists_p (fun p -> return (p.Switch.pkt_count > 0)) + st.Switch.ports) with + | false -> OS.Time.sleep 0.5 + | true -> return () + +let forward_thread st = +(* while_lwt true do + lwt _ = check_packets st Lwt_condition.wait st.Switch.ready in + Lwt_list.iter_s (fun p -> +(* lwt empty = Lwt_stream.is_empty p.Switch.queue in *) + if (p.Switch.pkt_count = 0) then +(* let _ = cp (sp "port %d no packets\n" p.Switch.port_id) in *) + return () + else + lwt frames = Lwt_stream.nget p.Switch.pkt_count p.Switch.queue in + lwt _ = + Lwt_list.iter_p + (fun f -> + p.Switch.pkt_count <- p.Switch.pkt_count - 1; process_frame_inner st p f) + frames in +(* let _ = cp (sp "port %d got packet\n" p.Switch.port_id) in *) +(* let _ = cp (sp "port %d processed packet\n" p.Switch.port_id) in *) + return () + ) st.Switch.ports + done *) + Lwt_list.iter_p (fun p -> + while_lwt true do +(* if (p.Switch.pkt_count > 0) then + lwt frames = Lwt_stream.nget 10 p.Switch.queue in + Lwt_list.iter_p ( + fun f -> p.Switch.pkt_count <- p.Switch.pkt_count - 1; + process_frame_inner st p f) frames + else *) + lwt _ = Lwt_stream.next p.Switch.in_queue >>= process_frame_inner st p in +(* let _ = + if (p.Switch.pkt_count mod 20 = 1) then + cp (sp "port %d got packet %d" p.Switch.port_id p.Switch.pkt_count) in + * *) + return (p.Switch.pkt_count <- p.Switch.pkt_count - 1) + done <&> ( + while_lwt true do + lwt frame = Lwt_stream.next p.Switch.out_queue in +(* lwt _ = OS.Time.sleep 0.0 in *) +(* let frames = Lwt_stream.get_available p.Switch.out_queue in*) +(* let _ = Printf.printf "got %d packets\n%!" (1+(List.length frames)) in + * *) + OS.Netif.writev p.Switch.netif [frame] (*frame::frames*) + done + ) + ) st.Switch.ports + +let process_frame st p _ frame = + let _ = + try + match frame with + | Net.Ethif.Output _ -> () + | Net.Ethif.Input frame -> +(* let _ = Lwt_condition.broadcast st.Switch.ready () in *) +(* if (p.Switch.pkt_count < 1000) then *) + let _ = p.Switch.pkt_count <- p.Switch.pkt_count + 1 in +(* let _ = Printf.printf "pushing packet to port %d %d\n%!" + p.Switch.port_id p.Switch.pkt_count in *) + p.Switch.in_push (Some frame) +(* Printf.printf "pushed packet to port %d\n%!" p.Switch.port_id*) +(* else + cp "[process_frame] blocked queue" *) with - | Not_found -> - return (pr "%03.6f: Invalid port\n%!" (OS.Clock.time ())) - | Packet_type_unknw -> - return (pr "%03.6f: received a malformed packet\n%!" (OS.Clock.time ())) - | exn -> - return (pr "%03.6f: switch error: %s\n%!" (OS.Clock.time ()) (Printexc.to_string exn)) - -let data_plane st () = - try_lwt - while_lwt true do - lwt a = Lwt_stream.get st.Switch.packet_queue in - match a with - | Some (pkt, p) -> - st.Switch.queue_len <- st.Switch.queue_len - 1; - process_frame_inner st p pkt - | None -> return () - done - + | Not_found -> cp (sp "[switch] process_frame: Invalid port\n%!") + | Packet_type_unknw -> cp (sp "[switch] process_frame: malformed packet\n%!") + | exn -> cp (sp "[switch] process_frame: switch error: %s\n%!" (Printexc.to_string exn)) + in + return () (************************************************* * Switch OpenFlow control channel *************************************************) - -type endhost = { - ip: Nettypes.ipv4_addr; - port: int; -} - -let process_openflow st t bits = function - | OP.Hello (h) -> - (* Reply to HELLO with a HELLO and a feature request *) - cp "HELLO"; - return () - | OP.Echo_req (h, bs) -> (* Reply to ECHO requests *) - cp "ECHO_REQ"; - let h = OP.Header.(create ECHO_RESP sizeof_ofp_header h.xid) in - let bits = OP.marshal_and_sub (OP.Header.marshal_header h) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Features_req (h) -> - cp "FEAT_REQ"; - let bits = OP.marshal_and_sub - (OP.Switch.marshal_reply_features h.OP.Header.xid st.Switch.features ) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats_req(h, req) -> begin - let xid = h.OP.Header.xid in - cp "STATS_REQ\n%!"; - match req with - | OP.Stats.Desc_req(req) -> - let desc = OP.Stats.({ imfr_desc="Mirage"; hw_desc="Mirage"; - sw_desc="Mirage"; serial_num="0.1";dp_desc="Mirage";}) - in - let resp_h = OP.Stats.({st_ty=DESC; more_to_follow=false;}) in - let bits = OP.marshal_and_sub - (OP.Stats.marshal_stats_resp xid (OP.Stats.Desc_resp(resp_h, - desc))) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> +let get_flow_stats st of_match = + let open OP.Match in + let match_flows of_match key value ret = + if (flow_match_compare key of_match of_match.wildcards) then ( + (Entry.flow_counters_to_flow_stats key (char_of_int 1) value)::ret + ) else + ret + in + Hashtbl.fold (fun key value r -> match_flows of_match key value r) + st.Switch.table.Table.entries [] + +let process_buffer_id st t msg xid buffer_id actions = + let open OP.Header in + let pkt_in = ref None in + let _ = + st.Switch.packet_buffer <- + List.filter ( fun a -> + if (a.OP.Packet_in.buffer_id = buffer_id) then + (pkt_in := Some(a); false ) + else true ) st.Switch.packet_buffer in + match (!pkt_in) with + | None -> + cp (sp "[switch] invalid buffer id %ld\n%!" buffer_id); + let bits = OP.marshal msg in + let h = create ~xid ERROR (get_len + 4 + (Cstruct.len bits)) in + OSK.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) + | Some(pkt_in) -> + OP.Packet_in.(Switch.apply_of_actions st pkt_in.in_port pkt_in.data actions) + +let process_openflow st t msg = + let open OP.Header in + let _ = if st.Switch.verbose then cp (sp "[switch] %s\n%!" (OP.to_string msg)) in + match msg with + | OP.Hello (h) -> return () + | OP.Echo_resp h -> return (st.Switch.echo_resp_received <- true) + | OP.Echo_req h -> (* Reply to ECHO requests *) + OSK.send_packet t (OP.Echo_req (create ~xid:h.xid ECHO_RESP sizeof_ofp_header)) + | OP.Features_req (h) -> + let h = create ~xid:(h.xid) FEATURES_RESP (OP.Switch.get_len st.Switch.features) in + OSK.send_packet t (OP.Features_resp (h, st.Switch.features)) + | OP.Stats_req(h, req) -> begin + let xid = h.xid in + match req with + | OP.Stats.Desc_req(req) -> + let p = OP.Stats.(Desc_resp ({st_ty=DESC; more=false;}, + (create_desc_stat_resp "Mirage" "Mirage" "Mirage" + "0.1" "Mirage"))) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len p) in + OSK.send_packet t (OP.Stats_resp (h, p)) + | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> (*TODO Need to consider the table_id and the out_port and * split reply over multiple openflow packets if they don't * fit a single packet. *) - let match_flows of_match key value ret = - if (OP.Match.flow_match_compare key of_match - of_match.OP.Match.wildcards) then ( - ret @ [ - (Entry.flow_counters_to_flow_stats - of_match (char_of_int 1) value)] - ) else - ret - in - let flows = - Hashtbl.fold (fun key value r -> match_flows of_match key value r) - st.Switch.table.Table.entries [] in - let stats = OP.Stats.({st_ty=FLOW; more_to_follow=false;}) in - let reply = OP.Stats.Flow_resp(stats, flows) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> - let aggr_flow_bytes = ref 0L in - let aggr_flow_pkts = ref 0L in - let aggr_flows = ref 0l in - let match_flows_aggr of_match key value = - if (OP.Match.flow_match_compare key of_match - of_match.OP.Match.wildcards) then ( - aggr_flows := Int32.add (!aggr_flows) 1l; - aggr_flow_bytes := Int64.add (!aggr_flow_bytes) - value.Entry.counters.Entry.n_bytes; - aggr_flow_pkts := Int64.add (!aggr_flow_pkts) - value.Entry.counters.Entry.n_packets - ) in - Hashtbl.iter (fun key value -> match_flows_aggr of_match key value) - st.Switch.table.Table.entries; - let stats = OP.Stats.({st_ty=AGGREGATE; more_to_follow=false;}) in - let reply = OP.Stats.Aggregate_resp(stats, - OP.Stats.({byte_count=(!aggr_flow_bytes); - packet_count=(!aggr_flow_pkts); - flow_count=(!aggr_flows);})) - in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats.Table_req(req) -> - let stats = OP.Stats.({st_ty=TABLE; more_to_follow=false;}) in - let reply = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats.Port_req(req_h, port) -> begin - match port with - | OP.Port.No_port -> - let port_stats = List.map (fun p -> p.Switch.counter) st.Switch.ports in - let stats = OP.Stats.({st_ty=PORT; more_to_follow=false;}) in - let reply = OP.Stats.Port_resp(stats, port_stats) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Port.Port(port_id) -> - try_lwt - let port = Hashtbl.find st.Switch.int_to_port port_id in - let stats = OP.Stats.({st_ty=PORT; more_to_follow=false;}) in - let reply = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - with Not_found -> + let flows = get_flow_stats st of_match in + let stats = OP.Stats.({st_ty=FLOW; more=true;}) in + lwt (_, flows) = + Lwt_list. fold_right_s ( + fun fl (sz, flows) -> + let fl_sz = OP.Flow.flow_stats_len fl in + if (sz + fl_sz > 0xffff) then + let r = OP.Stats.Flow_resp(stats, flows) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + lwt _ = OSK.send_packet t (OP.Stats_resp (h, r)) in + return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) + else + return ((sz + fl_sz), (fl::flows)) ) + flows ((OP.Header.get_len + OP.Stats.get_resp_hdr_size), []) in + let stats = OP.Stats.({st_ty=FLOW; more=false;}) in + let r = OP.Stats.Flow_resp(stats, flows) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> + let match_flows_aggr of_match key value (fl_b, fl_p, fl)= + let open OP.Match in + let open Entry in + if (flow_match_compare key of_match of_match.wildcards) then + ((Int64.add fl_b value.counters.n_bytes), (Int64.add fl_p + value.counters.n_packets), (Int32.succ fl)) + else (fl_b, fl_p, fl) in + let (byte_count, packet_count,flow_count) = + Hashtbl.fold (match_flows_aggr of_match) + st.Switch.table.Table.entries (0L, 0L, 0l) in + let stats = OP.Stats.({st_ty=AGGREGATE; more=false;}) in + let r = OP.Stats.Aggregate_resp(stats, + OP.Stats.({byte_count;packet_count;flow_count;})) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Table_req(req) -> + let stats = OP.Stats.({st_ty=TABLE; more=false;}) in + let r = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Port_req(req_h, port) -> begin + match port with + | OP.Port.No_port -> + let port_stats = List.map (fun p -> p.Switch.counter) st.Switch.ports in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in + let r = OP.Stats.Port_resp(stats, port_stats) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Port.Port(port_id) -> begin + try_lwt + let port = Hashtbl.find st.Switch.int_to_port port_id in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in + let r = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + with Not_found -> (* TODO reply with right error code *) - pr "Invalid port_id in stats\n%!"; - return () + cp (sp "[switch] unregistered port %s\n%!"(OP.Port.string_of_port port)); + let h = create ~xid ERROR (OP.Header.get_len + 4) in + OSK.send_packet t (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) + end + | _ -> + cp "[switch] unsupported stats request\n%!"; + let h = create ~xid ERROR (get_len + 4) in + OSK.send_packet t OP.(Error (h, ACTION_BAD_OUT_PORT, (marshal msg))) + end + | _ -> begin + let h = create ~xid ERROR (get_len + 4) in + OSK.send_packet t (OP.Error (h, OP.REQUEST_BAD_SUBTYPE, (get_new_buffer 0))) end - | _ -> - let bits = OP.marshal_and_sub (OP.marshal_error - OP.REQUEST_BAD_SUBTYPE bits xid) (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - end - | OP.Get_config_req(h) -> + end + | OP.Get_config_req(h) -> let resp = OP.Switch.init_switch_config in - let bits = OP.marshal_and_sub (OP.Switch.marshal_switch_config - h.OP.Header.xid resp) (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Barrier_req(h) -> - cp (sp "BARRIER_REQ: %s\n%!" (OP.Header.header_to_string h)); - let resp_h = (OP.Header.create OP.Header.BARRIER_RESP - (OP.Header.sizeof_ofp_header) h.OP.Header.xid) in - let bits = OP.marshal_and_sub (OP.Header.marshal_header resp_h) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Packet_out(h, pkt) -> - cp (sp "PACKET_OUT: %s\n%!" (OP.Packet_out.packet_out_to_string pkt)); - if (pkt.OP.Packet_out.buffer_id = -1l) then - Switch.apply_of_actions st pkt.OP.Packet_out.in_port - pkt.OP.Packet_out.data pkt.OP.Packet_out.actions - else begin - let pkt_in = ref None in - let _ = - st.Switch.packet_buffer <- - List.filter ( - fun a -> - if (a.OP.Packet_in.buffer_id = pkt.OP.Packet_out.buffer_id) then - (pkt_in := Some(a); false ) - else true - ) st.Switch.packet_buffer - in - match (!pkt_in) with - | None -> - let bs = OP.marshal_and_sub - (OP.marshal_error OP.REQUEST_BUFFER_UNKNOWN bits h.OP.Header.xid) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bs in - Channel.flush t - | Some(pkt_in) -> - Switch.apply_of_actions st pkt_in.OP.Packet_in.in_port - pkt_in.OP.Packet_in.data pkt.OP.Packet_out.actions - end + let h = create ~xid:h.xid GET_CONFIG_RESP OP.Switch.config_get_len in + OSK.send_packet t (OP.Get_config_resp(h, resp)) + | OP.Barrier_req(h) -> + OSK.send_packet t (OP.Barrier_resp(create ~xid:h.xid BARRIER_RESP sizeof_ofp_header)) + + | OP.Packet_out(h, pkt) -> + let open OP.Packet_out in + if (pkt.buffer_id = -1l) then + Switch.apply_of_actions st pkt.in_port pkt.data pkt.actions + else begin + process_buffer_id st t msg h.xid pkt.buffer_id pkt.actions + end | OP.Flow_mod(h,fm) -> - cp (sp "FLOW_MOD: %s\n%!" (OP.Flow_mod.flow_mod_to_string fm)); - let of_match = fm.OP.Flow_mod.of_match in - let of_actions = fm.OP.Flow_mod.actions in - lwt _ = - match (fm.OP.Flow_mod.command) with - | OP.Flow_mod.ADD - | OP.Flow_mod.MODIFY - | OP.Flow_mod.MODIFY_STRICT -> - return (Table.add_flow st.Switch.table fm) - | OP.Flow_mod.DELETE - | OP.Flow_mod.DELETE_STRICT -> - Table.del_flow st.Switch.table t of_match fm.OP.Flow_mod.out_port - in - if (fm.OP.Flow_mod.buffer_id = -1l) then - return () - else begin - let pkt_in = ref None in - let _ = - st.Switch.packet_buffer <- - List.filter ( - fun a -> - if (a.OP.Packet_in.buffer_id = fm.OP.Flow_mod.buffer_id) then - (pkt_in := Some(a); false ) - else true - ) st.Switch.packet_buffer - in - match (!pkt_in) with - | None -> - let bs = - OP.marshal_and_sub - (OP.marshal_error OP.REQUEST_BUFFER_UNKNOWN bits h.OP.Header.xid) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bs in - Channel.flush t - | Some(pkt_in) -> - (* TODO check if the match is accurate? *) - Switch.apply_of_actions st pkt_in.OP.Packet_in.in_port - pkt_in.OP.Packet_in.data of_actions - end + let open OP.Flow_mod in + lwt _ = + match (fm.command) with + | ADD + | MODIFY + | MODIFY_STRICT -> + Table.add_flow st st.Switch.table fm st.Switch.verbose + | DELETE + | DELETE_STRICT -> + (* Need to implemente strict deletion in order to enable signpost + * switching *) + Table.del_flow st.Switch.table fm.of_match fm.out_port (Some t) st.Switch.verbose + in + if (fm.buffer_id = -1l) then return () + else process_buffer_id st t msg h.xid fm.buffer_id fm.actions + | OP.Set_config (h, _) -> return () | OP.Queue_get_config_resp (h, _, _) | OP.Queue_get_config_req (h, _) | OP.Barrier_resp h @@ -804,80 +909,196 @@ let process_openflow st t bits = function | OP.Port_status (h, _) | OP.Flow_removed (h, _) | OP.Packet_in (h, _) - | OP.Set_config (h, _) | OP.Get_config_resp (h, _) | OP.Features_resp (h, _) - | OP.Vendor (h, _, _) - | OP.Echo_resp (h, _) - | OP.Error (h, _) -> - let bits = OP.marshal_and_sub (OP.marshal_error - OP.REQUEST_BAD_TYPE bits h.OP.Header.xid) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - -let control_channel st (remote_addr, remote_port) t = - let rs = Nettypes.ipv4_addr_to_string remote_addr in - Printf.eprintf "OpenFlow Switch: controller %s:%d" rs remote_port; - st.Switch.controllers <- (st.Switch.controllers @ [t]); - + | OP.Vendor (h, _) + | OP.Error (h, _, _) -> + let bits = OP.marshal msg in + let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR + (OP.Header.get_len + 4 + (Cstruct.len bits)) in + OSK.send_packet t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits)) + +let monitor_control_channel st conn = + let is_active = ref true in + while_lwt !is_active do + let _ = st.Switch.echo_resp_received <- false in + let _ = st.Switch.last_echo_req <- (OS.Clock.time ()) in + lwt _ = OSK.send_packet conn + OP.(Echo_req Header.(create ECHO_REQ sizeof_ofp_header)) in + lwt _ = OS.Time.sleep 10.0 in + return (is_active := st.Switch.echo_resp_received) + done + +let control_channel_run st conn = (* Trigger the dance between the 2 nodes *) - let h = OP.Header.(create HELLO sizeof_ofp_header 1l) in - let bits = OP.marshal_and_sub (OP.Header.marshal_header h) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - lwt _ = Channel.flush t in - let cached_socket = Ofsocket.create_socket t in - + let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in + lwt _ = OSK.send_packet conn (OP.Hello(h)) in let rec echo () = try_lwt - lwt hbuf = Ofsocket.read_data cached_socket OP.Header.sizeof_ofp_header in - let ofh = OP.Header.parse_header hbuf in - let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in - lwt dbuf = Ofsocket.read_data cached_socket dlen in - let ofp = OP.parse ofh dbuf in - process_openflow st t dbuf ofp (* Bitstring.concat [hbuf; dbuf] *) - >> echo () + OSK.read_packet conn >>= process_openflow st conn >>= echo with - | Nettypes.Closed -> - (* TODO Need to remove the t from st.Switch.controllers *) - pr "Controller channel closed....\n%!"; - return () - | OP.Unparsed (m, bs) -> (pr "# unparsed! m=%s\n %!" m); echo () + | Net.Nettypes.Closed -> + return (cp "[switch] ERROR:Controller channel closed....\n%!") + | OP.Unparsed (m, bs) -> + cp (sp "[switch] ERROR:unparsed! m=%s\n %!" m); echo () | exn -> - pr "[OpenFlow-Switch-Control] ERROR:%s\n" (Printexc.to_string exn); - (echo () ) - - in - echo () <&> (Table.monitor_flow_timeout st.Switch.table t) + cp (sp "[switch] ERROR:%s\n%!" (Printexc.to_string exn)); echo () + in + lwt _ = + echo () + Switch.(Table.monitor_flow_timeout st.table (Some conn) st.verbose) + (monitor_control_channel st conn) + in + let _ = OSK.close conn in + let _ = st.Switch.controller <- None in + return (cp "[switch] control channel thread returned") + +let control_channel st (addr, port) t = + cp (sp "[switch] controller %s:%d" (Ipaddr.V4.to_string addr) port); + let conn = OSK.init_socket_conn_state t in + let _ = st.Switch.controller <- (Some conn) in + control_channel_run st conn (* * Interaface with external applications * *) -let add_port mgr sw ethif = +let get_port_name mgr a = + let ethif = Net.Manager.get_ethif (get_ethif mgr a) in + OS.Netif.string_of_id (OS.Netif.id (Net.Ethif.get_netif ethif)) + +let add_port mgr ?(use_mac=false) sw id = sw.Switch.portnum <- sw.Switch.portnum + 1; - let _ = pr "Adding port %d (%s)\n %!" sw.Switch.portnum - (Net.Manager.get_intf_name mgr ethif) in - let port = Switch.init_port mgr sw.Switch.portnum ethif in + let ethif = Net.Manager.get_ethif (get_ethif mgr id) in + let hw_addr = Macaddr.to_string (Net.Ethif.mac ethif) in + let dev_name = get_port_name mgr id in + let _ = OS.Console.log (sp "[switch] Adding port %d (%s) '%s' \n %!" + sw.Switch.portnum dev_name hw_addr) in + let port = Switch.init_port mgr sw.Switch.portnum id in sw.Switch.ports <- sw.Switch.ports @ [port]; Hashtbl.add sw.Switch.int_to_port sw.Switch.portnum (ref port); - Hashtbl.add sw.Switch.dev_to_port ethif (ref port); + Hashtbl.add sw.Switch.dev_to_port id (ref port); sw.Switch.features.OP.Switch.ports <- sw.Switch.features.OP.Switch.ports @ [port.Switch.phy]; - let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw) in - () - -let create_switch () = - let (packet_queue, push_packet) = Lwt_stream.create () in + let _ = Net.Manager.set_promiscuous mgr id (process_frame sw port) in + let h,p = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in + match sw.Switch.controller with + | None -> return () + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) + +let del_port mgr sw name = + try_lwt + let open Switch in + let port = + List.find (fun a -> (get_port_name mgr a.ethif) = name) sw.ports in + let _ = + sw.ports <- List.filter (fun a -> (get_port_name mgr a.ethif) <> name ) sw.ports in + let _ = Hashtbl.remove sw.int_to_port port.port_id in + let _ = Hashtbl.remove sw.dev_to_port port.ethif in + let h,p = OP.Port.create_port_status OP.Port.DEL port.phy in + let of_match = OP.Match.create_flow_match (OP.Wildcards.full_wildcard ()) () in + lwt _ = Table.del_flow sw.table of_match + (OP.Port.port_of_int port.port_id) sw.controller sw.verbose in + let of_match = OP.Match.create_flow_match (OP.Wildcards.in_port_match ()) + ~in_port:(port.Switch.port_id) () in + lwt _ = Table.del_flow sw.table of_match + OP.Port.No_port sw.controller sw.verbose in + let _ = cp (sp "[switch] Removing port %s (port_id=%d)" name port.port_id) in + match sw.controller with + | None -> return () + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) + with exn -> + return (cp (sp "[switch] del_port: port %s not found\n%!" name)) + +let add_port_local mgr sw ethif = + (*TODO Find first if a port is already registered as port 0 + * as port 0 and disable it *) +let open Switch in + let local_port_id = OP.Port.int_of_port OP.Port.Local in + let port = init_port mgr local_port_id ethif in + sw.ports <- port :: (List.filter (fun a -> (a.port_id <> 0)) sw.ports); + Hashtbl.replace sw.int_to_port local_port_id (ref port); + Hashtbl.iter + (fun a b -> if (!b.port_id = local_port_id) then + Hashtbl.remove sw.dev_to_port a + ) sw.dev_to_port; + Hashtbl.add sw.dev_to_port ethif (ref port); + (*TODO Need to filter out any 0 port *) + sw.features.OP.Switch.ports <- + port.phy :: + (List.filter (fun a -> (a.OP.Port.port_no <> local_port_id)) + sw.Switch.features.OP.Switch.ports ); + let _ = cp (sp "[switch] Adding port %s (port_id=%d)" + (OS.Netif.string_of_id ethif) local_port_id) in + return (Net.Manager.set_promiscuous mgr ethif (process_frame sw port)) + +let add_flow st fm = Switch.(Table.add_flow st st.table fm st.verbose) +let del_flow st m = + Switch.(Table.del_flow st.table m OP.Port.No_port st.controller st.verbose) + +let create_switch ?(verbose=false) dpid = Switch.( { ports = []; int_to_port = (Hashtbl.create 64); dev_to_port=(Hashtbl.create 64); - p_sflow = 0_l; controllers=[]; errornum = 0l; portnum=0; packet_queue; push_packet; - queue_len = 0; stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; - table = (Table.init_table ()); features=(Switch.switch_features ()); - packet_buffer=[]; packet_buffer_id=0l};) + controller=None; errornum = 0l; portnum=0; + stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; + table = (Table.init_table ()); features=(Switch.switch_features dpid); + packet_buffer=[]; last_echo_req=0.; echo_resp_received=true; + packet_buffer_id=0l;ready=(Lwt_condition.create ()); + verbose;}) let listen st mgr loc = - Channel.listen mgr (`TCPv4 (loc, (control_channel st))) <&> (data_plane st ()) + Net.Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> + (forward_thread st) <&> + (Ofswitch_config.listen_t mgr (add_port mgr st) + (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) let connect st mgr loc = - Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> (data_plane st ()) + Net.Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> + (forward_thread st) <&> + (Ofswitch_config.listen_t mgr (add_port mgr st) (del_port mgr st) (get_flow_stats st) + (add_flow st) (del_flow st) 6634) + +let local_connect st mgr conn = + let _ = st.Switch.controller <- (Some conn) in + (control_channel_run st conn) <&> + (forward_thread st) <&> + (Ofswitch_config.listen_t mgr (add_port mgr st) (del_port mgr st) (get_flow_stats st) + (add_flow st) (del_flow st) 6634) + +let standalone_connect st mgr loc = + let of_ctrl = Ofswitch_standalone.init_controller () in + let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (add_port mgr st) (del_port mgr st) + (get_flow_stats st) (add_flow st) (del_flow st) 6634) in + let _ = ignore_result (forward_thread st) in + let _ = cp "[switch] Listening socket...\n%!" in + while_lwt true do + let t,u = Lwt.task () in + ( + let _ = cp "[switch] Standalone controller taking over..." in + lwt conn = + Ofswitch_standalone.run_controller mgr of_ctrl in +(* let conn = OSK.init_local_conn_state switch_in switch_out in *) + let _ = st.Switch.controller <- (Some conn) in + lwt _ = Lwt.pick [(control_channel_run st conn); t] in + let _ = OSK.close conn in + return (cp "[switch] Standalone controller stopped..." ) + ) <&> ( + let rec connect_socket () = + let sock = ref None in + try_lwt + let _ = Printf.printf "trying to connect to controller\n%!" in + lwt _ = Lwt.pick + [(Net.Channel.connect mgr (`TCPv4(None,loc,(fun t -> return (sock:=Some(t)))))); + (OS.Time.sleep 10.0)] + in + match !sock with + | None -> connect_socket () + | Some t -> return t + with exn -> connect_socket () + in + lwt conn = connect_socket () >|= OSK.init_socket_conn_state in + let _ = wakeup u (st.Switch.controller <- (Some conn)) in + lwt _ = control_channel_run st conn in + let _ = OSK.close conn in + return (cp "[switch ]Remote controller connected...") + ) + done diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index b544fde..01db3cd 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -14,11 +14,47 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +open Net type t -val add_port : Net.Manager.t -> t -> Net.Manager.id -> unit -val create_switch : unit -> t -val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> - unit Lwt.t -val connect : t -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> - unit Lwt.t + +(** [create dpid] initializes the state for a switch with a datapth id dpid *) +val create_switch : ?verbose:bool -> int64 -> t + +(** Port Management *) + +(** [add_port mgr st intf] add port intf under the control of the switch st *) +val add_port : Manager.t -> ?use_mac:bool -> t -> Manager.id -> unit Lwt.t +(** [del_port mgr st intf] remove port intf from the control of the switch st *) +val del_port : Manager.t -> t -> string -> unit Lwt.t +(** [add_port_local mgr st intf] add port intf as the local loopback interface + * of th switch st *) +val add_port_local : Manager.t -> t -> Manager.id -> unit Lwt.t + +(** Switch state management *) + +(** [add_flow st fl] add flow definition fl to the switch st *) +val add_flow : t -> Openflow.Ofpacket.Flow_mod.t -> unit Lwt.t + +(** [del_flow st fl] remove all flows matching flow definition fl + * from the switch st *) +val del_flow : t -> Openflow.Ofpacket.Match.t -> unit Lwt.t + +(** [get_flow_stats st fl] fetch statistics for flows matching flow definition + * fl from the switch st *) +val get_flow_stats : t -> Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list + +(** Daemon run *) + +(** [listen st mgr addr] start a listening switch control channel on addr *) +val listen : t -> Manager.t -> Nettypes.ipv4_src -> unit Lwt.t +(** [connect st mgr addr] connect a switch control channel to a controller + * on addr *) +val connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t +(** [local_connect st mgr conn] setup a switch control channel on the local + * Open`flow socket conn *) +val local_connect : t -> Manager.t -> Openflow.Ofsocket.conn_state -> unit Lwt.t +(** [standalone_connect st mgr addr] same as connect method, but a local + * learning switch is responsible to control the switch, when the remote + * control channel is unresponsive *) +val standalone_connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml new file mode 100644 index 0000000..e1ba78b --- /dev/null +++ b/lib/ofswitch_config.ml @@ -0,0 +1,283 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Lwt +open Printf + +module OP = Openflow.Ofpacket + +let sp = Printf.sprintf +let cp = OS.Console.log + +let parse_actions actions = + let actions = Re_str.split (Re_str.regexp "/") actions in + let split_action = Re_str.regexp ":" in + List.fold_right ( + fun action actions -> + try + match (Re_str.split split_action action) with + | "output"::port::_ -> begin + match (OP.Port.port_of_string port) with + | Some port -> + actions @ [(OP.Flow.Output(port, 2000))] + | None -> + let _ = printf "[ofswitch-config] Invalid port %s\n%!" port in + actions + end + | "set_vlan_vid"::vif::_ -> + actions @ [(OP.Flow.Set_vlan_vid(int_of_string vif))] + | "set_vlan_pcp"::pcp::_ -> + actions @ [(OP.Flow.Set_vlan_pcp(int_of_string pcp))] + | "set_dl_src"::addr::_ -> begin + match (Macaddr.of_string addr) with + | None -> + let _ = cp (sp "[ofswitch-config] Invalid mac %s\n%!" action) in + actions + | Some addr -> actions @[(OP.Flow.Set_dl_src(addr))] + end + | "set_dl_dst"::addr::_ -> begin + match (Macaddr.of_string addr) with + | None -> + let _ = cp (sp "[ofswitch-config] Invalid mac %s\n%!" action) in + actions + | Some addr -> actions @[(OP.Flow.Set_dl_dst(addr))] + end + | "set_nw_src"::addr::_ -> begin + match (Ipaddr.V4.of_string addr) with + | None -> + let _ = cp (sp "[ofswitch-config] invalid ip %s\n%!" addr) in + actions + | Some ip -> actions @ [(OP.Flow.Set_nw_src(ip))] + end + | "set_nw_dst"::addr::_ -> begin + match (Ipaddr.V4.of_string addr) with + | None -> + let _ = cp (sp "[ofswitch-config] invalid ip %s\n%!" addr) in + actions + | Some ip -> actions @ [(OP.Flow.Set_nw_dst(ip))] + end + | "set_nw_tos"::tos::_ -> + actions @ [(OP.Flow.Set_nw_tos(char_of_int (int_of_string tos)))] + | "set_tp_src"::port::_ -> + actions @ [(OP.Flow.Set_tp_src(int_of_string port))] + | "set_tp_dst"::port::_ -> + actions @ [(OP.Flow.Set_tp_dst(int_of_string port))] + | _ -> + let _ = cp (sp "[ofswitch-config] invalid action %s" action) in + actions + with exn -> + let _ = cp (sp "[ofswitch-config] error parsing action %s\n%!" action) in + actions + ) actions [] + + +let hashtbl_to_flow_match t = + let of_match = OP.Match.wildcard () in + let map = + List.fold_right ( + fun (name, value) r -> + let _ = Hashtbl.add r name (Rpc.string_of_rpc value) in +(* let _ = printf "Adding %s = %s\n%!" name + (Rpc.string_of_rpc value) in *) + r + ) t (Hashtbl.create 10) in + let _ = + Hashtbl.iter ( + fun name value -> + match name with + | "in_port" -> begin + match (OP.Port.port_of_string value) with + | Some port -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.in_port <- + false in + let _ = of_match.OP.Match.in_port <- port in + () + | None -> + let _ = printf "[ofswitch-config] Invalid port %s\n%!" value in + () + end + | "dl_vlan" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan <- false in + let _ = of_match.OP.Match.dl_vlan <- int_of_string value in + () + | "dl_vlan_pcp" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan_pcp <- false in + let _ = of_match.OP.Match.dl_vlan_pcp <- char_of_int (int_of_string value) in + () + | "dl_src" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_src <- false in + let _ = + match (Macaddr.of_string value) with + | None -> printf "Invalid mac addr %s\n%!" value + | Some t -> of_match.OP.Match.dl_src <- t + in + () + | "dl_dst" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_dst <- false in + let _ = + match (Macaddr.of_string value) with + | None -> printf "Invalid mac addr %s\n%!" value + | Some t -> of_match.OP.Match.dl_dst <- t + in + () + | "dl_type" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_type <- false in + let _ = of_match.OP.Match.dl_type <- int_of_string value in + () + | "nw_src" -> begin + match (Re_str.split (Re_str.regexp "/") value) with + | ip::mask::_ -> begin + match (Ipaddr.V4.of_string ip) with + | None -> printf "Invalid ip definition" + | Some ip -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_src <- + char_of_int (int_of_string mask) in + let _ = of_match.OP.Match.nw_src <- ip in + () + end + | _ -> printf "Invalid ip definition" + end + | "nw_dst" -> begin + match (Re_str.split (Re_str.regexp "/") value) with + | ip::mask::_ -> begin + match (Ipaddr.V4.of_string ip) with + | None -> printf "Invalid ip definition" + | Some ip -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_dst <- + char_of_int (int_of_string mask) in + let _ = of_match.OP.Match.nw_dst <- ip + in + () + end + | _ -> printf "Invalid ip definition" + end + | "nw_tos" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_tos <- false in + let _ = of_match.OP.Match.nw_tos <- char_of_int (int_of_string + value) in + () + | "nw_proto" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_proto <- false in + let _ = of_match.OP.Match.nw_proto <- char_of_int (int_of_string + value) in + () + | "tp_src" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_src <- false in + let _ = of_match.OP.Match.tp_src <- int_of_string value in + () + | "tp_dst" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_dst <- false in + let _ = of_match.OP.Match.tp_dst <- int_of_string value in + () + | _ -> + let _ = eprintf "Invalid field name %s" name in + () + ) map in + of_match + +let get_ethif mgr id = + let lst = Net.Manager.get_intfs mgr in + let (_, ethif) = List.find (fun (dev_id,_) -> id = dev_id) lst in + ethif + +let listen_t mgr add_port del_port get_stats add_flow del_flow port = + let manage (dip,dpt) t = + try_lwt + lwt req = Net.Channel.read_line t in + let req = + List.fold_right ( + fun a r -> + r ^ (Cstruct.to_string a) + ) req "" in + let req = Jsonrpc.call_of_string req in + lwt success = + match (req.Rpc.name, req.Rpc.params) with + | ("add-port", (Rpc.String (devname))::_) -> begin + try_lwt +(* let (fd, name) = Tuntap.opentap ~persist:true ~devname () in + let id = OS.Netif.id_of_string name in + (* OS.Netif.add_vif id OS.Netif.ETH fd; *) + lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in *) + return (Rpc.Enum [(Rpc.String "true")]) + with exn -> + cp (sp "[ofswitch-confid] add-port: %s\n%!" (Printexc.to_string exn)); + return (Rpc.Enum [(Rpc.String "false")]) + + end + | ("del-port", (Rpc.String (dev))::_) -> + + (*let ethif = Net.Ethif.get_netif + (Net.Manager.get_ethif (get_ethif mgr (OS.Netif.id_of_string + dev))) in *) + (* lwt _ = OS.Netif.destroy ethif in *) + lwt _ = del_port dev in + return (Rpc.Enum [(Rpc.String "true")]) + | ("dump-flows", (Rpc.Dict t)::_) -> + let of_match = hashtbl_to_flow_match t in + let _ = cp (sp "Find rules matching %s\n%!" + (OP.Match.match_to_string of_match)) in + let flows = get_stats of_match in + let res = + List.fold_right ( + fun a r -> (Rpc.String (OP.Flow.string_of_flow_stat a))::r) flows [] in + return (Rpc.Enum res) + | ("add-flow", (Rpc.Dict t)::_) -> + let _ = cp (sp "adding flow %s\n%!" (Rpc.string_of_call req)) in + let fm = OP.Flow_mod.create (OP.Match.wildcard () ) 0L OP.Flow_mod.ADD [] () in + let map = + List.fold_right ( + fun (name, value) r -> + match name with + | "actions" -> + fm.OP.Flow_mod.actions <- parse_actions (Rpc.string_of_rpc value); + r + | "idle_timeout" -> + fm.OP.Flow_mod.idle_timeout <- (Rpc.int_of_rpc value); + r + | "hard_timeout" -> + fm.OP.Flow_mod.hard_timeout <- (Rpc.int_of_rpc value); + r + | "priority" -> + fm.OP.Flow_mod.priority <- (Rpc.int_of_rpc value); + r + | _ -> r @ [(name, value)] + ) t [] in + let _ = fm.OP.Flow_mod.of_match <- hashtbl_to_flow_match map in + let _ = cp (sp "Add flow %s\n%!" (OP.Flow_mod.flow_mod_to_string fm)) in + lwt _ = add_flow fm in + return (Rpc.Enum [(Rpc.String "true")] ) + | ("del-flow", (Rpc.Dict t)::_) -> + let of_match = hashtbl_to_flow_match t in + lwt _ = del_flow of_match in + return (Rpc.Enum [(Rpc.String "true")] ) + | (_, _) -> + let _ = printf "[ofswitch-config] invalid action %s\n%!" + (req.Rpc.name) in + return (Rpc.Enum [(Rpc.String "false")]) + in + let resp = + Jsonrpc.string_of_response (Rpc.success success) in + let _ = Net.Channel.write_line t resp in + lwt _ = Net.Channel.flush t in + lwt _ = Net.Channel.close t in + return () + with + | End_of_file -> return () + | exn -> + let _ = cp "[ofswitch_config] server error" in + return () + in + Net.Channel.listen mgr (`TCPv4 ((None, 6634), manage )) diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli new file mode 100644 index 0000000..733bed2 --- /dev/null +++ b/lib/ofswitch_config.mli @@ -0,0 +1,25 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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. + *) + + +(** initalize a switch configration daemon *) +val listen_t: Net.Manager.t -> + (Net.Manager.id -> unit Lwt.t) -> + (string -> unit Lwt.t) -> + (Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list) -> + (Openflow.Ofpacket.Flow_mod.t -> unit Lwt.t) -> + (Openflow.Ofpacket.Match.t -> unit Lwt.t) -> + int -> unit Lwt.t diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml new file mode 100644 index 0000000..1dd27ea --- /dev/null +++ b/lib/ofswitch_ctrl.ml @@ -0,0 +1,111 @@ +(* + * Copyright (c) 2011 Richard Mortier + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Lwt +open Printf +open Lwt_unix + +let check_cmd_args cmd count = + if ((Array.length Sys.argv) < (2 + count)) then + failwith (sprintf "Insufficient args for command %s (required %d)" + cmd count) + +let flow_element = + ["in_port"; "dl_src"; "dl_dst"; "dl_vlan"; "dl_pcp"; "dl_type"; + "nw_src";"nw_dst"; + "nw_tos"; "nw_proto"; "tp_src"; "tp_dst"; "actions";"priority"; + "idle_timeout"; "hard_timeout"; ] + +let process_flow_description flow = + let fields = Re_str.split (Re_str.regexp ",") flow in + let rec process_flow_inner = function + | [] -> [] + | hd::tl -> + let name::value::_ = Re_str.split (Re_str.regexp "=") hd in + let _ = + if (not (List.mem name flow_element) ) then + failwith (sprintf "Invalid flow field %s" name) + in + [(name, (Rpc.String value))] @ (process_flow_inner tl) + in + process_flow_inner fields + + + +let send_cmd (input, output) = + try_lwt + let _ = + if ((Array.length Sys.argv) < 2) then + failwith "No command defined" + in + lwt resp = + match (Sys.argv.(1)) with + | "add-port" -> + let _ = check_cmd_args Sys.argv.(1) 2 in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String Sys.argv.(3))];}) in + lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in + lwt resp = Lwt_io.read_line input in + let resp = Jsonrpc.response_of_string resp in + return (string_of_bool resp.Rpc.success) + | "del-port" -> + let _ = check_cmd_args Sys.argv.(1) 2 in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String + Sys.argv.(3))];}) in + lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in + lwt resp = Lwt_io.read_line input in + let resp = Jsonrpc.response_of_string resp in + return (string_of_bool resp.Rpc.success) + | "dump-flows" -> begin + let _ = check_cmd_args Sys.argv.(1) 2 in + let fields = process_flow_description Sys.argv.(3) in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.Dict fields)];}) in + lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in + lwt resp = Lwt_io.read_line input in + let resp = Jsonrpc.response_of_string resp in + match resp.Rpc.contents with + | Rpc.Enum flows -> + return + (List.fold_right + (fun a r -> sprintf "%s%s\n%!" r (Rpc.string_of_rpc a)) flows "") + | _ -> return "" + end + | "add-flow" -> begin + let _ = check_cmd_args Sys.argv.(1) 2 in + let fields = process_flow_description Sys.argv.(3) in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.Dict fields)];}) in + lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in + lwt resp = Lwt_io.read_line input in + let resp = Jsonrpc.response_of_string resp in + return (string_of_bool resp.Rpc.success) + end + | _ -> + return (sprintf "Fail: unknown cmd: %s\n%!" Sys.argv.(1)) + in + let _ = printf "result:\n%s\n%!" resp in + return () + with ex -> + return (printf "Fail: %s" (Printexc.to_string ex)) + +lwt _ = + try_lwt + let dst = ADDR_INET( (Unix.inet_addr_of_string "10.20.0.2"), + 6634) in + lwt _ = Lwt_io.with_connection dst (send_cmd) in + return () + with e -> + Printf.eprintf "Error: %s" (Printexc.to_string e); + return () diff --git a/lib/ofswitch_model.ml b/lib/ofswitch_model.ml new file mode 100644 index 0000000..ace2ae6 --- /dev/null +++ b/lib/ofswitch_model.ml @@ -0,0 +1,1133 @@ +(* + * Copyright (c) 2011 Richard Mortier + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Lwt + +open Ofswitch_config + +module OP = Openflow.Ofpacket +module OSK = Openflow.Ofsocket + +exception Packet_type_unknw + +let sp = Printf.sprintf +let pr = Printf.printf +let pp = Printf.printf +let ep = Printf.eprintf +let cp = OS.Console.log + +(* XXX should really stndardise these *) +type uint16 = OP.uint16 +type uint32 = OP.uint32 +type uint64 = OP.uint64 +type byte = OP.byte + +type port = uint16 +type cookie = uint64 + +type device = string (* XXX placeholder! *) + +let resolve t = Lwt.on_success t (fun _ -> ()) + +let get_new_buffer len = + let buf = OS.Io_page.to_cstruct (OS.Io_page.get 1) in + Cstruct.sub buf 0 len + +let get_intf mgr id = + let lst = Net.Manager.get_intfs mgr in + let (_, intf) = List.find (fun (dev_id,_) -> id = dev_id) lst in + intf + +type delay_model = { + flow_insert : float; + flow_update : float; + pktin_rate : float; + pktin_delay : float; + stats_delay : float; + pktout_delay: float; +} + +module Entry = struct + type table_counter = { + n_active: uint32; + n_lookups: uint64; + n_matches: uint64; + } + + type flow_counter = { + mutable n_packets: uint64; + mutable n_bytes: uint64; + flags : OP.Flow_mod.flags; + priority: uint16; + cookie: int64; + insert_sec: int; + insert_nsec: int; + mutable last_sec: int; + mutable last_nsec: int; + idle_timeout: int; + hard_timeout:int; + } + + type queue_counter = { + tx_queue_packets: uint64; + tx_queue_bytes: uint64; + tx_queue_overrun_errors: uint64; + } + + let init_flow_counters t = + let ts = int_of_float (OS.Clock.time ()) in + {n_packets=0L; n_bytes=0L; priority=t.OP.Flow_mod.priority; + cookie=t.OP.Flow_mod.cookie; insert_sec=ts; insert_nsec=0; + last_sec=ts;last_nsec=0; idle_timeout=t.OP.Flow_mod.idle_timeout; + hard_timeout=t.OP.Flow_mod.hard_timeout; flags=t.OP.Flow_mod.flags; } + + type t = { + counters: flow_counter; + actions: OP.Flow.action list; + mutable cache_entries: OP.Match.t list; + } + let update_flow pkt_len flow = + flow.counters.n_packets <- Int64.add flow.counters.n_packets 1L; + flow.counters.n_bytes <- Int64.add flow.counters.n_bytes pkt_len; + flow.counters.last_sec <- int_of_float (OS.Clock.time ()) + + + let flow_counters_to_flow_stats of_match table_id flow = + let priority = flow.counters.priority in + let idle_timeout=flow.counters.idle_timeout in + let hard_timeout=flow.counters.hard_timeout in + let cookie=flow.counters.cookie in + let packet_count=flow.counters.n_packets in + let byte_count=flow.counters.n_bytes in + let action=flow.actions in + OP.Flow.({table_id; of_match; + duration_sec = Int32.of_int (flow.counters.last_sec - + flow.counters.insert_sec); + duration_nsec = Int32.of_int (flow.counters.last_nsec - + flow.counters.insert_nsec); + priority; idle_timeout; hard_timeout; cookie; + packet_count; byte_count; action; }) + +end + +module Table = struct + type t = { + flow_add_queue: (OP.Match.t * (OP.Flow.action list -> unit Lwt.t) * Entry.t) Lwt_stream.t; + flow_add_push : ((OP.Match.t * (OP.Flow.action list -> unit Lwt.t) * Entry.t) option -> unit); + + flow_upd_queue: (OP.Match.t * (OP.Flow.action list -> unit Lwt.t) * Entry.t) Lwt_stream.t; + flow_upd_push : ((OP.Match.t * (OP.Flow.action list -> unit Lwt.t) * Entry.t) option -> unit); + + tid: cookie; + (* This entry stores wildcard and exact match entries as + * transmitted by the controller *) + mutable entries: (OP.Match.t, Entry.t) Hashtbl.t; + (* Intermediate table to store exact match flos deriving from wildcard + * entries *) + mutable cache : (OP.Match.t, Entry.t ref) Hashtbl.t; + stats : OP.Stats.table; + } + + let init_table () = + let open OP.Wildcards in + let (flow_add_queue, flow_add_push) = Lwt_stream.create () in + let (flow_upd_queue, flow_upd_push) = Lwt_stream.create () in + { tid = 0_L; flow_add_queue; flow_add_push; flow_upd_queue; flow_upd_push; + entries = (Hashtbl.create 10000); cache = (Hashtbl.create 10000); + stats = OP.Stats.( + {table_id=(table_id_of_int 1); name="main_tbl"; + wildcards=(exact_match ()); max_entries=1024l; active_count=0l; + lookup_count=0L; matched_count=0L});} + + let add_flow_nodelay table verbose m entry process_bid = + let open OP.Flow_mod in + let open OP.Match in + let _ = Hashtbl.replace table.entries m entry in + (* In the fast path table, I need to delete any conflicting entries *) + let _ = + Hashtbl.iter ( + fun a e -> + if ((flow_match_compare a m m.wildcards) && + Entry.(entry.counters.priority >= (!e).counters.priority)) then ( + let _ = (!e).Entry.cache_entries <- + List.filter (fun c -> a <> c) (!e).Entry.cache_entries in + let _ = Hashtbl.replace table.cache a (ref entry) in + entry.Entry.cache_entries <- a :: entry.Entry.cache_entries + ) + ) table.cache in + let _ = ignore_result (process_bid entry.Entry.actions) in +(* if (bid = -1l) then return () + else process_buffer_id st t msg h.xid bid entry.Entry.actions *) + + let _ = if (verbose) then + cp (sp "[switch] Adding flow %s" (OP.Match.match_to_string m)) + in + () + + + (* TODO fix flow_mod flag support. overlap is not considered *) + let add_flow table t verbose process_bid = + let open OP.Flow_mod in + let open OP.Match in + let _ = + (* max priority for exact match rules *) + if (t.of_match.wildcards=(OP.Wildcards.exact_match ())) then + t.priority <- 0x1001 + in + let entry = Entry.({actions=t.OP.Flow_mod.actions; + counters=(init_flow_counters t); cache_entries=[];}) in + if (Hashtbl.mem table.entries t.of_match) then + table.flow_upd_push (Some (t.of_match, process_bid, entry)) + else + table.flow_add_push (Some (t.of_match, process_bid, entry) ) + + (* TODO check if the details are correct e.g. IP type etc. *) + let add_flow_t st table delay verbose = + while_lwt true do + lwt (m, bid, entry) = Lwt_stream.next table.flow_add_queue in + lwt () = OS.Time.sleep delay in + let () = add_flow_nodelay table verbose m entry bid in + return () + done + let upd_flow_t table delay verbose = + while_lwt true do + lwt (m, bid, entry) = Lwt_stream.next table.flow_upd_queue in + lwt () = OS.Time.sleep delay in + let () = add_flow_nodelay table verbose m entry bid in + return () + done + + + (* check if a list of actions has an output action forwarding packets to + * out_port. + * Used when removing a port from the switch control in order to clean related + * flows *) + let rec is_output_port out_port = function + | [] -> false + | OP.Flow.Output(port, _)::_ when (port = out_port) -> true + | _ :: tail -> is_output_port out_port tail + + let del_flow table ?(xid=(Random.int32 Int32.max_int)) + ?(reason=OP.Flow_removed.DELETE) tuple out_port t verbose = + (* Delete all matching entries from the flow table*) + let remove_flow = + Hashtbl.fold ( + fun of_match flow ret -> + if ((OP.Match.flow_match_compare of_match tuple + tuple.OP.Match.wildcards) && + ((out_port = OP.Port.No_port) || + (is_output_port out_port flow.Entry.actions))) then ( + let _ = Hashtbl.remove table.entries of_match in + (of_match, flow)::ret + ) else ret + ) table.entries [] in + + (* Delete all entries from cache *) + let _ = + List.iter ( + fun (_, flow) -> + List.iter (Hashtbl.remove table.cache) flow.Entry.cache_entries + ) remove_flow in + + (* Check for notification flag in flow and send + * flow modification warnings *) + Lwt_list.iter_s ( + fun (of_match, flow) -> + let _ = + if verbose then + cp (sp "[switch] Removing flow %s" (OP.Match.match_to_string of_match)) + in + match(t, flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) with + | (Some t, true) -> + let duration_sec = (int_of_float (OS.Clock.time ())) - + flow.Entry.counters.Entry.insert_sec in + let fl_rm = OP.Flow_removed.( + {of_match; cookie=flow.Entry.counters.Entry.cookie; + priority=flow.Entry.counters.Entry.priority; + reason; duration_sec=(Int32.of_int duration_sec); duration_nsec=0l; + idle_timeout=flow.Entry.counters.Entry.idle_timeout; + packet_count=flow.Entry.counters.Entry.n_packets; + byte_count=flow.Entry.counters.Entry.n_bytes;}) in + let h = OP.Header.(create ~xid FLOW_REMOVED (OP.Flow_removed.get_len)) in + OSK.send_packet t (OP.Flow_removed (h,fl_rm)) + | _ -> return () + ) remove_flow + + (* table stat update methods *) + let update_table_found table = + let open OP.Stats in + table.stats.lookup_count <- Int64.succ table.stats.lookup_count; + table.stats.matched_count <- Int64.succ table.stats.matched_count + + let update_table_missed table = + let open OP.Stats in + table.stats.lookup_count <- Int64.succ table.stats.lookup_count + + (* monitor thread to timeout flows *) + let monitor_flow_timeout table t verbose = + let open Entry in + let check_flow_timeout table t verbose = + let ts = int_of_float (OS.Clock.time ()) in + let flows = Hashtbl.fold ( + fun of_match entry ret -> + let hard = ts - entry.counters.insert_sec in + let idle = ts - entry.counters.last_sec in + match (hard, idle) with + | (l, _) when ((entry.counters.hard_timeout > 0) && + (l >= entry.counters.hard_timeout)) -> + (of_match, entry, OP.Flow_removed.HARD_TIMEOUT )::ret + | (_, l) when ((entry.counters.idle_timeout > 0) && + (l >= entry.counters.idle_timeout)) -> + ret @ [(of_match, entry, OP.Flow_removed.IDLE_TIMEOUT )] + | _ -> ret + ) table.entries [] in + Lwt_list.iter_s ( + fun (of_match, entry, reason) -> + del_flow table ~reason of_match OP.Port.No_port t verbose + ) flows + in + while_lwt true do + lwt _ = OS.Time.sleep 1.0 in + check_flow_timeout table t verbose + done +end + +module Switch = struct + type port = { + port_id: int; + ethif: Net.Manager.id; + netif: OS.Netif.t; + counter: OP.Port.stats; + phy: OP.Port.phy; + in_queue: Cstruct.t Lwt_stream.t; + in_push : (Cstruct.t option -> unit); + out_queue: Cstruct.t Lwt_stream.t; + out_push : (Cstruct.t option -> unit); + mutable pkt_count : int; + } + + let init_port mgr port_no id = + let ethif = Net.Manager.get_ethif ( get_intf mgr id ) in + let netif = Net.Ethif.get_netif ethif in + let hw_addr = Net.Ethif.mac ethif in + let (in_queue, in_push) = Lwt_stream.create () in + let (out_queue, out_push) = Lwt_stream.create () in + let counter = OP.Port.( + { port_id=port_no; rx_packets=0L; tx_packets=0L; rx_bytes=0L; + tx_bytes=0L; rx_dropped=0L; tx_dropped=0L; rx_errors=0L; + tx_errors=0L; rx_frame_err=0L; rx_over_err=0L; rx_crc_err=0L; + collisions=0L;}) in + + let features = OP.Port.( + {pause_asym=true; pause=true; autoneg=true; fiber=true; + copper=true; f_10GB_FD=true; f_1GB_FD=true; f_1GB_HD=true; + f_100MB_FD=true; f_100MB_HD=true; f_10MB_FD=true; + f_10MB_HD=true;}) in + let port_config = OP.Port.( + { port_down=false; no_stp=false; no_recv=false; + no_recv_stp=false; no_flood=false; no_fwd=false; + no_packet_in=false;}) in + let port_state = OP.Port.( + {link_down =false; stp_listen =false; stp_learn =false; + stp_forward =false; stp_block =false;}) in + let phy = OP.Port.( + {port_no; hw_addr;name=(OS.Netif.string_of_id id); config= port_config; + state= port_state; curr=features; advertised=features; + supported=features; peer=features;}) in + + {port_id=port_no; counter; + ethif=id;netif;phy;in_queue;in_push;pkt_count=0; + out_queue;out_push;} + + type stats = { + mutable n_frags: uint64; + mutable n_hits: uint64; + mutable n_missed: uint64; + mutable n_lost: uint64; + } + + type lookup_ret = + Found of Entry.t ref + | NOT_FOUND + + type t = { + (* Mapping port ids to port numbers *) + ports: (int, port) Hashtbl.t; + mutable controller: OSK.conn_state option; + mutable last_echo_req : float; + mutable echo_resp_received : bool; + model : delay_model; + table: Table.t; + stats: stats; + mutable errornum : uint32; + mutable portnum : int; + features : OP.Switch.features; + mutable packet_buffer: OP.Packet_in.t list; + mutable packet_buffer_id: int32; + ready : unit Lwt_condition.t ; + verbose : bool; + + pktin_queue: OP.t Lwt_stream.t; + pktin_push : OP.t option -> unit; + + pktout_queue: (Cstruct.t * int) Lwt_stream.t; + pktout_push : (Cstruct.t * int) option -> unit; + + stats_queue: (Cstruct.t * int) Lwt_stream.t; + stats_push : (Cstruct.t * int) option -> unit; + } + + let supported_actions () = + OP.Switch.({ output=true; set_vlan_id=true; set_vlan_pcp=true; strip_vlan=true; + set_dl_src=true; set_dl_dst=true; set_nw_src=true; set_nw_dst=true; + set_nw_tos=true; set_tp_src=true; set_tp_dst=true; enqueue=false;vendor=true; }) + let supported_capabilities () = + OP.Switch.({flow_stats=true;table_stats=true;port_stats=true;stp=true; + ip_reasm=false;queue_stats=false;arp_match_ip=true;}) + let switch_features datapath_id = + OP.Switch.({datapath_id; n_buffers=0l; n_tables=(char_of_int 1); ports=[]; + capabilities=(supported_capabilities ()); actions=(supported_actions ()); }) + + + let update_port_tx_stats pkt_len port = + OP.Port.(port.counter.tx_packets <- Int64.add port.counter.tx_packets 1L); + OP.Port.(port.counter.tx_bytes <- Int64.add port.counter.tx_bytes pkt_len) + + let update_port_rx_stats pkt_len port = + OP.Port.(port.counter.rx_packets <- Int64.add port.counter.rx_packets 1L); + OP.Port.(port.counter.rx_bytes <- Int64.add port.counter.rx_bytes pkt_len) + + cstruct dl_header { + uint8_t dl_dst[6]; + uint8_t dl_src[6]; + uint16_t dl_type + } as big_endian + + cstruct arphdr { + uint16_t ar_hrd; + uint16_t ar_pro; + uint8_t ar_hln; + uint8_t ar_pln; + uint16_t ar_op; + uint8_t ar_sha[6]; + uint32_t nw_src; + uint8_t ar_tha[6]; + uint32_t nw_dst + } as big_endian + + cstruct nw_header { + uint8_t hlen_version; + uint8_t nw_tos; + uint16_t total_len; + uint8_t pad[5]; + uint8_t nw_proto; + uint16_t csum; + uint32_t nw_src; + uint32_t nw_dst + } as big_endian + + cstruct tp_header { + uint16_t tp_src; + uint16_t tp_dst + } as big_endian + + cstruct icmphdr { + uint8_t typ; + uint8_t code; + uint16_t checksum + } as big_endian + + cstruct tcpv4 { + uint16_t src_port; + uint16_t dst_port; + uint32_t sequence; + uint32_t ack_number; + uint32_t dataoff_flags_window; + uint16_t checksum + } as big_endian + + cstruct pseudo_header { + uint32_t src; + uint32_t dst; + uint8_t res; + uint8_t proto; + uint16_t len + } as big_endian + + let tcp_checksum ~src ~dst = + let pbuf = Cstruct.sub (Cstruct.of_bigarray (OS.Io_page.get 1)) 0 sizeof_pseudo_header in + fun data -> + set_pseudo_header_src pbuf (Ipaddr.V4.to_int32 src); + set_pseudo_header_dst pbuf (Ipaddr.V4.to_int32 dst); + set_pseudo_header_res pbuf 0; + set_pseudo_header_proto pbuf 6; + set_pseudo_header_len pbuf (Cstruct.lenv data); + Net.Checksum.ones_complement_list (pbuf::data) + + let send_packet port bits = + update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; +(* return (port.out_push (Some bits)) *) + Lwt.ignore_result (OS.Netif.write port.netif bits) +(* Net.Manager.inject_packet port.mgr port.ethif bits *) + + let process_pktin_nodelay st pkt = + match st.controller with + | None ->(* return *)() + | Some conn -> Lwt.ignore_result (OSK.send_packet conn pkt) + + + let process_pktin st pkt = + if (st.model.pktin_delay > 0.) then + (st.pktin_push (Some pkt) ) + else + process_pktin_nodelay st pkt + + let pktin_t st delay rate = + let start_ts = ref 0.0 in +(* let (fraction, _) = modf !start_ts in *) + let counter = ref 0.0 in + while_lwt true do + lwt pktin = Lwt_stream.next st.pktin_queue in + let now = OS.Clock.time () in + let () = + if ((!start_ts +. 1.0) < now) then + let _ = counter := 0. in + start_ts := (floor now) + in + if ((rate = 0.) || (!counter <= rate)) then + lwt () = OS.Time.sleep delay in + counter := !counter +. 1.; + return (process_pktin_nodelay st pktin) + else + let _ = Printf.printf "%f: counter = %f, start_ts %f dropping packet\n%!" + now !counter !start_ts in + return () + done + + let forward_frame st in_port bits pkt_size checksum port = + let _ = + if ((checksum) && ((get_dl_header_dl_type bits) = 0x800)) then + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let _ = set_nw_header_csum ip_data 0 in + let csm = Net.Checksum.ones_complement (Cstruct.sub ip_data 0 (len*4)) in + let _ = set_nw_header_csum ip_data csm in + let _ = + match (get_nw_header_nw_proto ip_data) with + | 6 (* TCP *) -> + let src = Ipaddr.V4.of_int32 (get_nw_header_nw_src + ip_data) in + let dst = Ipaddr.V4.of_int32 (get_nw_header_nw_dst + ip_data) in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tcpv4_checksum tp_data 0 in + let csm = tcp_checksum ~src ~dst [tp_data] in + set_tcpv4_checksum tp_data csm + | 17 (* UDP *) -> () + | _ -> () + in + () + in + match port with + | OP.Port.Port(port) -> + if Hashtbl.mem st.ports port then + let out_p = (Hashtbl.find st.ports port) in + send_packet out_p bits +(* Net.Manager.inject_packet out_p.mgr out_p.ethif bits *) + else + (* return *)(cp (sp "[switch] forward_frame: Port %d not registered\n%!" port)) + | OP.Port.No_port ->(* return *)() + | OP.Port.Flood + |OP.Port.All -> + let inp = OP.Port.int_of_port in_port in + (*Lwt_l*)List.iter + (fun port -> send_packet port bits) + (Hashtbl.fold (fun ix p r -> + if(ix != inp) then p::r else r) st.ports []) + | OP.Port.In_port -> + let port = (OP.Port.int_of_port in_port) in + if Hashtbl.mem st.ports port then + send_packet (Hashtbl.find st.ports port) bits + else + (* return *)(cp (sp "[switch] forward_frame: Port %d unregistered\n%!" port)) + | OP.Port.Local -> + let local = OP.Port.int_of_port OP.Port.Local in + if Hashtbl.mem st.ports local then + send_packet (Hashtbl.find st.ports local) bits + else + (* return *)(cp (sp "[switch] forward_frame: Port %d unregistered \n%!" local)) + | OP.Port.Controller -> begin + let size = + if (Cstruct.len bits > pkt_size) then + pkt_size + else + Cstruct.len bits + in + let (h, pkt_in) = + OP.Packet_in.(create_pkt_in ~buffer_id:(-1l) ~in_port + ~reason:ACTION ~data:(Cstruct.sub bits 0 size)) in + process_pktin st (OP.Packet_in (h, pkt_in)) + end + (* | Table + * | Normal *) + | _ -> + (* return *)(cp (sp "[switch] forward_frame: unsupported output port\n")) + + (* Assumwe that action are valid. I will not get a flow that sets an ip + * address unless it defines that the ethType is ip. Need to enforce + * these rule in the parsing process of the flow_mod packets *) + let apply_of_actions st in_port bits actions = + let apply_of_actions_inner st in_port bits checksum action = + try (*_lwt *) + match action with + | OP.Flow.Output (port, pkt_size) -> + (* Make a packet copy in case the buffer is modified and multiple + * outputs are defined? *) + let _ = forward_frame st in_port bits pkt_size checksum port in + (* return *)false + | OP.Flow.Set_dl_src(eaddr) -> + let _ = set_dl_header_dl_src (Macaddr.to_bytes eaddr) 0 bits in + (* return *)checksum + | OP.Flow.Set_dl_dst(eaddr) -> + let _ = set_dl_header_dl_dst (Macaddr.to_bytes eaddr) 0 bits in + (* return *)checksum + (* TODO: Add for this actions to check when inserted if + * the flow is an ip flow *) + | OP.Flow.Set_nw_tos(tos) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_tos ip_data (int_of_char tos) in + (* return *)true + (* TODO: wHAT ABOUT ARP? + * *) + | OP.Flow.Set_nw_src(ip) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_src ip_data (Ipaddr.V4.to_int32 ip) in + (* return *)true + | OP.Flow.Set_nw_dst(ip) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_dst ip_data (Ipaddr.V4.to_int32 ip) in + (* return *)true + | OP.Flow.Set_tp_src(port) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tp_header_tp_src tp_data port in + (* return *)true + | OP.Flow.Set_tp_dst(port) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tp_header_tp_dst tp_data port in + (* return *)true + (* | OP.Flow.Enqueue(_, _) + | OP.Flow.Set_vlan_pcp _ + | OP.Flow.Set_vlan_vid _ + | OP.Flow.VENDOR_ACT + | OP.Flow.STRIP_VLAN *) + | act -> + let _ = cp (sp "[switch] apply_of_actions: Unsupported action %s" + (OP.Flow.string_of_action act)) in + (* return *)checksum + with exn -> + let _ = cp(sp "[switch] apply_of_actions: (packet size %d) %s %s\n%!" + (Cstruct.len bits) (OP.Flow.string_of_action action) + (Printexc.to_string exn )) in + (* return *)checksum + in + let rec apply_of_actions_rec st in_port bits checksum = function + | [] ->(* return *)false + | head :: actions -> + let checksum = apply_of_actions_inner st in_port bits checksum head in + apply_of_actions_rec st in_port bits checksum actions + in + let _ = apply_of_actions_rec st in_port bits false actions in () + + let lookup_flow st of_match = + (* Check first the match table cache + * NOTE an exact match flow will be found on this step and thus + * return a result immediately, without needing to get to the cache table + * and consider flow priorities *) + let open Table in + let open OP.Match in + if (Hashtbl.mem st.table.cache of_match ) then + let entry = (Hashtbl.find st.table.cache of_match) in + Found(entry) + else begin + (* Check the wilcard card table *) + let lookup_flow flow entry r = + match (r, (flow_match_compare of_match flow flow.wildcards)) with + | (_, false) -> r + | (None, true) -> Some(flow, entry) + | (Some(f,e), true) when (Entry.(e.counters.priority > entry.counters.priority)) -> r + | (Some(f,e), true) when (Entry.(e.counters.priority <= entry.counters.priority)) -> + Some(flow, entry) + | (_, _) -> r + in + let flow_match = Hashtbl.fold lookup_flow st.table.entries None in + match (flow_match) with + | None -> NOT_FOUND + | Some(f,e) -> + Hashtbl.add st.table.cache of_match (ref e); + Entry.(e.cache_entries <- of_match :: e.cache_entries); + Found(ref e) + end +end + +type t = Switch.t + +(********************************************* + * Switch OpenFlow data plane + *********************************************) +let process_frame_inner st p frame = + let open Switch in + let open OP.Packet_in in + try + let in_port = (OP.Port.port_of_int p.Switch.port_id) in + let tupple = (OP.Match.raw_packet_to_match in_port frame ) in + (* Update port rx statistics *) + let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in + + (* Lookup packet flow to existing flows in table *) + match (Switch.lookup_flow st tupple) with + | Switch.NOT_FOUND -> begin + Table.update_table_missed st.table; + let buffer_id = st.packet_buffer_id in + (*TODO Move this code in the Switch module *) + st.packet_buffer_id <- Int32.succ st.packet_buffer_id; + let (h, pkt_in) = create_pkt_in ~buffer_id ~in_port ~reason:NO_MATCH ~data:frame in + st.packet_buffer <- pkt_in::st.packet_buffer; + + (* Disable for now packet trimming for buffered packets *) + let size = + if (Cstruct.len frame > 92) then 92 + else Cstruct.len frame in + let (h, pkt_in) = create_pkt_in ~buffer_id ~in_port ~reason:NO_MATCH + ~data:(Cstruct.sub frame 0 size) in + process_pktin st (OP.Packet_in(h,pkt_in)) +(* return ( *) +(* ( match st.Switch.controller with + | None -> () + | Some conn -> ignore_result (OSK.send_packet conn (OP.Packet_in(h,pkt_in))) + ) + *) + end + (* generate a packet in event *) + | Switch.Found(entry) -> + let _ = Table.update_table_found st.table in + let _ = Entry.update_flow (Int64.of_int (Cstruct.len frame)) !entry in + apply_of_actions st tupple.OP.Match.in_port frame (!entry).Entry.actions + with exn -> + (* return *) (cp (sp "[switch] process_frame_inner: control channel error: %s\n" + (Printexc.to_string exn))) + +let forward_thread st = + Lwt_list.iter_p (fun p -> + while_lwt true do + lwt pkt = Lwt_stream.next p.Switch.in_queue in + let _ = process_frame_inner st p pkt in + return (p.Switch.pkt_count <- p.Switch.pkt_count - 1) + done <&> ( + while_lwt true do + lwt frame = Lwt_stream.next p.Switch.out_queue in + OS.Netif.writev p.Switch.netif [frame] (*frame::frames*) + done + ) + ) (Hashtbl.fold (fun _ p c -> p::c) st.Switch.ports []) + +let process_frame st p _ frame = + let _ = + try + match frame with + | Net.Ethif.Output _ -> () + | Net.Ethif.Input frame -> process_frame_inner st p frame + with + | Not_found -> cp (sp "[switch] process_frame: Invalid port\n%!") + | Packet_type_unknw -> cp (sp "[switch] process_frame: malformed packet\n%!") + | exn -> cp (sp "[switch] process_frame: switch error: %s\n%!" (Printexc.to_string exn)) + in + return () + +(************************************************* + * Switch OpenFlow control channel + *************************************************) +let get_flow_stats st of_match = + let open OP.Match in + let match_flows of_match key value ret = + if (flow_match_compare key of_match of_match.wildcards) then ( + (Entry.flow_counters_to_flow_stats key (char_of_int 1) value)::ret + ) else + ret + in + Hashtbl.fold (fun key value r -> match_flows of_match key value r) + st.Switch.table.Table.entries [] + +let process_buffer_id st t msg xid buffer_id actions = + let open OP.Header in + let pkt_in = ref None in + let _ = + st.Switch.packet_buffer <- + List.filter ( fun a -> + if (a.OP.Packet_in.buffer_id = buffer_id) then + (pkt_in := Some(a); false ) + else true ) st.Switch.packet_buffer in + match (!pkt_in) with + | None -> + cp (sp "[switch] invalid buffer id %ld\n%!" buffer_id); + let bits = OP.marshal msg in + let h = create ~xid ERROR (get_len + 4 + (Cstruct.len bits)) in + OSK.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) + | Some(pkt_in) -> + return (OP.Packet_in.(Switch.apply_of_actions st pkt_in.in_port pkt_in.data + actions)) + +let process_openflow st t msg = + let open OP.Header in + let _ = if st.Switch.verbose then cp (sp "[switch] %s\n%!" (OP.to_string msg)) in + match msg with + | OP.Hello (h) -> return () + | OP.Echo_resp h -> return (st.Switch.echo_resp_received <- true) + | OP.Echo_req h -> (* Reply to ECHO requests *) + OSK.send_packet t (OP.Echo_req (create ~xid:h.xid ECHO_RESP sizeof_ofp_header)) + | OP.Features_req (h) -> + let h = create ~xid:(h.xid) FEATURES_RESP (OP.Switch.get_len st.Switch.features) in + OSK.send_packet t (OP.Features_resp (h, st.Switch.features)) + | OP.Stats_req(h, req) -> begin + let xid = h.xid in + match req with + | OP.Stats.Desc_req(req) -> + let p = OP.Stats.( + Desc_resp({st_ty=DESC; more=false;}, + {imfr_desc="Mirage"; hw_desc="Mirage"; + sw_desc="Mirage";serial_num="0.1";dp_desc="Mirage";})) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len p) in + OSK.send_packet t (OP.Stats_resp (h, p)) + | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> + (*TODO Need to consider the table_id and the out_port and + * split reply over multiple openflow packets if they don't + * fit a single packet. *) + let flows = get_flow_stats st of_match in + let stats = OP.Stats.({st_ty=FLOW; more=true;}) in + lwt (_, flows) = + Lwt_list. fold_right_s ( + fun fl (sz, flows) -> + let fl_sz = OP.Flow.flow_stats_len fl in + if (sz + fl_sz > 0xffff) then + let r = OP.Stats.Flow_resp(stats, flows) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + lwt _ = OSK.send_packet t (OP.Stats_resp (h, r)) in + return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) + else + return ((sz + fl_sz), (fl::flows)) ) + flows ((OP.Header.get_len + OP.Stats.get_resp_hdr_size), []) in + let stats = OP.Stats.({st_ty=FLOW; more=false;}) in + let r = OP.Stats.Flow_resp(stats, flows) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> + let match_flows_aggr of_match key value (fl_b, fl_p, fl)= + let open OP.Match in + let open Entry in + if (flow_match_compare key of_match of_match.wildcards) then + ((Int64.add fl_b value.counters.n_bytes), (Int64.add fl_p + value.counters.n_packets), (Int32.succ fl)) + else (fl_b, fl_p, fl) in + let (byte_count, packet_count,flow_count) = + Hashtbl.fold (match_flows_aggr of_match) + st.Switch.table.Table.entries (0L, 0L, 0l) in + let stats = OP.Stats.({st_ty=AGGREGATE; more=false;}) in + let r = OP.Stats.Aggregate_resp(stats, + OP.Stats.({byte_count;packet_count;flow_count;})) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Table_req(req) -> + let stats = OP.Stats.({st_ty=TABLE; more=false;}) in + let r = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Port_req(req_h, port) -> begin + match port with + | OP.Port.No_port -> + let port_stats = Hashtbl.fold (fun ix p r -> p.Switch.counter::r) + st.Switch.ports [] in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in + let r = OP.Stats.Port_resp(stats, port_stats) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Port.Port(port_id) -> begin + try_lwt + let port = Hashtbl.find st.Switch.ports port_id in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in + let r = OP.Stats.Port_resp(stats, [port.Switch.counter]) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + with Not_found -> + (* TODO reply with right error code *) + cp (sp "[switch] unregistered port %s\n%!"(OP.Port.string_of_port port)); + let h = create ~xid ERROR (OP.Header.get_len + 4) in + OSK.send_packet t (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) + end + | _ -> + cp "[switch] unsupported stats request\n%!"; + let h = create ~xid ERROR (get_len + 4) in + OSK.send_packet t OP.(Error (h, ACTION_BAD_OUT_PORT, (marshal msg))) + end + | _ -> begin + let h = create ~xid ERROR (get_len + 4) in + OSK.send_packet t (OP.Error (h, OP.REQUEST_BAD_SUBTYPE, (get_new_buffer 0))) + end + end + | OP.Get_config_req(h) -> + let resp = OP.Switch.init_switch_config in + let h = create ~xid:h.xid GET_CONFIG_RESP OP.Switch.config_get_len in + OSK.send_packet t (OP.Get_config_resp(h, resp)) + | OP.Barrier_req(h) -> + OSK.send_packet t (OP.Barrier_resp(create ~xid:h.xid BARRIER_RESP sizeof_ofp_header)) + + | OP.Packet_out(h, pkt) -> + let open OP.Packet_out in + if (pkt.buffer_id = -1l) then + return (Switch.apply_of_actions st pkt.in_port pkt.data pkt.actions) + else begin + process_buffer_id st t msg h.xid pkt.buffer_id pkt.actions + end + | OP.Flow_mod(h,fm) -> + let open OP.Flow_mod in + lwt _ = + match (fm.command) with + | ADD + | MODIFY + | MODIFY_STRICT -> + let process_bid st t msg xid bid actions = + if (bid = -1l) then + return () + else + process_buffer_id st t msg xid bid actions + in + if (st.Switch.model.flow_insert > 0.) then + return (Table.add_flow st.Switch.table fm st.Switch.verbose + (process_bid st t msg h.xid fm.buffer_id) ) + else + let entry = + Entry.({actions=fm.OP.Flow_mod.actions; + counters=(init_flow_counters fm); cache_entries=[];}) in + return (Table.add_flow_nodelay st.Switch.table st.Switch.verbose + fm.OP.Flow_mod.of_match entry + (process_bid st t msg h.xid fm.buffer_id) ) + | DELETE + | DELETE_STRICT -> + (* Need to implemente strict deletion in order to enable signpost + * switching *) + Table.del_flow st.Switch.table fm.of_match fm.out_port (Some t) st.Switch.verbose + in + return () + | OP.Queue_get_config_resp (h, _, _) + | OP.Queue_get_config_req (h, _) + | OP.Barrier_resp h + | OP.Stats_resp (h, _) + | OP.Port_mod (h, _) + | OP.Port_status (h, _) + | OP.Flow_removed (h, _) + | OP.Packet_in (h, _) + | OP.Set_config (h, _) + | OP.Get_config_resp (h, _) + | OP.Features_resp (h, _) + | OP.Vendor (h, _) + | OP.Error (h, _, _) -> + let bits = OP.marshal msg in + let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR + (OP.Header.get_len + 4 + (Cstruct.len bits)) in + OSK.send_packet t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits)) + +let monitor_control_channel st conn = + let is_active = ref true in + while_lwt !is_active do + let _ = st.Switch.echo_resp_received <- false in + let _ = st.Switch.last_echo_req <- (OS.Clock.time ()) in + lwt _ = OSK.send_packet conn + OP.(Echo_req Header.(create ECHO_REQ sizeof_ofp_header)) in + lwt _ = OS.Time.sleep 10.0 in + return (is_active := st.Switch.echo_resp_received) + done + +let control_channel_run st conn = + (* Trigger the dance between the 2 nodes *) + let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in + lwt _ = OSK.send_packet conn (OP.Hello(h)) in + let rec echo () = + try_lwt + OSK.read_packet conn >>= process_openflow st conn >>= echo + with + | Net.Nettypes.Closed -> + return (cp "[switch] ERROR:Controller channel closed....\n%!") + | OP.Unparsed (m, bs) -> + cp (sp "[switch] ERROR:unparsed! m=%s\n %!" m); echo () + | exn -> + cp (sp "[switch] ERROR:%s\n%!" (Printexc.to_string exn)); echo () + in + lwt _ = + echo () + Switch.(Table.monitor_flow_timeout st.table (Some conn) st.verbose) + (monitor_control_channel st conn) + in + let _ = OSK.close conn in + let _ = st.Switch.controller <- None in + return (cp "[switch] control channel thread returned") + +let control_channel st (addr, port) t = + cp (sp "[switch] controller %s:%d" (Ipaddr.V4.to_string addr) port); + let conn = OSK.init_socket_conn_state t in + let _ = st.Switch.controller <- (Some conn) in + control_channel_run st conn + +(* + * Interaface with external applications + * *) +let get_port_name mgr id = + let ethif = Net.Manager.get_ethif (get_intf mgr id) in + OS.Netif.string_of_id (OS.Netif.id (Net.Ethif.get_netif ethif)) + +let add_port mgr ?(use_mac=false) sw id = + sw.Switch.portnum <- sw.Switch.portnum + 1; + let ethif = Net.Manager.get_ethif (get_intf mgr id) in + let hw_addr = Macaddr.to_string (Net.Ethif.mac ethif) in + let _ = OS.Console.log (sp "[switch] Adding port %d (%s) '%s' \n %!" + sw.Switch.portnum (OS.Netif.string_of_id id) hw_addr) in + let port = Switch.init_port mgr sw.Switch.portnum id in + Hashtbl.add sw.Switch.ports sw.Switch.portnum port; + sw.Switch.features.OP.Switch.ports <- + sw.Switch.features.OP.Switch.ports @ [port.Switch.phy]; + let _ = Net.Manager.set_promiscuous mgr id (process_frame sw port) in + let h,p = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in + match sw.Switch.controller with + | None -> return () + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) + +let del_port mgr sw name = + try_lwt + let open Switch in + let ix = Hashtbl.fold (fun ix p r -> + if (OS.Netif.string_of_id p.ethif = name) then ix else r) sw.ports 0 in + let port = Hashtbl.find sw.ports ix in + let _ = + Hashtbl.remove sw.ports ix in + let h,p = OP.Port.create_port_status OP.Port.DEL port.phy in + let of_match = OP.Match.create_flow_match (OP.Wildcards.full_wildcard ()) () in + lwt _ = Table.del_flow sw.table of_match + (OP.Port.port_of_int port.port_id) sw.controller sw.verbose in + let of_match = OP.Match.create_flow_match (OP.Wildcards.in_port_match ()) + ~in_port:(port.Switch.port_id) () in + lwt _ = Table.del_flow sw.table of_match + OP.Port.No_port sw.controller sw.verbose in + let _ = cp (sp "[switch] Removing port %s (port_id=%d)" name port.port_id) in + match sw.controller with + | None -> return () + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) + with exn -> + return (cp (sp "[switch] del_port: port %s not found\n%!" name)) + +let add_port_local mgr sw ethif = + (*TODO Find first if a port is already registered as port 0 + * as port 0 and disable it *) +let open Switch in + let local_port_id = OP.Port.int_of_port OP.Port.Local in + let port = init_port mgr local_port_id ethif in + Hashtbl.replace sw.ports local_port_id port; + (*TODO Need to filter out any 0 port *) + sw.features.OP.Switch.ports <- + port.phy :: + (List.filter (fun a -> (a.OP.Port.port_no <> local_port_id)) + sw.Switch.features.OP.Switch.ports ); + let _ = cp (sp "[switch] Adding port %s (port_id=%d)" + (OS.Netif.string_of_id ethif) local_port_id) in + return (Net.Manager.set_promiscuous mgr ethif (process_frame sw port)) + +let create_switch ?(verbose=false) dpid model = + let open Switch in + let (pktin_queue, pktin_push) = Lwt_stream.create () in + let (stats_queue, stats_push) = Lwt_stream.create () in + let (pktout_queue, pktout_push) = Lwt_stream.create () in + let st = Switch.( + { ports = (Hashtbl.create 64); + controller=None; errornum = 0l; portnum=0; model; + stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; + table = (Table.init_table ()); features=(Switch.switch_features dpid); + packet_buffer=[]; last_echo_req=0.; echo_resp_received=true; + packet_buffer_id=0l;ready=(Lwt_condition.create ()); + verbose;pktin_queue; + pktin_push;pktout_queue;pktout_push;stats_queue;stats_push;}) in + let _ = + if (st.model.flow_insert > 0.) then + let _ = ignore_result (Table.add_flow_t st st.Switch.table + st.Switch.model.flow_insert st.Switch.verbose) in + ignore_result (Table.upd_flow_t st.Switch.table st.Switch.model.flow_update + st.Switch.verbose) + in + let _ = + if (st.Switch.model.pktin_delay > 0.) || (st.Switch.model.pktin_rate > 0.) then + ignore_result (Switch.pktin_t st st.Switch.model.pktin_delay + st.Switch.model.pktin_rate) + in + st + +let listen st mgr loc = + Net.Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> + (forward_thread st) + +let connect st mgr loc = + Net.Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> + (forward_thread st) + +let local_connect st mgr conn = + let _ = st.Switch.controller <- (Some conn) in + (control_channel_run st conn) <&> + (forward_thread st) + +let standalone_connect st mgr loc = + let of_ctrl = Ofswitch_standalone.init_controller () in + (* let _ = ignore_result (forward_thread st) in *) + let _ = cp "[switch] Listening socket...\n%!" in + while_lwt true do + let t,u = Lwt.task () in + ( + let _ = cp "[switch] Standalone controller taking over..." in + lwt conn = + Ofswitch_standalone.run_controller mgr of_ctrl in +(* let conn = OSK.init_local_conn_state switch_in switch_out in *) + let _ = st.Switch.controller <- (Some conn) in + lwt _ = Lwt.pick [(control_channel_run st conn); t] in + let _ = OSK.close conn in + return (cp "[switch] Standalone controller stopped..." ) + ) <&> ( + let rec connect_socket () = + let sock = ref None in + try_lwt + lwt _ = Lwt.pick + [(Net.Channel.connect mgr (`TCPv4(None,loc,(fun t -> return (sock:=Some(t)))))); + (OS.Time.sleep 10.0)] + in + match !sock with + | None -> connect_socket () + | Some t -> return t + with exn -> connect_socket () + in + lwt conn = connect_socket () >|= OSK.init_socket_conn_state in + let _ = wakeup u (st.Switch.controller <- (Some conn)) in + lwt _ = control_channel_run st conn in + let _ = OSK.close conn in + return (cp "[switch ]Remote controller connected...") + ) + done diff --git a/lib/ofswitch_model.mli b/lib/ofswitch_model.mli new file mode 100644 index 0000000..09174df --- /dev/null +++ b/lib/ofswitch_model.mli @@ -0,0 +1,60 @@ +(* + * Copyright (c) 2011 Richard Mortier + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Net + +type t + +type delay_model = { + flow_insert : float; + flow_update : float; + pktin_rate : float; + pktin_delay : float; + stats_delay : float; + pktout_delay: float; +} + +(** [create dpid] initializes the state for a switch with a datapth id dpid *) +val create_switch : ?verbose:bool -> int64 -> delay_model -> t + +(** Port Management *) + +(** [add_port mgr st intf] add port intf under the control of the switch st *) +val add_port : Manager.t -> ?use_mac:bool -> t -> Manager.id -> unit Lwt.t +(** [del_port mgr st intf] remove port intf from the control of the switch st *) +val del_port : Manager.t -> t -> string -> unit Lwt.t +(** [add_port_local mgr st intf] add port intf as the local loopback interface + * of th switch st *) +val add_port_local : Manager.t -> t -> Manager.id -> unit Lwt.t + +(** [get_flow_stats st fl] fetch statistics for flows matching flow definition + * fl from the switch st *) +val get_flow_stats : t -> Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list + +(** Daemon run *) + +(** [listen st mgr addr] start a listening switch control channel on addr *) +val listen : t -> Manager.t -> Nettypes.ipv4_src -> unit Lwt.t +(** [connect st mgr addr] connect a switch control channel to a controller + * on addr *) +val connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t +(** [local_connect st mgr conn] setup a switch control channel on the local + * Open`flow socket conn *) +val local_connect : t -> Manager.t -> Openflow.Ofsocket.conn_state -> unit Lwt.t +(** [standalone_connect st mgr addr] same as connect method, but a local + * learning switch is responsible to control the switch, when the remote + * control channel is unresponsive *) +val standalone_connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml new file mode 100644 index 0000000..a914ce8 --- /dev/null +++ b/lib/ofswitch_standalone.ml @@ -0,0 +1,158 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * 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 Lwt +open Printf +open Net +open Net.Nettypes + +let resolve t = Lwt.on_success t (fun _ -> ()) + +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event +module OSK = Openflow.Ofsocket + +let pp = Printf.printf +let sp = Printf.sprintf + + +(* TODO this the mapping is incorrect. the datapath must be moved to the key + * of the hashtbl *) +type mac_switch = { + addr: Macaddr.t; + switch: OP.datapath_id; +} + +type switch_state = { + mutable mac_cache: (Macaddr.t, OP.Port.t) Hashtbl.t; + req_count: int ref; +} + +let switch_data = + { mac_cache = Hashtbl.create 0; req_count=(ref 0);} + + +let datapath_join_cb controller dpid evt = + let dp = + match evt with + | OE.Datapath_join (c, _) -> c + | _ -> invalid_arg "bogus datapath_join event match!" + in + return (pp "+ datapath:0x%012Lx\n" dp) + +let datapath_leave_cb controller dpid evt = + let dp = + match evt with + | OE.Datapath_leave (c) -> c + | _ -> invalid_arg "bogus datapath_leave event match!" + in + let _ = Hashtbl.clear switch_data.mac_cache in + let _ = switch_data.req_count := 0 in + return (pp "- datapath:0x%012Lx\n" dp) + + +let req_count = (ref 0) +let port_status_cb controller dpid = function + | OE.Port_status (OP.Port.DEL, port, _) -> + let macs = Hashtbl.fold ( + fun mac p r -> + if(p = (OP.Port.port_of_int port.OP.Port.port_no) ) then + r @ [mac] + else + r ) switch_data.mac_cache [] + in + return ( + List.iter (Hashtbl.remove switch_data.mac_cache) macs) + | _ -> return () +let add_entry_in_hashtbl mac_cache ix in_port = + if not (Hashtbl.mem mac_cache ix ) then + Hashtbl.add mac_cache ix in_port + else + Hashtbl.replace mac_cache ix in_port + +let packet_in_cb controller dpid evt = + incr switch_data.req_count; + let (in_port, buffer_id, data, dp) = + match evt with + | OE.Packet_in (inp, _, buf, dat, dp) -> (inp, buf, dat, dp) + | _ -> invalid_arg "bogus datapath_join event match!" + in + (* Parse Ethernet header *) + let m = OP.Match.raw_packet_to_match in_port data in + + (* Store src mac address and incoming port *) + let ix = m.OP.Match.dl_src in + let _ = Hashtbl.replace switch_data.mac_cache ix in_port in + + (* check if I know the output port in order to define what type of message + * we need to send *) + let ix = m.OP.Match.dl_dst in + if ( (ix = Macaddr.broadcast ) + || (not (Hashtbl.mem switch_data.mac_cache ix)) ) + then ( + let bs = + (OP.Packet_out.create ~buffer_id:buffer_id + ~actions:[ OP.Flow.Output(OP.Port.All , 2000)] + ~data:data ~in_port:in_port () ) in + let h = OP.Header.create OP.Header.PACKET_OUT 0 in + OC.send_data controller dpid (OP.Packet_out (h, bs)) + ) else ( + let out_port = (Hashtbl.find switch_data.mac_cache ix) in + let flags = OP.Flow_mod.({send_flow_rem=true; emerg=false; overlap=false;}) in + lwt _ = + if (buffer_id = -1l) then + (* Need to send also the packet in cache the packet is not cached *) + let bs = + OP.Packet_out.create + ~buffer_id:buffer_id + ~actions:[ OP.Flow.Output(out_port, 2000)] + ~data:data ~in_port:in_port () in + let h = OP.Header.create OP.Header.PACKET_OUT 0 in + OC.send_data controller dpid (OP.Packet_out (h, bs)) + else + return () + in + let pkt = + (OP.Flow_mod.create m 0_L OP.Flow_mod.ADD ~hard_timeout:0 + ~idle_timeout:0 ~buffer_id:(Int32.to_int buffer_id) ~flags + [OP.Flow.Output(out_port, 2000)] ()) in + let h = OP.Header.create OP.Header.FLOW_MOD 0 in + OC.send_data controller dpid (OP.Flow_mod (h, pkt)) + ) + +let init controller = + pp "test controller register datapath cb\n%!"; + OC.register_cb controller OE.DATAPATH_JOIN datapath_join_cb; + pp "test controller register leave cb\n%!"; + OC.register_cb controller OE.DATAPATH_LEAVE datapath_leave_cb; + pp "test controller register packet_in cb\n%!"; + OC.register_cb controller OE.PACKET_IN packet_in_cb; + pp "test controller register packet_in cb\n%!"; + OC.register_cb controller OE.PORT_STATUS_CHANGE port_status_cb + + +let init_controller () = OC.init_controller init + +let run_controller mgr st = + let (controller, switch) = OSK.init_local_conn_state () in + let _ = Lwt.ignore_result ( + try_lwt + OC.local_connect st controller + with exn -> + return (printf "[switch] standalone controllern failed %s\n%!" (Printexc.to_string + exn)) + ) in + return switch diff --git a/lib/ofswitch_standalone.mli b/lib/ofswitch_standalone.mli new file mode 100644 index 0000000..544777e --- /dev/null +++ b/lib/ofswitch_standalone.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * 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. + *) + +val init_controller : unit -> Openflow.Ofcontroller.t +val run_controller : Net.Manager.t -> Openflow.Ofcontroller.t -> Openflow.Ofsocket.conn_state Lwt.t diff --git a/lib/openflow.mlpack b/lib/openflow.mlpack index 26a1c02..2371ea3 100644 --- a/lib/openflow.mlpack +++ b/lib/openflow.mlpack @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 169e106a3d54b9d1a37dc1f99698ecbb) +# DO NOT EDIT (digest: b6991de36e646d2bbeea2320259aae59) Ofpacket Ofcontroller -Ofswitch +Ofsocket # OASIS_STOP diff --git a/lib/openflow.odocl b/lib/openflow.odocl index 26a1c02..2371ea3 100644 --- a/lib/openflow.odocl +++ b/lib/openflow.odocl @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 169e106a3d54b9d1a37dc1f99698ecbb) +# DO NOT EDIT (digest: b6991de36e646d2bbeea2320259aae59) Ofpacket Ofcontroller -Ofswitch +Ofsocket # OASIS_STOP diff --git a/lib/openflow_lwt_unix.mllib b/lib/openflow_lwt_unix.mllib deleted file mode 100644 index b4d2a31..0000000 --- a/lib/openflow_lwt_unix.mllib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: de41b2701caa2c8011a5d2e3e48ede84) -Ofcontroller -Ofswitch -# OASIS_STOP diff --git a/lib/openflow_mirage.mllib b/lib/openflow_mirage.mllib deleted file mode 100644 index b4d2a31..0000000 --- a/lib/openflow_mirage.mllib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: de41b2701caa2c8011a5d2e3e48ede84) -Ofcontroller -Ofswitch -# OASIS_STOP diff --git a/lib/path.ml b/lib/path.ml new file mode 100644 index 0000000..08b6014 --- /dev/null +++ b/lib/path.ml @@ -0,0 +1,238 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: path.ml,v 1.6 2005-07-18 07:10:35 filliatr Exp $ *) + +module type WEIGHT = sig + type label + type t + val weight : label -> t + val compare : t -> t -> int + val add : t -> t -> t + val zero : t +end + +module type G = sig + type t + module V : Sig.COMPARABLE + module E : sig + type t + type label + val label : t -> label + val src : t -> V.t + val dst : t -> V.t + end + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit + val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a + val nb_vertex : t -> int +end + +module Dijkstra + (G: G) + (W: WEIGHT with type label = G.E.label) = +struct + + open G.E + + module H = Hashtbl.Make(G.V) + + module Elt = struct + type t = W.t * G.V.t * G.E.t list + + (* weights are compared first, and minimal weights come first in the + queue *) + let compare (w1,v1,_) (w2,v2,_) = + let cw = W.compare w2 w1 in + if cw != 0 then cw else G.V.compare v1 v2 + end + + module PQ = Heap.Imperative(Elt) + + let shortest_path g v1 v2 = + let visited = H.create 97 in + let dist = H.create 97 in + let q = PQ.create 17 in + let rec loop () = + if PQ.is_empty q then raise Not_found; + let (w,v,p) = PQ.pop_maximum q in + if G.V.compare v v2 = 0 then + List.rev p, w + else begin + if not (H.mem visited v) then begin + H.add visited v (); + G.iter_succ_e + (fun e -> + let ev = dst e in + if not (H.mem visited ev) then begin + let dev = W.add w (W.weight (label e)) in + let improvement = + try W.compare dev (H.find dist ev) < 0 with Not_found -> true + in + if improvement then begin + H.replace dist ev dev; + PQ.add q (dev, ev, e :: p) + end + end) + g v + end; + loop () + end + in + PQ.add q (W.zero, v1, []); + H.add dist v1 W.zero; + loop () + +end + +(* The following module is a contribution of Yuto Takei (University of Tokyo) *) + +module BellmanFord + (G: G) + (W: WEIGHT with type label = G.E.label) = +struct + + open G.E + + module H = Hashtbl.Make(G.V) + + exception NegativeCycle of G.E.t list + + let all_shortest_paths g vs = + let dist = H.create 97 in + H.add dist vs W.zero; + let admissible = H.create 97 in + let build_cycle_from x0 = + let rec traverse_parent x ret = + let e = H.find admissible x in + let s = src e in + if G.V.equal s x0 then e :: ret else traverse_parent s (e :: ret) + in + traverse_parent x0 [] + in + let find_cycle x0 = + let visited = H.create 97 in + let rec visit x = + if H.mem visited x then + build_cycle_from x + else begin + H.add visited x (); + let e = H.find admissible x in + visit (src e) + end + in + visit x0 + in + let rec relax i = + let update = G.fold_edges_e + (fun e x -> + let ev1 = src e in + let ev2 = dst e in + try begin + let dev1 = H.find dist ev1 in + let dev2 = W.add dev1 (W.weight (label e)) in + let improvement = + try W.compare dev2 (H.find dist ev2) < 0 + with Not_found -> true + in + if improvement then begin + H.replace dist ev2 dev2; + H.replace admissible ev2 e; + Some ev2 + end else x + end with Not_found -> x) g None in + match update with + | Some x -> + if i == G.nb_vertex g then raise (NegativeCycle (find_cycle x)) + else relax (i + 1) + | None -> dist + in + relax 0 + + let find_negative_cycle_from g vs = + try let _ = all_shortest_paths g vs in raise Not_found + with NegativeCycle l -> l + + + module Comp = Components.Make(G) + + (* This is rather inefficient implementation. Indeed, for each + strongly connected component, we run a full Bellman-Ford + algorithm using one of its vertex as source, taking all edges + into consideration. Instead, we could limit ourselves to the + edges of the component. *) + let find_negative_cycle g = + let rec iter = function + | [] -> + raise Not_found + | (x :: _) :: cl -> + begin try find_negative_cycle_from g x with Not_found -> iter cl end + | [] :: _ -> + assert false (* a component is not empty *) + in + iter (Comp.scc_list g) + +end + + +module Check + (G : + sig + type t + module V : Sig.COMPARABLE + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + end) = +struct + + module HV = Hashtbl.Make(G.V) + module HVV = Hashtbl.Make(Util.HTProduct(G.V)(G.V)) + + (* the cache contains the path tests already computed *) + type path_checker = { cache : bool HVV.t; graph : G.t } + + let create g = { cache = HVV.create 97; graph = g } + + let check_path pc v1 v2 = + try + HVV.find pc.cache (v1, v2) + with Not_found -> + (* the path is not in cache; we check it with Dijkstra *) + let visited = HV.create 97 in + let q = Queue.create () in + let rec loop () = + if Queue.is_empty q then begin + HVV.add pc.cache (v1, v2) false; + false + end else begin + let v = Queue.pop q in + HVV.add pc.cache (v1, v) true; + if G.V.compare v v2 = 0 then + true + else begin + if not (HV.mem visited v) then begin + HV.add visited v (); + G.iter_succ (fun v' -> Queue.add v' q) pc.graph v + end; + loop () + end + end + in + Queue.add v1 q; + loop () + +end diff --git a/lib/path.mli b/lib/path.mli new file mode 100644 index 0000000..25e0a84 --- /dev/null +++ b/lib/path.mli @@ -0,0 +1,143 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: path.mli,v 1.9 2005-07-18 07:10:35 filliatr Exp $ *) + +(** Paths *) + +(** Minimal graph signature for Dijkstra's algorithm. + Sub-signature of {!Sig.G}. *) +module type G = sig + type t + module V : Sig.COMPARABLE + module E : sig + type t + type label + val label : t -> label + val src : t -> V.t + val dst : t -> V.t + end + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit + val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a + val nb_vertex : t -> int +end + +(** Signature for edges' weights. *) +module type WEIGHT = sig + type label + (** Type for labels of graph edges. *) + type t + (** Type of edges' weights. *) + val weight : label -> t + (** Get the weight of an edge. *) + val compare : t -> t -> int + (** Weights must be ordered. *) + val add : t -> t -> t + (** Addition of weights. *) + val zero : t + (** Neutral element for {!add}. *) +end + +module Dijkstra + (G: G) + (W: WEIGHT with type label = G.E.label) : +sig + + val shortest_path : G.t -> G.V.t -> G.V.t -> G.E.t list * W.t + (** [shortest_path g v1 v2] computes the shortest path from vertex [v1] + to vertex [v2] in graph [g]. The path is returned as the list of + followed edges, together with the total length of the path. + raise [Not_found] if the path from [v1] to [v2] does not exist. + + Complexity: at most O((V+E)log(V)) *) + +end + +(* The following module is a contribution of Yuto Takei (University of Tokyo) *) + +module BellmanFord + (G: G) + (W: WEIGHT with type label = G.E.label) : +sig + + module H : Hashtbl.S with type key = G.V.t + + exception NegativeCycle of G.E.t list + + val all_shortest_paths : G.t -> G.V.t -> W.t H.t + (** [shortest_path g vs] computes the distances of shortest paths + from vertex [vs] to all other vertices in graph [g]. They are + returned as a hash table mapping each vertex reachable from + [vs] to its distance from [vs]. If [g] contains a + negative-length cycle reachable from [vs], raises + [NegativeCycle l] where [l] is such a cycle. + + Complexity: at most O(VE) *) + + val find_negative_cycle_from: G.t -> G.V.t -> G.E.t list + (** [find_negative_cycle_from g vs] looks for a negative-length + cycle in graph [g] that is reachable from vertex [vs] and + returns it as a list of edges. If no such a cycle exists, + raises [Not_found]. + + Complexity: at most O(VE). *) + + val find_negative_cycle: G.t -> G.E.t list + (** [find_negative_cycle g] looks for a negative-length cycle in + graph [g] and returns it. If the graph [g] is free from such a + cycle, raises [Not_found]. + + Complexity: O(V^2E) *) +end + + +(** Check for a path. *) +module Check + (G : sig + type t + module V : Sig.COMPARABLE + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + end) : +sig + + type path_checker + (** the abstract data type of a path checker; this is a mutable data + structure *) + + val create : G.t -> path_checker + (** [create g] builds a new path checker for the graph [g]; + if the graph is mutable, it must not be mutated while this path + checker is in use (through the function [check_path] below). *) + + val check_path : path_checker -> G.V.t -> G.V.t -> bool + (** [check_path pc v1 v2] checks whether there is a path from [v1] to + [v2] in the graph associated to the path checker [pc]. + + Complexity: The path checker contains a cache of all results computed + so far. This cache is implemented with a hash table so access in this + cache is usually O(1). When the result is not in the cache, Dijkstra's + algorithm is run to check for the path, and all intermediate results + are cached. + + Note: if checks are to be done for almost all pairs of vertices, it + may be more efficient to compute the transitive closure of the graph + (see module [Oper]). + *) + +end diff --git a/lib/sig.mli b/lib/sig.mli new file mode 100644 index 0000000..8e92aaf --- /dev/null +++ b/lib/sig.mli @@ -0,0 +1,360 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** {b Signatures for graph implementations.} *) + +(** {2 Signatures for graph implementations} *) + +(** Signature for vertices. *) +module type VERTEX = sig + + (** Vertices are {!COMPARABLE}. *) + + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + + (** Vertices are labeled. *) + + type label + val create : label -> t + val label : t -> label + +end + +(** Signature for edges. *) +module type EDGE = sig + + (** Edges are {!ORDERED_TYPE}. *) + + type t + val compare : t -> t -> int + + (** Edges are directed. *) + + type vertex + + val src : t -> vertex + (** Edge origin. *) + val dst : t -> vertex + (** Edge destination. *) + + (** Edges are labeled. *) + + type label + val create : vertex -> label -> vertex -> t + (** [create v1 l v2] creates an edge from [v1] to [v2] with label [l] *) + val label : t -> label + (** Get the label of an edge. *) + +end + +(** Common signature for all graphs. *) +module type G = sig + + (** {2 Graph structure} *) + + (** Abstract type of graphs *) + type t + + (** Vertices have type [V.t] and are labeled with type [V.label] + (note that an implementation may identify the vertex with its + label) *) + module V : VERTEX + type vertex = V.t + + (** Edges have type [E.t] and are labeled with type [E.label]. + [src] (resp. [dst]) returns the origin (resp. the destination) of a + given edge. *) + module E : EDGE with type vertex = vertex + type edge = E.t + + (** Is this an implementation of directed graphs? *) + val is_directed : bool + + (** {2 Size functions} *) + + val is_empty : t -> bool + val nb_vertex : t -> int + val nb_edges : t -> int + + (** Degree of a vertex *) + + val out_degree : t -> vertex -> int + (** [out_degree g v] returns the out-degree of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val in_degree : t -> vertex -> int + (** [in_degree g v] returns the in-degree of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** {2 Membership functions} *) + + val mem_vertex : t -> vertex -> bool + val mem_edge : t -> vertex -> vertex -> bool + val mem_edge_e : t -> edge -> bool + + val find_edge : t -> vertex -> vertex -> edge + (** [find_edge g v1 v2] returns the edge from [v1] to [v2] if it exists. + Unspecified behaviour if [g] has several edges from [v1] to [v2]. + @raise Not_found if no such edge exists. *) + + val find_all_edges : t -> vertex -> vertex -> edge list + (** [find_all_edges g v1 v2] returns all the edges from [v1] to [v2]. + @since ocamlgraph 1.8 *) + + (** {2 Successors and predecessors} + + You should better use iterators on successors/predecessors (see + Section "Vertex iterators"). *) + + val succ : t -> vertex -> vertex list + (** [succ g v] returns the successors of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val pred : t -> vertex -> vertex list + (** [pred g v] returns the predecessors of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** Labeled edges going from/to a vertex *) + + val succ_e : t -> vertex -> edge list + (** [succ_e g v] returns the edges going from [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val pred_e : t -> vertex -> edge list + (** [pred_e g v] returns the edges going to [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** {2 Graph iterators} *) + + val iter_vertex : (vertex -> unit) -> t -> unit + (** Iter on all vertices of a graph. *) + + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + (** Fold on all vertices of a graph. *) + + val iter_edges : (vertex -> vertex -> unit) -> t -> unit + (** Iter on all edges of a graph. Edge label is ignored. *) + + val fold_edges : (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a + (** Fold on all edges of a graph. Edge label is ignored. *) + + val iter_edges_e : (edge -> unit) -> t -> unit + (** Iter on all edges of a graph. *) + + val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a + (** Fold on all edges of a graph. *) + + val map_vertex : (vertex -> vertex) -> t -> t + (** Map on all vertices of a graph. *) + + (** {2 Vertex iterators} + + Each iterator [iterator f v g] iters [f] to the successors/predecessors + of [v] in the graph [g] and raises [Invalid_argument] if [v] is not in + [g]. It is the same for functions [fold_*] which use an additional + accumulator. + + Time complexity for ocamlgraph implementations: + operations on successors are in O(1) amortized for imperative graphs and + in O(ln(|V|)) for persistent graphs while operations on predecessors are + in O(max(|V|,|E|)) for imperative graphs and in O(max(|V|,|E|)*ln|V|) for + persistent graphs. *) + + (** iter/fold on all successors/predecessors of a vertex. *) + + val iter_succ : (vertex -> unit) -> t -> vertex -> unit + val iter_pred : (vertex -> unit) -> t -> vertex -> unit + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val fold_pred : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + (** iter/fold on all edges going from/to a vertex. *) + + val iter_succ_e : (edge -> unit) -> t -> vertex -> unit + val fold_succ_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val iter_pred_e : (edge -> unit) -> t -> vertex -> unit + val fold_pred_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + +end + +(** Signature for persistent (i.e. immutable) graph. *) +module type P = sig + + include G + (** A persistent graph is a graph. *) + + val empty : t + (** The empty graph. *) + + val add_vertex : t -> vertex -> t + (** [add_vertex g v] adds the vertex [v] to the graph [g]. + Just return [g] if [v] is already in [g]. *) + + val remove_vertex : t -> vertex -> t + (** [remove g v] removes the vertex [v] from the graph [g] + (and all the edges going from [v] in [g]). + Just return [g] if [v] is not in [g]. + + Time complexity for ocamlgraph implementations: + O(|V|*ln(|V|)) for unlabeled graphs and + O(|V|*max(ln(|V|),D)) for labeled graphs. + D is the maximal degree of the graph. *) + + val add_edge : t -> vertex -> vertex -> t + (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] + in the graph [g]. + Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. + Just return [g] if this edge is already in [g]. *) + + val add_edge_e : t -> edge -> t + (** [add_edge_e g e] adds the edge [e] in the graph [g]. + Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst + e]) is not in [g]. + Just return [g] if [e] is already in [g]. *) + + val remove_edge : t -> vertex -> vertex -> t + (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the + graph [g]. If the graph is labelled, all the edges going from [v1] to + [v2] are removed from [g]. + Just return [g] if this edge is not in [g]. + @raise Invalid_argument if [v1] or [v2] are not in [g]. *) + + val remove_edge_e : t -> edge -> t + (** [remove_edge_e g e] removes the edge [e] from the graph [g]. + Just return [g] if [e] is not in [g]. + @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) + +end + +(** Signature for imperative (i.e. mutable) graphs. *) +module type I = sig + + include G + (** An imperative graph is a graph. *) + + val create : ?size:int -> unit -> t + (** [create ()] returns an empty graph. Optionally, a size can be + given, which should be on the order of the expected number of + vertices that will be in the graph (for hash tables-based + implementations). The graph grows as needed, so [size] is + just an initial guess. *) + + val clear: t -> unit + (** Remove all vertices and edges from the given graph. + @since ocamlgraph 1.4 *) + + val copy : t -> t + (** [copy g] returns a copy of [g]. Vertices and edges (and eventually + marks, see module [Mark]) are duplicated. *) + + val add_vertex : t -> vertex -> unit + (** [add_vertex g v] adds the vertex [v] to the graph [g]. + Do nothing if [v] is already in [g]. *) + + val remove_vertex : t -> vertex -> unit + (** [remove g v] removes the vertex [v] from the graph [g] + (and all the edges going from [v] in [g]). + Do nothing if [v] is not in [g]. + + Time complexity for ocamlgraph implementations: + O(|V|*ln(D)) for unlabeled graphs and O(|V|*D) for + labeled graphs. D is the maximal degree of the graph. *) + + val add_edge : t -> vertex -> vertex -> unit + (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] + in the graph [g]. + Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. + Do nothing if this edge is already in [g]. *) + + val add_edge_e : t -> edge -> unit + (** [add_edge_e g e] adds the edge [e] in the graph [g]. + Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst + e]) is not in [g]. + Do nothing if [e] is already in [g]. *) + + val remove_edge : t -> vertex -> vertex -> unit + (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the + graph [g]. If the graph is labelled, all the edges going from [v1] to + [v2] are removed from [g]. + Do nothing if this edge is not in [g]. + @raise Invalid_argument if [v1] or [v2] are not in [g]. *) + + val remove_edge_e : t -> edge -> unit + (** [remove_edge_e g e] removes the edge [e] from the graph [g]. + Do nothing if [e] is not in [g]. + @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) + +end + +(** Signature for marks on vertices. *) +module type MARK = sig + type graph + (** Type of graphs. *) + type vertex + (** Type of graph vertices. *) + val clear : graph -> unit + (** [clear g] sets all the marks to 0 for all the vertices of [g]. *) + val get : vertex -> int + (** Mark value (in O(1)). *) + val set : vertex -> int -> unit + (** Set the mark of the given vertex. *) +end + +(** Signature for imperative graphs with marks on vertices. *) +module type IM = sig + include I + (** An imperative graph with marks is an imperative graph. *) + + (** Mark on vertices. + Marks can be used if you want to store some information on vertices: + it is more efficient to use marks than an external table. *) + module Mark : MARK with type graph = t and type vertex = vertex +end + +(** {2 Signature for ordered and hashable types} *) + +(** Signature with only an abstract type. *) +module type ANY_TYPE = sig type t end + +(** Signature equivalent to [Set.OrderedType]. *) +module type ORDERED_TYPE = sig type t val compare : t -> t -> int end + +(** Signature equivalent to [Set.OrderedType] with a default value. *) +module type ORDERED_TYPE_DFT = sig include ORDERED_TYPE val default : t end + +(** Signature equivalent to [Hashtbl.HashedType]. *) +module type HASHABLE = sig + type t + val hash : t -> int + val equal : t -> t -> bool +end + +(** Signature merging {!ORDERED_TYPE} and {!HASHABLE}. *) +module type COMPARABLE = sig + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool +end + +(* +Local Variables: +compile-command: "make -C .." +End: +*) diff --git a/lib/switch.mlpack b/lib/switch.mlpack new file mode 100644 index 0000000..b1c6b86 --- /dev/null +++ b/lib/switch.mlpack @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: a67c0c05231915ebff9464af7a4213ec) +Ofswitch +Ofswitch_config +Ofswitch_standalone +# OASIS_STOP diff --git a/lib/switch_model.mlpack b/lib/switch_model.mlpack new file mode 100644 index 0000000..1e68b96 --- /dev/null +++ b/lib/switch_model.mlpack @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: d668207c07c4ef2fe58a2c8043caa223) +Ofswitch_model +# OASIS_STOP diff --git a/lib/util.ml b/lib/util.ml new file mode 100644 index 0000000..a7d50ea --- /dev/null +++ b/lib/util.ml @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +open Sig + +module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) = struct + type t = X.t * Y.t + let compare (x1, y1) (x2, y2) = + let cv = X.compare x1 x2 in + if cv != 0 then cv else Y.compare y1 y2 +end + +module HTProduct(X: HASHABLE)(Y: HASHABLE) = struct + type t = X.t * Y.t + let equal (x1, y1) (x2, y2) = X.equal x1 x2 && Y.equal y1 y2 + let hash (x, y) = Hashtbl.hash (X.hash x, Y.hash y) +end + +module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) = struct + include HTProduct(X)(Y) + include (OTProduct(X)(Y): sig val compare : t -> t -> int end) +end + +module DataV(L : sig type t end)(V : Sig.COMPARABLE) = struct + type data = L.t + type label = V.t + type t = data ref * V.t + let compare (_, x) (_, x') = V.compare x x' + let hash (_, x) = V.hash x + let equal (_, x) (_, x') = V.equal x x' + let create y lbl = (ref y, lbl) + let label (_, z) = z + let data (y, _) = !y + let set_data (y, _) = (:=) y +end + diff --git a/lib/util.mli b/lib/util.mli new file mode 100644 index 0000000..63ae42f --- /dev/null +++ b/lib/util.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Some useful operations. *) + +open Sig + +(** Cartesian product of two ordered types. *) +module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) : + ORDERED_TYPE with type t = X.t * Y.t + +(** Cartesian product of two hashable types. *) +module HTProduct(X: HASHABLE)(Y: HASHABLE) : + HASHABLE with type t = X.t * Y.t + +(** Cartesian product of two comparable types. *) +module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) : + COMPARABLE with type t = X.t * Y.t + +(** Create a vertex type with some data attached to it *) +module DataV(L : sig type t end)(V : Sig.COMPARABLE) : sig + type data = L.t + and label = V.t + and t = data ref * V.t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + val create : data -> V.t -> t + val label : t -> V.t + val data : t -> data + val set_data : t -> data -> unit +end + diff --git a/mirage-controller.cfg b/mirage-controller.cfg deleted file mode 100644 index fabe4a0..0000000 --- a/mirage-controller.cfg +++ /dev/null @@ -1,9 +0,0 @@ -kernel = "./_build/controller/learning_switch_mirage.xen" -name = "ofcontroller" -vif = [ -# 'mac=00:16:3e:e8:20:e6, bridge=br0' - 'bridge=test0' -] -memory = 512 -on_crash = "preserve" -on_exit = "preserve" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index df37d3d..1630e89 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 4ea9cb294a4d3c02ae97c0bbbdbc9400) *) +(* DO NOT EDIT (digest: d09f38b5f845453a33251ed8fef2743c) *) module OASISGettext = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISGettext.ml" +(* # 21 "src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISExpr.ml" +(* # 21 "src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseEnvLight.ml" +(* # 21 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -213,76 +213,8 @@ end # 215 "myocamlbuild.ml" -module MyOCamlbuildXen = struct -# 22 "/Users/avsm/src/git/avsm/oasis/src/plugins/ocamlbuild/MyOCamlbuildXen.ml" - - open Ocamlbuild_plugin - - module Util = struct - 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 run_and_read x = List.hd (split_nl (Ocamlbuild_pack.My_unix.run_and_read x)) - end - - module Xen = struct - (** Link to a standalone Xen microkernel *) - let cc_xen_link bc tags arg out env = - (* XXX check ocamlfind path here *) - let xenlib = Util.run_and_read "ocamlfind query mirage" in - let jmp_obj = Px (xenlib / "longjmp.o") in - let head_obj = Px (xenlib / "x86_64.o") in - let ocamllib = match bc with |true -> "ocamlbc" |false -> "ocaml" in - let ld = getenv ~default:"ld" "LD" in - let ldlibs = List.map (fun x -> Px (xenlib / ("lib" ^ x ^ ".a"))) - [ocamllib; "xen"; "xencaml"; "diet"; "m"] in - Cmd (S ( A ld :: [ T(tags++"link"++"xen"); - A"-d"; A"-nostdlib"; A"-m"; A"elf_x86_64"; A"-T"; - Px (xenlib / "mirage-x86_64.lds"); head_obj; P arg ] - @ ldlibs @ [jmp_obj; A"-o"; Px out])) - - let cc_xen_bc_link tags arg out env = cc_xen_link true tags arg out env - let cc_xen_nc_link tags arg out env = cc_xen_link false tags arg out env - - (* Rewrite sections for Xen LDS layout *) - let xen_objcopy dst src env builder = - let dst = env dst in - let src = env src in - let cmd = ["objcopy";"--rename-section";".bss=.mlbss";"--rename-section"; - ".data=.mldata";"--rename-section";".rodata=.mlrodata"; - "--rename-section";".text=.mltext"] in - let cmds = List.map (fun x -> A x) cmd in - Cmd (S (cmds @ [Px src; Px dst])) - - let rules () = - let cc_link_c_implem ?tag fn c o env build = - let c = env c and o = env o in - fn (tags_of_pathname c++"implem"+++tag) c o env - in - rule "final link: %.nobj.o -> %.xen" ~prod:"%(file).xen" ~dep:"%(file).nobj.o" - (cc_link_c_implem cc_xen_nc_link "%(file).nobj.o" "%(file).xen") - - end - - let dispatch = - function - | After_rules -> - Xen.rules () - | _ -> - () -end - module MyOCamlbuildFindlib = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -358,11 +290,20 @@ module MyOCamlbuildFindlib = struct * 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]; + let base_args = [A"-package"; A pkg] in + let syn_args = [A"-syntax"; A "camlp4o"] in + let args = + (* heuristic to identify syntax extensions: + whether they end in ".syntax"; some might not *) + if Filename.check_suffix pkg "syntax" + then syn_args @ base_args + else base_args + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; end (find_packages ()); @@ -394,7 +335,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -410,7 +351,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -# 56 "/Users/avsm/src/git/avsm/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { @@ -527,11 +468,20 @@ module MyOCamlbuildBase = struct let native_output_obj x = OC.link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] OC.ocamlopt_link_prog - (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x + (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x in rule "ocaml: cmx* and o* -> .nobj.o" ~prod:"%.nobj.o" ~deps:["%.cmx"; "%.o"] (native_output_obj "%.cmx" "%.nobj.o"); + (* Add output_obj rules mapped to .bobj.o *) + let bytecode_output_obj x = + OC.link_gen "cmo" "cma" !Options.ext_lib [!Options.ext_obj; "cmi"] + OC.ocamlc_link_prog + (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x + in + rule "ocaml: cmo* -> .nobj.o" ~prod:"%.bobj.o" ~deps:["%.cmo"] + (bytecode_output_obj "%.cmo" "%.bobj.o"); + (* Add flags *) List.iter (fun (tags, cond_specs) -> @@ -548,17 +498,22 @@ module MyOCamlbuildBase = struct [ dispatch t; MyOCamlbuildFindlib.dispatch; - MyOCamlbuildXen.dispatch; ] end -# 557 "myocamlbuild.ml" +# 506 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { - MyOCamlbuildBase.lib_ocaml = [("openflow", ["lib"])]; + MyOCamlbuildBase.lib_ocaml = + [ + ("openflow", ["lib"]); + ("flv", ["lib"]); + ("switch", ["lib"]); + ("switch_model", ["lib"]) + ]; lib_c = []; flags = []; includes = [("switch", ["lib"]); ("controller", ["lib"])]; @@ -567,6 +522,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 571 "myocamlbuild.ml" +# 526 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index de61b1a..b0f361d 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ -(* setup.ml generated for the first time by OASIS v0.2.0 *) +(* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 1dc9ff07d9daaf97238193f048024200) *) +(* DO NOT EDIT (digest: a74b50c4be9714be24cc3dd375101778) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISGettext.ml" +(* # 21 "src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISContext.ml" +(* # 21 "src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -# 1 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISString.ml" +(* # 1 "src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISUtils.ml" +(* # 21 "src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/PropList.ml" +(* # 21 "src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -# 71 "/Users/avsm/src/git/avsm/oasis/src/oasis/PropList.ml" +(* # 71 "src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISMessage.ml" +(* # 21 "src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISVersion.ml" +(* # 21 "src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISLicense.ml" +(* # 21 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISExpr.ml" +(* # 21 "src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISTypes.ml" +(* # 21 "src/oasis/OASISTypes.ml" *) @@ -964,6 +964,8 @@ module OASISTypes = struct type compiled_object = | Byte | Native + | Native_object + | Bytecode_object | Best @@ -1018,7 +1020,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -# 102 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISTypes.ml" +(* # 104 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1077,7 +1079,6 @@ module OASISTypes = struct { exec_custom: bool; exec_main_is: unix_filename; - exec_target: string option; } type flag = @@ -1185,7 +1186,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISUnixPath.ml" +(* # 21 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1269,7 +1270,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISHostPath.ml" +(* # 21 "src/oasis/OASISHostPath.ml" *) open Filename @@ -1302,7 +1303,7 @@ module OASISHostPath = struct end module OASISSection = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISSection.ml" +(* # 21 "src/oasis/OASISSection.ml" *) open OASISTypes @@ -1385,12 +1386,12 @@ module OASISSection = struct end module OASISBuildSection = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISBuildSection.ml" +(* # 21 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISExecutable.ml" +(* # 21 "src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1403,6 +1404,8 @@ module OASISExecutable = struct let is_native_exec = match bs.bs_compiled_object with | Native -> true + | Native_object -> false + | Bytecode_object -> false | Best -> is_native () | Byte -> false in @@ -1421,7 +1424,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISLibrary.ml" +(* # 21 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1529,6 +1532,8 @@ module OASISLibrary = struct (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true + | Native_object -> false + | Bytecode_object -> false | Best -> is_native | Byte -> false in @@ -1566,11 +1571,11 @@ module OASISLibrary = struct [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with - | Native -> + | Native | Native_object -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) - | Byte | Best -> + | Byte | Bytecode_object | Best -> byte acc_nopath in @@ -1599,7 +1604,7 @@ module OASISLibrary = struct end module OASISObject = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISObject.ml" +(* # 21 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext @@ -1654,17 +1659,17 @@ module OASISObject = struct in List.map (List.map f) ( match bs.bs_compiled_object with - | Native -> + | Native | Native_object -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] - | Byte | Best -> + | Byte | Bytecode_object | Best -> byte :: header :: []) end module OASISFindlib = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISFindlib.ml" +(* # 21 "src/oasis/OASISFindlib.ml" *) open OASISTypes @@ -1951,32 +1956,32 @@ module OASISFindlib = struct end module OASISFlag = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISFlag.ml" +(* # 21 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISPackage.ml" +(* # 21 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISSourceRepository.ml" +(* # 21 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISTest.ml" +(* # 21 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISDocument.ml" +(* # 21 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISExec.ml" +(* # 21 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -2054,7 +2059,7 @@ module OASISExec = struct end module OASISFileUtil = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/oasis/OASISFileUtil.ml" +(* # 21 "src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2249,9 +2254,9 @@ module OASISFileUtil = struct end -# 2252 "setup.ml" +# 2257 "setup.ml" module BaseEnvLight = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseEnvLight.ml" +(* # 21 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2347,9 +2352,9 @@ module BaseEnvLight = struct end -# 2350 "setup.ml" +# 2355 "setup.ml" module BaseContext = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseContext.ml" +(* # 21 "src/base/BaseContext.ml" *) open OASISContext @@ -2360,7 +2365,7 @@ module BaseContext = struct end module BaseMessage = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseMessage.ml" +(* # 21 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2379,7 +2384,7 @@ module BaseMessage = struct end module BaseEnv = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseEnv.ml" +(* # 21 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2839,7 +2844,7 @@ module BaseEnv = struct end module BaseArgExt = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseArgExt.ml" +(* # 21 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2867,7 +2872,7 @@ module BaseArgExt = struct end module BaseCheck = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseCheck.ml" +(* # 21 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2993,7 +2998,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseOCamlcConfig.ml" +(* # 21 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -3109,7 +3114,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseStandardVar.ml" +(* # 21 "src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3473,7 +3478,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseFileAB.ml" +(* # 21 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3521,7 +3526,7 @@ module BaseFileAB = struct end module BaseLog = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseLog.ml" +(* # 21 "src/base/BaseLog.ml" *) open OASISUtils @@ -3640,7 +3645,7 @@ module BaseLog = struct end module BaseBuilt = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseBuilt.ml" +(* # 21 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3808,7 +3813,7 @@ module BaseBuilt = struct end module BaseCustom = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseCustom.ml" +(* # 21 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3858,7 +3863,7 @@ module BaseCustom = struct end module BaseDynVar = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseDynVar.ml" +(* # 21 "src/base/BaseDynVar.ml" *) open OASISTypes @@ -3905,7 +3910,7 @@ module BaseDynVar = struct end module BaseTest = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseTest.ml" +(* # 21 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3995,7 +4000,7 @@ module BaseTest = struct end module BaseDoc = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseDoc.ml" +(* # 21 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -4030,7 +4035,7 @@ module BaseDoc = struct end module BaseSetup = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/base/BaseSetup.ml" +(* # 21 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4609,9 +4614,9 @@ module BaseSetup = struct end -# 4612 "setup.ml" +# 4617 "setup.ml" module InternalConfigurePlugin = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/plugins/internal/InternalConfigurePlugin.ml" +(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4867,7 +4872,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/plugins/internal/InternalInstallPlugin.ml" +(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5450,9 +5455,9 @@ module InternalInstallPlugin = struct end -# 5453 "setup.ml" +# 5458 "setup.ml" module OCamlbuildCommon = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/plugins/ocamlbuild/OCamlbuildCommon.ml" +(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5554,7 +5559,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" +(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5693,15 +5698,17 @@ module OCamlbuildPlugin = struct (* Add executable *) let acc = - match exec.exec_target, bs.bs_compiled_object with - | Some t, _ -> - (target ("." ^ t)) :: acc - | None, Native -> - (target ".native") :: (target ".nobj.o") :: acc - | None, Best when bool_of_string (is_native ()) -> - (target ".native") :: (target ".nobj.o") :: acc - | None, Byte - | None, Best -> + match bs.bs_compiled_object with + | Native_object -> + (target ".nobj.o") :: acc + | Bytecode_object -> + (target ".bobj.o") :: acc + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> (target ".byte") :: acc in acc @@ -5759,7 +5766,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -# 21 "/Users/avsm/src/git/avsm/oasis/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" +(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5807,7 +5814,7 @@ module OCamlbuildDocPlugin = struct end -# 5810 "setup.ml" +# 5817 "setup.ml" open OASISTypes;; let setup_t = @@ -5827,7 +5834,7 @@ let setup_t = package = { oasis_version = "0.3"; - ocaml_version = Some (OASISVersion.VGreaterEqual "3.12"); + ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); findlib_version = None; name = "openflow"; version = "0.3.0"; @@ -5851,7 +5858,7 @@ let setup_t = ]; homepage = None; synopsis = - "OpenFlow protocol and switch implementations in pure OCaml"; + "OpenFlow controller, switch and flowvisor implementation in pure OCaml"; description = None; categories = []; conf_type = (`Configure, "internal", Some "0.3"); @@ -5892,42 +5899,34 @@ let setup_t = [ Flag ({ - cs_name = "lwt"; + cs_name = "direct"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - flag_description = Some "build the Lwt library"; + flag_description = + Some "build things over the direct xen net"; flag_default = [(OASISExpr.EBool true, false)]; }); Flag ({ - cs_name = "xen"; + cs_name = "unix"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - flag_description = Some "build the Xen tests"; + flag_description = + Some "build programs with a depency on lwt.unix"; flag_default = [(OASISExpr.EBool true, false)]; }); Flag ({ - cs_name = "mirage"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "build the Mirage library"; - flag_default = [(OASISExpr.EBool true, false)]; - }); - Flag - ({ - cs_name = "nettests"; + cs_name = "xen"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - flag_description = Some "run the internet-using tests"; + flag_description = Some "build xen applications"; flag_default = [(OASISExpr.EBool true, false)]; }); Library @@ -5940,15 +5939,18 @@ let setup_t = bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; - bs_compiled_object = Best; + bs_compiled_object = Native; bs_build_depends = [ + FindlibPackage ("ipaddr", None); FindlibPackage ("cstruct", None); FindlibPackage ("cstruct.syntax", None); + FindlibPackage ("rpclib", None); + FindlibPackage ("rpclib.json", None); FindlibPackage ("mirage", None); FindlibPackage ("mirage-net", - Some (OASISVersion.VGreaterEqual "0.4.0")) + Some (OASISVersion.VGreaterEqual "0.3.0")) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -5961,7 +5963,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { - lib_modules = ["Ofpacket"; "Ofcontroller"; "Ofswitch"]; + lib_modules = ["Ofpacket"; "Ofcontroller"; "Ofsocket"]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; @@ -5996,9 +5998,40 @@ let setup_t = doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; }); - Executable + Library ({ - cs_name = "learning_switch_lwt"; + cs_name = "flv"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "lib"; + bs_compiled_object = Native; + bs_build_depends = []; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + ["Flowvisor"; "Lldp"; "Flowvisor_topology"]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "openflow"; + lib_findlib_name = Some "flv"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "switch"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6006,16 +6039,19 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) + (OASISExpr.EFlag "direct", true) ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "controller"; - bs_compiled_object = Best; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "direct", true) + ]; + bs_path = "lib"; + bs_compiled_object = Native; bs_build_depends = [ - FindlibPackage ("cstruct", None); - FindlibPackage ("cstruct.syntax", None); - InternalLibrary "openflow" + FindlibPackage ("re.str", None); + FindlibPackage ("tuntap", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6028,13 +6064,18 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { - exec_custom = true; - exec_main_is = "learning_switch.ml"; - exec_target = None; + lib_modules = + ["Ofswitch"; "Ofswitch_config"; "Ofswitch_standalone" + ]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "openflow"; + lib_findlib_name = Some "switch"; + lib_findlib_containers = []; }); - Executable + Library ({ - cs_name = "basic_switch_lwt"; + cs_name = "switch_model"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6042,12 +6083,20 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) + (OASISExpr.EFlag "direct", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "direct", true) + ]; + bs_path = "lib"; + bs_compiled_object = Native; + bs_build_depends = + [ + FindlibPackage ("re.str", None); + FindlibPackage ("tuntap", None) ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "switch"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "openflow"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6059,30 +6108,32 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { - exec_custom = true; - exec_main_is = "basic_switch.ml"; - exec_target = None; + lib_modules = ["Ofswitch_model"]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "openflow"; + lib_findlib_name = Some "switch_model"; + lib_findlib_containers = []; }); Executable ({ - cs_name = "learning_switch_mirage_unix"; + cs_name = "ofcontroller_lwt"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - bs_build = + bs_build = [(OASISExpr.EBool true, false)]; + bs_install = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "mirage", true) + (OASISExpr.EFlag "unix", true) ]; - bs_install = [(OASISExpr.EBool true, false)]; bs_path = "controller"; bs_compiled_object = Native; bs_build_depends = [ - FindlibPackage ("cstruct", None); - FindlibPackage ("cstruct.syntax", None); - InternalLibrary "openflow" + InternalLibrary "openflow"; + FindlibPackage ("tuntap", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6094,27 +6145,24 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - { - exec_custom = true; - exec_main_is = "learning_switch.ml"; - exec_target = None; - }); + {exec_custom = true; exec_main_is = "lwt_controller.ml"; }); Executable ({ - cs_name = "basic_switch_mirage_unix"; + cs_name = "ofswitch_lwt"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "mirage", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; + bs_build = [(OASISExpr.EBool true, false)]; + bs_install = [(OASISExpr.EBool true, true)]; bs_path = "switch"; bs_compiled_object = Native; - bs_build_depends = [InternalLibrary "openflow"]; + bs_build_depends = + [ + InternalLibrary "openflow"; + InternalLibrary "switch"; + FindlibPackage ("tuntap", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6125,14 +6173,10 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - { - exec_custom = true; - exec_main_is = "basic_switch.ml"; - exec_target = None; - }); + {exec_custom = true; exec_main_is = "lwt_switch.ml"; }); Executable ({ - cs_name = "learning_switch_mirage"; + cs_name = "ofswitch"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6140,19 +6184,15 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "mirage", - OASISExpr.EFlag "xen"), - true) + (OASISExpr.EFlag "xen", true) ]; bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "controller"; - bs_compiled_object = Native; + bs_path = "switch"; + bs_compiled_object = Native_object; bs_build_depends = [ - FindlibPackage ("cstruct", None); - FindlibPackage ("cstruct.syntax", None); - InternalLibrary "openflow" + InternalLibrary "openflow"; + FindlibPackage ("re.str", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6164,14 +6204,10 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - { - exec_custom = true; - exec_main_is = "learning_switch.ml"; - exec_target = Some "xen"; - }); + {exec_custom = false; exec_main_is = "xen_switch.ml"; }); Executable ({ - cs_name = "basic_switch_mirage"; + cs_name = "ofcontroller"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6179,15 +6215,16 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "mirage", - OASISExpr.EFlag "xen"), - true) + (OASISExpr.EFlag "xen", true) ]; bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "switch"; - bs_compiled_object = Native; - bs_build_depends = [InternalLibrary "openflow"]; + bs_path = "controller"; + bs_compiled_object = Native_object; + bs_build_depends = + [ + InternalLibrary "openflow"; + FindlibPackage ("re.str", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6198,19 +6235,16 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - { - exec_custom = true; - exec_main_is = "basic_switch.ml"; - exec_target = Some "xen"; - }) + {exec_custom = false; exec_main_is = "xen_controller.ml"; + }) ]; - plugins = [(`Extra, "META", Some "0.2")]; + plugins = [(`Extra, "META", Some "0.3")]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "\021º*\158\132\029Ôì´z·Æ&\0010"; + oasis_digest = Some "\004\143t\131\247\170^h\230d\b\132-\211\201P"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6218,6 +6252,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6222 "setup.ml" +# 6256 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index 76485e4..2629004 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -19,37 +19,55 @@ open Printf open Net open Net.Nettypes +let resolve t = Lwt.on_success t (fun _ -> ()) + +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event +open Ofswitch + +let pp = Printf.printf +let sp = Printf.sprintf + (**************************************************************** * OpenFlow Switch configuration *****************************************************************) - -let print_time () = - while_lwt true do - OS.Time.sleep 10.0 >> - return (printf "%03.6f: process running..\n%!" (OS.Clock.time ())) - done - -let switch_run () = - let sw = Ofswitch.create_switch () in - try_lwt - Manager.create ~devs:3 - (fun mgr interface id -> - match (Manager.get_intf_name mgr id) with - | "tap0" -> - let ip = - (ipv4_addr_of_tuple (10l,0l,0l,1l), - ipv4_addr_of_tuple (255l,255l,255l,0l), []) in - lwt _ = Manager.configure interface (`IPv4 ip) in - let dst_ip = ipv4_addr_of_tuple (10l,0l,0l,2l) in - lwt _ = (Ofswitch.listen sw mgr (None, 6633) <&> - (print_time ())) in - return () - | _ -> - return (Ofswitch.add_port mgr sw id) - ) +let switch_run () = +(* let delay = {flow_insert=0.; flow_update=0.; pktin_rate=50.; pktin_delay=0.002; + stats_delay=0.; pktout_delay=0.;} in *) + let model = Ofswitch_model.( + {flow_insert=0.002; + flow_update=0.002; pktin_rate=18.; pktin_delay=0.002;stats_delay=0.; + pktout_delay=0.;}) in + let sw = create_switch 0x100L (* model *) in + let use_mac = ref true in + try_lwt + Manager.create (fun mgr interface id -> + match (OS.Netif.string_of_id id) with + | "tap0" + | "0" -> + lwt _ = OS.Time.sleep 5.0 in + let _ = printf "connecting switch...\n%!" in + let ip = Ipaddr.V4.(make 10l 20l 0l 100l, Prefix.mask 24, []) in + lwt _ = Manager.configure interface (`IPv4 ip) in + let dst_ip = Ipaddr.V4.make 10l 20l 0l 4l in + standalone_connect sw mgr (dst_ip, 6633) + | str_id -> +(* let find dev = + try + let _ = Re_str.search_forward (Re_str.regexp "tap") dev 0 in true + with Not_found -> false + in + lwt _ = + if (not (find str_id) ) then + lwt _ = add_port mgr ~use_mac:(!use_mac) sw id in + return (use_mac := false) + else *) + add_port mgr ~use_mac:false sw id +(* in + return () *) + ) with e -> Printf.eprintf "Error: %s" (Printexc.to_string e); return () - -let _ = OS.Main.run(switch_run ()) diff --git a/switch/lwt_switch.ml b/switch/lwt_switch.ml new file mode 100644 index 0000000..9962cfc --- /dev/null +++ b/switch/lwt_switch.ml @@ -0,0 +1,29 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * 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 _ = OS.Main.run( + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap0" () in +(* let _ = Tuntap.set_ipv4 ~devname:("tap0") ~ipv4:"10.20.0.1" + ~netmask:"255.255.255.0" () in *) + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap1" () in + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap2" () in + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + Basic_switch.switch_run () + ) diff --git a/switch/xen_switch.ml b/switch/xen_switch.ml new file mode 100644 index 0000000..8d3e363 --- /dev/null +++ b/switch/xen_switch.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * 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 _ = OS.Main.run(Basic_switch.switch_run ())