module SocketServer(ClientMsg(..),SocketMsg(..),mapSocketMsg,socketServerF) where import AllFudgets import DialogueIO hiding (IOError) data ClientMsg a = ClientMsg a | ClientEOS | ClientNew deriving (Int -> ClientMsg a -> ShowS [ClientMsg a] -> ShowS ClientMsg a -> String (Int -> ClientMsg a -> ShowS) -> (ClientMsg a -> String) -> ([ClientMsg a] -> ShowS) -> Show (ClientMsg a) forall a. Show a => Int -> ClientMsg a -> ShowS forall a. Show a => [ClientMsg a] -> ShowS forall a. Show a => ClientMsg a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ClientMsg a] -> ShowS $cshowList :: forall a. Show a => [ClientMsg a] -> ShowS show :: ClientMsg a -> String $cshow :: forall a. Show a => ClientMsg a -> String showsPrec :: Int -> ClientMsg a -> ShowS $cshowsPrec :: forall a. Show a => Int -> ClientMsg a -> ShowS Show) data SocketMsg a = SocketMsg a | SocketEOS deriving (Int -> SocketMsg a -> ShowS [SocketMsg a] -> ShowS SocketMsg a -> String (Int -> SocketMsg a -> ShowS) -> (SocketMsg a -> String) -> ([SocketMsg a] -> ShowS) -> Show (SocketMsg a) forall a. Show a => Int -> SocketMsg a -> ShowS forall a. Show a => [SocketMsg a] -> ShowS forall a. Show a => SocketMsg a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [SocketMsg a] -> ShowS $cshowList :: forall a. Show a => [SocketMsg a] -> ShowS show :: SocketMsg a -> String $cshow :: forall a. Show a => SocketMsg a -> String showsPrec :: Int -> SocketMsg a -> ShowS $cshowsPrec :: forall a. Show a => Int -> SocketMsg a -> ShowS Show) mapSocketMsg :: (t -> a) -> SocketMsg t -> SocketMsg a mapSocketMsg t -> a f (SocketMsg t a) = a -> SocketMsg a forall a. a -> SocketMsg a SocketMsg (t -> a f t a) mapSocketMsg t -> a f SocketMsg t SocketEOS = SocketMsg a forall a. SocketMsg a SocketEOS instance Functor SocketMsg where fmap :: (a -> b) -> SocketMsg a -> SocketMsg b fmap = (a -> b) -> SocketMsg a -> SocketMsg b forall a b. (a -> b) -> SocketMsg a -> SocketMsg b mapSocketMsg socketServerF :: Int -> (Socket -> String -> F a (SocketMsg a)) -> F (Int, a) (Int, ClientMsg a) socketServerF Int port Socket -> String -> F a (SocketMsg a) f = F (Either (Either (Int, F a (SocketMsg a)) (Int, SocketMsg a)) (Int, a)) (Either (Either Any (Int, DynMsg a (F a (SocketMsg a)))) (Int, ClientMsg a)) -> F (Either Any (Int, DynMsg a (F a (SocketMsg a)))) (Either (Int, F a (SocketMsg a)) (Int, SocketMsg a)) -> F (Int, a) (Int, ClientMsg a) forall a b c d. F (Either a b) (Either c d) -> F c a -> F b d loopThroughRightF ((Either (Either (Int, F a (SocketMsg a)) (Int, SocketMsg a)) (Int, a) -> [Either (Either Any (Int, DynMsg a (F a (SocketMsg a)))) (Int, ClientMsg a)]) -> F (Either (Either (Int, F a (SocketMsg a)) (Int, SocketMsg a)) (Int, a)) (Either (Either Any (Int, DynMsg a (F a (SocketMsg a)))) (Int, ClientMsg a)) forall a b. (a -> [b]) -> F a b concatMapF Either (Either (Int, F a (SocketMsg a)) (Int, SocketMsg a)) (Int, a) -> [Either (Either Any (Int, DynMsg a (F a (SocketMsg a)))) (Int, ClientMsg a)] forall a b a a a. Either (Either (a, b) (a, SocketMsg a)) (a, a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] router) (F Any (Int, F a (SocketMsg a)) forall b. F b (Int, F a (SocketMsg a)) listenerF F Any (Int, F a (SocketMsg a)) -> F (Int, DynMsg a (F a (SocketMsg a))) (Int, SocketMsg a) -> F (Either Any (Int, DynMsg a (F a (SocketMsg a)))) (Either (Int, F a (SocketMsg a)) (Int, SocketMsg a)) forall a b c d. F a b -> F c d -> F (Either a c) (Either b d) >+< F (Int, DynMsg a (F a (SocketMsg a))) (Int, SocketMsg a) forall a b. F (Int, DynFMsg a b) (Int, b) dynListF) where router :: Either (Either (a, b) (a, SocketMsg a)) (a, a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] router = (Either (a, b) (a, SocketMsg a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)]) -> ((a, a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)]) -> Either (Either (a, b) (a, SocketMsg a)) (a, a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (((a, b) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)]) -> ((a, SocketMsg a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)]) -> Either (a, b) (a, SocketMsg a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (a, b) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] forall a b a a a. (a, b) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] fromListener (a, SocketMsg a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] forall a a a a b. (a, SocketMsg a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] fromDynList) (a, a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] forall a a a b b. (a, a) -> [Either (Either a (a, DynMsg a b)) b] fromOutside where fromListener :: (a, b) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] fromListener (a i,b f) = [(a, DynMsg a b) -> Either (Either a (a, DynMsg a b)) (a, ClientMsg a) forall b a b. b -> Either (Either a b) b todyn (a i,b -> DynMsg a b forall a b. b -> DynMsg a b DynCreate b f), (a, ClientMsg a) -> Either (Either a (a, DynMsg a b)) (a, ClientMsg a) forall b a. b -> Either a b out (a i,ClientMsg a forall a. ClientMsg a ClientNew)] fromDynList :: (a, SocketMsg a) -> [Either (Either a (a, DynMsg a b)) (a, ClientMsg a)] fromDynList (a i,SocketMsg a m) = case SocketMsg a m of SocketMsg a m' -> [(a, ClientMsg a) -> Either (Either a (a, DynMsg a b)) (a, ClientMsg a) forall b a. b -> Either a b out (a i,a -> ClientMsg a forall a. a -> ClientMsg a ClientMsg a m')] SocketMsg a SocketEOS -> [(a, ClientMsg a) -> Either (Either a (a, DynMsg a b)) (a, ClientMsg a) forall b a. b -> Either a b out (a i,ClientMsg a forall a. ClientMsg a ClientEOS), (a, DynMsg a b) -> Either (Either a (a, DynMsg a b)) (a, ClientMsg a) forall b a b. b -> Either (Either a b) b todyn (a i,DynMsg a b forall a b. DynMsg a b DynDestroy)] fromOutside :: (a, a) -> [Either (Either a (a, DynMsg a b)) b] fromOutside (a i,a m) = [(a, DynMsg a b) -> Either (Either a (a, DynMsg a b)) b forall b a b. b -> Either (Either a b) b todyn (a i,a -> DynMsg a b forall a b. a -> DynMsg a b DynMsg a m)] todyn :: b -> Either (Either a b) b todyn = Either a b -> Either (Either a b) b forall a b. a -> Either a b Left (Either a b -> Either (Either a b) b) -> (b -> Either a b) -> b -> Either (Either a b) b forall b c a. (b -> c) -> (a -> b) -> a -> c . b -> Either a b forall a b. b -> Either a b Right out :: b -> Either a b out = b -> Either a b forall a b. b -> Either a b Right listenerF :: F b (Int, F a (SocketMsg a)) listenerF = Int -> (LSocket -> F b (Int, F a (SocketMsg a))) -> F b (Int, F a (SocketMsg a)) forall (f :: * -> * -> *) b ho. FudgetIO f => Int -> (LSocket -> f b ho) -> f b ho openLSocketF Int port ((LSocket -> F b (Int, F a (SocketMsg a))) -> F b (Int, F a (SocketMsg a))) -> (LSocket -> F b (Int, F a (SocketMsg a))) -> F b (Int, F a (SocketMsg a)) forall a b. (a -> b) -> a -> b $ \LSocket lsocket -> [Descriptor] -> F b (Int, F a (SocketMsg a)) -> F b (Int, F a (SocketMsg a)) forall (f :: * -> * -> *) hi ho. FudgetIO f => [Descriptor] -> f hi ho -> f hi ho select [LSocket -> Descriptor LSocketDe LSocket lsocket] (F b (Int, F a (SocketMsg a)) -> F b (Int, F a (SocketMsg a))) -> F b (Int, F a (SocketMsg a)) -> F b (Int, F a (SocketMsg a)) forall a b. (a -> b) -> a -> b $ Int -> F b (Int, F a (SocketMsg a)) forall t a. Num t => t -> F a (t, F a (SocketMsg a)) accepter Int 0 where accepter :: t -> F a (t, F a (SocketMsg a)) accepter t i = Cont (F a (t, F a (SocketMsg a))) (KEvent a) forall a b. Cont (F a b) (KEvent a) getMessageFu Cont (F a (t, F a (SocketMsg a))) (KEvent a) -> Cont (F a (t, F a (SocketMsg a))) (KEvent a) forall a b. (a -> b) -> a -> b $ \KEvent a e -> case KEvent a e of Low (DResp (AsyncInput (Descriptor _,SocketAccepted Socket socket String peer))) -> (t, F a (SocketMsg a)) -> F a (t, F a (SocketMsg a)) -> F a (t, F a (SocketMsg a)) forall ho hi. ho -> F hi ho -> F hi ho putF (t i,Socket -> String -> F a (SocketMsg a) f Socket socket String peer) (F a (t, F a (SocketMsg a)) -> F a (t, F a (SocketMsg a))) -> F a (t, F a (SocketMsg a)) -> F a (t, F a (SocketMsg a)) forall a b. (a -> b) -> a -> b $ t -> F a (t, F a (SocketMsg a)) accepter (t it -> t -> t forall a. Num a => a -> a -> a +t 1) KEvent a _ -> t -> F a (t, F a (SocketMsg a)) accepter t i