module FullSession.NwSession where
import qualified Control.Exception as E
import System.IO.Error (mkIOError, userErrorType)
import Prelude hiding (catch)
import System.IO
import Data.IORef
import qualified Network.Socket as N
import Network.BSD
import Control.Monad (liftM)
import Control.Concurrent
import System.IO.Unsafe (unsafePerformIO)
import System.Exit
import FullSession.Base
import FullSession.Types
import FullSession.TypeAlgebra
import FullSession.Ended
import FullSession.SMonad
errorExit :: String -> a
errorExit str = E.throw (mkIOError userErrorType str Nothing Nothing)
finish :: (Ended ss n, IsEnded ss T) => String -> Session t ss tt ()
finish str = Session (\_ -> errorExit str)
connectTo :: String -> Int -> IO (Handle, IORef String)
connectTo host port_ = do
let port = toEnum port_
sock <- N.socket N.AF_INET N.Stream 0
addrs <- liftM hostAddresses $ getHostByName host
if null addrs then errorExit $ "no such host : " ++ host else return ()
N.connect sock $ N.SockAddrInet port (head addrs)
handle <- N.socketToHandle sock ReadWriteMode
str <- hGetContents handle
ref <- newIORef str
return (handle, ref)
listenAt :: Int -> IO (Handle, IORef String)
listenAt port_ = do
let port = toEnum port_
lsock <- N.socket N.AF_INET N.Stream 0
N.bindSocket lsock $ N.SockAddrInet port N.iNADDR_ANY
N.listen lsock 1
(sock,N.SockAddrInet _ _) <- N.accept lsock
N.sClose lsock
handle <- N.socketToHandle sock ReadWriteMode
str <- hGetContents handle
ref <- newIORef str
return (handle, ref)
newtype NwService u = NwService (String,Int)
mkNwService :: NwSession u => String -> Int -> u -> NwService u
mkNwService str port _ = NwService (str,port)
connectNw :: (SList ss l, NwSession u) => NwService u -> Session t ss (ss:>u) (Channel t l)
connectNw (NwService (host,port)) = Session $ \ss -> do
(handle, ref) <- connectTo host port
let u = genSession ref handle
return (ss:>u, C (len_ ss))
newtype NwService2 u u' = NwService2 (String,Int)
mkNwService2 :: (NwSendOnly u, NwReceiveOnly u') => String -> Int -> u -> u' -> NwService2 u u'
mkNwService2 str port _ _ = NwService2 (str,port)
connectNw2 :: (SList ss l, NwSendOnly u, NwReceiveOnly u') => NwService2 u u' -> Session t ss (ss:>u:>u') (Channel t l, Channel t (S l))
connectNw2 (NwService2 (host,port)) = Session $ \ss -> do
(handle, ref) <- connectTo host port
let u = genSession ref handle
u' = genSession ref handle
return (ss:>u:>u', (C (len_ ss), C (S (len_ ss))))
acceptOneNw2 :: (SList ss l, NwSendOnly u, NwReceiveOnly u') => NwService2 u u' -> Session t ss (ss:>u:>u') (Channel t l, Channel t (S l))
acceptOneNw2 (NwService2 (_,port)) = Session $ \ss -> do
(handle, ref) <- listenAt port
let u = genSession ref handle
u' = genSession ref handle
return (ss:>u:>u', (C (len_ ss), C (S (len_ ss))))
dualNw :: NwDual u u' => NwService u -> NwService u'
dualNw (NwService (host,port)) = NwService (host,port)
dualNw2 :: (NwDual u1 u1', NwDual u2 u2') => NwService2 u1 u2 -> NwService2 u1' u2'
dualNw2 (NwService2 (host,port)) = NwService2 (host,port)
class Message mes where
parseMessage :: String -> Maybe (mes,String)
showMessage :: mes -> String
class NwSession u => NwSender u
instance (NwSession u, Message v) => NwSender (Send v u)
instance (NwSender u1, NwSender u2) => NwSender (SelectN u1 u2)
class NwSession u => NwReceiver u where
tryParse :: u -> String -> Bool
instance (NwSession u, Message v) => NwReceiver (Recv v u) where
tryParse _ str = maybe False (const True) (parseMessage str::Maybe (v,String))
instance (NwReceiver u1, NwReceiver u2) => NwReceiver (OfferN u1 u2) where
tryParse (OfferN _ u1 u2) str = tryParse u1 str || tryParse u2 str
class NwSession u where
genSession :: IORef String -> Handle -> u
instance (Message v, NwSession u) => NwSession (Send v u) where
genSession str h = Send (\v -> do hPutStr h (showMessage v); hFlush h) (genSession str h)
instance (Message v, NwSession u) => NwSession (Recv v u) where
genSession ref h =
Recv (do str <- readIORef ref;
case parseMessage str of
Just (v, rest) -> do writeIORef ref rest; return v;
Nothing -> errorExit ("no parse : "++str)
) (genSession ref h)
instance NwSession Close where
genSession _ h = Close (putStrLn "closing connection.." >> hFlush h >> hClose h)
instance (NwSender u1, NwSender u2) => NwSession (SelectN u1 u2) where
genSession str h = SelectN (genSession str h) (genSession str h)
instance (NwReceiver u1, NwReceiver u2) => NwSession (OfferN u1 u2) where
genSession ref h = offer (genSession ref h) (genSession ref h)
where
offer l r =
OfferN
(do str <- readIORef ref;
if tryParse l str
then return (Just True)
else if tryParse r str
then return (Just False)
else return Nothing)
l r
instance (NwSession u, Nat m) => NwSession (Rec m u) where
genSession str h = Rec nat (genSession str h)
instance Nat n => NwSession (Var n) where
genSession str h = Var nat
sel1N :: (Pickup ss n (SelectN s x), Update ss n s tt) => Channel t n -> Session t ss tt ()
sel1N (C n) = Session (\ss ->
case pickup ss n of SelectN u1 _ -> return (update ss n u1, ()))
sel2N :: (Pickup ss n (SelectN x s), Update ss n s tt) => Channel t n -> Session t ss tt ()
sel2N (C n) = Session (\ss ->
case pickup ss n of SelectN _ u2 -> return (update ss n u2, ()))
ifSelectN :: (Pickup ss n (SelectN x y), Update ss n x sx, Update ss n y sy, Diff xx yy zz, IsEnded ss F)
=> Channel t n
-> Bool
-> Session t sx xx a
-> Session t sy yy a
-> Session t ss zz a
ifSelectN (C n) b (Session s) (Session t) = Session $ \ss -> case pickup ss n of
(SelectN x y) -> (\diff ->
if b then s (update ss n x) >>= \(xx,a) -> return (diff (Left xx), a)
else t (update ss n y) >>= \(yy,a) -> return (diff (Right yy), a)) diff
offerN :: (NwReceiver x, NwReceiver y,
Pickup ss n (OfferN x y), Update ss n x sx, Update ss n y sy, Diff xx yy zz, IsEnded ss F)
=> Channel t n
-> Session t sx xx a
-> Session t sy yy a
-> Session t ss zz a
offerN (C n) (Session s) (Session t) = Session $ \ss -> case pickup ss n of
(OfferN test x y) -> test >>= \m -> (\diff ->
case m of
Just True -> s (update ss n x) >>= \(xx,a) -> return (diff (Left xx), a)
Just False -> t (update ss n y) >>= \(yy,a) -> return (diff (Right yy), a)
Nothing -> errorExit "no parse"
) diff
class (NwSession s, NwSession t) => NwDual s t | s -> t, t -> s
instance NwDual Close Close
instance (Message t, Message t', NwDual u u', t ~ t') => NwDual (Send t u) (Recv t' u')
instance (Message t, Message t', NwDual u' u, t ~ t') => NwDual (Recv t' u') (Send t u)
instance (NwSender u1, NwReceiver u1', NwSender u2, NwReceiver u2', NwDual u1 u1', NwDual u2 u2') => NwDual (SelectN u1 u2) (OfferN u1' u2')
instance (NwReceiver u1, NwSender u1', NwReceiver u2, NwSender u2', NwDual u1 u1', NwDual u2 u2') => NwDual (OfferN u1 u2) (SelectN u1' u2')
instance (NwDual r r', Nat m, m ~ m') => NwDual (Rec m r) (Rec m' r')
instance (Nat v, v ~ v') => NwDual (Var v) (Var v')
class NwSession u => NwSendOnly u
instance (NwSendOnly u, Message v) => NwSendOnly (Send v u)
instance (NwSendOnly u1, NwSendOnly u2, NwSender u1, NwSender u2) => NwSendOnly (SelectN u1 u2)
instance NwSendOnly Close
instance (NwSendOnly u, Nat m) => NwSendOnly (Rec m u)
instance Nat n => NwSendOnly (Var n)
class NwSession u => NwReceiveOnly u
instance (NwReceiveOnly u, Message v) => NwReceiveOnly (Recv v u)
instance (NwReceiveOnly u1, NwReceiveOnly u2, NwReceiver u1, NwReceiver u2) => NwReceiveOnly (OfferN u1 u2)
instance NwReceiveOnly Close
instance (NwReceiveOnly u, Nat m) => NwReceiveOnly (Rec m u)
instance Nat n => NwReceiveOnly (Var n)
finallys :: Session t ss tt () -> IO () -> Session t ss tt ()
finallys (Session f) m = Session (\tt -> E.finally (f tt) m)