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