├── .exrc ├── .gitignore ├── .merlin ├── .ocp-indent ├── CHANGES ├── Makefile ├── README.md ├── TESTING.md ├── USAGE.md ├── _oasis ├── _tags ├── controller ├── learning_switch.ml ├── lwt_controller.ml └── xen_controller.ml ├── lib ├── META ├── bitv.ml ├── bitv.mli ├── blocks.ml ├── components.ml ├── components.mli ├── flowvisor.ml ├── flowvisor.mli ├── flowvisor_topology.ml ├── flowvisor_topology.mli ├── flv.mlpack ├── heap.ml ├── heap.mli ├── imperative.ml ├── imperative.mli ├── lldp.ml ├── lldp.mli ├── ofcontroller.ml ├── ofcontroller.mli ├── ofpacket.ml ├── ofpacket.mli ├── ofsocket.ml ├── ofsocket.mli ├── ofswitch.ml ├── ofswitch.mli ├── ofswitch_config.ml ├── ofswitch_config.mli ├── ofswitch_ctrl.ml ├── ofswitch_model.ml ├── ofswitch_model.mli ├── ofswitch_standalone.ml ├── ofswitch_standalone.mli ├── openflow.mlpack ├── openflow.odocl ├── path.ml ├── path.mli ├── sig.mli ├── switch.mlpack ├── switch_model.mlpack ├── util.ml └── util.mli ├── myocamlbuild.ml ├── setup.ml └── switch ├── basic_switch.ml ├── lwt_switch.ml └── xen_switch.ml /.exrc: -------------------------------------------------------------------------------- 1 | if &cp | set nocp | endif 2 | let s:cpo_save=&cpo 3 | set cpo&vim 4 | inoremap (neocomplcache_start_omni_complete)  5 | inoremap (neocomplcache_start_auto_complete_no_select)  6 | inoremap (neocomplcache_start_auto_complete) =neocomplcache#mappings#popup_post() 7 | inoremap (neocomplcache_start_unite_quick_match) unite#sources#neocomplcache#start_quick_match() 8 | inoremap (neocomplcache_start_unite_complete) unite#sources#neocomplcache#start_complete() 9 | inoremap neocomplcache#smart_close_popup()."\" 10 | noremap  h 11 | nmap  :NERDTreeToggle 12 | noremap j 13 | noremap  k 14 | noremap  l 15 | nmap OD h 16 | nmap OC l 17 | nmap OB j 18 | nmap OA k 19 | vnoremap = :call OcpIndentRange() 20 | map == :call OcpIndentRange() 21 | xmap S VSurround 22 | nmap [xx unimpaired_line_xml_encode 23 | xmap [x unimpaired_xml_encode 24 | nmap [x unimpaired_xml_encode 25 | nmap [uu unimpaired_line_url_encode 26 | xmap [u unimpaired_url_encode 27 | nmap [u unimpaired_url_encode 28 | nmap [yy unimpaired_line_string_encode 29 | xmap [y unimpaired_string_encode 30 | nmap [y unimpaired_string_encode 31 | nmap [p unimpairedPutAbove 32 | nnoremap [ox :set cursorline cursorcolumn 33 | nnoremap [ow :set wrap 34 | nnoremap [os :set spell 35 | nnoremap [or :set relativenumber 36 | nnoremap [on :set number 37 | nnoremap [ol :set list 38 | nnoremap [oi :set ignorecase 39 | nnoremap [oh :set hlsearch 40 | nnoremap [od :diffthis 41 | nnoremap [ou :set cursorcolumn 42 | nnoremap [oc :set cursorline 43 | xmap [e unimpairedMoveUp 44 | nmap [e unimpairedMoveUp 45 | nmap [ unimpairedBlankUp 46 | omap [n unimpairedContextPrevious 47 | nmap [n unimpairedContextPrevious 48 | nmap [o unimpairedOPrevious 49 | nmap [f unimpairedDirectoryPrevious 50 | nmap [T unimpairedTFirst 51 | nmap [t unimpairedTPrevious 52 | nmap [ unimpairedQPFile 53 | nmap [Q unimpairedQFirst 54 | nmap [q unimpairedQPrevious 55 | nmap [ unimpairedLPFile 56 | nmap [L unimpairedLFirst 57 | nmap [l unimpairedLPrevious 58 | nmap [B unimpairedBFirst 59 | nmap [b unimpairedBPrevious 60 | nmap [A unimpairedAFirst 61 | nmap [a unimpairedAPrevious 62 | nnoremap \i :call OcpIndentBuffer() 63 | vnoremap \i :call OcpIndentRange() 64 | vmap \t :call Ocaml_print_type("visual") `< 65 | nmap \t :call Ocaml_print_type("normal") 66 | omap \t :call Ocaml_print_type("normal") 67 | map \S :call OCaml_switch(1) 68 | map \s :call OCaml_switch(0) 69 | nmap \\u CommentaryUndo 70 | nmap \\\ CommentaryLine 71 | nmap \\ Commentary 72 | xmap \\ Commentary 73 | map \bta :!/usr/local/bin/ctags -R . 74 | map \ta :TlistToggle 75 | nmap ]xx unimpaired_line_xml_decode 76 | xmap ]x unimpaired_xml_decode 77 | nmap ]x unimpaired_xml_decode 78 | nmap ]uu unimpaired_line_url_decode 79 | xmap ]u unimpaired_url_decode 80 | nmap ]u unimpaired_url_decode 81 | nmap ]yy unimpaired_line_string_decode 82 | xmap ]y unimpaired_string_decode 83 | nmap ]y unimpaired_string_decode 84 | nmap ]p unimpairedPutBelow 85 | nnoremap ]ox :set nocursorline nocursorcolumn 86 | nnoremap ]ow :set nowrap 87 | nnoremap ]os :set nospell 88 | nnoremap ]or :set norelativenumber 89 | nnoremap ]on :set nonumber 90 | nnoremap ]ol :set nolist 91 | nnoremap ]oi :set noignorecase 92 | nnoremap ]oh :set nohlsearch 93 | nnoremap ]od :diffoff 94 | nnoremap ]ou :set nocursorcolumn 95 | nnoremap ]oc :set nocursorline 96 | xmap ]e unimpairedMoveDown 97 | nmap ]e unimpairedMoveDown 98 | nmap ] unimpairedBlankDown 99 | omap ]n unimpairedContextNext 100 | nmap ]n unimpairedContextNext 101 | nmap ]o unimpairedONext 102 | nmap ]f unimpairedDirectoryNext 103 | nmap ]T unimpairedTLast 104 | nmap ]t unimpairedTNext 105 | nmap ] unimpairedQNFile 106 | nmap ]Q unimpairedQLast 107 | nmap ]q unimpairedQNext 108 | nmap ] unimpairedLNFile 109 | nmap ]L unimpairedLLast 110 | nmap ]l unimpairedLNext 111 | nmap ]B unimpairedBLast 112 | nmap ]b unimpairedBNext 113 | nmap ]A unimpairedALast 114 | nmap ]a unimpairedANext 115 | nnoremap cox :set =&cursorline && &cursorcolumn ? 'nocursorline nocursorcolumn' : 'cursorline cursorcolumn'  116 | nnoremap cod :=&diff ? 'diffoff' : 'diffthis'  117 | nmap cs Csurround 118 | nmap ds Dsurround 119 | nmap gx NetrwBrowseX 120 | nmap gcu CommentaryUndo 121 | nmap gcc CommentaryLine 122 | nmap gc Commentary 123 | xmap gc Commentary 124 | xmap gS VgSurround 125 | nmap ySS YSsurround 126 | nmap ySs YSsurround 127 | nmap yss Yssurround 128 | nmap yS YSurround 129 | nmap ys Ysurround 130 | nnoremap NetrwBrowseX :call netrw#NetrwBrowseX(expand(""),0) 131 | nnoremap (vimshell_create) :VimShellCreate 132 | nnoremap (vimshell_switch) :VimShell 133 | xnoremap unimpairedMoveDown :exe 'exe "normal! m`"|''<,''>move''>+'.v:count1 `` 134 | xnoremap unimpairedMoveUp :exe 'exe "normal! m`"|''<,''>move--'.v:count1 `` 135 | nmap unimpairedOPrevious unimpairedDirectoryPrevious:echohl WarningMSG|echo "[o is deprecated. Use [f"|echohl NONE 136 | nmap unimpairedONext unimpairedDirectoryNext:echohl WarningMSG|echo "]o is deprecated. Use ]f"|echohl NONE 137 | nnoremap unimpairedTLast :exe "".(v:count ? v:count : "")."tlast" 138 | nnoremap unimpairedTFirst :exe "".(v:count ? v:count : "")."tfirst" 139 | nnoremap unimpairedTNext :exe "".(v:count ? v:count : "")."tnext" 140 | nnoremap unimpairedTPrevious :exe "".(v:count ? v:count : "")."tprevious" 141 | nnoremap unimpairedQNFile :exe "".(v:count ? v:count : "")."cnfile" 142 | nnoremap unimpairedQPFile :exe "".(v:count ? v:count : "")."cpfile" 143 | nnoremap unimpairedQLast :exe "".(v:count ? v:count : "")."clast" 144 | nnoremap unimpairedQFirst :exe "".(v:count ? v:count : "")."cfirst" 145 | nnoremap unimpairedQNext :exe "".(v:count ? v:count : "")."cnext" 146 | nnoremap unimpairedQPrevious :exe "".(v:count ? v:count : "")."cprevious" 147 | nnoremap unimpairedLNFile :exe "".(v:count ? v:count : "")."lnfile" 148 | nnoremap unimpairedLPFile :exe "".(v:count ? v:count : "")."lpfile" 149 | nnoremap unimpairedLLast :exe "".(v:count ? v:count : "")."llast" 150 | nnoremap unimpairedLFirst :exe "".(v:count ? v:count : "")."lfirst" 151 | nnoremap unimpairedLNext :exe "".(v:count ? v:count : "")."lnext" 152 | nnoremap unimpairedLPrevious :exe "".(v:count ? v:count : "")."lprevious" 153 | nnoremap unimpairedBLast :exe "".(v:count ? v:count : "")."blast" 154 | nnoremap unimpairedBFirst :exe "".(v:count ? v:count : "")."bfirst" 155 | nnoremap unimpairedBNext :exe "".(v:count ? v:count : "")."bnext" 156 | nnoremap unimpairedBPrevious :exe "".(v:count ? v:count : "")."bprevious" 157 | nnoremap unimpairedALast :exe "".(v:count ? v:count : "")."last" 158 | nnoremap unimpairedAFirst :exe "".(v:count ? v:count : "")."first" 159 | nnoremap unimpairedANext :exe "".(v:count ? v:count : "")."next" 160 | nnoremap unimpairedAPrevious :exe "".(v:count ? v:count : "")."previous" 161 | nnoremap SurroundRepeat . 162 | nnoremap :call UpdateTags() 163 | inoremap  neocomplcache#cancel_popup() 164 | imap S ISurround 165 | imap s Isurround 166 | inoremap  neocomplcache#undo_completion() 167 | inoremap  neocomplcache#smart_close_popup()."\" 168 | inoremap  pumvisible() ? "\" : "\ " 169 | inoremap  neocomplcache#complete_common_string() 170 | imap  Isurround 171 | inoremap  neocomplcache#close_popup() 172 | imap OD hi 173 | imap OC li 174 | imap OB ji 175 | imap OA ki 176 | let &cpo=s:cpo_save 177 | unlet s:cpo_save 178 | set autoindent 179 | set autoread 180 | set backspace=2 181 | set completefunc=neocomplcache#complete#manual_complete 182 | set completeopt=menuone 183 | set noequalalways 184 | set expandtab 185 | set fileencodings=ucs-bom,utf-8,default,latin1 186 | set helplang=en 187 | set history=50 188 | set hlsearch 189 | set ignorecase 190 | set incsearch 191 | set laststatus=2 192 | set omnifunc=merlin#Complete 193 | set printoptions=paper:a4 194 | set ruler 195 | 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 196 | set shiftwidth=2 197 | set smartcase 198 | set smarttab 199 | set softtabstop=2 200 | set statusline=\ %{HasPaste()}%<%-15.25(%f%)%m%r%h\ %w\ \ \ \ \ [%{&ff}/%Y]\ \ \ %<%20.30(%{hostname()}:%{CurDir()}%)\ %=%-10.(%l,%c%V%)\ %p%%/%L 201 | set suffixes=.bak,~,.swp,.o,.info,.aux,.log,.dvi,.bbl,.blg,.brf,.cb,.ind,.idx,.ilg,.inx,.out,.toc 202 | set textwidth=80 203 | set timeoutlen=500 204 | set title 205 | set titlestring=%F\ -\ Vim 206 | set updatetime=1500 207 | 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 208 | " vim: set ft=vim : 209 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | _build/ 3 | setup.data 4 | setup.log 5 | setup.bin 6 | *.docdir 7 | *.native 8 | *.byte 9 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt mirage mirage-net cstruct ipaddr 2 | S ./lib 3 | S ./controller 4 | S ./switch 5 | B _build/lib 6 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | syntax = lwt 2 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | ===== 0.3.0 (04-Sep-2012) ===== 2 | 3 | * Initial public release, with learning switch example. 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean distclean setup build doc install test 2 | all: build 3 | 4 | NAME=openflow 5 | J=4 6 | 7 | UNIX ?= $(shell if [ $(MIRAGE_OS) = "unix" ]; then echo --enable-unix; else echo --disable-unix; fi) 8 | DIRECT ?= $(shell if [ $(MIRAGE_NET) = "direct" ]; then echo --enable-direct; else echo --disable-direct; fi) 9 | XEN ?= $(shell if [ $(MIRAGE_OS) = "xen" ]; then echo --enable-xen; else echo --disable-xen; fi) 10 | caml_path ?= $(shell ocamlfind printconf path) 11 | 12 | # MIRAGE = --enable-mirage 13 | 14 | -include Makefile.config 15 | 16 | setup.ml: _oasis 17 | oasis setup 18 | 19 | setup.data: setup.ml 20 | ocaml setup.ml -configure $(UNIX) $(XEN) $(DIRECT) 21 | 22 | clean: setup.data 23 | ocaml setup.ml -clean $(OFLAGS) 24 | rm -f setup.data setup.log setup.ml 25 | 26 | distclean: setup.ml setup.data 27 | ocaml setup.ml -distclean $(OFLAGS) 28 | rm -f setup.data setup.log setup.ml 29 | 30 | setup: setup.data 31 | 32 | build: setup.data $(wildcard lib/*.ml) 33 | ocaml setup.ml -build -cflags -bin-annot -j $(J) $(OFLAGS) $(DR) 34 | ifeq ($(MIRAGE_OS), xen) 35 | ld -d -nostdlib -m elf_x86_64 -T $(caml_path)/mirage-xen/mirage-x86_64.lds \ 36 | $(caml_path)/mirage-xen/x86_64.o _build/switch/xen_switch.nobj.o \ 37 | $(caml_path)/mirage-xen/libocaml.a $(caml_path)/mirage-xen/libxen.a \ 38 | $(caml_path)/mirage-xen/libxencaml.a $(caml_path)/mirage-xen/libdiet.a \ 39 | $(caml_path)/mirage-xen/libm.a $(caml_path)/mirage-xen/longjmp.o \ 40 | -o ofswitch.xen 41 | 42 | ld -d -nostdlib -m elf_x86_64 -T $(caml_path)/mirage-xen/mirage-x86_64.lds \ 43 | $(caml_path)/mirage-xen/x86_64.o _build/controller/xen_controller.nobj.o \ 44 | $(caml_path)/mirage-xen/libocaml.a $(caml_path)/mirage-xen/libxen.a \ 45 | $(caml_path)/mirage-xen/libxencaml.a $(caml_path)/mirage-xen/libdiet.a \ 46 | $(caml_path)/mirage-xen/libm.a $(caml_path)/mirage-xen/longjmp.o \ 47 | -o ofcontroller.xen 48 | 49 | endif 50 | 51 | doc: setup.data setup.ml 52 | ocaml setup.ml -doc -j $(J) $(OFLAGS) 53 | 54 | install: 55 | ocamlfind remove $(NAME) 56 | ocaml setup.ml -install $(OFLAGS) 57 | 58 | test: build 59 | ocaml setup.ml -test 60 | 61 | 62 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Mirage OpenFlow Implementation 2 | ============================== 3 | 4 | OpenFlow is a switching standard and open protocol enabling 5 | distributed control of the flow tables contained within Ethernet 6 | switches in a network. Each OpenFlow switch has three parts: 7 | 8 | + A **datapath**, containing a *flow table*, associating set of 9 | *actions* with each flow entry; 10 | + A **secure channel**, connecting to a controller; and 11 | + The **OpenFlow protocol**, used by the controller to talk to 12 | switches. 13 | 14 | Following this standard model, the implementation comprises three parts: 15 | 16 | * `Openflow` library, contains a complete parsing library in pure Ocaml and a 17 | minimal controller library using an event-driven model. 18 | * `Openflow.switch` library, provides a skeleton OpenFlow switch supporting most 19 | elementary switch functionality. 20 | * `Openflow.flv` library, implements a basic FLowVisor reimplementation in 21 | ocaml. 22 | 23 | __N.B.__ _There are two versions of the OpenFlow protocol: v1.0.0 (`0x01` on 24 | the wire) and v1.1.0 (`0x02` on the wire). The implementation supports wire 25 | protocol `0x01` as this is what is implemented in [Open vSwitch][ovs-1.2], 26 | used for debugging._ 27 | 28 | Openflow.Ofpacket 29 | ----------- 30 | 31 | The file begins with some utility functions, operators, types. The 32 | bulk of the code is organised following the v1.0.0 33 | [protocol specification][of-1.0], as implemented by 34 | [Open vSwitch v1.2][ovs-1.2]. Each set of messages is contained 35 | within its own module, most of which contain a type `t` representing 36 | the entity named by the module, plus relevant parsers to convert a 37 | bitstring to a type (`parse_*`) and pretty printers for the type 38 | (`string_of_*`). At the end of the file, in the root `Ofpacket` 39 | module scope, are definitions for interacting with the protocol as a 40 | whole, e.g., error codes, OpenFlow message types and standard header, 41 | root OpenFlow parser, OpenFlow packet builders. 42 | 43 | ### Queue, Port, Switch 44 | 45 | The `Queue` module is really a placeholder currently. OpenFlow 46 | defines limited quality-of-service support via a simple queueing 47 | mechanism. Flows are mapped to queues attached to ports, and each 48 | queue is then configured as desired. The specification currently 49 | defines just a minimum rate, although specific implementations may 50 | provide more. 51 | 52 | The `Port` module wraps several port related elements: 53 | 54 | + _t_, where that is either simply the index of the port in the 55 | switch, or the special indexes (> 0xff00) representing the 56 | controller, flooding, etc. 57 | + _config_, a specific port's configuration (up/down, STP 58 | supported, etc). 59 | + _features_, a port's feature set (rate, fiber/copper, 60 | etc). 61 | + _state_, a port's current state (up/down, STP learning mode, etc). 62 | + _phy_, a port's physical details (index, address, name, etc). 63 | + _stats_, current statistics of the port (packet and byte counters, 64 | collisions, etc). 65 | + _reason_ and _status_, for reporting changes to a port's 66 | configuration; _reason_ is one of `ADD|DEL|MOD`. 67 | 68 | Finally, `Switch` wraps elements pertaining to a whole switch, that is 69 | a collection of ports, tables (including the _group table_), and the 70 | connection to the controller. 71 | 72 | + _capabilities_, the switch's capabilities in terms of supporting IP 73 | fragment reassembly, various statistics, etc. 74 | + _action_, the types of action the switch's ports support (setting 75 | various fields, etc). 76 | + _features_, the switch's id, number of buffers, tables, port list etc. 77 | + _config_, for masking against handling of IP fragments: no special 78 | handling, drop, reassemble. 79 | 80 | ### Wildcards, Match, Flow 81 | 82 | The `Wildcards` and `Match` modules both simply wrap types 83 | respectively representing the fields to wildcard in a flow match, and 84 | the flow match specification itself. 85 | 86 | The `Flow` module then contains structures representing: 87 | 88 | + _t_, the flow itself (its age, activity, priority, etc); and 89 | + _stats_, extended statistics association with a flow identified by a 90 | 64 bit `cookie`. 91 | 92 | ### Packet_in, Packet_out 93 | 94 | These represent messages associated with receipt or transmission of a 95 | packet in response to a controller initiated action. 96 | 97 | `Packet_in` is used where a packet arrives at the switch and is 98 | forwarded to the controller, either due to lack of matching entry, or 99 | an explicit action. 100 | 101 | `Packet_out` contains the structure used by the controller to indicate 102 | to the switch that a packet it has been buffering must now have some 103 | actions performed on it, typically culminating in it being forward out 104 | of one or more ports. 105 | 106 | ### Flow_mod, Port_mod 107 | 108 | These represent modification messages to existing flow and port state 109 | in the switch. 110 | 111 | ### Stats 112 | 113 | Finally, the `Stats` module contains structures representing the 114 | different statistics messages available through OpenFlow, as well as 115 | the request and response messages that transport them. 116 | 117 | [of-1.0]: http://www.openflow.org/documents/openflow-spec-v1.0.0.pdf 118 | [of-1.1]: http://www.openflow.org/documents/openflow-spec-v1.1.0.pdf 119 | [ovs-1.2]: http://openvswitch.org/releases/openvswitch-1.2.2.tar.gz 120 | 121 | Openflow.Ofsocket 122 | ------------- 123 | 124 | A simple module to create an openflow channel abstraction over a serires of 125 | different transport mechanisms. At the moment the library contains support of 126 | Channel.t connections and Lwt_stream streams. The protocol ensures to read from 127 | the socket full Openflow pdus and transform them to appropriate Ofpacket 128 | structures. 129 | 130 | Openflow.Ofontroller 131 | ------------- 132 | 133 | Initially modelled after [NOX][], this is a skeleton controller 134 | that provides a simple event based wrapper around the OpenFlow 135 | protocol. It currently provides the minimal set of events 136 | corresponding to basic switch operation: 137 | 138 | + `DATAPATH_JOIN`, representing the connection of a datapath to the 139 | controller, i.e., notification of the existence of a switch. 140 | + `DATAPATH_LEAVE`, representing the disconnection of a datapath from 141 | the controller, i.e., notification of the destruction of a switch. 142 | + `PACKET_IN`, representing the forwarding of a packet to the 143 | controller, whether through an explicit action corresponding to a 144 | flow match, or simply as the default when flow match is found. 145 | + `FLOW_REMOVED`, i.e., representing the switch notification regarding the 146 | removal of a flow from the flow table. 147 | + `FLOW_STATS_REPLY`, i.e., represents the replies transmitted by the switch 148 | after a flow_stats_req. 149 | + `AGGR_FLOW_STATS_REPLY`, i.e., representing the reply transmitted by the switch 150 | to an aggr_flow_stats_req. 151 | + ` DESC_STATS_REPLY`, i.e., representing the reply of a switch to desc_stats 152 | request. 153 | + `PORT_STATS_REPLY`, i.e., representing the replt of a switch to a port_stats 154 | request providing port level counter and the state of the switch. 155 | + `TABLE_STATS_REPLY`, i.e., representing the reply of a switch to a 156 | table_stats request. 157 | + `PORT_STATUS_REPLY`, i.e., representing the notification send by the switch 158 | when the state of a port of the switch is changed. 159 | 160 | The controller state is mutable and modelled as: 161 | 162 | + A list of callbacks per event, each taking the current state, the 163 | originating datapath, and the event; 164 | + Mappings from switch (`datapath_id`) to a Mirage communications 165 | channel (`Channel.t`); and 166 | 167 | The main work of the controller is carried out in `process_of_packet` 168 | which processes each received packet within the context given by the 169 | current state of the switch: this is where the OpenFlow state machine 170 | is implemented. 171 | 172 | The controller entry point is via the `listen`, `local_connect` or `connect` 173 | function which effectively creates a receiving channel to parse OpenFlow 174 | packets, and pass them to `process_of_packet` which handles a range of standard 175 | protocol-level interactions, e.g., `ECHO_REQ`, `FEATURES_RESP`, generating 176 | Mirage events as appropriate. Specifically, `controller` is passed as callback 177 | to the respective connection method, and recursively evaluates `read_packet` to 178 | read the incoming packet and pass it to `process_of_packet`. 179 | 180 | [nox]: http://noxrepo.org/ 181 | 182 | 183 | Openflow.Switch.Ofswitch 184 | --------- 185 | 186 | An OpenFlow _switch_ or _datapath_ consists of a _flow table_, a _group table_ 187 | (in later versions, not supported in v1.0.0), and a _channel_ back to the 188 | controller. Communication over the channel is via the OpenFlow protocol, and is 189 | how the controller manages the switch. 190 | 191 | In short, each table contains flow entries consisting of _match fields_, 192 | _counters_, and _instructions_ to apply to packets. Starting with the first 193 | flow table, if an incoming packet matches an entry, the counters are updated 194 | and the instructions carried out. If no entry in the first table matches, 195 | (part of) the packet is forwarded to the controller, or it is dropped, or it 196 | proceeds to the next flow table. 197 | 198 | At the current point the switch doesn't support any queue principles. 199 | 200 | Skeleton code is as follows: 201 | 202 | ### Entry 203 | 204 | Represents a single flow table entry. Each entry consists of: 205 | 206 | + _counters_, to keep statistics per-table, -flow, -port, -queue 207 | (`Entry.table_counter list`, `Entry.flow_counter list`, `Entry.port_counter 208 | list`, `Entry.queue_counter list`); and 209 | + _actions_, to perform on packets matching the fields (`Entry.action list`). 210 | 211 | ### Table 212 | 213 | A simple module representing a table of flow entries. Currently just an id 214 | (`tid`) , a hashtbl of entries (`(OP.Match.t, Entry.t) Hashtbl.t`), a list of 215 | exact match entries to reduce the lookup time for wildcard entries and a the 216 | table counter. 217 | 218 | ### Switch 219 | 220 | Encapsulating the switch (or datapath) itself. Currently defines a _port_ as: 221 | 222 | + _details_, a physical port configuration (`Ofpacket.Port.phy`); and 223 | + _device_, some handle to the physical device (mocked out as a `string`). 224 | 225 | The switch is then modelled as: 226 | 227 | + _ports_, a list of physical ports (`Switch.port list`); 228 | + _table_, the table of flow entries for this switch; 229 | + _stats_, a set of per-switch counters (`Switch.stats`); and 230 | + *p_sflow*, the probability in use when sFlow sampling. 231 | 232 | Note that the vocabulary of a number of these changes with v1.1.0, in addition 233 | to the table structure becoming more complex (support for chains of tables, 234 | forwarding to tables, and the group table). 235 | 236 | Questions/Notes 237 | --------------- 238 | 239 | What's the best way to structure the controller so that application code can 240 | introduce generation and consumption of new events? NOX permits this within a 241 | single event-handling framework -- is this simply out-of-scope here, or should 242 | we have a separate event-based programming framework available, or is there a 243 | straightforward Ocaml-ish way to incorporate this into the OpenFlow 244 | Controller? 245 | 246 | What's the best way to expose parsing as a separate activity to reading data 247 | off the wire? Specifically, I'd really like to reuse functions from 248 | `Net.Ethif`, `Net.Ipv4`, etc to recover structure from the bitstring without 249 | need to have `OfPacket.Match.parse_from_raw_packet`. Previously I have found 250 | having parsers that return structured data and then wrapping up the packet 251 | structure as a nested type, e.g., `PCAP(pcaph, ETH(ethh, IPv4(iph, payload)))` 252 | or `...TCP(tcph, payload))))` worked well, permitting fairly natural pattern 253 | matching. The depth to which the packet was deumltiplexed was controlled by a 254 | parameter to the entry-point parser. 255 | 256 | The `Switch` design is almost certainly very inefficient, and needs working 257 | on. This is waiting on implementation -- although sketched out, waiting on 258 | network driver model to actually be able to get hold of physical devices and 259 | frames. When we can, also need to consider how to control packet parsing, and 260 | demultiplexing of frames for switching from frames comprising the TCP stream 261 | carrying the controller channel. Ideally, it would be transparent to have 262 | a `Channel` for the controller's OpenFlow messages _and_ a per-device frame 263 | handler for everything else. That is, Mirage would do the necessary 264 | demultiplexing -- but only what's necessary -- passing non-OpenFlow frames to 265 | the switch to be matched, but reassembling the TCP flow carrying the 266 | controller's OpenFlow traffic. 267 | -------------------------------------------------------------------------------- /TESTING.md: -------------------------------------------------------------------------------- 1 | Mirage OpenFlow Implementation 2 | ============================== 3 | 4 | This setup describes using VirtualBox on OSX with Ubuntu images. 5 | 6 | 7 | OSX Setup 8 | --------- 9 | 10 | 1. Manually configure `en3` on OSX to `172.16.0.1/255.255.255.0`. 11 | 12 | 2. Setup `bootpd` on OSX: `sudo /bin/launchctl load -w /System/Library/LaunchDaemons/bootps.plist` 13 | 14 | To unload: `sudo /bin/launchctl unload -w /System/Library/LaunchDaemons/bootps.plist` 15 | 16 | 3. Create `/etc/bootpd.plist`: 17 | 18 | ```xml 19 | 20 | 21 | 22 | 23 | Subnets 24 | 25 | 26 | allocate 27 | 28 | lease_max 29 | 86400 30 | lease_min 31 | 86400 32 | name 33 | 172.16.0 34 | net_address 35 | 172.16.0.0 36 | net_mask 37 | 255.255.255.0 38 | net_range 39 | 40 | 172.16.0.2 41 | 172.16.0.254 42 | 43 | 44 | 45 | bootp_enabled 46 | 47 | detect_other_dhcp_server 48 | 49 | dhcp_enabled 50 | 51 | en3 52 | 53 | reply_threshold_seconds 54 | 0 55 | 56 | 57 | ``` 58 | 59 | 4. Create `/etc/bootptab`, eg., 60 | 61 | ``` 62 | %% 63 | # machine entries have the following format: 64 | # 65 | # hostname hwtype hwaddr ipaddr bootfile 66 | greyjay-ubuntu-1 1 08:00:27:38:72:c6 172.16.0.11 67 | greyjay-ubuntu-2 1 08:00:27:11:dd:a0 172.16.0.12 68 | ``` 69 | 70 | VirtualBox setup 71 | ---------------- 72 | 73 | 1. Build two Ubuntu 10.04 LTS server (64 bit) image. 74 | 75 | 2. Set each VM to have two adaptors: 76 | + `eth0` bridged connected to `en1` (or `en0`) 77 | + `eth1` bridged connected to `en3` 78 | 79 | 80 | Ubuntu setup 81 | ------------ 82 | 83 | 1. Set ssh keys and adjust `sshd_config` setting to disallow passwords. 84 | 85 | 2. Install packages required to build Open vSwitch et al 86 | 87 | ``` 88 | apt-get install openssh-server git-core build-essential \ 89 | autoconf libtool pkg-config libboost1.40-all-dev \ 90 | libssl-dev swig 91 | ``` 92 | 93 | 3. Pull and build Open vSwitch: 94 | 95 | ``` 96 | git clone git://openvswitch.org/openvswitch 97 | cd openvswitch/ 98 | ./boot.sh 99 | ./configure --with-linux=/lib/modules/`uname -r`/build 100 | make -j6 101 | make && sudo make install 102 | cd .. 103 | ``` 104 | and NOX: 105 | 106 | ``` 107 | git clone git://noxrepo.org/nox 108 | cd nox 109 | ./boot.sh 110 | ../configure 111 | make -j5 112 | ``` 113 | 114 | 4. Install the kernel module: `sudo insmod ~/openvswitch/datapath/linux/openvswitch_mod.ko` 115 | 116 | 5. Setup Open vSwitch: 117 | 118 | ``` 119 | sudo ovsdb-server ./openvswitch/ovsdb.conf --remote=punix:/var/run/ovsdb-server 120 | ovsdb-tool create ovsdb.conf vswitchd/vswitch.ovsschema 121 | sudo ovs-vswitchd unix:/var/run/ovsdb-server 122 | sudo ovs-vsctl --db=unix:/var/run/ovsdb-server init 123 | sudo ovs-vsctl --db=unix:/var/run/ovsdb-server add-br dp0 124 | sudo ovs-vsctl --db=unix:/var/run/ovsdb-server set-fail-mode dp0 secure 125 | sudo ovs-vsctl --db=unix:/var/run/ovsdb-server set-controller dp0 tcp:172.16.0.1:6633 126 | sudo ovs-vsctl --db=unix:/var/run/ovsdb-server add-port dp0 eth0 127 | ``` 128 | 129 | 6. Set IP addresses on the interfaces: 130 | 131 | ``` 132 | sudo ifconfig eth0 0.0.0.0 133 | sudo ifconfig dp0 134 | ``` 135 | -------------------------------------------------------------------------------- /USAGE.md: -------------------------------------------------------------------------------- 1 | API 2 | === 3 | 4 | The source code contains 3 main libraries: Openflow, Openflow.Switch and 5 | Openflow.Flv. 6 | 7 | The Openflow module contains all the code to parse, print and generate openflow 8 | messages, as well as, a basic openflow control platform. The ofcontroller 9 | implements an openflow controller library. The library is event driven. The 10 | programmer can access any openflow message by registering event callback during 11 | the init phase of the code for every connected switch. The parsing uses cstruct.t objects. 12 | 13 | The Openflow.Switch module implements an openflow switch. The module exposes a simple API through 14 | which a user can add and remove ports to the controller and run the default openflow 15 | processing switch functionality. In addition, the module contains an 16 | out-of-channel mechanism to modify the state of the switch using a json-rpc 17 | mechanism and insert, delete and view flow entries or enable or disable network 18 | ports. Finally, the switch provides a standalone mode, when the controller 19 | becomes unavailable, using a local learning switch logic, implemented in module 20 | Openflow.Switch.Ofswitch_standalone. Standalone functionality can be initiated 21 | through the Ofswitch.standalone_connect method. 22 | 23 | Additionally the library contains a small number of helper functions that enhance the 24 | functionality of openflow application. Ofswitch_config is a daemon that exposes a json 25 | API through which other apps can have configure the ports of the switch and access the 26 | content of the datapath table, using a simple tcp socket. Ofswitch_standalone is a minimum 27 | learning switch implementation over openflow that can be enabled on the switch module when 28 | no controller is accessible. 29 | 30 | The Openflow.Flv library reimplements the functionality provided by the flowvisor 31 | switch virtualisation software. FLowvisor is able to aggregate multiple switches 32 | and expose them to controller as a single switch, aggregating all the ports of 33 | the switches. The module provides elementary slicing 34 | functionality using wildcards. Additionally, the module implements a simple 35 | switch topology discovery mechanism using the lldp protocol. The functionality 36 | of this module is currently experimental and the library is not fully 37 | functional (e.g. OP.Port.Flood output actions are not supported by the module ). 38 | 39 | Programs 40 | ======= 41 | 42 | The source code of the library contains a number of small appliances that provide simple 43 | examples over the functionality of the library. 44 | 45 | lwt_switch 46 | ================ 47 | 48 | This is a unix backend implementation of an openflow switch. The application exposes both 49 | the json config web service and uses the standalone embedded controller. The application 50 | tries to connect to locahost in order to connect to controller and also run the json-based 51 | configuration daemon on port 6634. 52 | 53 | lwt_controller 54 | ========== 55 | 56 | An openflow controller that implements a simple openflow-based learning switch. 57 | The program listens on port 6633. 58 | 59 | ofswitch_ctrl 60 | ============ 61 | 62 | This is a simple implementation of a configuration client for the switch code. 63 | The application has a lot of similarities with the syntax of the ovs-vsctl code. 64 | Users can access and modify the state of the switch with the following command 65 | line parameters: 66 | 67 | * dump-flows intf tupple: this command will match all flows on the forwardign 68 | table of the switch and return a dump of the matching flows to the 69 | provided tupple. 70 | * del-flows intf tupple: delete matching flows. 71 | * add-flows intf tupple: adding a tupple to the flow table. 72 | * add-port intf network_device : adding a port under the control of the openflow switch. 73 | * del-port intf network_device : remove a port from the control of the switch. 74 | 75 | ofswitch.xen 76 | =============== 77 | 78 | A unikernel appliance of the lwt_switch for the xen backend. 79 | 80 | ofcontroller.xen 81 | ============== 82 | 83 | A unikernel application of the lwt_controller for the xen backend. 84 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.3 2 | OCamlVersion: >= 4.00.1 3 | Name: openflow 4 | Version: 0.3.0 5 | Authors: Charalampos Rotsos, Richard Mortier, Anil Madhavappedy, Balraj Singh 6 | License: ISC 7 | Synopsis: OpenFlow controller, switch and flowvisor implementation in pure OCaml 8 | Plugins: META (0.3) 9 | BuildTools: ocamlbuild 10 | 11 | Flag direct 12 | Description: build things over the direct xen net 13 | Default: false 14 | 15 | Flag unix 16 | Description: build programs with a depency on lwt.unix 17 | Default: false 18 | 19 | Flag xen 20 | Description: build xen applications 21 | Default: false 22 | 23 | Library openflow 24 | Path: lib 25 | Findlibname: openflow 26 | CompiledObject: native 27 | Modules: Ofpacket, Ofcontroller, Ofsocket 28 | Pack: True 29 | BuildDepends: ipaddr, cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0) 30 | 31 | Document openflow 32 | Title: OpenFlow docs 33 | Type: ocamlbuild (0.2) 34 | BuildTools+: ocamldoc 35 | XOCamlbuildPath: lib 36 | XOCamlbuildModules: Ofpacket, Ofcontroller, Ofsocket 37 | 38 | Library flv 39 | Path: lib 40 | Findlibname: flv 41 | Findlibparent: openflow 42 | CompiledObject: native 43 | Modules: Flowvisor, Lldp, Flowvisor_topology 44 | Pack: True 45 | 46 | Library switch 47 | Path: lib 48 | Findlibname: switch 49 | Findlibparent: openflow 50 | Build$: flag(direct) 51 | Install$: flag(direct) 52 | CompiledObject: native 53 | Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone 54 | Pack: True 55 | BuildDepends: re.str, tuntap 56 | 57 | Library switch_model 58 | Path: lib 59 | Findlibname: switch_model 60 | Findlibparent: openflow 61 | Build$: flag(direct) 62 | Install$: flag(direct) 63 | CompiledObject: native 64 | Modules: Ofswitch_model 65 | Pack: True 66 | BuildDepends: re.str, tuntap 67 | 68 | Executable ofcontroller_lwt 69 | Path: controller 70 | MainIs: lwt_controller.ml 71 | Build: false 72 | Custom: true 73 | CompiledObject: native 74 | Install$: flag(unix) 75 | BuildDepends: openflow,tuntap 76 | 77 | Executable ofswitch_lwt 78 | Path: switch 79 | MainIs: lwt_switch.ml 80 | Custom: true 81 | Build: false 82 | CompiledObject: native 83 | BuildDepends: openflow, openflow.switch,tuntap 84 | 85 | Executable ofswitch 86 | Path: switch 87 | MainIs: xen_switch.ml 88 | Build$: flag(xen) 89 | CompiledObject: native_object 90 | Install: false 91 | BuildDepends: openflow, re.str 92 | 93 | Executable ofcontroller 94 | Path: controller 95 | MainIs: xen_controller.ml 96 | Build$: flag(xen) 97 | CompiledObject: native_object 98 | Install: false 99 | BuildDepends: openflow, re.str 100 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 2e93c3b498a48aeea27e4bda67fc628e) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | <**/.svn>: -traverse 7 | <**/.svn>: not_hygienic 8 | ".bzr": -traverse 9 | ".bzr": not_hygienic 10 | ".hg": -traverse 11 | ".hg": not_hygienic 12 | ".git": -traverse 13 | ".git": not_hygienic 14 | "_darcs": -traverse 15 | "_darcs": not_hygienic 16 | # Library openflow 17 | "lib/openflow.cmxs": use_openflow 18 | "lib/ofpacket.cmx": for-pack(Openflow) 19 | "lib/ofcontroller.cmx": for-pack(Openflow) 20 | "lib/ofsocket.cmx": for-pack(Openflow) 21 | : pkg_ipaddr 22 | : pkg_cstruct 23 | : pkg_cstruct.syntax 24 | : pkg_rpclib 25 | : pkg_rpclib.json 26 | : pkg_mirage 27 | : pkg_mirage-net 28 | # Library flv 29 | "lib/flv.cmxs": use_flv 30 | "lib/flowvisor.cmx": for-pack(Flv) 31 | "lib/lldp.cmx": for-pack(Flv) 32 | "lib/flowvisor_topology.cmx": for-pack(Flv) 33 | # Library switch 34 | "lib/switch.cmxs": use_switch 35 | "lib/ofswitch.cmx": for-pack(Switch) 36 | "lib/ofswitch_config.cmx": for-pack(Switch) 37 | "lib/ofswitch_standalone.cmx": for-pack(Switch) 38 | # Library switch_model 39 | "lib/switch_model.cmxs": use_switch_model 40 | "lib/ofswitch_model.cmx": for-pack(Switch_model) 41 | : pkg_re.str 42 | : pkg_tuntap 43 | # Executable ofcontroller_lwt 44 | "controller/lwt_controller.native": use_openflow 45 | "controller/lwt_controller.native": pkg_tuntap 46 | "controller/lwt_controller.native": pkg_ipaddr 47 | "controller/lwt_controller.native": pkg_cstruct 48 | "controller/lwt_controller.native": pkg_cstruct.syntax 49 | "controller/lwt_controller.native": pkg_rpclib 50 | "controller/lwt_controller.native": pkg_rpclib.json 51 | "controller/lwt_controller.native": pkg_mirage 52 | "controller/lwt_controller.native": pkg_mirage-net 53 | : pkg_tuntap 54 | "controller/lwt_controller.native": custom 55 | # Executable ofswitch_lwt 56 | "switch/lwt_switch.native": use_openflow 57 | "switch/lwt_switch.native": use_switch 58 | "switch/lwt_switch.native": pkg_re.str 59 | "switch/lwt_switch.native": pkg_tuntap 60 | "switch/lwt_switch.native": pkg_ipaddr 61 | "switch/lwt_switch.native": pkg_cstruct 62 | "switch/lwt_switch.native": pkg_cstruct.syntax 63 | "switch/lwt_switch.native": pkg_rpclib 64 | "switch/lwt_switch.native": pkg_rpclib.json 65 | "switch/lwt_switch.native": pkg_mirage 66 | "switch/lwt_switch.native": pkg_mirage-net 67 | : use_switch 68 | : pkg_tuntap 69 | "switch/lwt_switch.native": custom 70 | # Executable ofswitch 71 | "switch/xen_switch.nobj.o": use_openflow 72 | "switch/xen_switch.nobj.o": pkg_re.str 73 | "switch/xen_switch.nobj.o": pkg_ipaddr 74 | "switch/xen_switch.nobj.o": pkg_cstruct 75 | "switch/xen_switch.nobj.o": pkg_cstruct.syntax 76 | "switch/xen_switch.nobj.o": pkg_rpclib 77 | "switch/xen_switch.nobj.o": pkg_rpclib.json 78 | "switch/xen_switch.nobj.o": pkg_mirage 79 | "switch/xen_switch.nobj.o": pkg_mirage-net 80 | : use_openflow 81 | : pkg_re.str 82 | : pkg_ipaddr 83 | : pkg_cstruct 84 | : pkg_cstruct.syntax 85 | : pkg_rpclib 86 | : pkg_rpclib.json 87 | : pkg_mirage 88 | : pkg_mirage-net 89 | # Executable ofcontroller 90 | "controller/xen_controller.nobj.o": use_openflow 91 | "controller/xen_controller.nobj.o": pkg_re.str 92 | "controller/xen_controller.nobj.o": pkg_ipaddr 93 | "controller/xen_controller.nobj.o": pkg_cstruct 94 | "controller/xen_controller.nobj.o": pkg_cstruct.syntax 95 | "controller/xen_controller.nobj.o": pkg_rpclib 96 | "controller/xen_controller.nobj.o": pkg_rpclib.json 97 | "controller/xen_controller.nobj.o": pkg_mirage 98 | "controller/xen_controller.nobj.o": pkg_mirage-net 99 | : use_openflow 100 | : pkg_re.str 101 | : pkg_ipaddr 102 | : pkg_cstruct 103 | : pkg_cstruct.syntax 104 | : pkg_rpclib 105 | : pkg_rpclib.json 106 | : pkg_mirage 107 | : pkg_mirage-net 108 | # OASIS_STOP 109 | true: annot 110 | : syntax_camlp4o 111 | : pkg_lwt.syntax 112 | : syntax_camlp4o 113 | : pkg_lwt.syntax 114 | : syntax_camlp4o 115 | : pkg_lwt.syntax 116 | : syntax_camlp4o 117 | : pkg_lwt.syntax 118 | true: bin_annot 119 | -------------------------------------------------------------------------------- /controller/learning_switch.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* Simple openflow controller that listens on port 6633 and replies 18 | with echo request on every packet_in event *) 19 | open Lwt 20 | open Printf 21 | open Net 22 | open Net.Nettypes 23 | 24 | let resolve t = Lwt.on_success t (fun _ -> ()) 25 | 26 | module OP = Openflow.Ofpacket 27 | module OC = Openflow.Ofcontroller 28 | module OE = Openflow.Ofcontroller.Event 29 | 30 | let pp = Printf.printf 31 | let sp = Printf.sprintf 32 | 33 | type mac_switch = { 34 | addr: Macaddr.t; 35 | switch: OP.datapath_id; 36 | } 37 | 38 | type switch_state = { 39 | mutable mac_cache: (Macaddr.t, OP.Port.t) Hashtbl.t; 40 | req_count: int ref; 41 | } 42 | 43 | let switch_data = 44 | { mac_cache = Hashtbl.create 2048; (* dpid = []; 45 | of_ctrl = []; *) req_count=(ref 0);} 46 | 47 | 48 | let datapath_join_cb controller dpid evt = 49 | let dp = 50 | match evt with 51 | | OE.Datapath_join (c, _) -> c 52 | | _ -> invalid_arg "bogus datapath_join event match!" 53 | in 54 | (* switch_data.dpid <- switch_data.dpid @ [dp]; *) 55 | return (pp "+ datapath:0x%012Lx\n" dp) 56 | 57 | let req_count = (ref 0) 58 | 59 | let packet_in_cb controller dpid evt = 60 | incr switch_data.req_count; 61 | let (in_port, buffer_id, data, dp) = 62 | match evt with 63 | | OE.Packet_in (inp, _, buf, dat, dp) -> (inp, buf, dat, dp) 64 | | _ -> invalid_arg "bogus datapath_join event match!" 65 | in 66 | (* Parse Ethernet header *) 67 | let m = OP.Match.raw_packet_to_match in_port data in 68 | 69 | (* Store src mac address and incoming port *) 70 | let ix = m.OP.Match.dl_src in 71 | let _ = Hashtbl.replace switch_data.mac_cache ix in_port in 72 | 73 | (* check if I know the output port in order to define what type of message 74 | * we need to send *) 75 | let ix = m.OP.Match.dl_dst in 76 | if ( (ix = Macaddr.broadcast) 77 | || (not (Hashtbl.mem switch_data.mac_cache ix)) ) 78 | then ( 79 | let bs = 80 | OP.marshal_and_sub 81 | ( OP.Packet_out.marshal_packet_out 82 | (OP.Packet_out.create 83 | ~buffer_id:buffer_id 84 | ~actions:[ OP.(Flow.Output(Port.All , 2000))] 85 | ~data:data ~in_port:in_port () )) (Cstruct.of_bigarray (OS.Io_page.get 1)) in 86 | OC.send_of_data controller dpid bs 87 | ) else ( 88 | let out_port = (Hashtbl.find switch_data.mac_cache ix) in 89 | let flags = OP.Flow_mod.({send_flow_rem=true; emerg=false; overlap=false;}) in 90 | lwt _ = 91 | if (buffer_id = -1l) then 92 | (* Need to send also the packet in cache the packet is not cached *) 93 | let bs = 94 | OP.marshal_and_sub 95 | ( OP.Packet_out.marshal_packet_out 96 | (OP.Packet_out.create 97 | ~buffer_id:buffer_id 98 | ~actions:[ OP.(Flow.Output(out_port, 2000))] 99 | ~data:data ~in_port:in_port () )) 100 | (Cstruct.of_bigarray (OS.Io_page.get 1)) in 101 | OC.send_of_data controller dpid bs 102 | else 103 | return () 104 | in 105 | let pkt = 106 | OP.marshal_and_sub 107 | ( OP.Flow_mod.marshal_flow_mod 108 | (OP.Flow_mod.create m 0_L OP.Flow_mod.ADD ~hard_timeout:0 109 | ~idle_timeout:0 ~buffer_id:(Int32.to_int buffer_id) ~flags 110 | [OP.Flow.Output(out_port, 2000)] ())) 111 | (Cstruct.of_bigarray (OS.Io_page.get 1)) in 112 | OC.send_of_data controller dpid pkt 113 | ) 114 | 115 | let init controller = 116 | pp "test controller register datapath cb\n"; 117 | OC.register_cb controller OE.DATAPATH_JOIN datapath_join_cb; 118 | pp "test controller register packet_in cb\n"; 119 | OC.register_cb controller OE.PACKET_IN packet_in_cb 120 | 121 | let port = 6633 122 | 123 | let run () = 124 | Net.Manager.create (fun mgr interface id -> 125 | try_lwt 126 | let ip = Ipaddr.V4.(make 10l 20l 0l 4l, Prefix.mask 24, []) in 127 | lwt _ = Manager.configure interface (`IPv4 ip) in 128 | OC.listen mgr ~verbose:true (None, port) init 129 | with | e -> 130 | return (Printf.eprintf "Unexpected exception : %s" (Printexc.to_string e)) 131 | ) 132 | 133 | -------------------------------------------------------------------------------- /controller/lwt_controller.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | 18 | let _ = OS.Main.run ( 19 | let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap9" () in 20 | let _ = Tuntap.set_ipv4 ~devname:("tap9") ~ipv4:"10.20.0.3" 21 | ~netmask:"255.255.255.0" () in 22 | let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in 23 | Learning_switch.run () 24 | 25 | ) 26 | 27 | -------------------------------------------------------------------------------- /controller/xen_controller.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let _ = OS.Main.run(Learning_switch.run ()) 18 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 27751d9b328e9b59d215c02667dc4f29) 3 | version = "0.3.0" 4 | description = 5 | "OpenFlow controller, switch and flowvisor implementation in pure OCaml" 6 | requires = 7 | "ipaddr cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net" 8 | archive(byte) = "openflow.cma" 9 | archive(byte, plugin) = "openflow.cma" 10 | archive(native) = "openflow.cmxa" 11 | archive(native, plugin) = "openflow.cmxs" 12 | exists_if = "openflow.cmxa" 13 | package "switch_model" ( 14 | version = "0.3.0" 15 | description = 16 | "OpenFlow controller, switch and flowvisor implementation in pure OCaml" 17 | requires = "re.str tuntap" 18 | archive(byte) = "switch_model.cma" 19 | archive(byte, plugin) = "switch_model.cma" 20 | archive(native) = "switch_model.cmxa" 21 | archive(native, plugin) = "switch_model.cmxs" 22 | exists_if = "switch_model.cmxa" 23 | ) 24 | 25 | package "switch" ( 26 | version = "0.3.0" 27 | description = 28 | "OpenFlow controller, switch and flowvisor implementation in pure OCaml" 29 | requires = "re.str tuntap" 30 | archive(byte) = "switch.cma" 31 | archive(byte, plugin) = "switch.cma" 32 | archive(native) = "switch.cmxa" 33 | archive(native, plugin) = "switch.cmxs" 34 | exists_if = "switch.cmxa" 35 | ) 36 | 37 | package "flv" ( 38 | version = "0.3.0" 39 | description = 40 | "OpenFlow controller, switch and flowvisor implementation in pure OCaml" 41 | archive(byte) = "flv.cma" 42 | archive(byte, plugin) = "flv.cma" 43 | archive(native) = "flv.cmxa" 44 | archive(native, plugin) = "flv.cmxs" 45 | exists_if = "flv.cmxa" 46 | ) 47 | # OASIS_STOP 48 | 49 | -------------------------------------------------------------------------------- /lib/bitv.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (*s {\bf Module Bitv}. 19 | This module implements bit vectors, as an abstract datatype [t]. 20 | Since bit vectors are particular cases of arrays, this module provides 21 | the same operations as the module [Array] (Sections~\ref{barray} 22 | up to \ref{earray}). It also provides bitwise operations 23 | (Section~\ref{bitwise}). In the following, [false] stands for the bit 0 24 | and [true] for the bit 1. *) 25 | 26 | type t 27 | 28 | (*s {\bf Creation, access and assignment.} \label{barray} 29 | [(Bitv.create n b)] creates a new bit vector of length [n], 30 | initialized with [b]. 31 | [(Bitv.init n f)] returns a fresh vector of length [n], 32 | with bit number [i] initialized to the result of [(f i)]. 33 | [(Bitv.set v n b)] sets the [n]th bit of [v] to the value [b]. 34 | [(Bitv.get v n)] returns the [n]th bit of [v]. 35 | [Bitv.length] returns the length (number of elements) of the given 36 | vector. *) 37 | 38 | val create : int -> bool -> t 39 | 40 | val init : int -> (int -> bool) -> t 41 | 42 | val set : t -> int -> bool -> unit 43 | 44 | val get : t -> int -> bool 45 | 46 | val length : t -> int 47 | 48 | (*s [max_length] is the maximum length of a bit vector (System dependent). *) 49 | 50 | val max_length : int 51 | 52 | (*s {\bf Copies and concatenations.} 53 | [(Bitv.copy v)] returns a copy of [v], 54 | that is, a fresh vector containing the same elements as 55 | [v]. [(Bitv.append v1 v2)] returns a fresh vector containing the 56 | concatenation of the vectors [v1] and [v2]. [Bitv.concat] is 57 | similar to [Bitv.append], but catenates a list of vectors. *) 58 | 59 | val copy : t -> t 60 | 61 | val append : t -> t -> t 62 | 63 | val concat : t list -> t 64 | 65 | (*s {\bf Sub-vectors and filling.} 66 | [(Bitv.sub v start len)] returns a fresh 67 | vector of length [len], containing the bits number [start] to 68 | [start + len - 1] of vector [v]. Raise [Invalid_argument 69 | "Bitv.sub"] if [start] and [len] do not designate a valid 70 | subvector of [v]; that is, if [start < 0], or [len < 0], or [start 71 | + len > Bitv.length a]. 72 | 73 | [(Bitv.fill v ofs len b)] modifies the vector [v] in place, 74 | storing [b] in elements number [ofs] to [ofs + len - 1]. Raise 75 | [Invalid_argument "Bitv.fill"] if [ofs] and [len] do not designate 76 | a valid subvector of [v]. 77 | 78 | [(Bitv.blit v1 o1 v2 o2 len)] copies [len] elements from vector 79 | [v1], starting at element number [o1], to vector [v2], starting at 80 | element number [o2]. It {\em does not work} correctly if [v1] and [v2] are 81 | the same vector with the source and destination chunks overlapping. 82 | Raise [Invalid_argument "Bitv.blit"] if [o1] and [len] do not 83 | designate a valid subvector of [v1], or if [o2] and [len] do not 84 | designate a valid subvector of [v2]. *) 85 | 86 | val sub : t -> int -> int -> t 87 | 88 | val fill : t -> int -> int -> bool -> unit 89 | 90 | val blit : t -> int -> t -> int -> int -> unit 91 | 92 | (*s {\bf Iterators.} \label{earray} 93 | [(Bitv.iter f v)] applies function [f] in turn to all 94 | the elements of [v]. Given a function [f], [(Bitv.map f v)] applies 95 | [f] to all 96 | the elements of [v], and builds a vector with the results returned 97 | by [f]. [Bitv.iteri] and [Bitv.mapi] are similar to [Bitv.iter] 98 | and [Bitv.map] respectively, but the function is applied to the 99 | index of the element as first argument, and the element itself as 100 | second argument. 101 | 102 | [(Bitv.fold_left f x v)] computes [f (... (f (f x (get v 0)) (get 103 | v 1)) ...) (get v (n-1))], where [n] is the length of the vector 104 | [v]. 105 | 106 | [(Bitv.fold_right f a x)] computes [f (get v 0) (f (get v 1) 107 | ( ... (f (get v (n-1)) x) ...))], where [n] is the length of the 108 | vector [v]. *) 109 | 110 | val iter : (bool -> unit) -> t -> unit 111 | val map : (bool -> bool) -> t -> t 112 | 113 | val iteri : (int -> bool -> unit) -> t -> unit 114 | val mapi : (int -> bool -> bool) -> t -> t 115 | 116 | val fold_left : ('a -> bool -> 'a) -> 'a -> t -> 'a 117 | val fold_right : (bool -> 'a -> 'a) -> t -> 'a -> 'a 118 | val foldi_left : ('a -> int -> bool -> 'a) -> 'a -> t -> 'a 119 | val foldi_right : (int -> bool -> 'a -> 'a) -> t -> 'a -> 'a 120 | 121 | (*s [gray_iter f n] iterates function [f] on all bit vectors 122 | of length [n], once each, using a Gray code. The order in which 123 | bit vectors are processed is unspecified. *) 124 | 125 | val gray_iter : (t -> unit) -> int -> unit 126 | 127 | (*s {\bf Bitwise operations.} \label{bitwise} [bwand], [bwor] and 128 | [bwxor] implement logical and, or and exclusive or. They return 129 | fresh vectors and raise [Invalid_argument "Bitv.xxx"] if the two 130 | vectors do not have the same length (where \texttt{xxx} is the 131 | name of the function). [bwnot] implements the logical negation. 132 | It returns a fresh vector. 133 | [shiftl] and [shiftr] implement shifts. They return fresh vectors. 134 | [shiftl] moves bits from least to most significant, and [shiftr] 135 | from most to least significant (think [lsl] and [lsr]). 136 | [all_zeros] and [all_ones] respectively test for a vector only 137 | containing zeros and only containing ones. *) 138 | 139 | val bw_and : t -> t -> t 140 | val bw_or : t -> t -> t 141 | val bw_xor : t -> t -> t 142 | val bw_not : t -> t 143 | 144 | val shiftl : t -> int -> t 145 | val shiftr : t -> int -> t 146 | 147 | val all_zeros : t -> bool 148 | val all_ones : t -> bool 149 | 150 | (*s {\bf Conversions to and from strings.} 151 | Least significant bit comes first. *) 152 | 153 | val to_string : t -> string 154 | val of_string : string -> t 155 | val print : Format.formatter -> t -> unit 156 | 157 | (*s {\bf Conversions to and from lists of integers.} 158 | The list gives the indices of bits which are set (ie [true]). *) 159 | 160 | val to_list : t -> int list 161 | val of_list : int list -> t 162 | val of_list_with_length : int list -> int -> t 163 | 164 | (*s Interpretation of bit vectors as integers. Least significant bit 165 | comes first (ie is at index 0 in the bit vector). 166 | [to_xxx] functions truncate when the bit vector is too wide, 167 | and raise [Invalid_argument] when it is too short. 168 | Suffix [_s] indicates that sign bit is kept, 169 | and [_us] that it is discarded. *) 170 | 171 | (* type [int] (length 31/63 with sign, 30/62 without) *) 172 | val of_int_s : int -> t 173 | val to_int_s : t -> int 174 | val of_int_us : int -> t 175 | val to_int_us : t -> int 176 | (* type [Int32.t] (length 32 with sign, 31 without) *) 177 | val of_int32_s : Int32.t -> t 178 | val to_int32_s : t -> Int32.t 179 | val of_int32_us : Int32.t -> t 180 | val to_int32_us : t -> Int32.t 181 | (* type [Int64.t] (length 64 with sign, 63 without) *) 182 | val of_int64_s : Int64.t -> t 183 | val to_int64_s : t -> Int64.t 184 | val of_int64_us : Int64.t -> t 185 | val to_int64_us : t -> Int64.t 186 | (* type [Nativeint.t] (length 32/64 with sign, 31/63 without) *) 187 | val of_nativeint_s : Nativeint.t -> t 188 | val to_nativeint_s : t -> Nativeint.t 189 | val of_nativeint_us : Nativeint.t -> t 190 | val to_nativeint_us : t -> Nativeint.t 191 | 192 | (*s Only if you know what you are doing... *) 193 | 194 | val unsafe_set : t -> int -> bool -> unit 195 | val unsafe_get : t -> int -> bool 196 | -------------------------------------------------------------------------------- /lib/components.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (* $Id: components.ml,v 1.9 2004-10-22 14:42:06 signoles Exp $ *) 19 | 20 | open Util 21 | 22 | module type G = sig 23 | type t 24 | module V : Sig.COMPARABLE 25 | val iter_vertex : (V.t -> unit) -> t -> unit 26 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 27 | end 28 | 29 | module Make(G: G) = struct 30 | 31 | module H = Hashtbl.Make(G.V) 32 | 33 | let scc g = 34 | let root = H.create 997 in 35 | let hashcomp = H.create 997 in 36 | let stack = ref [] in 37 | let numdfs = ref 0 in 38 | let numcomp = ref 0 in 39 | let rec pop x = function 40 | | (y, w) :: l when y > x -> 41 | H.add hashcomp w !numcomp; 42 | pop x l 43 | | l -> l 44 | in 45 | let rec visit v = 46 | if not (H.mem root v) then begin 47 | let n = incr numdfs; !numdfs in 48 | H.add root v n; 49 | G.iter_succ 50 | (fun w -> 51 | visit w; 52 | if not (H.mem hashcomp w) then 53 | H.replace root v (min (H.find root v) (H.find root w))) 54 | g v; 55 | if H.find root v = n then begin 56 | H.add hashcomp v !numcomp; 57 | let s = pop n !stack in 58 | stack:= s; 59 | incr numcomp 60 | end else 61 | stack := (n,v) :: !stack; 62 | end 63 | in 64 | G.iter_vertex visit g; 65 | !numcomp, (fun v -> H.find hashcomp v) 66 | 67 | let scc_array g = 68 | let n,f = scc g in 69 | let t = Array.make n [] in 70 | G.iter_vertex (fun v -> let i = f v in t.(i) <- v :: t.(i)) g; 71 | t 72 | 73 | let scc_list g = 74 | let _,scc = scc g in 75 | let tbl = Hashtbl.create 97 in 76 | G.iter_vertex 77 | (fun v -> 78 | let n = scc v in 79 | try 80 | let l = Hashtbl.find tbl n in 81 | l := v :: !l 82 | with Not_found -> 83 | Hashtbl.add tbl n (ref [ v ])) 84 | g; 85 | Hashtbl.fold (fun _ v l -> !v :: l) tbl [] 86 | 87 | end 88 | -------------------------------------------------------------------------------- /lib/components.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (* $Id: components.mli,v 1.12 2004-10-22 14:42:06 signoles Exp $ *) 19 | 20 | (** Strongly connected components. *) 21 | 22 | (** Minimal graph signature required by {!Make}. 23 | Sub-signature of {!Sig.G}. *) 24 | module type G = sig 25 | type t 26 | module V : Sig.COMPARABLE 27 | val iter_vertex : (V.t -> unit) -> t -> unit 28 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 29 | end 30 | 31 | (** Functor providing functions to compute strongly connected components of a 32 | graph. *) 33 | module Make (G: G) : sig 34 | 35 | val scc : G.t -> int * (G.V.t -> int) 36 | (** [scc g] computes the strongly connected components of [g]. 37 | The result is a pair [(n,f)] where [n] is the number of 38 | components. Components are numbered from [0] to [n-1], and 39 | [f] is a function mapping each vertex to its component 40 | number. In particular, [f u = f v] if and only if [u] and 41 | [v] are in the same component. Another property of the 42 | numbering is that components are numbered in a topological 43 | order: if there is an arc from [u] to [v], then [f u >= f u] 44 | 45 | Not tail-recursive. 46 | Complexity: O(V+E) 47 | The function returned has complexity O(1) *) 48 | 49 | val scc_array : G.t -> G.V.t list array 50 | (** [scc_array] computes the strongly connected components of [g]. 51 | Components are stored in the resulting array, indexed with a 52 | numbering with the same properties as for [scc] above. *) 53 | 54 | val scc_list : G.t -> G.V.t list list 55 | (** [scc_list] computes the strongly connected components of [g]. 56 | The result is a partition of the set of the vertices of [g]. *) 57 | 58 | end 59 | -------------------------------------------------------------------------------- /lib/flowvisor.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt 18 | open Net 19 | open Net.Nettypes 20 | 21 | type t 22 | 23 | (* 24 | * TODO: 25 | * 26 | * expose read write permissions to slices 27 | * *) 28 | 29 | (** initialize required state for a flowvisor instance *) 30 | val create_flowvisor: ?verbose:bool -> unit -> t 31 | 32 | (** switch listening daemons *) 33 | 34 | val listen: t -> Manager.t -> ipv4_src -> unit Lwt.t 35 | val local_listen: t -> Openflow.Ofsocket.conn_state -> unit Lwt.t 36 | 37 | (** slice management methods *) 38 | 39 | (** connect to a local control socket and expose a slice of the network control 40 | * traffic *) 41 | val add_local_slice : t -> Openflow.Ofpacket.Match.t -> 42 | Openflow.Ofsocket.conn_state -> int64 -> unit 43 | (** connect to a remote controller and expose a slice of the network control 44 | * traffic *) 45 | val add_slice : Net.Manager.t -> t -> Openflow.Ofpacket.Match.t -> 46 | ipv4_dst -> int64 -> unit 47 | (** stop exposing a control slice *) 48 | val remove_slice : t -> Openflow.Ofpacket.Match.t -> unit 49 | -------------------------------------------------------------------------------- /lib/flowvisor_topology.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt 18 | open Printf 19 | open Net 20 | open Net.Nettypes 21 | open Lldp 22 | 23 | module OP = Openflow.Ofpacket 24 | module OC = Openflow.Ofcontroller 25 | module OE = Openflow.Ofcontroller.Event 26 | module OSK = Openflow.Ofsocket 27 | open OP 28 | 29 | let sp = Printf.sprintf 30 | let cp = OS.Console.log 31 | 32 | module V = struct 33 | type t = int64 34 | let compare = Int64.compare 35 | let hash = Hashtbl.hash 36 | let equal = (=) 37 | end 38 | module E = struct 39 | type t = (int64 * int * int64 * int * int) 40 | let compare v1 v2 = 41 | let (src1_dpid, src1_port, dst1_dpid, dst1_port, _) = v1 in 42 | let (src2_dpid, src2_port, dst2_dpid, dst2_port, _) = v2 in 43 | if ((src1_dpid = src2_dpid) && (src1_port = src2_port) && 44 | (dst1_dpid = dst2_dpid) && (dst1_port = dst2_port)) || 45 | ((src1_dpid = dst2_dpid) && (src1_port = dst2_port) && 46 | (dst1_dpid = src2_dpid) && (dst1_port = src2_port)) then 47 | 0 48 | else 49 | Pervasives.compare v1 v2 50 | let default = (0L, 0, 0L, 0, 1) 51 | end 52 | 53 | module Graph = Imperative.Graph.ConcreteLabeled(V)(E) 54 | 55 | module W = struct 56 | type t = float 57 | type label = (int64 * int * int64 * int * int) 58 | let weight (_, _, _, _, rate) = 1.0 /. (float_of_int rate) 59 | let compare = Pervasives.compare 60 | let add = (+.) 61 | let zero = 0.0 62 | end 63 | 64 | module Dijkstra = Path.Dijkstra(Graph)(W) 65 | 66 | type t = { 67 | ports : (int64 * int, Macaddr.t * bool) Hashtbl.t; 68 | channels : (int64, OC.t) Hashtbl.t; 69 | topo : Graph.t; 70 | } 71 | 72 | let init_topology () = 73 | let topo = Graph.create () in 74 | {ports=(Hashtbl.create 64); channels=(Hashtbl.create 64); 75 | topo;} 76 | 77 | let add_channel t dpid ch = Hashtbl.replace t.channels dpid ch 78 | 79 | let generate_lldp_discovery dpid src_mac port = 80 | let bits = OS.Io_page.to_cstruct (OS.Io_page.get 1) in 81 | let _ = Cstruct.BE.set_uint64 bits 0 dpid in 82 | let dpid = Cstruct.to_string (Cstruct.sub bits 0 8) in 83 | let bits = OS.Io_page.to_cstruct (OS.Io_page.get 1) in 84 | let _ = Cstruct.BE.set_uint16 bits 0 port in 85 | let port = Cstruct.(to_string (sub bits 0 2)) in 86 | marshal_and_sub (marsal_lldp_tlvs src_mac 87 | [Tlv_chassis_id_mac(src_mac); 88 | Tlv_port_id_port_comp(port); 89 | Tlv_ttl(120); 90 | Tlv(LLDP_TYPE_SYSTEM_DESCR, dpid); 91 | Tlv_end;]) 92 | (OS.Io_page.to_cstruct (OS.Io_page.get 1)) 93 | 94 | let send_port_lldp t dpid port mac = 95 | let data = generate_lldp_discovery dpid mac port in 96 | let h = OP.Header.(create PACKET_OUT 0) in 97 | let m = OP.Packet_out.create ~actions:[(OP.Flow.Output(OP.Port.Port(port), 2000))] 98 | ~data ~in_port:(OP.Port.No_port) () in 99 | let ch = Hashtbl.find t.channels dpid in 100 | OC.send_data ch dpid (OP.Packet_out(h, m)) 101 | 102 | let add_port t dpid port mac = 103 | let _ = cp (sp "[flowvisor-topo] adding port %Ld:%d\n%!" dpid port) in 104 | let _ = Hashtbl.replace t.ports (dpid, port) (mac, false) in 105 | send_port_lldp t dpid port mac 106 | 107 | let mark_port_down t dpid port down = 108 | let fmac = Macaddr.broadcast in 109 | try 110 | let (mac, _) = Hashtbl.find t.ports (dpid, port) in 111 | Hashtbl.replace t.ports (dpid, port) (mac, down) 112 | with Not_found -> Hashtbl.add t.ports (dpid, port) (fmac, down) 113 | 114 | let discover t = 115 | while_lwt true do 116 | let ports = 117 | Hashtbl.fold 118 | (fun (dpid, port) (mac, _) r -> (dpid, port, mac)::r) 119 | t.ports [] in 120 | 121 | lwt _ = Lwt_list.iter_p ( 122 | fun (dpid, port, mac) -> send_port_lldp t dpid port mac) ports in 123 | lwt _ = OS.Time.sleep 120.0 in 124 | return () 125 | done 126 | 127 | let print_graph t = 128 | Graph.iter_edges_e ( 129 | fun (_, (sdpid, sport, ddpid, dport, len), _) -> 130 | printf "%06Lx:%d - %06Lx:%d = %d\n%!" sdpid sport ddpid dport len 131 | ) t.topo 132 | 133 | let process_lldp_packet t src_dpid src_port pkt = 134 | let tlvs = parse_lldp_tlvs pkt in 135 | let (dst_dpid, dst_port, mac) = 136 | List.fold_right ( 137 | fun tlv (dpid, port, mac) -> 138 | match tlv with 139 | | Tlv_chassis_id_mac (mac) -> 140 | (dpid, port, mac) 141 | | Tlv_port_id_port_comp(bits) -> 142 | let port_id = ref 0 in 143 | let _ = String.iter ( 144 | fun c -> 145 | port_id := (!port_id lsl 8) + (int_of_char c) 146 | ) bits in 147 | (dpid, !port_id, mac) 148 | | Tlv(LLDP_TYPE_SYSTEM_DESCR, bits) -> 149 | let dpid = ref 0L in 150 | let _ = String.iter ( 151 | fun c -> 152 | dpid := Int64.add (Int64.shift_left !dpid 8) 153 | (Int64.of_int (int_of_char c)) 154 | ) bits in 155 | (!dpid, port, mac) 156 | | _ -> (dpid, port, mac) 157 | ) tlvs (0L, 0, Macaddr.broadcast ) in 158 | match (Hashtbl.mem t.channels dst_dpid) with 159 | | false -> false 160 | | true -> 161 | let v = (src_dpid, (src_dpid, src_port, dst_dpid, dst_port, 1), dst_dpid) in 162 | let _ = cp (sp "[flowvisor-topo] adding link %Ld:%d-%Ld:%d\n%!" 163 | src_dpid src_port dst_dpid dst_port) in 164 | let _ = Graph.add_edge_e t.topo v in 165 | let _ = mark_port_down t src_dpid src_port true in 166 | let _ = mark_port_down t dst_dpid dst_port true in 167 | true 168 | 169 | let remove_dpid t dpid = 170 | let _ = Graph.remove_vertex t.topo dpid in 171 | let _ = 172 | Hashtbl.iter ( 173 | fun (dp, p) _ -> 174 | if (dpid = dp) then 175 | Hashtbl.remove t.ports (dp, p)) t.ports in 176 | Hashtbl.remove t.channels dpid 177 | 178 | let is_transit_port t dpid port = 179 | try 180 | let (_, down) = Hashtbl.find t.ports (dpid, port) in down 181 | with Not_found -> false 182 | 183 | 184 | let find_dpid_path t src_dpid src_port dst_dpid dst_port = 185 | (* let _ = printf "[flowvisor-topo] looking for path %Ld:%s - %Ld:%s\n%!" 186 | src_dpid (OP.Port.string_of_port src_port) 187 | dst_dpid (OP.Port.string_of_port dst_port) in *) 188 | let (path, w) = Dijkstra.shortest_path t.topo src_dpid dst_dpid in 189 | let (path, dpid, port) = List.fold_right ( 190 | fun (sdp, (dp_1, port_1, dp_2, port_2, _), ddp) (p, curr_dp, curr_p) -> 191 | (* let _ = printf "[flowvisor-topo] found link %Ld:%d-%Ld:%d\n%!" 192 | dp_1 port_1 dp_2 port_2 in *) 193 | let (hop, curr_dp, curr_p) = 194 | match (curr_dp) with 195 | | dp when dp = dp_1 -> 196 | let hop = (curr_dp, OP.Port.Port(port_1), 197 | curr_p) in 198 | (hop, dp_2, port_2) 199 | | dp when dp = dp_2 -> 200 | let hop = (curr_dp, 201 | OP.Port.Port(port_2), curr_p) in 202 | (hop, dp_1, port_1) 203 | | _ -> 204 | failwith (sp "Unknwk dpid %Ld" curr_dp) 205 | in 206 | ((hop :: p), curr_dp, OP.Port.Port(curr_p)) 207 | ) path ([], dst_dpid, dst_port) in 208 | (src_dpid, src_port, port) :: path 209 | -------------------------------------------------------------------------------- /lib/flowvisor_topology.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Net.Nettypes 18 | 19 | type t 20 | 21 | (** FlowVisor topology discovery *) 22 | 23 | 24 | (** Initialize a topology struct *) 25 | val init_topology: unit -> t 26 | 27 | (** Add to the structure a new switch and the relevant controller channel *) 28 | val add_channel: t -> int64 -> Openflow.Ofcontroller.t -> unit 29 | (** Add a new port on a switch *) 30 | val add_port: t -> int64 -> int -> Macaddr.t -> unit Lwt.t 31 | (** run a daemon which broadcasts lldp packet every 120 seconds in order to 32 | * discover physical connectivity between switches *) 33 | val discover: t-> unit Lwt.t 34 | 35 | (** parse and process an lldp packet *) 36 | val process_lldp_packet: t -> int64 -> int -> Cstruct.t -> bool 37 | (** discover a path between two ports of connected switches *) 38 | val find_dpid_path: t -> int64 -> Openflow.Ofpacket.Port.t -> int64 -> 39 | Openflow.Ofpacket.Port.t -> (int64 * Openflow.Ofpacket.Port.t * Openflow.Ofpacket.Port.t) list 40 | (** remove all ports of a specific switch *) 41 | val remove_dpid: t -> int64 -> unit 42 | (** reports if a link function a a transit link between two adjacent switches *) 43 | val is_transit_port : t -> int64 -> int -> bool 44 | 45 | -------------------------------------------------------------------------------- /lib/flv.mlpack: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 1ee3b02f2e7271b683bd994a941b7777) 3 | Flowvisor 4 | Lldp 5 | Flowvisor_topology 6 | # OASIS_STOP 7 | -------------------------------------------------------------------------------- /lib/heap.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (* $Id:$ *) 19 | 20 | module type Ordered = sig 21 | type t 22 | val compare : t -> t -> int 23 | end 24 | 25 | exception EmptyHeap 26 | 27 | (*s Imperative implementation *) 28 | 29 | module Imperative(X : Ordered) = struct 30 | 31 | (* The heap is encoded in the array [data], where elements are stored 32 | from [0] to [size - 1]. From an element stored at [i], the left 33 | (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) 34 | 35 | type t = { mutable size : int; mutable data : X.t array } 36 | 37 | (* When [create n] is called, we cannot allocate the array, since there is 38 | no known value of type [X.t]; we'll wait for the first addition to 39 | do it, and we remember this situation with a negative size. *) 40 | 41 | let create n = 42 | if n <= 0 then invalid_arg "create"; 43 | { size = -n; data = [||] } 44 | 45 | let is_empty h = h.size <= 0 46 | 47 | (* [resize] doubles the size of [data] *) 48 | 49 | let resize h = 50 | let n = h.size in 51 | assert (n > 0); 52 | let n' = 2 * n in 53 | let d = h.data in 54 | let d' = Array.create n' d.(0) in 55 | Array.blit d 0 d' 0 n; 56 | h.data <- d' 57 | 58 | let add h x = 59 | (* first addition: we allocate the array *) 60 | if h.size < 0 then begin 61 | h.data <- Array.create (- h.size) x; h.size <- 0 62 | end; 63 | let n = h.size in 64 | (* resizing if needed *) 65 | if n == Array.length h.data then resize h; 66 | let d = h.data in 67 | (* moving [x] up in the heap *) 68 | let rec moveup i = 69 | let fi = (i - 1) / 2 in 70 | if i > 0 && X.compare d.(fi) x < 0 then begin 71 | d.(i) <- d.(fi); 72 | moveup fi 73 | end else 74 | d.(i) <- x 75 | in 76 | moveup n; 77 | h.size <- n + 1 78 | 79 | let maximum h = 80 | if h.size <= 0 then raise EmptyHeap; 81 | h.data.(0) 82 | 83 | let remove h = 84 | if h.size <= 0 then raise EmptyHeap; 85 | let n = h.size - 1 in 86 | h.size <- n; 87 | let d = h.data in 88 | let x = d.(n) in 89 | (* moving [x] down in the heap *) 90 | let rec movedown i = 91 | let j = 2 * i + 1 in 92 | if j < n then 93 | let j = 94 | let j' = j + 1 in 95 | if j' < n && X.compare d.(j') d.(j) > 0 then j' else j 96 | in 97 | if X.compare d.(j) x > 0 then begin 98 | d.(i) <- d.(j); 99 | movedown j 100 | end else 101 | d.(i) <- x 102 | else 103 | d.(i) <- x 104 | in 105 | movedown 0 106 | 107 | let pop_maximum h = let m = maximum h in remove h; m 108 | 109 | let iter f h = 110 | let d = h.data in 111 | for i = 0 to h.size - 1 do f d.(i) done 112 | 113 | let fold f h x0 = 114 | let n = h.size in 115 | let d = h.data in 116 | let rec foldrec x i = 117 | if i >= n then x else foldrec (f d.(i) x) (succ i) 118 | in 119 | foldrec x0 0 120 | 121 | end 122 | 123 | 124 | (*s Functional implementation *) 125 | 126 | module type FunctionalSig = sig 127 | type elt 128 | type t 129 | val empty : t 130 | val add : elt -> t -> t 131 | val maximum : t -> elt 132 | val remove : t -> t 133 | val iter : (elt -> unit) -> t -> unit 134 | val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a 135 | end 136 | 137 | module Functional(X : Ordered) = struct 138 | 139 | (* Heaps are encoded as complete binary trees, i.e., binary trees 140 | which are full expect, may be, on the bottom level where it is filled 141 | from the left. 142 | These trees also enjoy the heap property, namely the value of any node 143 | is greater or equal than those of its left and right subtrees. 144 | 145 | There are 4 kinds of complete binary trees, denoted by 4 constructors: 146 | [FFF] for a full binary tree (and thus 2 full subtrees); 147 | [PPF] for a partial tree with a partial left subtree and a full 148 | right subtree; 149 | [PFF] for a partial tree with a full left subtree and a full right subtree 150 | (but of different heights); 151 | and [PFP] for a partial tree with a full left subtree and a partial 152 | right subtree. *) 153 | 154 | type elt = X.t 155 | 156 | type t = 157 | | Empty 158 | | FFF of t * X.t * t (* full (full, full) *) 159 | | PPF of t * X.t * t (* partial (partial, full) *) 160 | | PFF of t * X.t * t (* partial (full, full) *) 161 | | PFP of t * X.t * t (* partial (full, partial) *) 162 | 163 | let empty = Empty 164 | 165 | (* smart constructors for insertion *) 166 | let p_f l x r = match l with 167 | | Empty | FFF _ -> PFF (l, x, r) 168 | | _ -> PPF (l, x, r) 169 | 170 | let pf_ l x = function 171 | | Empty | FFF _ as r -> FFF (l, x, r) 172 | | r -> PFP (l, x, r) 173 | 174 | let rec add x = function 175 | | Empty -> 176 | FFF (Empty, x, Empty) 177 | (* insertion to the left *) 178 | | FFF (l, y, r) | PPF (l, y, r) -> 179 | if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r 180 | (* insertion to the right *) 181 | | PFF (l, y, r) | PFP (l, y, r) -> 182 | if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r) 183 | 184 | let maximum = function 185 | | Empty -> raise EmptyHeap 186 | | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x 187 | 188 | (* smart constructors for removal; note that they are different 189 | from the ones for insertion! *) 190 | let p_f l x r = match l with 191 | | Empty | FFF _ -> FFF (l, x, r) 192 | | _ -> PPF (l, x, r) 193 | 194 | let pf_ l x = function 195 | | Empty | FFF _ as r -> PFF (l, x, r) 196 | | r -> PFP (l, x, r) 197 | 198 | let rec remove = function 199 | | Empty -> 200 | raise EmptyHeap 201 | | FFF (Empty, _, Empty) -> 202 | Empty 203 | | PFF (l, _, Empty) -> 204 | l 205 | (* remove on the left *) 206 | | PPF (l, x, r) | PFF (l, x, r) -> 207 | let xl = maximum l in 208 | let xr = maximum r in 209 | let l' = remove l in 210 | if X.compare xl xr >= 0 then 211 | p_f l' xl r 212 | else 213 | p_f l' xr (add xl (remove r)) 214 | (* remove on the right *) 215 | | FFF (l, x, r) | PFP (l, x, r) -> 216 | let xl = maximum l in 217 | let xr = maximum r in 218 | let r' = remove r in 219 | if X.compare xl xr > 0 then 220 | pf_ (add xr (remove l)) xl r' 221 | else 222 | pf_ l xr r' 223 | 224 | let rec iter f = function 225 | | Empty -> 226 | () 227 | | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> 228 | iter f l; f x; iter f r 229 | 230 | let rec fold f h x0 = match h with 231 | | Empty -> 232 | x0 233 | | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> 234 | fold f l (fold f r (f x x0)) 235 | 236 | end 237 | -------------------------------------------------------------------------------- /lib/heap.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | 19 | module type Ordered = sig 20 | type t 21 | val compare : t -> t -> int 22 | end 23 | 24 | exception EmptyHeap 25 | 26 | (*S Imperative implementation. *) 27 | 28 | module Imperative(X: Ordered) : sig 29 | 30 | (* Type of imperative heaps. 31 | (In the following [n] refers to the number of elements in the heap) *) 32 | 33 | type t 34 | 35 | (* [create c] creates a new heap, with initial capacity of [c] *) 36 | val create : int -> t 37 | 38 | (* [is_empty h] checks the emptiness of [h] *) 39 | val is_empty : t -> bool 40 | 41 | (* [add x h] adds a new element [x] in heap [h]; size of [h] is doubled 42 | when maximum capacity is reached; complexity $O(log(n))$ *) 43 | val add : t -> X.t -> unit 44 | 45 | (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] 46 | when [h] is empty; complexity $O(1)$ *) 47 | val maximum : t -> X.t 48 | 49 | (* [remove h] removes the maximum element of [h]; raises [EmptyHeap] 50 | when [h] is empty; complexity $O(log(n))$ *) 51 | val remove : t -> unit 52 | 53 | (* [pop_maximum h] removes the maximum element of [h] and returns it; 54 | raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) 55 | val pop_maximum : t -> X.t 56 | 57 | (* usual iterators and combinators; elements are presented in 58 | arbitrary order *) 59 | val iter : (X.t -> unit) -> t -> unit 60 | 61 | val fold : (X.t -> 'a -> 'a) -> t -> 'a -> 'a 62 | 63 | end 64 | 65 | (*S Functional implementation. *) 66 | 67 | module type FunctionalSig = sig 68 | 69 | (* heap elements *) 70 | type elt 71 | 72 | (* Type of functional heaps *) 73 | type t 74 | 75 | (* The empty heap *) 76 | val empty : t 77 | 78 | (* [add x h] returns a new heap containing the elements of [h], plus [x]; 79 | complexity $O(log(n))$ *) 80 | val add : elt -> t -> t 81 | 82 | (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] 83 | when [h] is empty; complexity $O(1)$ *) 84 | val maximum : t -> elt 85 | 86 | (* [remove h] returns a new heap containing the elements of [h], except 87 | the maximum of [h]; raises [EmptyHeap] when [h] is empty; 88 | complexity $O(log(n))$ *) 89 | val remove : t -> t 90 | 91 | (* usual iterators and combinators; elements are presented in 92 | arbitrary order *) 93 | val iter : (elt -> unit) -> t -> unit 94 | 95 | val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a 96 | 97 | end 98 | 99 | module Functional(X: Ordered) : FunctionalSig with type elt = X.t 100 | -------------------------------------------------------------------------------- /lib/imperative.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (** Imperative Graph Implementations. *) 19 | 20 | open Sig 21 | 22 | (** Signature of imperative graphs. *) 23 | module type S = sig 24 | 25 | (** Edges may be labeled or not: 26 | - Unlabeled: there is no label on edges 27 | - Labeled: you have to provide a label implementation as a functor 28 | parameter. 29 | 30 | Vertices may be concrete or abstract: 31 | - Concrete: type of vertex labels and type of vertices are identified. 32 | - Abstract: type of vertices is abstract (in particular it is not equal 33 | to type of vertex labels 34 | 35 | How to choose between concrete and abstract vertices for my graph 36 | implementation? 37 | 38 | Usually, if you fall into one of the following cases, use abstract 39 | vertices: 40 | - you cannot provide efficient comparison/hash functions for vertices; or 41 | - you wish to get two different vertices with the same label. 42 | 43 | In other cases, it is certainly easier to use concrete vertices. *) 44 | 45 | (** Imperative Unlabeled Graphs. *) 46 | module Concrete (V: COMPARABLE) : 47 | Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t 48 | and type E.label = unit 49 | 50 | (** Abstract Imperative Unlabeled Graphs. *) 51 | module Abstract(V: ANY_TYPE) : 52 | Sig.IM with type V.label = V.t and type E.label = unit 53 | 54 | (** Imperative Labeled Graphs. *) 55 | module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : 56 | Sig.I with type V.t = V.t and type V.label = V.t 57 | and type E.t = V.t * E.t * V.t and type E.label = E.t 58 | 59 | (** Abstract Imperative Labeled Graphs. *) 60 | module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : 61 | Sig.IM with type V.label = V.t and type E.label = E.t 62 | 63 | end 64 | 65 | (** Imperative Directed Graphs. *) 66 | module Digraph : sig 67 | 68 | include S 69 | 70 | (** {2 Bidirectional graphs} 71 | 72 | Bidirectional graphs use more memory space (at worse the double) that 73 | standard concrete directional graphs. But accessing predecessors is in 74 | O(1) amortized instead of O(max(|V|,|E|)) and removing a vertex is in 75 | O(D*ln(D)) instead of O(|V|*ln(D)). D is the maximal degree of the 76 | graph. *) 77 | 78 | (** Imperative Unlabeled, bidirectional graph. *) 79 | module ConcreteBidirectional (V: COMPARABLE) : 80 | Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t 81 | and type E.label = unit 82 | 83 | (** Imperative Labeled and bidirectional graph. *) 84 | module ConcreteBidirectionalLabeled(V:COMPARABLE)(E:ORDERED_TYPE_DFT) : 85 | Sig.I with type V.t = V.t and type V.label = V.t 86 | and type E.t = V.t * E.t * V.t and type E.label = E.t 87 | 88 | end 89 | 90 | (** Imperative Undirected Graphs. *) 91 | module Graph : S 92 | 93 | (** Imperative graphs implemented as adjacency matrices. *) 94 | module Matrix : sig 95 | 96 | module type S = sig 97 | 98 | (** Vertices are integers in [0..n-1]. 99 | A vertex label is the vertex itself. 100 | Edges are unlabeled. *) 101 | 102 | include Sig.I with type V.t = int and type V.label = int 103 | and type E.t = int * int 104 | 105 | (** Creation. graphs are not resizeable: size is given at creation time. 106 | Thus [make] must be used instead of [create]. *) 107 | val make : int -> t 108 | 109 | (** Note: [add_vertex] and [remove_vertex] have no effect. 110 | [clear] only removes edges, not vertices. *) 111 | 112 | end 113 | 114 | module Digraph : S 115 | (** Imperative Directed Graphs implemented with adjacency matrices. *) 116 | 117 | module Graph : S 118 | (** Imperative Undirected Graphs implemented with adjacency matrices. *) 119 | 120 | end 121 | 122 | (**** 123 | (** Faster implementations for abstract (un)labeled (di)graphs 124 | when vertices are _not shared_ between different graphs. 125 | This means that, when using the following implementations, two different 126 | graphs (created with two calls to [create]) must have disjoint sets of 127 | vertices. *) 128 | module UV : sig 129 | 130 | (** directed graphs *) 131 | module Digraph : sig 132 | 133 | module Abstract(V: ANY_TYPE) : 134 | Sig.IM with type V.label = V.t and type E.label = unit 135 | 136 | module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : 137 | Sig.IM with type V.label = V.t and type E.label = E.t 138 | 139 | end 140 | 141 | (** undirected graphs *) 142 | module Graph : sig 143 | 144 | module Abstract(V: ANY_TYPE) : 145 | Sig.IM with type V.label = V.t and type E.label = unit 146 | 147 | module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : 148 | Sig.IM with type V.label = V.t and type E.label = E.t 149 | 150 | end 151 | 152 | end 153 | ****) 154 | 155 | (* 156 | Local Variables: 157 | compile-command: "make -C .." 158 | End: 159 | *) 160 | -------------------------------------------------------------------------------- /lib/lldp.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Cstruct 18 | open Printf 19 | open Net 20 | open Net.Nettypes 21 | 22 | exception Unparsable of Cstruct.t 23 | 24 | (*cenum lldp_tlv_types { 25 | LLDP_TYPE_END = 0; 26 | LLDP_TYPE_CHASSIS_ID = 1; 27 | LLDP_TYPE_PORT_ID = 2; 28 | LLDP_TYPE_TTL = 3; 29 | LLDP_TYPE_PORT_DESCR = 4; 30 | LLDP_TYPE_SYSTEM_NAME = 5; 31 | LLDP_TYPE_SYSTEM_DESCR = 6; 32 | LLDP_TYPE_SYSTEM_CAP = 7; 33 | LLDP_TYPE_MGMT_ADDR = 8 34 | } as uint8_t 35 | 36 | cenum lldp_chassis_id_subtype { 37 | LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE = 1; 38 | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE = 2; 39 | LLDP_CHASSIS_PORT_COMP_SUBTYPE = 3; 40 | LLDP_CHASSIS_MAC_ADDR_SUBTYPE = 4; 41 | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE = 5; 42 | LLDP_CHASSIS_INTF_NAME_SUBTYPE = 6; 43 | LLDP_CHASSIS_LOCAL_SUBTYPE = 8 44 | } as uint8_t 45 | 46 | cenum lldp_port_id_subtype { 47 | LLDP_PORT_INTF_ALIAS_SUBTYPE = 1; 48 | LLDP_PORT_PORT_COMP_SUBTYPE = 2; 49 | LLDP_PORT_MAC_ADDR_SUBTYPE = 3; 50 | LLDP_PORT_NETWORK_ADDR_SUBTYPE = 4; 51 | LLDP_PORT_INTF_NAME_SUBTYPE = 5; 52 | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE = 6; 53 | LLDP_PORT_LOCAL_SUBTYPE = 7 54 | } as uint8_t*) 55 | 56 | cstruct ethernet { 57 | uint8_t dst[6]; 58 | uint8_t src[6]; 59 | uint16_t ethertype 60 | } as big_endian 61 | 62 | 63 | type lldp_tlv_types = 64 | LLDP_TYPE_END 65 | | LLDP_TYPE_CHASSIS_ID 66 | | LLDP_TYPE_PORT_ID 67 | | LLDP_TYPE_TTL 68 | | LLDP_TYPE_PORT_DESCR 69 | | LLDP_TYPE_SYSTEM_NAME 70 | | LLDP_TYPE_SYSTEM_DESCR 71 | | LLDP_TYPE_SYSTEM_CAP 72 | | LLDP_TYPE_MGMT_ADDR 73 | 74 | let lldp_tlv_types_of_int = 75 | function 76 | | 0 -> Some LLDP_TYPE_END 77 | | 1 -> Some LLDP_TYPE_CHASSIS_ID 78 | | 2 -> Some LLDP_TYPE_PORT_ID 79 | | 3 -> Some LLDP_TYPE_TTL 80 | | 4 -> Some LLDP_TYPE_PORT_DESCR 81 | | 5 -> Some LLDP_TYPE_SYSTEM_NAME 82 | | 6 -> Some LLDP_TYPE_SYSTEM_DESCR 83 | | 7 -> Some LLDP_TYPE_SYSTEM_CAP 84 | | 8 -> Some LLDP_TYPE_MGMT_ADDR 85 | | _ -> None 86 | 87 | let lldp_tlv_types_to_int = 88 | function 89 | | LLDP_TYPE_END -> 0 90 | | LLDP_TYPE_CHASSIS_ID -> 1 91 | | LLDP_TYPE_PORT_ID -> 2 92 | | LLDP_TYPE_TTL -> 3 93 | | LLDP_TYPE_PORT_DESCR -> 4 94 | | LLDP_TYPE_SYSTEM_NAME -> 5 95 | | LLDP_TYPE_SYSTEM_DESCR -> 6 96 | | LLDP_TYPE_SYSTEM_CAP -> 7 97 | | LLDP_TYPE_MGMT_ADDR -> 8 98 | 99 | let lldp_tlv_types_to_string = 100 | function 101 | | LLDP_TYPE_END -> "LLDP_TYPE_END" 102 | | LLDP_TYPE_CHASSIS_ID -> "LLDP_TYPE_CHASSIS_ID" 103 | | LLDP_TYPE_PORT_ID -> "LLDP_TYPE_PORT_ID" 104 | | LLDP_TYPE_TTL -> "LLDP_TYPE_TTL" 105 | | LLDP_TYPE_PORT_DESCR -> "LLDP_TYPE_PORT_DESCR" 106 | | LLDP_TYPE_SYSTEM_NAME -> "LLDP_TYPE_SYSTEM_NAME" 107 | | LLDP_TYPE_SYSTEM_DESCR -> "LLDP_TYPE_SYSTEM_DESCR" 108 | | LLDP_TYPE_SYSTEM_CAP -> "LLDP_TYPE_SYSTEM_CAP" 109 | | LLDP_TYPE_MGMT_ADDR -> "LLDP_TYPE_MGMT_ADDR" 110 | 111 | type lldp_chassis_id_subtype = 112 | LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE 113 | | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE 114 | | LLDP_CHASSIS_PORT_COMP_SUBTYPE 115 | | LLDP_CHASSIS_MAC_ADDR_SUBTYPE 116 | | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE 117 | | LLDP_CHASSIS_INTF_NAME_SUBTYPE 118 | | LLDP_CHASSIS_LOCAL_SUBTYPE 119 | 120 | let lldp_chassis_id_subtype_of_int = 121 | function 122 | | 1 -> Some LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE 123 | | 2 -> Some LLDP_CHASSIS_INTF_ALIAS_SUBTYPE 124 | | 3 -> Some LLDP_CHASSIS_PORT_COMP_SUBTYPE 125 | | 4 -> Some LLDP_CHASSIS_MAC_ADDR_SUBTYPE 126 | | 5 -> Some LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE 127 | | 6 -> Some LLDP_CHASSIS_INTF_NAME_SUBTYPE 128 | | 8 -> Some LLDP_CHASSIS_LOCAL_SUBTYPE 129 | | _ -> None 130 | 131 | let lldp_chassis_id_subtype_to_int = 132 | function 133 | | LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE -> 1 134 | | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE -> 2 135 | | LLDP_CHASSIS_PORT_COMP_SUBTYPE -> 3 136 | | LLDP_CHASSIS_MAC_ADDR_SUBTYPE -> 4 137 | | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE -> 5 138 | | LLDP_CHASSIS_INTF_NAME_SUBTYPE -> 6 139 | | LLDP_CHASSIS_LOCAL_SUBTYPE -> 8 140 | 141 | let lldp_chassis_id_subtype_to_string = 142 | function 143 | | LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE -> "LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE" 144 | | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE -> "LLDP_CHASSIS_INTF_ALIAS_SUBTYPE" 145 | | LLDP_CHASSIS_PORT_COMP_SUBTYPE -> "LLDP_CHASSIS_PORT_COMP_SUBTYPE" 146 | | LLDP_CHASSIS_MAC_ADDR_SUBTYPE -> "LLDP_CHASSIS_MAC_ADDR_SUBTYPE" 147 | | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE -> "LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE" 148 | | LLDP_CHASSIS_INTF_NAME_SUBTYPE -> "LLDP_CHASSIS_INTF_NAME_SUBTYPE" 149 | | LLDP_CHASSIS_LOCAL_SUBTYPE -> "LLDP_CHASSIS_LOCAL_SUBTYPE" 150 | 151 | type lldp_port_id_subtype = 152 | LLDP_PORT_INTF_ALIAS_SUBTYPE 153 | | LLDP_PORT_PORT_COMP_SUBTYPE 154 | | LLDP_PORT_MAC_ADDR_SUBTYPE 155 | | LLDP_PORT_NETWORK_ADDR_SUBTYPE 156 | | LLDP_PORT_INTF_NAME_SUBTYPE 157 | | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE 158 | | LLDP_PORT_LOCAL_SUBTYPE 159 | 160 | let lldp_port_id_subtype_of_int = 161 | function 162 | | 1 -> Some LLDP_PORT_INTF_ALIAS_SUBTYPE 163 | | 2 -> Some LLDP_PORT_PORT_COMP_SUBTYPE 164 | | 3 -> Some LLDP_PORT_MAC_ADDR_SUBTYPE 165 | | 4 -> Some LLDP_PORT_NETWORK_ADDR_SUBTYPE 166 | | 5 -> Some LLDP_PORT_INTF_NAME_SUBTYPE 167 | | 6 -> Some LLDP_PORT_AGENT_CIRC_ID_SUBTYPE 168 | | 7 -> Some LLDP_PORT_LOCAL_SUBTYPE 169 | | _ -> None 170 | 171 | let lldp_port_id_subtype_to_int = 172 | function 173 | | LLDP_PORT_INTF_ALIAS_SUBTYPE -> 1 174 | | LLDP_PORT_PORT_COMP_SUBTYPE -> 2 175 | | LLDP_PORT_MAC_ADDR_SUBTYPE -> 3 176 | | LLDP_PORT_NETWORK_ADDR_SUBTYPE -> 4 177 | | LLDP_PORT_INTF_NAME_SUBTYPE -> 5 178 | | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE -> 6 179 | | LLDP_PORT_LOCAL_SUBTYPE -> 7 180 | 181 | let lldp_port_id_subtype_to_string = 182 | function 183 | | LLDP_PORT_INTF_ALIAS_SUBTYPE -> "LLDP_PORT_INTF_ALIAS_SUBTYPE" 184 | | LLDP_PORT_PORT_COMP_SUBTYPE -> "LLDP_PORT_PORT_COMP_SUBTYPE" 185 | | LLDP_PORT_MAC_ADDR_SUBTYPE -> "LLDP_PORT_MAC_ADDR_SUBTYPE" 186 | | LLDP_PORT_NETWORK_ADDR_SUBTYPE -> "LLDP_PORT_NETWORK_ADDR_SUBTYPE" 187 | | LLDP_PORT_INTF_NAME_SUBTYPE -> "LLDP_PORT_INTF_NAME_SUBTYPE" 188 | | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE -> "LLDP_PORT_AGENT_CIRC_ID_SUBTYPE" 189 | | LLDP_PORT_LOCAL_SUBTYPE -> "LLDP_PORT_LOCAL_SUBTYPE" 190 | 191 | 192 | type lldp_tvl = 193 | | Tlv_chassis_id_chassis_comp of string 194 | | Tlv_chassis_id_intf_alias of string 195 | | Tlv_chassis_id_port_comp of string 196 | | Tlv_chassis_id_mac of Macaddr.t 197 | | Tlv_chassis_id_net of Ipaddr.V4.t 198 | | Tlv_chassis_id_intf_name of string 199 | | Tlv_chassis_id_local of string 200 | | Tlv_port_id_intf_alias of string 201 | | Tlv_port_id_port_comp of string 202 | | Tlv_port_id_mac of Macaddr.t 203 | | Tlv_port_id_net of Ipaddr.V4.t 204 | | Tlv_port_id_intf_name of string 205 | | Tlv_port_id_circ_id of string 206 | | Tlv_port_id_local of string 207 | | Tlv_ttl of int 208 | | Tlv_end 209 | | Tlv of lldp_tlv_types * string 210 | | Tlv_unk of int * string 211 | 212 | let parse_lldp_tlv bits = 213 | let tlv_type_len = Cstruct.BE.get_uint16 bits 0 in 214 | let tlv_type = tlv_type_len lsr 9 in 215 | let tlv_len = tlv_type_len land 0x01FF in 216 | let tlv = 217 | match (lldp_tlv_types_of_int tlv_type) with 218 | | Some(LLDP_TYPE_END) -> Tlv_end 219 | | Some(LLDP_TYPE_CHASSIS_ID) -> begin 220 | let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in 221 | let chassis_id_subtype = Cstruct.get_uint8 bits 2 in 222 | match (lldp_chassis_id_subtype_of_int chassis_id_subtype) with 223 | | Some(LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE)-> 224 | Tlv_chassis_id_chassis_comp(data) 225 | | Some(LLDP_CHASSIS_INTF_ALIAS_SUBTYPE) -> 226 | Tlv_chassis_id_intf_alias(data) 227 | | Some(LLDP_CHASSIS_PORT_COMP_SUBTYPE) -> 228 | Tlv_chassis_id_port_comp(data) 229 | | Some(LLDP_CHASSIS_MAC_ADDR_SUBTYPE) -> begin 230 | match (Macaddr.of_bytes data) with 231 | | None -> raise (Unparsable bits) 232 | | Some addr -> (Tlv_chassis_id_mac addr) 233 | end 234 | | Some(LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE)-> 235 | let ip = Ipaddr.V4.of_int32 236 | (Cstruct.BE.get_uint32 bits 3) in 237 | Tlv_chassis_id_net(ip) 238 | | Some(LLDP_CHASSIS_INTF_NAME_SUBTYPE) -> 239 | Tlv_chassis_id_intf_name(data) 240 | | Some(LLDP_CHASSIS_LOCAL_SUBTYPE) -> 241 | Tlv_chassis_id_local(data) 242 | | None -> 243 | raise (Unparsable(bits)) 244 | end 245 | | Some(LLDP_TYPE_PORT_ID) -> begin 246 | let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in 247 | let port_id_subtype = Cstruct.get_uint8 bits 2 in 248 | match (lldp_port_id_subtype_of_int port_id_subtype) with 249 | | Some(LLDP_PORT_INTF_ALIAS_SUBTYPE) -> 250 | Tlv_port_id_intf_alias(data) 251 | | Some(LLDP_PORT_PORT_COMP_SUBTYPE) -> 252 | Tlv_port_id_port_comp(data) 253 | | Some(LLDP_PORT_MAC_ADDR_SUBTYPE) -> begin 254 | match (Macaddr.of_bytes data) with 255 | | None -> raise (Unparsable(bits)) 256 | | Some addr -> Tlv_port_id_mac(addr) 257 | end 258 | | Some(LLDP_PORT_NETWORK_ADDR_SUBTYPE) -> 259 | let ip = Ipaddr.V4.of_int32 260 | (Cstruct.BE.get_uint32 bits 3) in 261 | Tlv_port_id_net(ip) 262 | | Some(LLDP_PORT_INTF_NAME_SUBTYPE) -> 263 | Tlv_port_id_intf_name(data) 264 | | Some(LLDP_PORT_AGENT_CIRC_ID_SUBTYPE)-> 265 | Tlv_port_id_circ_id(data) 266 | | Some(LLDP_PORT_LOCAL_SUBTYPE) -> 267 | Tlv_port_id_local(data) 268 | | None -> raise (Unparsable(bits)) 269 | end 270 | | Some(LLDP_TYPE_TTL) -> 271 | let ttl = Cstruct.BE.get_uint16 bits 3 in 272 | Tlv_ttl(ttl) 273 | | Some(typ) -> 274 | let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in 275 | Tlv(typ, data) 276 | | None -> 277 | let data = Cstruct.to_string (Cstruct.sub bits 2 tlv_len) in 278 | Tlv_unk(tlv_type, data) 279 | in 280 | (tlv_len + 2, tlv) 281 | 282 | let parse_lldp_tlvs bits = 283 | (* Ignore ethernet headers for now *) 284 | let bits = Cstruct.shift bits sizeof_ethernet in 285 | let rec parse_lldp_tlvs_inner bits = 286 | match (Cstruct.len bits) with 287 | | 0 -> [] 288 | | _ -> 289 | let (len, tlv) = parse_lldp_tlv bits in 290 | if(tlv = Tlv_end) then 291 | [tlv] 292 | else 293 | let bits = Cstruct.shift bits len in 294 | [tlv] @ (parse_lldp_tlvs_inner bits) 295 | in 296 | parse_lldp_tlvs_inner bits 297 | 298 | let set_lldp_tlv_typ_subtyp_data bits typ subtyp data = 299 | let typ = typ lsl 9 in 300 | let len = ((String.length data) + 1) land 0x1ff in 301 | let typ_len = typ + len in 302 | let _ = Cstruct.BE.set_uint16 bits 0 typ_len in 303 | let _ = Cstruct.set_uint8 bits 2 subtyp in 304 | let _ = Cstruct.blit_from_string data 0 bits 3 (String.length data) in 305 | len + 2 306 | 307 | let set_lldp_tlv_typ_data bits typ data = 308 | let typ = typ lsl 9 in 309 | let len = (String.length data) land 0x1ff in 310 | let typ_len = typ + len in 311 | let _ = Cstruct.BE.set_uint16 bits 0 typ_len in 312 | let _ = Cstruct.blit_from_string data 0 bits 2 (String.length data) in 313 | len + 2 314 | 315 | let marsal_lldp_tlv tlv bits = 316 | match tlv with 317 | (* chassis id *) 318 | | Tlv_chassis_id_chassis_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 1 1 data 319 | | Tlv_chassis_id_intf_alias(data) -> set_lldp_tlv_typ_subtyp_data bits 1 2 data 320 | | Tlv_chassis_id_port_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 1 3 data 321 | | Tlv_chassis_id_mac(mac) -> set_lldp_tlv_typ_subtyp_data bits 1 4 322 | (Macaddr.to_bytes mac) 323 | | Tlv_chassis_id_net(ip) -> 324 | let _ = Cstruct.BE.set_uint16 bits 0 0x205 in 325 | let _ = Cstruct.set_uint8 bits 2 5 in 326 | let _ = Cstruct.BE.set_uint32 bits 3 (Ipaddr.V4.to_int32 ip) in 327 | 7 328 | | Tlv_chassis_id_intf_name(data) -> set_lldp_tlv_typ_subtyp_data bits 1 6 data 329 | | Tlv_chassis_id_local(data) -> set_lldp_tlv_typ_subtyp_data bits 1 8 data 330 | (* Port id *) 331 | | Tlv_port_id_intf_alias(data) -> set_lldp_tlv_typ_subtyp_data bits 2 1 data 332 | | Tlv_port_id_port_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 2 2 data 333 | | Tlv_port_id_mac(mac) -> set_lldp_tlv_typ_subtyp_data bits 2 3 334 | (Macaddr.to_bytes mac) 335 | | Tlv_port_id_net(ip) -> 336 | let _ = Cstruct.BE.set_uint16 bits 0 0x405 in 337 | let _ = Cstruct.set_uint8 bits 2 4 in 338 | let _ = Cstruct.BE.set_uint32 bits 3 (Ipaddr.V4.to_int32 ip) in 339 | 7 340 | | Tlv_port_id_intf_name(data) -> set_lldp_tlv_typ_subtyp_data bits 2 5 data 341 | | Tlv_port_id_circ_id(data) -> set_lldp_tlv_typ_subtyp_data bits 2 6 data 342 | | Tlv_port_id_local(data) -> set_lldp_tlv_typ_subtyp_data bits 2 7 data 343 | | Tlv_ttl(ttl) -> 344 | let _ = Cstruct.BE.set_uint16 bits 0 0x602 in 345 | let _ = Cstruct.BE.set_uint16 bits 2 ttl in 346 | 4 347 | | Tlv_end -> 348 | let _ = Cstruct.BE.set_uint16 bits 0 0x000 in 349 | 2 350 | | Tlv(typ, data) -> 351 | set_lldp_tlv_typ_data bits (lldp_tlv_types_to_int typ) data 352 | | Tlv_unk (typ, data) -> set_lldp_tlv_typ_data bits typ data 353 | 354 | let marsal_lldp_tlvs mac tlvs bits = 355 | let _ = set_ethernet_dst "\x01\x80\xc2\x00\x00\x0e" 0 bits in 356 | let _ = set_ethernet_src (Macaddr.to_bytes mac) 357 | 0 bits in 358 | let _ = set_ethernet_ethertype bits 0x88cc in 359 | let bits = Cstruct.shift bits sizeof_ethernet in 360 | let rec marsal_lldp_tlvs_inner tlvs bits = 361 | match tlvs with 362 | | [] -> 0 363 | | h::t -> 364 | let len = marsal_lldp_tlv h bits in 365 | let bits = Cstruct.shift bits len in 366 | let rest = marsal_lldp_tlvs_inner t bits in 367 | len + rest 368 | in 369 | sizeof_ethernet + marsal_lldp_tlvs_inner tlvs bits 370 | -------------------------------------------------------------------------------- /lib/lldp.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | exception Unparsable of Cstruct.t 18 | 19 | (** LLDP basic message tbl types *) 20 | 21 | type lldp_tlv_types = 22 | | LLDP_TYPE_END 23 | | LLDP_TYPE_CHASSIS_ID 24 | | LLDP_TYPE_PORT_ID 25 | | LLDP_TYPE_TTL 26 | | LLDP_TYPE_PORT_DESCR 27 | | LLDP_TYPE_SYSTEM_NAME 28 | | LLDP_TYPE_SYSTEM_DESCR 29 | | LLDP_TYPE_SYSTEM_CAP 30 | | LLDP_TYPE_MGMT_ADDR 31 | 32 | type lldp_tvl = 33 | | Tlv_chassis_id_chassis_comp of string 34 | | Tlv_chassis_id_intf_alias of string 35 | | Tlv_chassis_id_port_comp of string 36 | | Tlv_chassis_id_mac of Macaddr.t 37 | | Tlv_chassis_id_net of Ipaddr.V4.t 38 | | Tlv_chassis_id_intf_name of string 39 | | Tlv_chassis_id_local of string 40 | | Tlv_port_id_intf_alias of string 41 | | Tlv_port_id_port_comp of string 42 | | Tlv_port_id_mac of Macaddr.t 43 | | Tlv_port_id_net of Ipaddr.V4.t 44 | | Tlv_port_id_intf_name of string 45 | | Tlv_port_id_circ_id of string 46 | | Tlv_port_id_local of string 47 | | Tlv_ttl of int 48 | | Tlv_end 49 | | Tlv of lldp_tlv_types * string 50 | | Tlv_unk of int * string 51 | 52 | (** [parse_lldp_tlvs bits] extract an lldp packet from a raw packet*) 53 | val parse_lldp_tlvs: Cstruct.t -> lldp_tvl list 54 | (** [marshal_lldp_tlvs mac tlvs bits] marshal lldp tlvs to bits memory address *) 55 | val marsal_lldp_tlvs: Macaddr.t -> lldp_tvl list -> Cstruct.t -> int 56 | -------------------------------------------------------------------------------- /lib/ofcontroller.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2005-2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt 18 | open Net 19 | open Ofsocket 20 | 21 | let sp = Printf.sprintf 22 | let cp = OS.Console.log 23 | 24 | module OP = Ofpacket 25 | 26 | module Event = struct 27 | type t = 28 | | DATAPATH_JOIN | DATAPATH_LEAVE | PACKET_IN | FLOW_REMOVED 29 | | FLOW_STATS_REPLY | AGGR_FLOW_STATS_REPLY | DESC_STATS_REPLY 30 | | PORT_STATS_REPLY | TABLE_STATS_REPLY | PORT_STATUS_CHANGE 31 | 32 | type e = 33 | | Datapath_join of OP.datapath_id * OP.Port.phy list 34 | | Datapath_leave of OP.datapath_id 35 | | Packet_in of OP.Port.t * OP.Packet_in.reason * 36 | int32 * Cstruct.t * OP.datapath_id 37 | | Flow_removed of 38 | OP.Match.t * OP.Flow_removed.reason * int32 * int32 * int64 * int64 39 | * OP.datapath_id 40 | | Flow_stats_reply of int32 * bool * OP.Flow.stats list * OP.datapath_id 41 | | Aggr_flow_stats_reply of int32 * int64 * int64 * int32 * OP.datapath_id 42 | | Port_stats_reply of int32 * bool * OP.Port.stats list * OP.datapath_id 43 | | Table_stats_reply of int32 * bool * OP.Stats.table list * OP.datapath_id 44 | | Desc_stats_reply of 45 | string * string * string * string * string 46 | * OP.datapath_id 47 | | Port_status of OP.Port.reason * OP.Port.phy * OP.datapath_id 48 | 49 | let string_of_event = function 50 | | Datapath_join (dpid, _) -> sp "Datapath_join: dpid:0x%012Lx" dpid 51 | | Datapath_leave dpid -> sp "Datapath_leave: dpid:0x%012Lx" dpid 52 | | Packet_in (port, r, buffer_id, bs, dpid) -> 53 | (sp "Packet_in: port:%s reason:%s dpid:0x%012Lx buffer_id:%ld" 54 | (OP.Port.string_of_port port) 55 | (OP.Packet_in.string_of_reason r) 56 | dpid buffer_id ) 57 | | Flow_removed (flow, reason, duration_sec, duration_usec, 58 | packet_count, byte_count, dpid) 59 | -> (sp "Flow_removed: flow: %s reason:%s duration:%ld.%ld packets:%s \ 60 | bytes:%s dpid:0x%012Lx" 61 | (OP.Match.match_to_string flow) 62 | (OP.Flow_removed.string_of_reason reason) 63 | duration_sec duration_usec 64 | (Int64.to_string packet_count) (Int64.to_string byte_count) dpid) 65 | | Flow_stats_reply(xid, more, flows, dpid) 66 | -> (sp "Flow stats reply: dpid:%012Lx more:%s flows:%d xid:%ld" 67 | dpid (string_of_bool more) (List.length flows) xid) 68 | | Aggr_flow_stats_reply(xid, packet_count, byte_count, flow_count, dpid) 69 | -> (sp "aggr flow stats reply: dpid:%012Lx packets:%Ld bytes:%Ld \ 70 | flows:%ld xid:%ld" 71 | dpid packet_count byte_count flow_count xid) 72 | | Port_stats_reply (xid, _, ports, dpid) 73 | -> (sp "port stats reply: dpid:%012Lx ports:%d xid%ld" 74 | dpid (List.length ports) xid) 75 | | Table_stats_reply (xid, _, tables, dpid) 76 | -> (sp "table stats reply: dpid:%012Lx tables:%d xid%ld" 77 | dpid (List.length tables) xid) 78 | | Desc_stats_reply (mfr_desc, hw_desc, sw_desc, serial_num, dp_desc, dpid) 79 | -> (sp "table stats reply: dpid:%012Lx mfr_desc:%s hw_desc:%s \ 80 | sw_desc:%s serial_num:%s dp_desc:%s" 81 | dpid mfr_desc hw_desc sw_desc serial_num dp_desc) 82 | | Port_status (r, ph, dpid) 83 | -> (sp "post stats: port:%s status:%s dpid:%012Lx" ph.OP.Port.name 84 | (OP.Port.reason_to_string r) dpid) 85 | end 86 | 87 | type t = { 88 | mutable dp_db: (OP.datapath_id, conn_state) Hashtbl.t; 89 | mutable datapath_join_cb: 90 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 91 | mutable datapath_leave_cb: 92 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 93 | mutable packet_in_cb: 94 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 95 | mutable flow_removed_cb: 96 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 97 | mutable flow_stats_reply_cb: 98 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 99 | mutable aggr_flow_stats_reply_cb: 100 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 101 | mutable desc_stats_reply_cb: 102 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 103 | mutable port_stats_reply_cb: 104 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 105 | mutable table_stats_reply_cb: 106 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 107 | mutable port_status_cb: 108 | (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; 109 | verbose : bool; 110 | } 111 | 112 | let register_cb controller e cb = 113 | Event.( 114 | match e with 115 | | DATAPATH_JOIN 116 | -> controller.datapath_join_cb <- controller.datapath_join_cb @ [cb] 117 | | DATAPATH_LEAVE 118 | -> controller.datapath_leave_cb <- controller.datapath_leave_cb @ [cb] 119 | | PACKET_IN 120 | -> controller.packet_in_cb <- controller.packet_in_cb @ [cb] 121 | | FLOW_REMOVED 122 | -> controller.flow_removed_cb <- controller.flow_removed_cb @ [cb] 123 | | FLOW_STATS_REPLY 124 | -> (controller.flow_stats_reply_cb 125 | <- controller.flow_stats_reply_cb @ [cb] 126 | ) 127 | | AGGR_FLOW_STATS_REPLY 128 | -> (controller.aggr_flow_stats_reply_cb 129 | <- controller.aggr_flow_stats_reply_cb @ [cb] 130 | ) 131 | | DESC_STATS_REPLY 132 | -> (controller.desc_stats_reply_cb 133 | <- controller.desc_stats_reply_cb @ [cb] 134 | ) 135 | | PORT_STATS_REPLY 136 | -> (controller.port_stats_reply_cb 137 | <- controller.port_stats_reply_cb @ [cb] 138 | ) 139 | | TABLE_STATS_REPLY 140 | -> (controller.table_stats_reply_cb 141 | <- controller.table_stats_reply_cb @ [cb]) 142 | | PORT_STATUS_CHANGE 143 | -> controller.port_status_cb <- controller.port_status_cb @ [cb] 144 | ) 145 | 146 | let process_of_packet state conn ofp = 147 | let _ = if state.verbose then cp (sp "[controller] rcv: %s\n%!" (OP.to_string ofp)) in 148 | OP.( 149 | match ofp with 150 | | Hello (h) -> (* Reply to HELLO with a HELLO and a feature request *) 151 | lwt _ = send_packet conn (OP.Hello (h)) in 152 | let h = OP.Header.create OP.Header.FEATURES_REQ OP.Header.get_len in 153 | send_packet conn (OP.Features_req (h) ) 154 | | Echo_req h -> (* Reply to ECHO requests *) 155 | send_packet conn (OP.Echo_resp OP.Header.(create ~xid:h.xid ECHO_RESP get_len)) 156 | | Echo_resp h -> return () (* At the moment ignore echo responses *) 157 | | Features_resp (h, sfs) -> begin (* Generate a datapath join event *) 158 | let open OP.Switch in 159 | let _ = conn.dpid <- sfs.datapath_id in 160 | let evt = Event.Datapath_join (sfs.datapath_id, sfs.ports) in 161 | let _ = 162 | if (Hashtbl.mem state.dp_db sfs.datapath_id) then 163 | cp (sp "[controller] Deleting old state for %Lx\n%!" conn.dpid) 164 | in 165 | let _ = Hashtbl.replace state.dp_db sfs.datapath_id conn in 166 | Lwt_list.iter_p (fun cb -> cb state sfs.datapath_id evt) 167 | state.datapath_join_cb 168 | end 169 | | OP.Packet_in (h, p) -> begin (* Generate a packet_in event *) 170 | let open OP.Packet_in in 171 | let evt = 172 | Event.Packet_in (p.in_port, p.reason, p.buffer_id, p.data, conn.dpid) in 173 | Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb 174 | end 175 | | OP.Flow_removed (h, p) -> 176 | let open OP.Flow_removed in 177 | let evt = Event.Flow_removed ( 178 | p.of_match, p.reason, p.duration_sec, p.duration_nsec, 179 | p.packet_count, p.byte_count, conn.dpid) in 180 | Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb 181 | | Stats_resp(h, resp) -> begin 182 | match resp with 183 | | OP.Stats.Flow_resp(resp_h, flows) -> begin 184 | let evt = Event.Flow_stats_reply( 185 | h.Header.xid, resp_h.OP.Stats.more, flows, conn.dpid) 186 | in 187 | Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) 188 | state.flow_stats_reply_cb 189 | end 190 | | OP.Stats.Aggregate_resp(resp_h, aggr) -> begin 191 | let evt = Event.Aggr_flow_stats_reply( 192 | h.Header.xid, aggr.OP.Stats.packet_count, 193 | aggr.OP.Stats.byte_count, aggr.OP.Stats.flow_count, conn.dpid) 194 | in 195 | Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) 196 | state.aggr_flow_stats_reply_cb 197 | end 198 | | OP.Stats.Desc_resp (resp_h, aggr) -> begin 199 | let evt = Event.Desc_stats_reply( 200 | aggr.OP.Stats.imfr_desc, aggr.OP.Stats.hw_desc, 201 | aggr.OP.Stats.sw_desc, aggr.OP.Stats.serial_num, 202 | aggr.OP.Stats.dp_desc, conn.dpid) 203 | in 204 | Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) 205 | state.desc_stats_reply_cb 206 | end 207 | 208 | | OP.Stats.Port_resp (resp_h, ports) -> begin 209 | let evt = 210 | Event.Port_stats_reply(h.Header.xid, resp_h.OP.Stats.more, 211 | ports, conn.dpid) 212 | in 213 | Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) 214 | state.port_stats_reply_cb 215 | end 216 | 217 | | OP.Stats.Table_resp (resp_h, tables) -> begin 218 | let evt = 219 | Event.Table_stats_reply(h.Header.xid, resp_h.OP.Stats.more, 220 | tables, conn.dpid) in 221 | Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) 222 | state.table_stats_reply_cb 223 | end 224 | | _ -> return (cp "[controller] unsupported stats response ") 225 | end 226 | 227 | | Port_status(h, st) -> begin 228 | let evt = Event.Port_status (st.OP.Port.reason, st.OP.Port.desc, conn.dpid) in 229 | Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb 230 | end 231 | | ofp -> return (cp (sp "[controller] Unsupported %s" (OP.to_string ofp))) 232 | ) 233 | 234 | let send_of_data controller dpid bits = 235 | Ofsocket.send_data_raw (Hashtbl.find controller.dp_db dpid ) bits 236 | 237 | let send_data controller dpid ofp = 238 | Ofsocket.send_packet (Hashtbl.find controller.dp_db dpid ) ofp 239 | 240 | let controller_run st conn = 241 | lwt _ = 242 | try_lwt 243 | while_lwt true do 244 | read_packet conn >>= process_of_packet st conn 245 | done 246 | with 247 | | Nettypes.Closed -> return (cp "[controller] switch disconnected\n%!") 248 | | OP.Unparsed(m, bs) 249 | | OP.Unparsable(m, bs) -> 250 | let _ = cp (sp "# unparsed! m=%s" m) in 251 | return (Cstruct.hexdump bs) 252 | | exn -> return (cp (sp "[controller] ERROR:%s\n%!" (Printexc.to_string exn))) 253 | in 254 | if (conn.dpid > 0L) then 255 | let evt = Event.Datapath_leave (conn.dpid) in 256 | lwt _ = Lwt_list.iter_p (fun cb -> cb st conn.dpid evt) 257 | st.datapath_leave_cb in 258 | let _ = Hashtbl.remove st.dp_db conn.dpid in 259 | return () 260 | else 261 | return () 262 | 263 | let socket_controller st (remote_addr, remote_port) t = 264 | let rs = Ipaddr.V4.to_string remote_addr in 265 | let _ = cp (sp "[controller]+ Controller %s:%d\n%!" rs remote_port) in 266 | let conn = init_socket_conn_state t in 267 | controller_run st conn 268 | 269 | let init_controller ?(verbose=false) init = 270 | let t = { verbose; 271 | dp_db = Hashtbl.create 0; 272 | datapath_join_cb = []; 273 | datapath_leave_cb = []; 274 | packet_in_cb = []; 275 | flow_removed_cb = []; 276 | flow_stats_reply_cb = []; 277 | aggr_flow_stats_reply_cb = []; 278 | desc_stats_reply_cb = []; 279 | port_stats_reply_cb = []; 280 | table_stats_reply_cb = []; 281 | port_status_cb = []; } in 282 | let _ = init t in 283 | t 284 | 285 | let listen mgr ?(verbose=false) loc init = 286 | let st = init_controller ~verbose init in 287 | (Channel.listen mgr (`TCPv4 (loc, (socket_controller st) ))) 288 | 289 | let connect mgr ?(verbose=false) loc init = 290 | let st = init_controller ~verbose init in 291 | Net.Channel.connect mgr (`TCPv4 (None, loc, 292 | (socket_controller st loc) )) 293 | 294 | let local_connect st conn = controller_run st conn 295 | -------------------------------------------------------------------------------- /lib/ofcontroller.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Richard Mortier 3 | * Copyright (c) 2011 Charalampos Rotsos 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Net 19 | 20 | module Event : sig 21 | open Ofpacket 22 | 23 | (** Event messages *) 24 | type t = 25 | DATAPATH_JOIN 26 | | DATAPATH_LEAVE 27 | | PACKET_IN 28 | | FLOW_REMOVED 29 | | FLOW_STATS_REPLY 30 | | AGGR_FLOW_STATS_REPLY 31 | | DESC_STATS_REPLY 32 | | PORT_STATS_REPLY 33 | | TABLE_STATS_REPLY 34 | | PORT_STATUS_CHANGE 35 | 36 | type e = 37 | Datapath_join of datapath_id * Ofpacket.Port.phy list 38 | | Datapath_leave of datapath_id 39 | | Packet_in of Port.t * Packet_in.reason * int32 * 40 | Cstruct.t * datapath_id 41 | | Flow_removed of Match.t * Flow_removed.reason * 42 | int32 * int32 * int64 * int64 * datapath_id 43 | | Flow_stats_reply of int32 * bool * Flow.stats list * datapath_id 44 | | Aggr_flow_stats_reply of int32 * int64 * int64 * int32 * datapath_id 45 | | Port_stats_reply of int32 * bool * Port.stats list * datapath_id 46 | | Table_stats_reply of int32 * bool * Stats.table list * datapath_id 47 | | Desc_stats_reply of string * string * string * string * string * datapath_id 48 | | Port_status of Port.reason * Port.phy * datapath_id 49 | 50 | (** convert a controller event to a string representation *) 51 | val string_of_event : e -> string 52 | end 53 | 54 | type t 55 | 56 | (** [register_cb ctrl evt fn] registers a callback for a specific event on 57 | * controller ctrl *) 58 | val register_cb : t -> Event.t -> (t -> Ofpacket.datapath_id -> Event.e -> unit Lwt.t) -> unit 59 | 60 | (** Controll channel packet transmission *) 61 | 62 | (** [send_of_data ctrl dpid bits] send a byte packet to the switch with datapath 63 | * dpid throught the ctrl controller *) 64 | val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.t -> unit Lwt.t 65 | (** [send_data ctrl dpid pkt] send the pkt OpenFlow message to the switch with datapath 66 | * dpid throught the ctrl controller *) 67 | val send_data : t -> Ofpacket.datapath_id -> Ofpacket.t -> unit Lwt.t 68 | 69 | (** Controller daemon setup *) 70 | 71 | (** [init_controller init] create the state for an openflow controller and 72 | * initialize it using the init method *) 73 | val init_controller : ?verbose:bool -> (t -> 'a) -> t 74 | (** [listen mgr addr init] listen on addr for connection switches. Intialize the 75 | * state for each control channel unsing the init method. *) 76 | val listen : Manager.t -> ?verbose:bool -> Nettypes.ipv4_src -> 77 | (t -> 'a) -> unit Lwt.t 78 | (** [connect mgr addr init] connect to the switch on addr. Intialize the 79 | * state of the control channel unsing the init method. *) 80 | val connect : Manager.t -> ?verbose:bool -> Nettypes.ipv4_dst -> 81 | (t -> 'a) -> unit Lwt.t 82 | (** [local_connect ctrl conn] connect to the switch using a local OpenFlow 83 | * socket. *) 84 | val local_connect : t -> Ofsocket.conn_state -> unit Lwt.t 85 | -------------------------------------------------------------------------------- /lib/ofsocket.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Haris Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | open Net 17 | open Lwt 18 | module OP = Ofpacket 19 | 20 | let resolve t = Lwt.on_success t (fun _ -> ()) 21 | 22 | let get_new_buffer len = 23 | let buf = OS.Io_page.to_cstruct (OS.Io_page.get 1) in 24 | Cstruct.sub buf 0 len 25 | 26 | module Socket = struct 27 | 28 | type t = { 29 | sock: Channel.t; 30 | data_cache: Cstruct.t ref; 31 | } 32 | 33 | let create_socket sock = 34 | { sock; data_cache=ref (get_new_buffer 0);} 35 | 36 | let write_buffer t bits = 37 | let _ = Channel.write_buffer t.sock bits in 38 | Channel.flush t.sock 39 | 40 | let close t = Channel.close t.sock 41 | 42 | let read_data t len = 43 | match (len, (Cstruct.len !(t.data_cache) ) ) with 44 | | (0, _) -> return (get_new_buffer 0) 45 | | (_, 0) -> 46 | lwt data = Channel.read_some t.sock in 47 | let ret = Cstruct.sub data 0 len in 48 | let _ = t.data_cache := (Cstruct.shift data len) in 49 | return ret 50 | | (_, l) when (l >= len) -> 51 | let ret = Cstruct.sub !(t.data_cache) 0 len in 52 | let _ = t.data_cache := (Cstruct.shift !(t.data_cache) len) in 53 | return ret 54 | | (_, l) when (l < len) -> 55 | let len_rest = len - l in 56 | let ret = Cstruct.set_len !(t.data_cache) len in 57 | lwt data = Channel.read_some t.sock in 58 | let _ = Cstruct.blit data 0 ret l len_rest in 59 | let _ = t.data_cache := (Cstruct.shift data len_rest) in 60 | return (ret) 61 | | _ -> failwith "invalid read data operation" 62 | end 63 | 64 | type conn_type = 65 | | Socket of Socket.t 66 | | Local of OP.t Lwt_stream.t * (OP.t option -> unit) 67 | 68 | type conn_state = { 69 | mutable dpid : OP.datapath_id; 70 | t : conn_type; 71 | } 72 | 73 | let init_socket_conn_state t = 74 | {dpid=0L;t=(Socket (Socket.create_socket t));} 75 | 76 | let init_local_conn_state () = 77 | let (controller_input, switch_output) = Lwt_stream.create () in 78 | let (switch_input, controller_output) = Lwt_stream.create () in 79 | let ch1 = {dpid=0L;t=(Local (controller_input, controller_output));} in 80 | let ch2 = {dpid=0L;t=(Local (switch_input, switch_output));} in 81 | (ch1, ch2) 82 | 83 | let read_packet conn = 84 | match conn.t with 85 | | Socket t -> 86 | lwt hbuf = Channel.read_exactly t.Socket.sock OP.Header.sizeof_ofp_header in 87 | let ofh = OP.Header.parse_header hbuf in 88 | let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in 89 | lwt dbuf = 90 | if (dlen = 0) then 91 | return (Cstruct.create 0) 92 | else 93 | Channel.read_exactly t.Socket.sock dlen 94 | in 95 | let ofp = OP.parse ofh dbuf in 96 | return ofp 97 | | Local (input, _) -> 98 | match_lwt (Lwt_stream.get input) with 99 | | None -> raise Nettypes.Closed 100 | | Some ofp -> return ofp 101 | 102 | let send_packet conn ofp = 103 | match conn.t with 104 | | Socket t -> Socket.write_buffer t (OP.marshal ofp) 105 | | Local (_, output) -> return (output (Some ofp )) 106 | 107 | let send_data_raw t bits = 108 | match t.t with 109 | | Local _ -> failwith "send_of_data is not supported in Local mode" 110 | | Socket t -> 111 | (* Socket.write_buffer t bits *) 112 | let _ = Channel.write_buffer t.Socket.sock bits in 113 | Channel.flush t.Socket.sock 114 | 115 | let close conn = 116 | match conn.t with 117 | | Socket t -> 118 | resolve ( 119 | try_lwt 120 | Socket.close t 121 | with exn -> 122 | return (OS.Console.log (Printf.sprintf "[socket] close error: %s\n%!" 123 | (Printexc.to_string exn))) 124 | ) 125 | | Local (_, output) -> output None 126 | 127 | -------------------------------------------------------------------------------- /lib/ofsocket.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Haris Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** OpenFlow socket structure *) 18 | type conn_type 19 | type conn_state = { 20 | mutable dpid : Ofpacket.datapath_id; 21 | t : conn_type; 22 | } 23 | 24 | (** Socket initialization *) 25 | 26 | (** initialize an OpenFlow socket from a Net.Channel.t socket*) 27 | val init_socket_conn_state : Net.Channel.t -> conn_state 28 | (** create an emulated local socket using Lwt_stream structures *) 29 | val init_local_conn_state: unit -> (conn_state * conn_state) 30 | 31 | (** Socket access methods *) 32 | 33 | (** [read_packet conn] read a complete and parsed OpenFlow packet from the 34 | * control channel socket *) 35 | val read_packet : conn_state -> Ofpacket.t Lwt.t 36 | (** [send_packet conn pkt] send an complete OpenFlow packet over the control 37 | * channel socket *) 38 | val send_packet : conn_state -> Ofpacket.t -> unit Lwt.t 39 | (** [send_data_raw conn bits] send raw bits over the control channel socket *) 40 | val send_data_raw : conn_state -> Cstruct.t -> unit Lwt.t 41 | (** [conn conn] teardown the control channel socket *) 42 | val close : conn_state -> unit 43 | -------------------------------------------------------------------------------- /lib/ofswitch.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Richard Mortier 3 | * Copyright (c) 2011 Charalampos Rotsos 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | open Net 18 | 19 | type t 20 | 21 | (** [create dpid] initializes the state for a switch with a datapth id dpid *) 22 | val create_switch : ?verbose:bool -> int64 -> t 23 | 24 | (** Port Management *) 25 | 26 | (** [add_port mgr st intf] add port intf under the control of the switch st *) 27 | val add_port : Manager.t -> ?use_mac:bool -> t -> Manager.id -> unit Lwt.t 28 | (** [del_port mgr st intf] remove port intf from the control of the switch st *) 29 | val del_port : Manager.t -> t -> string -> unit Lwt.t 30 | (** [add_port_local mgr st intf] add port intf as the local loopback interface 31 | * of th switch st *) 32 | val add_port_local : Manager.t -> t -> Manager.id -> unit Lwt.t 33 | 34 | (** Switch state management *) 35 | 36 | (** [add_flow st fl] add flow definition fl to the switch st *) 37 | val add_flow : t -> Openflow.Ofpacket.Flow_mod.t -> unit Lwt.t 38 | 39 | (** [del_flow st fl] remove all flows matching flow definition fl 40 | * from the switch st *) 41 | val del_flow : t -> Openflow.Ofpacket.Match.t -> unit Lwt.t 42 | 43 | (** [get_flow_stats st fl] fetch statistics for flows matching flow definition 44 | * fl from the switch st *) 45 | val get_flow_stats : t -> Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list 46 | 47 | (** Daemon run *) 48 | 49 | (** [listen st mgr addr] start a listening switch control channel on addr *) 50 | val listen : t -> Manager.t -> Nettypes.ipv4_src -> unit Lwt.t 51 | (** [connect st mgr addr] connect a switch control channel to a controller 52 | * on addr *) 53 | val connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t 54 | (** [local_connect st mgr conn] setup a switch control channel on the local 55 | * Open`flow socket conn *) 56 | val local_connect : t -> Manager.t -> Openflow.Ofsocket.conn_state -> unit Lwt.t 57 | (** [standalone_connect st mgr addr] same as connect method, but a local 58 | * learning switch is responsible to control the switch, when the remote 59 | * control channel is unresponsive *) 60 | val standalone_connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t 61 | -------------------------------------------------------------------------------- /lib/ofswitch_config.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt 18 | open Printf 19 | 20 | module OP = Openflow.Ofpacket 21 | 22 | let sp = Printf.sprintf 23 | let cp = OS.Console.log 24 | 25 | let parse_actions actions = 26 | let actions = Re_str.split (Re_str.regexp "/") actions in 27 | let split_action = Re_str.regexp ":" in 28 | List.fold_right ( 29 | fun action actions -> 30 | try 31 | match (Re_str.split split_action action) with 32 | | "output"::port::_ -> begin 33 | match (OP.Port.port_of_string port) with 34 | | Some port -> 35 | actions @ [(OP.Flow.Output(port, 2000))] 36 | | None -> 37 | let _ = printf "[ofswitch-config] Invalid port %s\n%!" port in 38 | actions 39 | end 40 | | "set_vlan_vid"::vif::_ -> 41 | actions @ [(OP.Flow.Set_vlan_vid(int_of_string vif))] 42 | | "set_vlan_pcp"::pcp::_ -> 43 | actions @ [(OP.Flow.Set_vlan_pcp(int_of_string pcp))] 44 | | "set_dl_src"::addr::_ -> begin 45 | match (Macaddr.of_string addr) with 46 | | None -> 47 | let _ = cp (sp "[ofswitch-config] Invalid mac %s\n%!" action) in 48 | actions 49 | | Some addr -> actions @[(OP.Flow.Set_dl_src(addr))] 50 | end 51 | | "set_dl_dst"::addr::_ -> begin 52 | match (Macaddr.of_string addr) with 53 | | None -> 54 | let _ = cp (sp "[ofswitch-config] Invalid mac %s\n%!" action) in 55 | actions 56 | | Some addr -> actions @[(OP.Flow.Set_dl_dst(addr))] 57 | end 58 | | "set_nw_src"::addr::_ -> begin 59 | match (Ipaddr.V4.of_string addr) with 60 | | None -> 61 | let _ = cp (sp "[ofswitch-config] invalid ip %s\n%!" addr) in 62 | actions 63 | | Some ip -> actions @ [(OP.Flow.Set_nw_src(ip))] 64 | end 65 | | "set_nw_dst"::addr::_ -> begin 66 | match (Ipaddr.V4.of_string addr) with 67 | | None -> 68 | let _ = cp (sp "[ofswitch-config] invalid ip %s\n%!" addr) in 69 | actions 70 | | Some ip -> actions @ [(OP.Flow.Set_nw_dst(ip))] 71 | end 72 | | "set_nw_tos"::tos::_ -> 73 | actions @ [(OP.Flow.Set_nw_tos(char_of_int (int_of_string tos)))] 74 | | "set_tp_src"::port::_ -> 75 | actions @ [(OP.Flow.Set_tp_src(int_of_string port))] 76 | | "set_tp_dst"::port::_ -> 77 | actions @ [(OP.Flow.Set_tp_dst(int_of_string port))] 78 | | _ -> 79 | let _ = cp (sp "[ofswitch-config] invalid action %s" action) in 80 | actions 81 | with exn -> 82 | let _ = cp (sp "[ofswitch-config] error parsing action %s\n%!" action) in 83 | actions 84 | ) actions [] 85 | 86 | 87 | let hashtbl_to_flow_match t = 88 | let of_match = OP.Match.wildcard () in 89 | let map = 90 | List.fold_right ( 91 | fun (name, value) r -> 92 | let _ = Hashtbl.add r name (Rpc.string_of_rpc value) in 93 | (* let _ = printf "Adding %s = %s\n%!" name 94 | (Rpc.string_of_rpc value) in *) 95 | r 96 | ) t (Hashtbl.create 10) in 97 | let _ = 98 | Hashtbl.iter ( 99 | fun name value -> 100 | match name with 101 | | "in_port" -> begin 102 | match (OP.Port.port_of_string value) with 103 | | Some port -> 104 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.in_port <- 105 | false in 106 | let _ = of_match.OP.Match.in_port <- port in 107 | () 108 | | None -> 109 | let _ = printf "[ofswitch-config] Invalid port %s\n%!" value in 110 | () 111 | end 112 | | "dl_vlan" -> 113 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan <- false in 114 | let _ = of_match.OP.Match.dl_vlan <- int_of_string value in 115 | () 116 | | "dl_vlan_pcp" -> 117 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan_pcp <- false in 118 | let _ = of_match.OP.Match.dl_vlan_pcp <- char_of_int (int_of_string value) in 119 | () 120 | | "dl_src" -> 121 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_src <- false in 122 | let _ = 123 | match (Macaddr.of_string value) with 124 | | None -> printf "Invalid mac addr %s\n%!" value 125 | | Some t -> of_match.OP.Match.dl_src <- t 126 | in 127 | () 128 | | "dl_dst" -> 129 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_dst <- false in 130 | let _ = 131 | match (Macaddr.of_string value) with 132 | | None -> printf "Invalid mac addr %s\n%!" value 133 | | Some t -> of_match.OP.Match.dl_dst <- t 134 | in 135 | () 136 | | "dl_type" -> 137 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_type <- false in 138 | let _ = of_match.OP.Match.dl_type <- int_of_string value in 139 | () 140 | | "nw_src" -> begin 141 | match (Re_str.split (Re_str.regexp "/") value) with 142 | | ip::mask::_ -> begin 143 | match (Ipaddr.V4.of_string ip) with 144 | | None -> printf "Invalid ip definition" 145 | | Some ip -> 146 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_src <- 147 | char_of_int (int_of_string mask) in 148 | let _ = of_match.OP.Match.nw_src <- ip in 149 | () 150 | end 151 | | _ -> printf "Invalid ip definition" 152 | end 153 | | "nw_dst" -> begin 154 | match (Re_str.split (Re_str.regexp "/") value) with 155 | | ip::mask::_ -> begin 156 | match (Ipaddr.V4.of_string ip) with 157 | | None -> printf "Invalid ip definition" 158 | | Some ip -> 159 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_dst <- 160 | char_of_int (int_of_string mask) in 161 | let _ = of_match.OP.Match.nw_dst <- ip 162 | in 163 | () 164 | end 165 | | _ -> printf "Invalid ip definition" 166 | end 167 | | "nw_tos" -> 168 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_tos <- false in 169 | let _ = of_match.OP.Match.nw_tos <- char_of_int (int_of_string 170 | value) in 171 | () 172 | | "nw_proto" -> 173 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_proto <- false in 174 | let _ = of_match.OP.Match.nw_proto <- char_of_int (int_of_string 175 | value) in 176 | () 177 | | "tp_src" -> 178 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_src <- false in 179 | let _ = of_match.OP.Match.tp_src <- int_of_string value in 180 | () 181 | | "tp_dst" -> 182 | let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_dst <- false in 183 | let _ = of_match.OP.Match.tp_dst <- int_of_string value in 184 | () 185 | | _ -> 186 | let _ = eprintf "Invalid field name %s" name in 187 | () 188 | ) map in 189 | of_match 190 | 191 | let get_ethif mgr id = 192 | let lst = Net.Manager.get_intfs mgr in 193 | let (_, ethif) = List.find (fun (dev_id,_) -> id = dev_id) lst in 194 | ethif 195 | 196 | let listen_t mgr add_port del_port get_stats add_flow del_flow port = 197 | let manage (dip,dpt) t = 198 | try_lwt 199 | lwt req = Net.Channel.read_line t in 200 | let req = 201 | List.fold_right ( 202 | fun a r -> 203 | r ^ (Cstruct.to_string a) 204 | ) req "" in 205 | let req = Jsonrpc.call_of_string req in 206 | lwt success = 207 | match (req.Rpc.name, req.Rpc.params) with 208 | | ("add-port", (Rpc.String (devname))::_) -> begin 209 | try_lwt 210 | (* let (fd, name) = Tuntap.opentap ~persist:true ~devname () in 211 | let id = OS.Netif.id_of_string name in 212 | (* OS.Netif.add_vif id OS.Netif.ETH fd; *) 213 | lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in *) 214 | return (Rpc.Enum [(Rpc.String "true")]) 215 | with exn -> 216 | cp (sp "[ofswitch-confid] add-port: %s\n%!" (Printexc.to_string exn)); 217 | return (Rpc.Enum [(Rpc.String "false")]) 218 | 219 | end 220 | | ("del-port", (Rpc.String (dev))::_) -> 221 | 222 | (*let ethif = Net.Ethif.get_netif 223 | (Net.Manager.get_ethif (get_ethif mgr (OS.Netif.id_of_string 224 | dev))) in *) 225 | (* lwt _ = OS.Netif.destroy ethif in *) 226 | lwt _ = del_port dev in 227 | return (Rpc.Enum [(Rpc.String "true")]) 228 | | ("dump-flows", (Rpc.Dict t)::_) -> 229 | let of_match = hashtbl_to_flow_match t in 230 | let _ = cp (sp "Find rules matching %s\n%!" 231 | (OP.Match.match_to_string of_match)) in 232 | let flows = get_stats of_match in 233 | let res = 234 | List.fold_right ( 235 | fun a r -> (Rpc.String (OP.Flow.string_of_flow_stat a))::r) flows [] in 236 | return (Rpc.Enum res) 237 | | ("add-flow", (Rpc.Dict t)::_) -> 238 | let _ = cp (sp "adding flow %s\n%!" (Rpc.string_of_call req)) in 239 | let fm = OP.Flow_mod.create (OP.Match.wildcard () ) 0L OP.Flow_mod.ADD [] () in 240 | let map = 241 | List.fold_right ( 242 | fun (name, value) r -> 243 | match name with 244 | | "actions" -> 245 | fm.OP.Flow_mod.actions <- parse_actions (Rpc.string_of_rpc value); 246 | r 247 | | "idle_timeout" -> 248 | fm.OP.Flow_mod.idle_timeout <- (Rpc.int_of_rpc value); 249 | r 250 | | "hard_timeout" -> 251 | fm.OP.Flow_mod.hard_timeout <- (Rpc.int_of_rpc value); 252 | r 253 | | "priority" -> 254 | fm.OP.Flow_mod.priority <- (Rpc.int_of_rpc value); 255 | r 256 | | _ -> r @ [(name, value)] 257 | ) t [] in 258 | let _ = fm.OP.Flow_mod.of_match <- hashtbl_to_flow_match map in 259 | let _ = cp (sp "Add flow %s\n%!" (OP.Flow_mod.flow_mod_to_string fm)) in 260 | lwt _ = add_flow fm in 261 | return (Rpc.Enum [(Rpc.String "true")] ) 262 | | ("del-flow", (Rpc.Dict t)::_) -> 263 | let of_match = hashtbl_to_flow_match t in 264 | lwt _ = del_flow of_match in 265 | return (Rpc.Enum [(Rpc.String "true")] ) 266 | | (_, _) -> 267 | let _ = printf "[ofswitch-config] invalid action %s\n%!" 268 | (req.Rpc.name) in 269 | return (Rpc.Enum [(Rpc.String "false")]) 270 | in 271 | let resp = 272 | Jsonrpc.string_of_response (Rpc.success success) in 273 | let _ = Net.Channel.write_line t resp in 274 | lwt _ = Net.Channel.flush t in 275 | lwt _ = Net.Channel.close t in 276 | return () 277 | with 278 | | End_of_file -> return () 279 | | exn -> 280 | let _ = cp "[ofswitch_config] server error" in 281 | return () 282 | in 283 | Net.Channel.listen mgr (`TCPv4 ((None, 6634), manage )) 284 | -------------------------------------------------------------------------------- /lib/ofswitch_config.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | 18 | (** initalize a switch configration daemon *) 19 | val listen_t: Net.Manager.t -> 20 | (Net.Manager.id -> unit Lwt.t) -> 21 | (string -> unit Lwt.t) -> 22 | (Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list) -> 23 | (Openflow.Ofpacket.Flow_mod.t -> unit Lwt.t) -> 24 | (Openflow.Ofpacket.Match.t -> unit Lwt.t) -> 25 | int -> unit Lwt.t 26 | -------------------------------------------------------------------------------- /lib/ofswitch_ctrl.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Richard Mortier 3 | * Copyright (c) 2011 Charalampos Rotsos 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Lwt 19 | open Printf 20 | open Lwt_unix 21 | 22 | let check_cmd_args cmd count = 23 | if ((Array.length Sys.argv) < (2 + count)) then 24 | failwith (sprintf "Insufficient args for command %s (required %d)" 25 | cmd count) 26 | 27 | let flow_element = 28 | ["in_port"; "dl_src"; "dl_dst"; "dl_vlan"; "dl_pcp"; "dl_type"; 29 | "nw_src";"nw_dst"; 30 | "nw_tos"; "nw_proto"; "tp_src"; "tp_dst"; "actions";"priority"; 31 | "idle_timeout"; "hard_timeout"; ] 32 | 33 | let process_flow_description flow = 34 | let fields = Re_str.split (Re_str.regexp ",") flow in 35 | let rec process_flow_inner = function 36 | | [] -> [] 37 | | hd::tl -> 38 | let name::value::_ = Re_str.split (Re_str.regexp "=") hd in 39 | let _ = 40 | if (not (List.mem name flow_element) ) then 41 | failwith (sprintf "Invalid flow field %s" name) 42 | in 43 | [(name, (Rpc.String value))] @ (process_flow_inner tl) 44 | in 45 | process_flow_inner fields 46 | 47 | 48 | 49 | let send_cmd (input, output) = 50 | try_lwt 51 | let _ = 52 | if ((Array.length Sys.argv) < 2) then 53 | failwith "No command defined" 54 | in 55 | lwt resp = 56 | match (Sys.argv.(1)) with 57 | | "add-port" -> 58 | let _ = check_cmd_args Sys.argv.(1) 2 in 59 | let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String Sys.argv.(3))];}) in 60 | lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in 61 | lwt resp = Lwt_io.read_line input in 62 | let resp = Jsonrpc.response_of_string resp in 63 | return (string_of_bool resp.Rpc.success) 64 | | "del-port" -> 65 | let _ = check_cmd_args Sys.argv.(1) 2 in 66 | let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String 67 | Sys.argv.(3))];}) in 68 | lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in 69 | lwt resp = Lwt_io.read_line input in 70 | let resp = Jsonrpc.response_of_string resp in 71 | return (string_of_bool resp.Rpc.success) 72 | | "dump-flows" -> begin 73 | let _ = check_cmd_args Sys.argv.(1) 2 in 74 | let fields = process_flow_description Sys.argv.(3) in 75 | let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.Dict fields)];}) in 76 | lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in 77 | lwt resp = Lwt_io.read_line input in 78 | let resp = Jsonrpc.response_of_string resp in 79 | match resp.Rpc.contents with 80 | | Rpc.Enum flows -> 81 | return 82 | (List.fold_right 83 | (fun a r -> sprintf "%s%s\n%!" r (Rpc.string_of_rpc a)) flows "") 84 | | _ -> return "" 85 | end 86 | | "add-flow" -> begin 87 | let _ = check_cmd_args Sys.argv.(1) 2 in 88 | let fields = process_flow_description Sys.argv.(3) in 89 | let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.Dict fields)];}) in 90 | lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in 91 | lwt resp = Lwt_io.read_line input in 92 | let resp = Jsonrpc.response_of_string resp in 93 | return (string_of_bool resp.Rpc.success) 94 | end 95 | | _ -> 96 | return (sprintf "Fail: unknown cmd: %s\n%!" Sys.argv.(1)) 97 | in 98 | let _ = printf "result:\n%s\n%!" resp in 99 | return () 100 | with ex -> 101 | return (printf "Fail: %s" (Printexc.to_string ex)) 102 | 103 | lwt _ = 104 | try_lwt 105 | let dst = ADDR_INET( (Unix.inet_addr_of_string "10.20.0.2"), 106 | 6634) in 107 | lwt _ = Lwt_io.with_connection dst (send_cmd) in 108 | return () 109 | with e -> 110 | Printf.eprintf "Error: %s" (Printexc.to_string e); 111 | return () 112 | -------------------------------------------------------------------------------- /lib/ofswitch_model.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Richard Mortier 3 | * Copyright (c) 2011 Charalampos Rotsos 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | open Net 18 | 19 | type t 20 | 21 | type delay_model = { 22 | flow_insert : float; 23 | flow_update : float; 24 | pktin_rate : float; 25 | pktin_delay : float; 26 | stats_delay : float; 27 | pktout_delay: float; 28 | } 29 | 30 | (** [create dpid] initializes the state for a switch with a datapth id dpid *) 31 | val create_switch : ?verbose:bool -> int64 -> delay_model -> t 32 | 33 | (** Port Management *) 34 | 35 | (** [add_port mgr st intf] add port intf under the control of the switch st *) 36 | val add_port : Manager.t -> ?use_mac:bool -> t -> Manager.id -> unit Lwt.t 37 | (** [del_port mgr st intf] remove port intf from the control of the switch st *) 38 | val del_port : Manager.t -> t -> string -> unit Lwt.t 39 | (** [add_port_local mgr st intf] add port intf as the local loopback interface 40 | * of th switch st *) 41 | val add_port_local : Manager.t -> t -> Manager.id -> unit Lwt.t 42 | 43 | (** [get_flow_stats st fl] fetch statistics for flows matching flow definition 44 | * fl from the switch st *) 45 | val get_flow_stats : t -> Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list 46 | 47 | (** Daemon run *) 48 | 49 | (** [listen st mgr addr] start a listening switch control channel on addr *) 50 | val listen : t -> Manager.t -> Nettypes.ipv4_src -> unit Lwt.t 51 | (** [connect st mgr addr] connect a switch control channel to a controller 52 | * on addr *) 53 | val connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t 54 | (** [local_connect st mgr conn] setup a switch control channel on the local 55 | * Open`flow socket conn *) 56 | val local_connect : t -> Manager.t -> Openflow.Ofsocket.conn_state -> unit Lwt.t 57 | (** [standalone_connect st mgr addr] same as connect method, but a local 58 | * learning switch is responsible to control the switch, when the remote 59 | * control channel is unresponsive *) 60 | val standalone_connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t 61 | -------------------------------------------------------------------------------- /lib/ofswitch_standalone.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | open Lwt 17 | open Printf 18 | open Net 19 | open Net.Nettypes 20 | 21 | let resolve t = Lwt.on_success t (fun _ -> ()) 22 | 23 | module OP = Openflow.Ofpacket 24 | module OC = Openflow.Ofcontroller 25 | module OE = Openflow.Ofcontroller.Event 26 | module OSK = Openflow.Ofsocket 27 | 28 | let pp = Printf.printf 29 | let sp = Printf.sprintf 30 | 31 | 32 | (* TODO this the mapping is incorrect. the datapath must be moved to the key 33 | * of the hashtbl *) 34 | type mac_switch = { 35 | addr: Macaddr.t; 36 | switch: OP.datapath_id; 37 | } 38 | 39 | type switch_state = { 40 | mutable mac_cache: (Macaddr.t, OP.Port.t) Hashtbl.t; 41 | req_count: int ref; 42 | } 43 | 44 | let switch_data = 45 | { mac_cache = Hashtbl.create 0; req_count=(ref 0);} 46 | 47 | 48 | let datapath_join_cb controller dpid evt = 49 | let dp = 50 | match evt with 51 | | OE.Datapath_join (c, _) -> c 52 | | _ -> invalid_arg "bogus datapath_join event match!" 53 | in 54 | return (pp "+ datapath:0x%012Lx\n" dp) 55 | 56 | let datapath_leave_cb controller dpid evt = 57 | let dp = 58 | match evt with 59 | | OE.Datapath_leave (c) -> c 60 | | _ -> invalid_arg "bogus datapath_leave event match!" 61 | in 62 | let _ = Hashtbl.clear switch_data.mac_cache in 63 | let _ = switch_data.req_count := 0 in 64 | return (pp "- datapath:0x%012Lx\n" dp) 65 | 66 | 67 | let req_count = (ref 0) 68 | let port_status_cb controller dpid = function 69 | | OE.Port_status (OP.Port.DEL, port, _) -> 70 | let macs = Hashtbl.fold ( 71 | fun mac p r -> 72 | if(p = (OP.Port.port_of_int port.OP.Port.port_no) ) then 73 | r @ [mac] 74 | else 75 | r ) switch_data.mac_cache [] 76 | in 77 | return ( 78 | List.iter (Hashtbl.remove switch_data.mac_cache) macs) 79 | | _ -> return () 80 | let add_entry_in_hashtbl mac_cache ix in_port = 81 | if not (Hashtbl.mem mac_cache ix ) then 82 | Hashtbl.add mac_cache ix in_port 83 | else 84 | Hashtbl.replace mac_cache ix in_port 85 | 86 | let packet_in_cb controller dpid evt = 87 | incr switch_data.req_count; 88 | let (in_port, buffer_id, data, dp) = 89 | match evt with 90 | | OE.Packet_in (inp, _, buf, dat, dp) -> (inp, buf, dat, dp) 91 | | _ -> invalid_arg "bogus datapath_join event match!" 92 | in 93 | (* Parse Ethernet header *) 94 | let m = OP.Match.raw_packet_to_match in_port data in 95 | 96 | (* Store src mac address and incoming port *) 97 | let ix = m.OP.Match.dl_src in 98 | let _ = Hashtbl.replace switch_data.mac_cache ix in_port in 99 | 100 | (* check if I know the output port in order to define what type of message 101 | * we need to send *) 102 | let ix = m.OP.Match.dl_dst in 103 | if ( (ix = Macaddr.broadcast ) 104 | || (not (Hashtbl.mem switch_data.mac_cache ix)) ) 105 | then ( 106 | let bs = 107 | (OP.Packet_out.create ~buffer_id:buffer_id 108 | ~actions:[ OP.Flow.Output(OP.Port.All , 2000)] 109 | ~data:data ~in_port:in_port () ) in 110 | let h = OP.Header.create OP.Header.PACKET_OUT 0 in 111 | OC.send_data controller dpid (OP.Packet_out (h, bs)) 112 | ) else ( 113 | let out_port = (Hashtbl.find switch_data.mac_cache ix) in 114 | let flags = OP.Flow_mod.({send_flow_rem=true; emerg=false; overlap=false;}) in 115 | lwt _ = 116 | if (buffer_id = -1l) then 117 | (* Need to send also the packet in cache the packet is not cached *) 118 | let bs = 119 | OP.Packet_out.create 120 | ~buffer_id:buffer_id 121 | ~actions:[ OP.Flow.Output(out_port, 2000)] 122 | ~data:data ~in_port:in_port () in 123 | let h = OP.Header.create OP.Header.PACKET_OUT 0 in 124 | OC.send_data controller dpid (OP.Packet_out (h, bs)) 125 | else 126 | return () 127 | in 128 | let pkt = 129 | (OP.Flow_mod.create m 0_L OP.Flow_mod.ADD ~hard_timeout:0 130 | ~idle_timeout:0 ~buffer_id:(Int32.to_int buffer_id) ~flags 131 | [OP.Flow.Output(out_port, 2000)] ()) in 132 | let h = OP.Header.create OP.Header.FLOW_MOD 0 in 133 | OC.send_data controller dpid (OP.Flow_mod (h, pkt)) 134 | ) 135 | 136 | let init controller = 137 | pp "test controller register datapath cb\n%!"; 138 | OC.register_cb controller OE.DATAPATH_JOIN datapath_join_cb; 139 | pp "test controller register leave cb\n%!"; 140 | OC.register_cb controller OE.DATAPATH_LEAVE datapath_leave_cb; 141 | pp "test controller register packet_in cb\n%!"; 142 | OC.register_cb controller OE.PACKET_IN packet_in_cb; 143 | pp "test controller register packet_in cb\n%!"; 144 | OC.register_cb controller OE.PORT_STATUS_CHANGE port_status_cb 145 | 146 | 147 | let init_controller () = OC.init_controller init 148 | 149 | let run_controller mgr st = 150 | let (controller, switch) = OSK.init_local_conn_state () in 151 | let _ = Lwt.ignore_result ( 152 | try_lwt 153 | OC.local_connect st controller 154 | with exn -> 155 | return (printf "[switch] standalone controllern failed %s\n%!" (Printexc.to_string 156 | exn)) 157 | ) in 158 | return switch 159 | -------------------------------------------------------------------------------- /lib/ofswitch_standalone.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | val init_controller : unit -> Openflow.Ofcontroller.t 18 | val run_controller : Net.Manager.t -> Openflow.Ofcontroller.t -> Openflow.Ofsocket.conn_state Lwt.t 19 | -------------------------------------------------------------------------------- /lib/openflow.mlpack: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: b6991de36e646d2bbeea2320259aae59) 3 | Ofpacket 4 | Ofcontroller 5 | Ofsocket 6 | # OASIS_STOP 7 | -------------------------------------------------------------------------------- /lib/openflow.odocl: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: b6991de36e646d2bbeea2320259aae59) 3 | Ofpacket 4 | Ofcontroller 5 | Ofsocket 6 | # OASIS_STOP 7 | -------------------------------------------------------------------------------- /lib/path.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (* $Id: path.ml,v 1.6 2005-07-18 07:10:35 filliatr Exp $ *) 19 | 20 | module type WEIGHT = sig 21 | type label 22 | type t 23 | val weight : label -> t 24 | val compare : t -> t -> int 25 | val add : t -> t -> t 26 | val zero : t 27 | end 28 | 29 | module type G = sig 30 | type t 31 | module V : Sig.COMPARABLE 32 | module E : sig 33 | type t 34 | type label 35 | val label : t -> label 36 | val src : t -> V.t 37 | val dst : t -> V.t 38 | end 39 | val iter_vertex : (V.t -> unit) -> t -> unit 40 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 41 | val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit 42 | val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a 43 | val nb_vertex : t -> int 44 | end 45 | 46 | module Dijkstra 47 | (G: G) 48 | (W: WEIGHT with type label = G.E.label) = 49 | struct 50 | 51 | open G.E 52 | 53 | module H = Hashtbl.Make(G.V) 54 | 55 | module Elt = struct 56 | type t = W.t * G.V.t * G.E.t list 57 | 58 | (* weights are compared first, and minimal weights come first in the 59 | queue *) 60 | let compare (w1,v1,_) (w2,v2,_) = 61 | let cw = W.compare w2 w1 in 62 | if cw != 0 then cw else G.V.compare v1 v2 63 | end 64 | 65 | module PQ = Heap.Imperative(Elt) 66 | 67 | let shortest_path g v1 v2 = 68 | let visited = H.create 97 in 69 | let dist = H.create 97 in 70 | let q = PQ.create 17 in 71 | let rec loop () = 72 | if PQ.is_empty q then raise Not_found; 73 | let (w,v,p) = PQ.pop_maximum q in 74 | if G.V.compare v v2 = 0 then 75 | List.rev p, w 76 | else begin 77 | if not (H.mem visited v) then begin 78 | H.add visited v (); 79 | G.iter_succ_e 80 | (fun e -> 81 | let ev = dst e in 82 | if not (H.mem visited ev) then begin 83 | let dev = W.add w (W.weight (label e)) in 84 | let improvement = 85 | try W.compare dev (H.find dist ev) < 0 with Not_found -> true 86 | in 87 | if improvement then begin 88 | H.replace dist ev dev; 89 | PQ.add q (dev, ev, e :: p) 90 | end 91 | end) 92 | g v 93 | end; 94 | loop () 95 | end 96 | in 97 | PQ.add q (W.zero, v1, []); 98 | H.add dist v1 W.zero; 99 | loop () 100 | 101 | end 102 | 103 | (* The following module is a contribution of Yuto Takei (University of Tokyo) *) 104 | 105 | module BellmanFord 106 | (G: G) 107 | (W: WEIGHT with type label = G.E.label) = 108 | struct 109 | 110 | open G.E 111 | 112 | module H = Hashtbl.Make(G.V) 113 | 114 | exception NegativeCycle of G.E.t list 115 | 116 | let all_shortest_paths g vs = 117 | let dist = H.create 97 in 118 | H.add dist vs W.zero; 119 | let admissible = H.create 97 in 120 | let build_cycle_from x0 = 121 | let rec traverse_parent x ret = 122 | let e = H.find admissible x in 123 | let s = src e in 124 | if G.V.equal s x0 then e :: ret else traverse_parent s (e :: ret) 125 | in 126 | traverse_parent x0 [] 127 | in 128 | let find_cycle x0 = 129 | let visited = H.create 97 in 130 | let rec visit x = 131 | if H.mem visited x then 132 | build_cycle_from x 133 | else begin 134 | H.add visited x (); 135 | let e = H.find admissible x in 136 | visit (src e) 137 | end 138 | in 139 | visit x0 140 | in 141 | let rec relax i = 142 | let update = G.fold_edges_e 143 | (fun e x -> 144 | let ev1 = src e in 145 | let ev2 = dst e in 146 | try begin 147 | let dev1 = H.find dist ev1 in 148 | let dev2 = W.add dev1 (W.weight (label e)) in 149 | let improvement = 150 | try W.compare dev2 (H.find dist ev2) < 0 151 | with Not_found -> true 152 | in 153 | if improvement then begin 154 | H.replace dist ev2 dev2; 155 | H.replace admissible ev2 e; 156 | Some ev2 157 | end else x 158 | end with Not_found -> x) g None in 159 | match update with 160 | | Some x -> 161 | if i == G.nb_vertex g then raise (NegativeCycle (find_cycle x)) 162 | else relax (i + 1) 163 | | None -> dist 164 | in 165 | relax 0 166 | 167 | let find_negative_cycle_from g vs = 168 | try let _ = all_shortest_paths g vs in raise Not_found 169 | with NegativeCycle l -> l 170 | 171 | 172 | module Comp = Components.Make(G) 173 | 174 | (* This is rather inefficient implementation. Indeed, for each 175 | strongly connected component, we run a full Bellman-Ford 176 | algorithm using one of its vertex as source, taking all edges 177 | into consideration. Instead, we could limit ourselves to the 178 | edges of the component. *) 179 | let find_negative_cycle g = 180 | let rec iter = function 181 | | [] -> 182 | raise Not_found 183 | | (x :: _) :: cl -> 184 | begin try find_negative_cycle_from g x with Not_found -> iter cl end 185 | | [] :: _ -> 186 | assert false (* a component is not empty *) 187 | in 188 | iter (Comp.scc_list g) 189 | 190 | end 191 | 192 | 193 | module Check 194 | (G : 195 | sig 196 | type t 197 | module V : Sig.COMPARABLE 198 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 199 | end) = 200 | struct 201 | 202 | module HV = Hashtbl.Make(G.V) 203 | module HVV = Hashtbl.Make(Util.HTProduct(G.V)(G.V)) 204 | 205 | (* the cache contains the path tests already computed *) 206 | type path_checker = { cache : bool HVV.t; graph : G.t } 207 | 208 | let create g = { cache = HVV.create 97; graph = g } 209 | 210 | let check_path pc v1 v2 = 211 | try 212 | HVV.find pc.cache (v1, v2) 213 | with Not_found -> 214 | (* the path is not in cache; we check it with Dijkstra *) 215 | let visited = HV.create 97 in 216 | let q = Queue.create () in 217 | let rec loop () = 218 | if Queue.is_empty q then begin 219 | HVV.add pc.cache (v1, v2) false; 220 | false 221 | end else begin 222 | let v = Queue.pop q in 223 | HVV.add pc.cache (v1, v) true; 224 | if G.V.compare v v2 = 0 then 225 | true 226 | else begin 227 | if not (HV.mem visited v) then begin 228 | HV.add visited v (); 229 | G.iter_succ (fun v' -> Queue.add v' q) pc.graph v 230 | end; 231 | loop () 232 | end 233 | end 234 | in 235 | Queue.add v1 q; 236 | loop () 237 | 238 | end 239 | -------------------------------------------------------------------------------- /lib/path.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (* $Id: path.mli,v 1.9 2005-07-18 07:10:35 filliatr Exp $ *) 19 | 20 | (** Paths *) 21 | 22 | (** Minimal graph signature for Dijkstra's algorithm. 23 | Sub-signature of {!Sig.G}. *) 24 | module type G = sig 25 | type t 26 | module V : Sig.COMPARABLE 27 | module E : sig 28 | type t 29 | type label 30 | val label : t -> label 31 | val src : t -> V.t 32 | val dst : t -> V.t 33 | end 34 | val iter_vertex : (V.t -> unit) -> t -> unit 35 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 36 | val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit 37 | val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a 38 | val nb_vertex : t -> int 39 | end 40 | 41 | (** Signature for edges' weights. *) 42 | module type WEIGHT = sig 43 | type label 44 | (** Type for labels of graph edges. *) 45 | type t 46 | (** Type of edges' weights. *) 47 | val weight : label -> t 48 | (** Get the weight of an edge. *) 49 | val compare : t -> t -> int 50 | (** Weights must be ordered. *) 51 | val add : t -> t -> t 52 | (** Addition of weights. *) 53 | val zero : t 54 | (** Neutral element for {!add}. *) 55 | end 56 | 57 | module Dijkstra 58 | (G: G) 59 | (W: WEIGHT with type label = G.E.label) : 60 | sig 61 | 62 | val shortest_path : G.t -> G.V.t -> G.V.t -> G.E.t list * W.t 63 | (** [shortest_path g v1 v2] computes the shortest path from vertex [v1] 64 | to vertex [v2] in graph [g]. The path is returned as the list of 65 | followed edges, together with the total length of the path. 66 | raise [Not_found] if the path from [v1] to [v2] does not exist. 67 | 68 | Complexity: at most O((V+E)log(V)) *) 69 | 70 | end 71 | 72 | (* The following module is a contribution of Yuto Takei (University of Tokyo) *) 73 | 74 | module BellmanFord 75 | (G: G) 76 | (W: WEIGHT with type label = G.E.label) : 77 | sig 78 | 79 | module H : Hashtbl.S with type key = G.V.t 80 | 81 | exception NegativeCycle of G.E.t list 82 | 83 | val all_shortest_paths : G.t -> G.V.t -> W.t H.t 84 | (** [shortest_path g vs] computes the distances of shortest paths 85 | from vertex [vs] to all other vertices in graph [g]. They are 86 | returned as a hash table mapping each vertex reachable from 87 | [vs] to its distance from [vs]. If [g] contains a 88 | negative-length cycle reachable from [vs], raises 89 | [NegativeCycle l] where [l] is such a cycle. 90 | 91 | Complexity: at most O(VE) *) 92 | 93 | val find_negative_cycle_from: G.t -> G.V.t -> G.E.t list 94 | (** [find_negative_cycle_from g vs] looks for a negative-length 95 | cycle in graph [g] that is reachable from vertex [vs] and 96 | returns it as a list of edges. If no such a cycle exists, 97 | raises [Not_found]. 98 | 99 | Complexity: at most O(VE). *) 100 | 101 | val find_negative_cycle: G.t -> G.E.t list 102 | (** [find_negative_cycle g] looks for a negative-length cycle in 103 | graph [g] and returns it. If the graph [g] is free from such a 104 | cycle, raises [Not_found]. 105 | 106 | Complexity: O(V^2E) *) 107 | end 108 | 109 | 110 | (** Check for a path. *) 111 | module Check 112 | (G : sig 113 | type t 114 | module V : Sig.COMPARABLE 115 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 116 | end) : 117 | sig 118 | 119 | type path_checker 120 | (** the abstract data type of a path checker; this is a mutable data 121 | structure *) 122 | 123 | val create : G.t -> path_checker 124 | (** [create g] builds a new path checker for the graph [g]; 125 | if the graph is mutable, it must not be mutated while this path 126 | checker is in use (through the function [check_path] below). *) 127 | 128 | val check_path : path_checker -> G.V.t -> G.V.t -> bool 129 | (** [check_path pc v1 v2] checks whether there is a path from [v1] to 130 | [v2] in the graph associated to the path checker [pc]. 131 | 132 | Complexity: The path checker contains a cache of all results computed 133 | so far. This cache is implemented with a hash table so access in this 134 | cache is usually O(1). When the result is not in the cache, Dijkstra's 135 | algorithm is run to check for the path, and all intermediate results 136 | are cached. 137 | 138 | Note: if checks are to be done for almost all pairs of vertices, it 139 | may be more efficient to compute the transitive closure of the graph 140 | (see module [Oper]). 141 | *) 142 | 143 | end 144 | -------------------------------------------------------------------------------- /lib/sig.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (** {b Signatures for graph implementations.} *) 19 | 20 | (** {2 Signatures for graph implementations} *) 21 | 22 | (** Signature for vertices. *) 23 | module type VERTEX = sig 24 | 25 | (** Vertices are {!COMPARABLE}. *) 26 | 27 | type t 28 | val compare : t -> t -> int 29 | val hash : t -> int 30 | val equal : t -> t -> bool 31 | 32 | (** Vertices are labeled. *) 33 | 34 | type label 35 | val create : label -> t 36 | val label : t -> label 37 | 38 | end 39 | 40 | (** Signature for edges. *) 41 | module type EDGE = sig 42 | 43 | (** Edges are {!ORDERED_TYPE}. *) 44 | 45 | type t 46 | val compare : t -> t -> int 47 | 48 | (** Edges are directed. *) 49 | 50 | type vertex 51 | 52 | val src : t -> vertex 53 | (** Edge origin. *) 54 | val dst : t -> vertex 55 | (** Edge destination. *) 56 | 57 | (** Edges are labeled. *) 58 | 59 | type label 60 | val create : vertex -> label -> vertex -> t 61 | (** [create v1 l v2] creates an edge from [v1] to [v2] with label [l] *) 62 | val label : t -> label 63 | (** Get the label of an edge. *) 64 | 65 | end 66 | 67 | (** Common signature for all graphs. *) 68 | module type G = sig 69 | 70 | (** {2 Graph structure} *) 71 | 72 | (** Abstract type of graphs *) 73 | type t 74 | 75 | (** Vertices have type [V.t] and are labeled with type [V.label] 76 | (note that an implementation may identify the vertex with its 77 | label) *) 78 | module V : VERTEX 79 | type vertex = V.t 80 | 81 | (** Edges have type [E.t] and are labeled with type [E.label]. 82 | [src] (resp. [dst]) returns the origin (resp. the destination) of a 83 | given edge. *) 84 | module E : EDGE with type vertex = vertex 85 | type edge = E.t 86 | 87 | (** Is this an implementation of directed graphs? *) 88 | val is_directed : bool 89 | 90 | (** {2 Size functions} *) 91 | 92 | val is_empty : t -> bool 93 | val nb_vertex : t -> int 94 | val nb_edges : t -> int 95 | 96 | (** Degree of a vertex *) 97 | 98 | val out_degree : t -> vertex -> int 99 | (** [out_degree g v] returns the out-degree of [v] in [g]. 100 | @raise Invalid_argument if [v] is not in [g]. *) 101 | 102 | val in_degree : t -> vertex -> int 103 | (** [in_degree g v] returns the in-degree of [v] in [g]. 104 | @raise Invalid_argument if [v] is not in [g]. *) 105 | 106 | (** {2 Membership functions} *) 107 | 108 | val mem_vertex : t -> vertex -> bool 109 | val mem_edge : t -> vertex -> vertex -> bool 110 | val mem_edge_e : t -> edge -> bool 111 | 112 | val find_edge : t -> vertex -> vertex -> edge 113 | (** [find_edge g v1 v2] returns the edge from [v1] to [v2] if it exists. 114 | Unspecified behaviour if [g] has several edges from [v1] to [v2]. 115 | @raise Not_found if no such edge exists. *) 116 | 117 | val find_all_edges : t -> vertex -> vertex -> edge list 118 | (** [find_all_edges g v1 v2] returns all the edges from [v1] to [v2]. 119 | @since ocamlgraph 1.8 *) 120 | 121 | (** {2 Successors and predecessors} 122 | 123 | You should better use iterators on successors/predecessors (see 124 | Section "Vertex iterators"). *) 125 | 126 | val succ : t -> vertex -> vertex list 127 | (** [succ g v] returns the successors of [v] in [g]. 128 | @raise Invalid_argument if [v] is not in [g]. *) 129 | 130 | val pred : t -> vertex -> vertex list 131 | (** [pred g v] returns the predecessors of [v] in [g]. 132 | @raise Invalid_argument if [v] is not in [g]. *) 133 | 134 | (** Labeled edges going from/to a vertex *) 135 | 136 | val succ_e : t -> vertex -> edge list 137 | (** [succ_e g v] returns the edges going from [v] in [g]. 138 | @raise Invalid_argument if [v] is not in [g]. *) 139 | 140 | val pred_e : t -> vertex -> edge list 141 | (** [pred_e g v] returns the edges going to [v] in [g]. 142 | @raise Invalid_argument if [v] is not in [g]. *) 143 | 144 | (** {2 Graph iterators} *) 145 | 146 | val iter_vertex : (vertex -> unit) -> t -> unit 147 | (** Iter on all vertices of a graph. *) 148 | 149 | val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a 150 | (** Fold on all vertices of a graph. *) 151 | 152 | val iter_edges : (vertex -> vertex -> unit) -> t -> unit 153 | (** Iter on all edges of a graph. Edge label is ignored. *) 154 | 155 | val fold_edges : (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a 156 | (** Fold on all edges of a graph. Edge label is ignored. *) 157 | 158 | val iter_edges_e : (edge -> unit) -> t -> unit 159 | (** Iter on all edges of a graph. *) 160 | 161 | val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a 162 | (** Fold on all edges of a graph. *) 163 | 164 | val map_vertex : (vertex -> vertex) -> t -> t 165 | (** Map on all vertices of a graph. *) 166 | 167 | (** {2 Vertex iterators} 168 | 169 | Each iterator [iterator f v g] iters [f] to the successors/predecessors 170 | of [v] in the graph [g] and raises [Invalid_argument] if [v] is not in 171 | [g]. It is the same for functions [fold_*] which use an additional 172 | accumulator. 173 | 174 | Time complexity for ocamlgraph implementations: 175 | operations on successors are in O(1) amortized for imperative graphs and 176 | in O(ln(|V|)) for persistent graphs while operations on predecessors are 177 | in O(max(|V|,|E|)) for imperative graphs and in O(max(|V|,|E|)*ln|V|) for 178 | persistent graphs. *) 179 | 180 | (** iter/fold on all successors/predecessors of a vertex. *) 181 | 182 | val iter_succ : (vertex -> unit) -> t -> vertex -> unit 183 | val iter_pred : (vertex -> unit) -> t -> vertex -> unit 184 | val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a 185 | val fold_pred : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a 186 | 187 | (** iter/fold on all edges going from/to a vertex. *) 188 | 189 | val iter_succ_e : (edge -> unit) -> t -> vertex -> unit 190 | val fold_succ_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a 191 | val iter_pred_e : (edge -> unit) -> t -> vertex -> unit 192 | val fold_pred_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a 193 | 194 | end 195 | 196 | (** Signature for persistent (i.e. immutable) graph. *) 197 | module type P = sig 198 | 199 | include G 200 | (** A persistent graph is a graph. *) 201 | 202 | val empty : t 203 | (** The empty graph. *) 204 | 205 | val add_vertex : t -> vertex -> t 206 | (** [add_vertex g v] adds the vertex [v] to the graph [g]. 207 | Just return [g] if [v] is already in [g]. *) 208 | 209 | val remove_vertex : t -> vertex -> t 210 | (** [remove g v] removes the vertex [v] from the graph [g] 211 | (and all the edges going from [v] in [g]). 212 | Just return [g] if [v] is not in [g]. 213 | 214 | Time complexity for ocamlgraph implementations: 215 | O(|V|*ln(|V|)) for unlabeled graphs and 216 | O(|V|*max(ln(|V|),D)) for labeled graphs. 217 | D is the maximal degree of the graph. *) 218 | 219 | val add_edge : t -> vertex -> vertex -> t 220 | (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] 221 | in the graph [g]. 222 | Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. 223 | Just return [g] if this edge is already in [g]. *) 224 | 225 | val add_edge_e : t -> edge -> t 226 | (** [add_edge_e g e] adds the edge [e] in the graph [g]. 227 | Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst 228 | e]) is not in [g]. 229 | Just return [g] if [e] is already in [g]. *) 230 | 231 | val remove_edge : t -> vertex -> vertex -> t 232 | (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the 233 | graph [g]. If the graph is labelled, all the edges going from [v1] to 234 | [v2] are removed from [g]. 235 | Just return [g] if this edge is not in [g]. 236 | @raise Invalid_argument if [v1] or [v2] are not in [g]. *) 237 | 238 | val remove_edge_e : t -> edge -> t 239 | (** [remove_edge_e g e] removes the edge [e] from the graph [g]. 240 | Just return [g] if [e] is not in [g]. 241 | @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) 242 | 243 | end 244 | 245 | (** Signature for imperative (i.e. mutable) graphs. *) 246 | module type I = sig 247 | 248 | include G 249 | (** An imperative graph is a graph. *) 250 | 251 | val create : ?size:int -> unit -> t 252 | (** [create ()] returns an empty graph. Optionally, a size can be 253 | given, which should be on the order of the expected number of 254 | vertices that will be in the graph (for hash tables-based 255 | implementations). The graph grows as needed, so [size] is 256 | just an initial guess. *) 257 | 258 | val clear: t -> unit 259 | (** Remove all vertices and edges from the given graph. 260 | @since ocamlgraph 1.4 *) 261 | 262 | val copy : t -> t 263 | (** [copy g] returns a copy of [g]. Vertices and edges (and eventually 264 | marks, see module [Mark]) are duplicated. *) 265 | 266 | val add_vertex : t -> vertex -> unit 267 | (** [add_vertex g v] adds the vertex [v] to the graph [g]. 268 | Do nothing if [v] is already in [g]. *) 269 | 270 | val remove_vertex : t -> vertex -> unit 271 | (** [remove g v] removes the vertex [v] from the graph [g] 272 | (and all the edges going from [v] in [g]). 273 | Do nothing if [v] is not in [g]. 274 | 275 | Time complexity for ocamlgraph implementations: 276 | O(|V|*ln(D)) for unlabeled graphs and O(|V|*D) for 277 | labeled graphs. D is the maximal degree of the graph. *) 278 | 279 | val add_edge : t -> vertex -> vertex -> unit 280 | (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] 281 | in the graph [g]. 282 | Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. 283 | Do nothing if this edge is already in [g]. *) 284 | 285 | val add_edge_e : t -> edge -> unit 286 | (** [add_edge_e g e] adds the edge [e] in the graph [g]. 287 | Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst 288 | e]) is not in [g]. 289 | Do nothing if [e] is already in [g]. *) 290 | 291 | val remove_edge : t -> vertex -> vertex -> unit 292 | (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the 293 | graph [g]. If the graph is labelled, all the edges going from [v1] to 294 | [v2] are removed from [g]. 295 | Do nothing if this edge is not in [g]. 296 | @raise Invalid_argument if [v1] or [v2] are not in [g]. *) 297 | 298 | val remove_edge_e : t -> edge -> unit 299 | (** [remove_edge_e g e] removes the edge [e] from the graph [g]. 300 | Do nothing if [e] is not in [g]. 301 | @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) 302 | 303 | end 304 | 305 | (** Signature for marks on vertices. *) 306 | module type MARK = sig 307 | type graph 308 | (** Type of graphs. *) 309 | type vertex 310 | (** Type of graph vertices. *) 311 | val clear : graph -> unit 312 | (** [clear g] sets all the marks to 0 for all the vertices of [g]. *) 313 | val get : vertex -> int 314 | (** Mark value (in O(1)). *) 315 | val set : vertex -> int -> unit 316 | (** Set the mark of the given vertex. *) 317 | end 318 | 319 | (** Signature for imperative graphs with marks on vertices. *) 320 | module type IM = sig 321 | include I 322 | (** An imperative graph with marks is an imperative graph. *) 323 | 324 | (** Mark on vertices. 325 | Marks can be used if you want to store some information on vertices: 326 | it is more efficient to use marks than an external table. *) 327 | module Mark : MARK with type graph = t and type vertex = vertex 328 | end 329 | 330 | (** {2 Signature for ordered and hashable types} *) 331 | 332 | (** Signature with only an abstract type. *) 333 | module type ANY_TYPE = sig type t end 334 | 335 | (** Signature equivalent to [Set.OrderedType]. *) 336 | module type ORDERED_TYPE = sig type t val compare : t -> t -> int end 337 | 338 | (** Signature equivalent to [Set.OrderedType] with a default value. *) 339 | module type ORDERED_TYPE_DFT = sig include ORDERED_TYPE val default : t end 340 | 341 | (** Signature equivalent to [Hashtbl.HashedType]. *) 342 | module type HASHABLE = sig 343 | type t 344 | val hash : t -> int 345 | val equal : t -> t -> bool 346 | end 347 | 348 | (** Signature merging {!ORDERED_TYPE} and {!HASHABLE}. *) 349 | module type COMPARABLE = sig 350 | type t 351 | val compare : t -> t -> int 352 | val hash : t -> int 353 | val equal : t -> t -> bool 354 | end 355 | 356 | (* 357 | Local Variables: 358 | compile-command: "make -C .." 359 | End: 360 | *) 361 | -------------------------------------------------------------------------------- /lib/switch.mlpack: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a67c0c05231915ebff9464af7a4213ec) 3 | Ofswitch 4 | Ofswitch_config 5 | Ofswitch_standalone 6 | # OASIS_STOP 7 | -------------------------------------------------------------------------------- /lib/switch_model.mlpack: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: d668207c07c4ef2fe58a2c8043caa223) 3 | Ofswitch_model 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/util.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | open Sig 19 | 20 | module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) = struct 21 | type t = X.t * Y.t 22 | let compare (x1, y1) (x2, y2) = 23 | let cv = X.compare x1 x2 in 24 | if cv != 0 then cv else Y.compare y1 y2 25 | end 26 | 27 | module HTProduct(X: HASHABLE)(Y: HASHABLE) = struct 28 | type t = X.t * Y.t 29 | let equal (x1, y1) (x2, y2) = X.equal x1 x2 && Y.equal y1 y2 30 | let hash (x, y) = Hashtbl.hash (X.hash x, Y.hash y) 31 | end 32 | 33 | module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) = struct 34 | include HTProduct(X)(Y) 35 | include (OTProduct(X)(Y): sig val compare : t -> t -> int end) 36 | end 37 | 38 | module DataV(L : sig type t end)(V : Sig.COMPARABLE) = struct 39 | type data = L.t 40 | type label = V.t 41 | type t = data ref * V.t 42 | let compare (_, x) (_, x') = V.compare x x' 43 | let hash (_, x) = V.hash x 44 | let equal (_, x) (_, x') = V.equal x x' 45 | let create y lbl = (ref y, lbl) 46 | let label (_, z) = z 47 | let data (y, _) = !y 48 | let set_data (y, _) = (:=) y 49 | end 50 | 51 | -------------------------------------------------------------------------------- /lib/util.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Ocamlgraph: a generic graph library for OCaml *) 4 | (* Copyright (C) 2004-2010 *) 5 | (* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) 6 | (* *) 7 | (* This software is free software; you can redistribute it and/or *) 8 | (* modify it under the terms of the GNU Library General Public *) 9 | (* License version 2.1, with the special exception on linking *) 10 | (* described in file LICENSE. *) 11 | (* *) 12 | (* This software is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 15 | (* *) 16 | (**************************************************************************) 17 | 18 | (** Some useful operations. *) 19 | 20 | open Sig 21 | 22 | (** Cartesian product of two ordered types. *) 23 | module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) : 24 | ORDERED_TYPE with type t = X.t * Y.t 25 | 26 | (** Cartesian product of two hashable types. *) 27 | module HTProduct(X: HASHABLE)(Y: HASHABLE) : 28 | HASHABLE with type t = X.t * Y.t 29 | 30 | (** Cartesian product of two comparable types. *) 31 | module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) : 32 | COMPARABLE with type t = X.t * Y.t 33 | 34 | (** Create a vertex type with some data attached to it *) 35 | module DataV(L : sig type t end)(V : Sig.COMPARABLE) : sig 36 | type data = L.t 37 | and label = V.t 38 | and t = data ref * V.t 39 | val compare : t -> t -> int 40 | val hash : t -> int 41 | val equal : t -> t -> bool 42 | val create : data -> V.t -> t 43 | val label : t -> V.t 44 | val data : t -> data 45 | val set_data : t -> data -> unit 46 | end 47 | 48 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: d09f38b5f845453a33251ed8fef2743c) *) 3 | module OASISGettext = struct 4 | (* # 21 "src/oasis/OASISGettext.ml" *) 5 | 6 | let ns_ str = 7 | str 8 | 9 | let s_ str = 10 | str 11 | 12 | let f_ (str : ('a, 'b, 'c, 'd) format4) = 13 | str 14 | 15 | let fn_ fmt1 fmt2 n = 16 | if n = 1 then 17 | fmt1^^"" 18 | else 19 | fmt2^^"" 20 | 21 | let init = 22 | [] 23 | 24 | end 25 | 26 | module OASISExpr = struct 27 | (* # 21 "src/oasis/OASISExpr.ml" *) 28 | 29 | 30 | 31 | open OASISGettext 32 | 33 | type test = string 34 | 35 | type flag = string 36 | 37 | type t = 38 | | EBool of bool 39 | | ENot of t 40 | | EAnd of t * t 41 | | EOr of t * t 42 | | EFlag of flag 43 | | ETest of test * string 44 | 45 | 46 | type 'a choices = (t * 'a) list 47 | 48 | let eval var_get t = 49 | let rec eval' = 50 | function 51 | | EBool b -> 52 | b 53 | 54 | | ENot e -> 55 | not (eval' e) 56 | 57 | | EAnd (e1, e2) -> 58 | (eval' e1) && (eval' e2) 59 | 60 | | EOr (e1, e2) -> 61 | (eval' e1) || (eval' e2) 62 | 63 | | EFlag nm -> 64 | let v = 65 | var_get nm 66 | in 67 | assert(v = "true" || v = "false"); 68 | (v = "true") 69 | 70 | | ETest (nm, vl) -> 71 | let v = 72 | var_get nm 73 | in 74 | (v = vl) 75 | in 76 | eval' t 77 | 78 | let choose ?printer ?name var_get lst = 79 | let rec choose_aux = 80 | function 81 | | (cond, vl) :: tl -> 82 | if eval var_get cond then 83 | vl 84 | else 85 | choose_aux tl 86 | | [] -> 87 | let str_lst = 88 | if lst = [] then 89 | s_ "" 90 | else 91 | String.concat 92 | (s_ ", ") 93 | (List.map 94 | (fun (cond, vl) -> 95 | match printer with 96 | | Some p -> p vl 97 | | None -> s_ "") 98 | lst) 99 | in 100 | match name with 101 | | Some nm -> 102 | failwith 103 | (Printf.sprintf 104 | (f_ "No result for the choice list '%s': %s") 105 | nm str_lst) 106 | | None -> 107 | failwith 108 | (Printf.sprintf 109 | (f_ "No result for a choice list: %s") 110 | str_lst) 111 | in 112 | choose_aux (List.rev lst) 113 | 114 | end 115 | 116 | 117 | # 117 "myocamlbuild.ml" 118 | module BaseEnvLight = struct 119 | (* # 21 "src/base/BaseEnvLight.ml" *) 120 | 121 | module MapString = Map.Make(String) 122 | 123 | type t = string MapString.t 124 | 125 | let default_filename = 126 | Filename.concat 127 | (Sys.getcwd ()) 128 | "setup.data" 129 | 130 | let load ?(allow_empty=false) ?(filename=default_filename) () = 131 | if Sys.file_exists filename then 132 | begin 133 | let chn = 134 | open_in_bin filename 135 | in 136 | let st = 137 | Stream.of_channel chn 138 | in 139 | let line = 140 | ref 1 141 | in 142 | let st_line = 143 | Stream.from 144 | (fun _ -> 145 | try 146 | match Stream.next st with 147 | | '\n' -> incr line; Some '\n' 148 | | c -> Some c 149 | with Stream.Failure -> None) 150 | in 151 | let lexer = 152 | Genlex.make_lexer ["="] st_line 153 | in 154 | let rec read_file mp = 155 | match Stream.npeek 3 lexer with 156 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 157 | Stream.junk lexer; 158 | Stream.junk lexer; 159 | Stream.junk lexer; 160 | read_file (MapString.add nm value mp) 161 | | [] -> 162 | mp 163 | | _ -> 164 | failwith 165 | (Printf.sprintf 166 | "Malformed data file '%s' line %d" 167 | filename !line) 168 | in 169 | let mp = 170 | read_file MapString.empty 171 | in 172 | close_in chn; 173 | mp 174 | end 175 | else if allow_empty then 176 | begin 177 | MapString.empty 178 | end 179 | else 180 | begin 181 | failwith 182 | (Printf.sprintf 183 | "Unable to load environment, the file '%s' doesn't exist." 184 | filename) 185 | end 186 | 187 | let var_get name env = 188 | let rec var_expand str = 189 | let buff = 190 | Buffer.create ((String.length str) * 2) 191 | in 192 | Buffer.add_substitute 193 | buff 194 | (fun var -> 195 | try 196 | var_expand (MapString.find var env) 197 | with Not_found -> 198 | failwith 199 | (Printf.sprintf 200 | "No variable %s defined when trying to expand %S." 201 | var 202 | str)) 203 | str; 204 | Buffer.contents buff 205 | in 206 | var_expand (MapString.find name env) 207 | 208 | let var_choose lst env = 209 | OASISExpr.choose 210 | (fun nm -> var_get nm env) 211 | lst 212 | end 213 | 214 | 215 | # 215 "myocamlbuild.ml" 216 | module MyOCamlbuildFindlib = struct 217 | (* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 218 | 219 | (** OCamlbuild extension, copied from 220 | * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild 221 | * by N. Pouillard and others 222 | * 223 | * Updated on 2009/02/28 224 | * 225 | * Modified by Sylvain Le Gall 226 | *) 227 | open Ocamlbuild_plugin 228 | 229 | (* these functions are not really officially exported *) 230 | let run_and_read = 231 | Ocamlbuild_pack.My_unix.run_and_read 232 | 233 | let blank_sep_strings = 234 | Ocamlbuild_pack.Lexers.blank_sep_strings 235 | 236 | let split s ch = 237 | let buf = Buffer.create 13 in 238 | let x = ref [] in 239 | let flush () = 240 | x := (Buffer.contents buf) :: !x; 241 | Buffer.clear buf 242 | in 243 | String.iter 244 | (fun c -> 245 | if c = ch then 246 | flush () 247 | else 248 | Buffer.add_char buf c) 249 | s; 250 | flush (); 251 | List.rev !x 252 | 253 | let split_nl s = split s '\n' 254 | 255 | let before_space s = 256 | try 257 | String.before s (String.index s ' ') 258 | with Not_found -> s 259 | 260 | (* this lists all supported packages *) 261 | let find_packages () = 262 | List.map before_space (split_nl & run_and_read "ocamlfind list") 263 | 264 | (* this is supposed to list available syntaxes, but I don't know how to do it. *) 265 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 266 | 267 | (* ocamlfind command *) 268 | let ocamlfind x = S[A"ocamlfind"; x] 269 | 270 | let dispatch = 271 | function 272 | | Before_options -> 273 | (* by using Before_options one let command line options have an higher priority *) 274 | (* on the contrary using After_options will guarantee to have the higher priority *) 275 | (* override default commands by ocamlfind ones *) 276 | Options.ocamlc := ocamlfind & A"ocamlc"; 277 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 278 | Options.ocamldep := ocamlfind & A"ocamldep"; 279 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 280 | Options.ocamlmktop := ocamlfind & A"ocamlmktop" 281 | 282 | | After_rules -> 283 | 284 | (* When one link an OCaml library/binary/package, one should use -linkpkg *) 285 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 286 | flag ["ocaml"; "link"; "output_obj"] & A"-linkpkg"; 287 | 288 | (* For each ocamlfind package one inject the -package option when 289 | * compiling, computing dependencies, generating documentation and 290 | * linking. *) 291 | List.iter 292 | begin fun pkg -> 293 | let base_args = [A"-package"; A pkg] in 294 | let syn_args = [A"-syntax"; A "camlp4o"] in 295 | let args = 296 | (* heuristic to identify syntax extensions: 297 | whether they end in ".syntax"; some might not *) 298 | if Filename.check_suffix pkg "syntax" 299 | then syn_args @ base_args 300 | else base_args 301 | in 302 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; 303 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; 304 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; 305 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; 306 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; 307 | end 308 | (find_packages ()); 309 | 310 | (* Like -package but for extensions syntax. Morover -syntax is useless 311 | * when linking. *) 312 | List.iter begin fun syntax -> 313 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 314 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 315 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 316 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 317 | end (find_syntaxes ()); 318 | 319 | (* The default "thread" tag is not compatible with ocamlfind. 320 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 321 | * options when using this tag. When using the "-linkpkg" option with 322 | * ocamlfind, this module will then be added twice on the command line. 323 | * 324 | * To solve this, one approach is to add the "-thread" option when using 325 | * the "threads" package using the previous plugin. 326 | *) 327 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 328 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 329 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 330 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) 331 | 332 | | _ -> 333 | () 334 | 335 | end 336 | 337 | module MyOCamlbuildBase = struct 338 | (* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 339 | 340 | (** Base functions for writing myocamlbuild.ml 341 | @author Sylvain Le Gall 342 | *) 343 | 344 | 345 | 346 | open Ocamlbuild_plugin 347 | module OC = Ocamlbuild_pack.Ocaml_compiler 348 | 349 | type dir = string 350 | type file = string 351 | type name = string 352 | type tag = string 353 | 354 | (* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 355 | 356 | type t = 357 | { 358 | lib_ocaml: (name * dir list) list; 359 | lib_c: (name * dir * file list) list; 360 | flags: (tag list * (spec OASISExpr.choices)) list; 361 | (* Replace the 'dir: include' from _tags by a precise interdepends in 362 | * directory. 363 | *) 364 | includes: (dir * dir list) list; 365 | } 366 | 367 | let env_filename = 368 | Pathname.basename 369 | BaseEnvLight.default_filename 370 | 371 | let dispatch_combine lst = 372 | fun e -> 373 | List.iter 374 | (fun dispatch -> dispatch e) 375 | lst 376 | 377 | let tag_libstubs nm = 378 | "use_lib"^nm^"_stubs" 379 | 380 | let nm_libstubs nm = 381 | nm^"_stubs" 382 | 383 | let dispatch t e = 384 | let env = 385 | BaseEnvLight.load 386 | ~filename:env_filename 387 | ~allow_empty:true 388 | () 389 | in 390 | match e with 391 | | Before_options -> 392 | let no_trailing_dot s = 393 | if String.length s >= 1 && s.[0] = '.' then 394 | String.sub s 1 ((String.length s) - 1) 395 | else 396 | s 397 | in 398 | List.iter 399 | (fun (opt, var) -> 400 | try 401 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 402 | with Not_found -> 403 | Printf.eprintf "W: Cannot get variable %s" var) 404 | [ 405 | Options.ext_obj, "ext_obj"; 406 | Options.ext_lib, "ext_lib"; 407 | Options.ext_dll, "ext_dll"; 408 | ] 409 | 410 | | After_rules -> 411 | (* Declare OCaml libraries *) 412 | List.iter 413 | (function 414 | | nm, [] -> 415 | ocaml_lib nm 416 | | nm, dir :: tl -> 417 | ocaml_lib ~dir:dir (dir^"/"^nm); 418 | List.iter 419 | (fun dir -> 420 | List.iter 421 | (fun str -> 422 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 423 | ["compile"; "infer_interface"; "doc"]) 424 | tl) 425 | t.lib_ocaml; 426 | 427 | (* Declare directories dependencies, replace "include" in _tags. *) 428 | List.iter 429 | (fun (dir, include_dirs) -> 430 | Pathname.define_context dir include_dirs) 431 | t.includes; 432 | 433 | (* Declare C libraries *) 434 | List.iter 435 | (fun (lib, dir, headers) -> 436 | (* Handle C part of library *) 437 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 438 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 439 | A("-l"^(nm_libstubs lib))]); 440 | 441 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 442 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 443 | 444 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 445 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 446 | 447 | (* When ocaml link something that use the C library, then one 448 | need that file to be up to date. 449 | *) 450 | dep ["link"; "ocaml"; "program"; tag_libstubs lib] 451 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 452 | 453 | dep ["compile"; "ocaml"; "program"; tag_libstubs lib] 454 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 455 | 456 | (* TODO: be more specific about what depends on headers *) 457 | (* Depends on .h files *) 458 | dep ["compile"; "c"] 459 | headers; 460 | 461 | (* Setup search path for lib *) 462 | flag ["link"; "ocaml"; "use_"^lib] 463 | (S[A"-I"; P(dir)]); 464 | ) 465 | t.lib_c; 466 | 467 | (* Add output_obj rules mapped to .nobj.o *) 468 | let native_output_obj x = 469 | OC.link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] 470 | OC.ocamlopt_link_prog 471 | (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x 472 | in 473 | rule "ocaml: cmx* and o* -> .nobj.o" ~prod:"%.nobj.o" ~deps:["%.cmx"; "%.o"] 474 | (native_output_obj "%.cmx" "%.nobj.o"); 475 | 476 | (* Add output_obj rules mapped to .bobj.o *) 477 | let bytecode_output_obj x = 478 | OC.link_gen "cmo" "cma" !Options.ext_lib [!Options.ext_obj; "cmi"] 479 | OC.ocamlc_link_prog 480 | (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x 481 | in 482 | rule "ocaml: cmo* -> .nobj.o" ~prod:"%.bobj.o" ~deps:["%.cmo"] 483 | (bytecode_output_obj "%.cmo" "%.bobj.o"); 484 | 485 | (* Add flags *) 486 | List.iter 487 | (fun (tags, cond_specs) -> 488 | let spec = 489 | BaseEnvLight.var_choose cond_specs env 490 | in 491 | flag tags & spec) 492 | t.flags 493 | | _ -> 494 | () 495 | 496 | let dispatch_default t = 497 | dispatch_combine 498 | [ 499 | dispatch t; 500 | MyOCamlbuildFindlib.dispatch; 501 | ] 502 | 503 | end 504 | 505 | 506 | # 506 "myocamlbuild.ml" 507 | open Ocamlbuild_plugin;; 508 | let package_default = 509 | { 510 | MyOCamlbuildBase.lib_ocaml = 511 | [ 512 | ("openflow", ["lib"]); 513 | ("flv", ["lib"]); 514 | ("switch", ["lib"]); 515 | ("switch_model", ["lib"]) 516 | ]; 517 | lib_c = []; 518 | flags = []; 519 | includes = [("switch", ["lib"]); ("controller", ["lib"])]; 520 | } 521 | ;; 522 | 523 | let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; 524 | 525 | # 526 "myocamlbuild.ml" 526 | (* OASIS_STOP *) 527 | Ocamlbuild_plugin.dispatch dispatch_default;; 528 | -------------------------------------------------------------------------------- /switch/basic_switch.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt 18 | open Printf 19 | open Net 20 | open Net.Nettypes 21 | 22 | let resolve t = Lwt.on_success t (fun _ -> ()) 23 | 24 | module OP = Openflow.Ofpacket 25 | module OC = Openflow.Ofcontroller 26 | module OE = Openflow.Ofcontroller.Event 27 | open Ofswitch 28 | 29 | let pp = Printf.printf 30 | let sp = Printf.sprintf 31 | 32 | (**************************************************************** 33 | * OpenFlow Switch configuration 34 | *****************************************************************) 35 | let switch_run () = 36 | (* let delay = {flow_insert=0.; flow_update=0.; pktin_rate=50.; pktin_delay=0.002; 37 | stats_delay=0.; pktout_delay=0.;} in *) 38 | let model = Ofswitch_model.( 39 | {flow_insert=0.002; 40 | flow_update=0.002; pktin_rate=18.; pktin_delay=0.002;stats_delay=0.; 41 | pktout_delay=0.;}) in 42 | let sw = create_switch 0x100L (* model *) in 43 | let use_mac = ref true in 44 | try_lwt 45 | Manager.create (fun mgr interface id -> 46 | match (OS.Netif.string_of_id id) with 47 | | "tap0" 48 | | "0" -> 49 | lwt _ = OS.Time.sleep 5.0 in 50 | let _ = printf "connecting switch...\n%!" in 51 | let ip = Ipaddr.V4.(make 10l 20l 0l 100l, Prefix.mask 24, []) in 52 | lwt _ = Manager.configure interface (`IPv4 ip) in 53 | let dst_ip = Ipaddr.V4.make 10l 20l 0l 4l in 54 | standalone_connect sw mgr (dst_ip, 6633) 55 | | str_id -> 56 | (* let find dev = 57 | try 58 | let _ = Re_str.search_forward (Re_str.regexp "tap") dev 0 in true 59 | with Not_found -> false 60 | in 61 | lwt _ = 62 | if (not (find str_id) ) then 63 | lwt _ = add_port mgr ~use_mac:(!use_mac) sw id in 64 | return (use_mac := false) 65 | else *) 66 | add_port mgr ~use_mac:false sw id 67 | (* in 68 | return () *) 69 | ) 70 | with e -> 71 | Printf.eprintf "Error: %s" (Printexc.to_string e); 72 | return () 73 | 74 | -------------------------------------------------------------------------------- /switch/lwt_switch.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let _ = OS.Main.run( 18 | let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap0" () in 19 | (* let _ = Tuntap.set_ipv4 ~devname:("tap0") ~ipv4:"10.20.0.1" 20 | ~netmask:"255.255.255.0" () in *) 21 | let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in 22 | 23 | let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap1" () in 24 | let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in 25 | 26 | let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap2" () in 27 | let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in 28 | Basic_switch.switch_run () 29 | ) 30 | -------------------------------------------------------------------------------- /switch/xen_switch.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Charalampos Rotsos 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let _ = OS.Main.run(Basic_switch.switch_run ()) 18 | --------------------------------------------------------------------------------