{-# LANGUAGE CPP,ForeignFunctionInterface #-}
module FudSocketIO(Socket,Fd,connectTo,listenOn,accept,closeS,closeLs,
                   select,sRead,sWrite,s2fd,ls2fd,stdinS) where
import Control.Concurrent(threadWaitRead)
import Control.Monad(filterM)
import qualified System.Posix.Types as U
import System.Posix.IO.ByteString(stdInput) --,fdRead,fdWrite needs unix>=2.8
import Sockets as S
--import ResourceIds

import XCallTypes
import StructFuns
import Marshall
import MyForeign

--import Ap
import Data.Traversable(traverse)
import System.IO(stderr,hPutStrLn) -- debug

default (Int)

eprint x = hPutStrLn stderr . take 239 . show $ x -- debug

#include "newstructfuns.h"

H_STRUCTTYPE(fd_set)

type Fd = Int32

select rfds wfds t =
  withFdSet rfds $ \ readfds ->
    withFdSet wfds $ \ writefds ->
       do timeout <- traverse newTimeVal t
          let maxfdvar = max (maximum (-1:rfds)) (maximum (-1:wfds))
	  n <- select' (maxfdvar+1) readfds writefds timeout
	  maybe (return ()) freePtr timeout
          if n == -1
            then error . ("select "++) =<< strerror =<< errno
	    else do rds <- filterM (fdIsSet readfds) rfds
                    wds <- filterM (fdIsSet writefds) wfds
                    return (rds,wds)

newTimeVal tleft =
  do timeout <- newPtr
     SET(timeVal,Int,timeout,tv_usec,(tleft `rem` 1000) * 1000)
     SET(timeVal,Int,timeout,tv_sec,(tleft `quot` 1000))
     return timeout

foreign import ccall "sys/select.h select" cselect :: Int32 -> Cfd_set -> Cfd_set -> Cfd_set -> CtimeVal -> IO Int32
--foreign import ccall "unistd.h" getdtablesize :: IO Int

select' :: Int32 -> Cfd_set -> Cfd_set -> Maybe CtimeVal -> IO Int32
select' nfds readfds writefds timeout = start where
 start = do
--  eprint ("select'",nfds)
--  eprint =<< filterM (fdIsSet readfds) [0..nfds-1]
    n <- cselect nfds readfds writefds nullPtr (maybe nullPtr id timeout)
--  eprint ("cselect returns",n)
    if n /= -1 then return n else do
       e <- errno
       if e == CCONST(EINTR) --- || e == CCONST(EAGAIN)
         then start -- again
         else return n

foreign import ccall "asyncinput.h get_errno" errno :: IO Int
--errno :: IO Int
--errno = _casm_ ``%r=errno;''

foreign import ccall "sys/socket.h" listen :: Fd -> Int32 -> IO Int
foreign import ccall "sys/socket.h" socket :: Int32 -> Int32 -> Int32 -> IO Fd
foreign import ccall "asyncinput.h" in_connect :: CString -> Int32 -> Int32 -> IO Int32
foreign import ccall "asyncinput.h" in_bind :: Int32 -> Int32 -> IO Fd
--foreign import ccall "asyncinput.h" get_stdin :: IO Int

connectTo host port =
  do chost <- marshallString host
     s <- tryP "in_connect" (>=0) $ 
--           _casm_ ``%r=in_connect(%0,%1,SOCK_STREAM);'' chost port
           in_connect chost (fi port) (fi CCONST(SOCK_STREAM))
     freePtr chost
     return $ So (fi s)

listenOn port =
   do s <- tryP "in_bind" (>=0) $ if port == 0 
--         then _casm_ ``%r=socket(AF_INET,SOCK_STREAM,0);''
           then socket (fi CCONST(AF_INET)) (fi CCONST(SOCK_STREAM)) 0
--	   else _casm_ ``%r=in_bind(%0,SOCK_STREAM);'' port
	   else in_bind (fi port) (fi CCONST(SOCK_STREAM))
      tryP "listen" (==0) $ listen s 5
      return $ LSo (fi s)


foreign import ccall "sys/socket.h accept" cAccept :: Fd -> CsockAddr -> CInt32 -> IO Fd

accept (LSo fd) =
  withPtr $ \ addrlen ->
   with newsockAddr $ \ addr ->
     do writeCVar addrlen (fi SIZEOF(sockAddr))
        eprint ("SIZEOF(sockAddr)",SIZEOF(sockAddr))
        sfd <- tryP "accept" (>=0) $ cAccept (fi fd) addr addrlen
        len <- readCVar addrlen
        eprint ("accept returned addr len",len)
        --buf <- stToIO $ newCharArray (1,1000)
        --tryP "hostName" (==0) $ _ccall_ hostName addr buf
        --peer <- cstring <$> mutByteArr2Addr buf
        let peer = ""
        return (So (fi sfd),peer,0) -- !!


closeS (So s) = cclose (fi s)
closeLs (LSo s) = cclose (fi s)

sRead = sRead' . fd2ufd . s2fd

sRead' fd n = do threadWaitRead fd
                 fdRead fd n

sWrite = fdWrite . fd2ufd . s2fd

stdinS = So (fi stdin) where U.Fd stdin = stdInput

fd2ufd = U.Fd . fi

s2fd (So s) = fi s :: Fd
ls2fd (LSo s) = fi s :: Fd

--foreign import ccall "sys/socket.h" getsockname :: Int -> CsockAddr -> Addr -> IO Int

foreign import ccall "string.h strerror" cstrerror :: Int -> IO CString
strerror e = unmarshallString =<< cstrerror e

tryP e p io = do
    r <- io
    if p (r{-::Int-}) then return r else do
      s <- strerror =<< errno
      failu (e++": "++ s)

foreign import ccall "asyncinput.h" fdzero :: Cfd_set -> IO ()
foreign import ccall "asyncinput.h fdset" fd_set :: Fd -> Cfd_set -> IO ()
foreign import ccall "asyncinput.h fdisset" fd_isset :: Fd -> Cfd_set -> IO Int

fdIsSet fdset fd = (/=0) <$> fd_isset fd fdset

withFdSet fds m = withPtr $ \ fdset ->
                  do fdzero fdset
--                   eprint ("fdset",fds)
                     mapM_ (flip fd_set fdset) fds
                     m fdset

foreign import ccall "unistd.h close" cclose :: Fd -> IO Int32

fi x = fromIntegral x

foreign import ccall "unistd.h read" cread :: Fd -> Addr -> CSize -> IO CSize
foreign import ccall "unistd.h write" cwrite :: Fd -> CString -> CSize -> IO CSize

fdRead (U.Fd fd) n =
  alloca n $ \ buf ->
  do got <- tryP "fdRead" (>=0) $ cread (fi fd) buf (fi n)
     unmarshallByteString' (CString buf) (fi got)

fdWrite (U.Fd fd) bs =
  withByteString bs $ \ cstr n -> cwrite (fi fd) cstr (fi n)