(** * なんちゃって daemon. linener 部. * * by IT Planning Co. Ltd. * *) (** Copyright (c) Satoshi Ogasawara All Rights Reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) open Event (** * cmdCh : kill を受け取って自身を終了する * acceptCh : Unix.accept した soket を送り出す *) type t = { cmdCh : [`Kill] channel; acceptCh : (Unix.file_descr * Unix.sockaddr) channel } let (@@) f g = f g let max_pending_requests = 10 let make sdomain stype addr = (* まずソケットを作って *) let socket = Unix.socket sdomain stype 0 in let _ = (* ソケットをリッスン用に宣言 *) Unix.bind socket addr; Unix.listen socket max_pending_requests; in let rec loop lsn = (* accept するスレッドを作って、accpet が来たら、応えを返す *) let accept_event () = let ac_channel = new_channel () in let accept_send () = sync @@ send ac_channel @@ Unix.accept socket in let _ = ignore @@ Thread.create accept_send () in guard (fun () -> receive ac_channel) in let cmd_fsm = function `Kill -> begin try Unix.close socket with _ -> (); () (* リソースを開放して終了 *) end | _ -> loop lsn in let sendout_socket socket = ignore @@ sync @@ send lsn.acceptCh socket; loop lsn in (* アクセプトイベントかコマンドを受け取るか、どちらか *) select [wrap (accept_event ()) sendout_socket; wrap (receive lsn.cmdCh) cmd_fsm] in let lsn = { cmdCh = new_channel (); acceptCh = new_channel () } in ignore @@ Thread.create loop lsn; lsn (* アクセプトイベント生成 *) let accept lsn = guard (fun () -> receive lsn.acceptCh) let kill lsn = sync @@ send lsn.cmdCh `Kill