ServerC module provides a conduits interface for doServer

2 files changed, 170 insertions, 0 deletions

diff --git a/Presence/ServerC.hs b/Presence/ServerC.hs
new file mode 100644
index 00000000..2e22825d
--- /dev/null
+++ b/Presence/ServerC.hs
@@ -0,0 +1,132 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+module ServerC 
+    ( doServer
+    , ConnId(..)
+    ) where
+
+import Network.Socket as Socket
+import Data.ByteString.Lazy.Char8 as L 
+    ( putStrLn )
+import Data.ByteString.Char8
+    ( hGetNonBlocking
+    )
+import qualified Data.ByteString.Char8 as S
+    ( hPutStr
+    )
+import System.IO 
+    ( IOMode(..)
+    , hSetBuffering
+    , BufferMode(..)
+    , hWaitForInput
+    , hClose
+    , hIsEOF
+    )
+import Control.Monad
+import Control.Concurrent (forkIO,threadDelay)
+import Control.Exception (handle,SomeException(..))
+import Data.HList
+import Data.HList.TypeEqGeneric1()
+import Data.HList.TypeCastGeneric1()
+import System.IO.Error
+
+import Data.Conduit
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Data.ByteString as S (ByteString)
+import System.IO (Handle)
+
+import ByteStringOperators
+import SocketLike
+
+
+
+newtype ConnId = ConnId Int
+  deriving Eq
+
+
+data AcceptResult =
+  GotConnection (Socket,SockAddr)
+  | Retry
+  | QuitOnException
+
+doServer ::
+  MonadIO m =>
+    HCons Socket.Family (HCons PortNumber l)
+    -> (HCons RestrictedSocket (HCons ConnId l)
+        -> Producer m S.ByteString 
+        -> Consumer S.ByteString m () 
+        -> IO ())
+    -> IO Socket
+doServer (HCons family port) g = runServer port (runConn g)
+ where
+    runServer (HCons port st) go = do
+        sock <- socket family Stream 0
+        setSocketOption sock ReuseAddr 1
+        case family of
+          AF_INET  -> bindSocket sock (SockAddrInet port iNADDR_ANY)
+          AF_INET6 -> bindSocket sock (SockAddrInet6 port 0 iN6ADDR_ANY 0)
+        listen sock 2
+        forkIO $ do
+            mainLoop sock (ConnId 0) go
+            -- L.putStrLn $ "quit accept loop"
+        return sock
+     where
+        mainLoop sock idnum@(ConnId n) go = do
+            let doException ioerror = do
+                let typ = ioeGetErrorType ioerror
+                case bshow typ of
+
+                  -- ResourceExhausted
+                  "resource exhausted" -> return Retry
+
+                  -- InvalidArgument
+                  "invalid argument"   -> L.putStrLn "quit accept-loop." >> return QuitOnException
+
+                  _  -> do
+                    L.putStrLn ("accept-loop exception: " <++> bshow ioerror <++> "\n")
+                    return QuitOnException
+
+            mcon <- handle doException $ fix $ \loop -> do
+                con <- accept sock
+                return $ GotConnection con
+            case mcon of
+              GotConnection con -> do
+                forkIO $ go (idnum `HCons` st) con 
+                mainLoop sock (ConnId (n+1)) go
+              Retry           -> threadDelay 500000 >> mainLoop sock idnum go
+              QuitOnException -> return ()
+
+packets :: MonadIO m => Handle -> Producer m S.ByteString
+packets h = do
+    packet <- lift $ liftIO $ getPacket h
+    yield packet
+    isEof <- lift $ liftIO $ hIsEOF h
+    when (not isEof) (packets h)
+ where
+    getPacket h = do { hWaitForInput h (-1) ; hGetNonBlocking h 1024 }
+
+outgoing :: MonadIO m => Handle -> Consumer S.ByteString m ()
+outgoing h = do
+    mpacket <- await
+    maybe (return ()) 
+          (\r -> (lift . liftIO . S.hPutStr h $ r) >> outgoing h) 
+          mpacket
+    
+
+runConn ::
+  MonadIO m =>
+  ( HCons RestrictedSocket st 
+    -> Producer m S.ByteString 
+    -> Consumer S.ByteString m () 
+    -> IO () )
+  -> st -> (Socket, t) -> IO ()
+
+runConn g st (sock,_) = do
+        h <- socketToHandle sock ReadWriteMode
+        hSetBuffering h NoBuffering
+        let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n")
+        handle doException (g (restrictSocket sock `HCons` st) (packets h) (outgoing h))
+        hClose h
diff --git a/Presence/SocketLike.hs b/Presence/SocketLike.hs
new file mode 100644
index 00000000..12fa07a3
--- /dev/null
+++ b/Presence/SocketLike.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module SocketLike
+    ( SocketLike
+    , getSocketName
+    , getPeerName
+    , getPeerCred
+    , socketPort
+    , RestrictedSocket
+    , restrictSocket
+    , PortNumber
+    , SockAddr
+    , CUInt
+    ) where
+
+import Network.Socket 
+    ( PortNumber
+    , SockAddr
+    )
+import Foreign.C.Types ( CUInt )
+
+import qualified Network.Socket as NS
+
+class SocketLike sock where
+    getSocketName :: sock -> IO SockAddr
+    getPeerName   :: sock -> IO SockAddr
+    getPeerCred   :: sock -> IO (CUInt, CUInt, CUInt)
+    socketPort    :: sock -> IO PortNumber
+
+instance SocketLike NS.Socket where
+    getSocketName = NS.getSocketName
+    getPeerName   = NS.getPeerName
+    getPeerCred   = NS.getPeerCred
+    socketPort    = NS.socketPort
+
+newtype RestrictedSocket = Restricted NS.Socket deriving SocketLike
+
+restrictSocket :: NS.Socket -> RestrictedSocket
+restrictSocket socket = Restricted socket