Commits

Anonymous committed 5af157f

Initial submit of OCaml NAE BEEP Core.

  • Participants
  • Parent commits 873338a

Comments (0)

Files changed (2)

beep/beep_channel.ml

+(*---------------------------------------------------------------------------*
+  IMPLEMENTATION  beep_channel.ml
+
+  Copyright (c) 2003-2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+open Iom_reactor
+open Cf_cmonad.Op
+
+module M_profile = struct
+    type encoding_t = E_none | E_base64
+
+    type t = {
+        uri: string;
+        encoding: encoding_t;
+        content: string;
+    }
+    
+    let cons ~uri ?(enc = E_none) content = {
+        uri = uri;
+        encoding = enc;
+        content = content;
+    }
+end
+
+module M_start = struct
+    type t = {
+        serverName: string option;
+        profiles: M_profile.t * M_profile.t list;
+    }
+    
+    let cons ?serverName = function
+        | [] -> invalid_arg "Beep_channel.M_start.cons: profile list empty."
+        | hd :: tl -> {
+            serverName = serverName;
+            profiles = hd, tl;
+        }
+end
+
+module type M_signal = sig
+    type t = {
+        code: int;
+        lang: string option;
+        content: string;
+    }
+    
+    val cons: ?loc:#Beep_locale.t -> int -> t
+end
+
+module M_signal = struct
+    type t = {
+        code: int;
+        lang: string option;
+        content: string;
+    }
+    
+    let default_locale_ = new Beep_locale.default []
+    
+    let cons ?loc =
+        let loc =
+            match loc with
+            | None -> default_locale_
+            | Some loc -> (loc :> Beep_locale.t)
+        in
+        fun code -> {
+            code = code;
+            lang = loc#lang;
+            content = loc#content code;
+        }
+end
+
+module M_close = M_signal
+module M_error = M_signal
+
+type control_rx_t =
+    | C_rx_exchange of Beep_exchange.t
+    | C_rx_close of M_close.t
+    | C_rx_error of M_error.t
+    | C_rx_release
+    | C_rx_abort
+
+type control_tx_t =
+    | C_tx_exchange of Beep_exchange.t
+    | C_tx_close of M_close.t
+    | C_tx_error of M_error.t
+    | C_tx_release
+    | C_tx_reset
+
+type control_duplex_t = control_tx_t rx * control_rx_t tx
+
+module Err = Beep_error
+module F = Beep_frame
+module E = Beep_exchange
+
+class profile =
+    object(self)
+        method private control_:
+            's. control_rx_t rx -> control_tx_t tx -> ('s, unit) t =
+            fun ctrlRx ctrlTx ->
+                let rec loop () =
+                    let ctrlRx = (ctrlRx :> control_rx_t rx) in
+                    let ctrlTx = (ctrlTx :> control_tx_t tx) in
+                    guard begin
+                        ctrlRx#get begin function
+                            | C_rx_abort
+                            | C_rx_release ->
+                                Cf_cmonad.return ()
+                            | C_rx_close _ ->
+                                ctrlTx#put C_tx_release
+                            | _ ->
+                                loop ()
+                        end
+                    end
+                in
+                start (loop ()) ()
+        
+        method profile: 's. ('s, control_duplex_t) t =
+            duplex >>= fun ((chRx, chTx), chIO) ->
+            self#control_ chRx chTx >>= fun () ->
+            Cf_cmonad.return chIO
+        
+        method tuning = false
+    end
+
+type client_start_t =
+    | CS_profile of M_profile.t * profile tx
+    | CS_error of M_error.t
+
+class type client =
+    object
+        method connect: 's. M_start.t tx -> client_start_t rx -> ('s, unit) t
+    end
+
+type service_start_t =
+    | SS_profile of M_profile.t * profile
+    | SS_error of M_error.t
+
+class type service =
+    object
+        method accept: 's. M_start.t -> ('s, service_start_t rx option) t
+    end
+
+(*--- End of File [ beep_channel.ml ] ---*)

beep/beep_channel.mli

+(*---------------------------------------------------------------------------*
+  INTERFACE  beep_channel.mli
+
+  Copyright (c) 2003-2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+module M_profile: sig
+    type encoding_t = E_none | E_base64
+
+    type t = {
+        uri: string;
+        encoding: encoding_t;
+        content: string;
+    }
+    
+    val cons: uri:string -> ?enc:encoding_t -> string -> t
+end
+
+module M_start: sig
+    type t = {
+        serverName: string option;
+        profiles: M_profile.t * M_profile.t list;
+    }
+    
+    val cons: ?serverName:string -> M_profile.t list -> t
+end
+
+module type M_signal = sig
+    type t = {
+        code: int;
+        lang: string option;
+        content: string;
+    }
+    
+    val cons: ?loc:#Beep_locale.t -> int -> t
+end
+
+module M_close: M_signal
+module M_error: M_signal
+
+open Iom_reactor
+
+type control_rx_t =
+    | C_rx_exchange of Beep_exchange.t
+    | C_rx_close of M_close.t
+    | C_rx_error of M_error.t
+    | C_rx_release
+    | C_rx_abort
+
+type control_tx_t =
+    | C_tx_exchange of Beep_exchange.t
+    | C_tx_close of M_close.t
+    | C_tx_error of M_error.t
+    | C_tx_release
+    | C_tx_reset
+
+type control_duplex_t = control_tx_t rx * control_rx_t tx
+
+class profile:
+    object
+        method private control_:
+            's. control_rx_t rx -> control_tx_t tx -> ('s, unit) t
+        
+        method profile: 's. ('s, control_duplex_t) t
+        method tuning: bool
+    end
+
+type client_start_t =
+    | CS_profile of M_profile.t * profile tx
+    | CS_error of M_error.t
+
+class type client =
+    object
+        method connect: 's. M_start.t tx -> client_start_t rx -> ('s, unit) t
+    end
+
+type service_start_t =
+    | SS_profile of M_profile.t * profile
+    | SS_error of M_error.t
+
+class type service =
+    object
+        method accept: 's. M_start.t -> ('s, service_start_t rx option) t
+    end
+
+(*--- End of File [ beep_channel.mli ] ---*)