{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module ServerC
    ( doServer
    , ConnId(..)
    , ServerHandle
    , quitListening
    , dummyServerHandle
    , packetSink
    ) where

import Network.Socket as Socket
import Logging
import Data.ByteString.Char8
    ( hGetNonBlocking
    )
import qualified Data.ByteString.Char8 as S
    ( hPutStrLn
    )
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.IO.Class (MonadIO (liftIO))
import qualified Data.ByteString as S (ByteString)
import System.IO (Handle)
import Control.Concurrent.MVar (newMVar)

import ByteStringOperators
import SocketLike



newtype ConnId = ConnId Int
  deriving Eq

newtype ServerHandle = ServerHandle Socket

dummyServerHandle = do
    mvar <- newMVar Closed
    let sock = MkSocket 0 AF_UNSPEC NoSocketType 0 mvar
    return (ServerHandle sock)

quitListening :: ServerHandle -> IO ()
quitListening (ServerHandle socket) = sClose socket


data AcceptResult =
  GotConnection (Socket,SockAddr)
  | Retry
  | QuitOnException

doServer ::
  MonadIO m =>
    HCons Socket.Family (HCons PortNumber l)
    -> (HCons RestrictedSocket (HCons ConnId l)
        -> Source m S.ByteString 
        -> Sink S.ByteString m ()
        -> IO ())
    -> IO ServerHandle
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 (ServerHandle 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"   -> debugL "quit accept-loop." >> return QuitOnException

                  _  -> do
                    debugL ("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 -> Source m S.ByteString
packets h = do
    packet <- liftIO $ getPacket h
    yield packet
    isEof <- liftIO $ hIsEOF h
    when (not isEof) (packets h)
 where
    getPacket h = do { hWaitForInput h (-1) ; hGetNonBlocking h 1024 }

packetSink :: MonadIO m => Handle -> Sink S.ByteString m ()
packetSink h = do
    -- liftIO . L.putStrLn $ "outgoing: waiting"
    mpacket <- await
    -- liftIO . L.putStrLn $ "outgoing: got packet " <++> bshow mpacket
    maybe (return ()) 
          (\r -> (liftIO . S.hPutStrLn h $ r) >> packetSink h) 
          mpacket
    



runConn ::
  MonadIO m =>
  (HCons RestrictedSocket st 
    -> Source m S.ByteString 
    -> Sink S.ByteString m () 
    -> IO ())
  -> st 
  -> (Socket, t) 
  -> IO ()
runConn g st (sock,_) = do
        h <- socketToHandle sock ReadWriteMode
        hSetBuffering h NoBuffering
        let doException (SomeException e) = debugStr ("\n\nexception: " ++ show e ++ "\n\n")
        handle doException (g (restrictSocket sock `HCons` st) (packets h) (packetSink h))
        hClose h