{-# LANGUAGE CPP, ForeignFunctionInterface, MagicHash, UnboxedTuples #-}
module AsyncInput
   (doSocketRequest,doSelect,getAsyncInput',initXCall,XCallState)
  where
import P_IO_data({-Request(..),-}Response(..))
--import Xtypes
import Sockets as S
import DLValue
import Unsafe.Coerce -- !!!
--import ResourceIds

import XCallTypes
import StructFuns
import Xlib(xPending,xConnectionNumber)
import EncodeEvent
import Marshall
import MyForeign
import GHC.Exts(addrToAny# )
import GHC.Ptr(FunPtr(..))

--import Ap
import HbcUtils(lookupWithDefault)
import Data.Maybe(mapMaybe)
--import Control.Monad(when)

import Timers
import FudSocketIO
import StartProcess(startProcess,dup)
import qualified Data.ByteString.Char8 as C(empty,pack,unpack)

import Control.Applicative
import System.IO.Error(catchIOError,isEOFError)
import Data.IORef(newIORef,readIORef,writeIORef,IORef)
import System.Posix.DynamicLinker as DL
--import System.IO(stderr,hPutStrLn) -- debug

--import PackedString(unpackPS,lengthPS{-,packCBytesST,psToByteArray-})

default (Int)

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

#include "newstructfuns.h"

H_STRUCTTYPE(fd_set)

allocaInt = allocaElem (0::Int)

type AiTable = [(Fd,Descriptor)]

data XCallState = XCallState (IORef AiTable) (IORef Timers)

initXCall = XCallState <$> newIORef [] <*> initTimers

getAsyncInput' (XCallState aitable tref) =
 AsyncInput <$> do
   ai <- readIORef aitable
   let doSelect = do
	  timeout <- timeLeft tref
--        eprint (ai,timeout)
	  (readfds,_) <- select (map fst ai) [] timeout
	  let findFd fd =
               let d = lookAi fd
               in case d of
                    DisplayDe _ -> mkEvent fd d
                    SocketDe so ->
                      do bs <- catchEOF C.empty (sRead so 2000)
                         return (d,SocketRead (C.unpack bs))
#ifdef VERSION_bytestring
                    BinSocketDe so ->
                      do bs <- catchEOF C.empty (sRead so 2000)
                         return (d,SocketReadBin bs)
#endif
                    LSocketDe ls ->
                      do (so,peer,_port) <- accept ls
                         return (d,SocketAccepted so peer)

                    _ -> error "getAsyncInput3"
          case readfds of
            fd:_ -> findFd fd
            _ -> do tno <- removeTimeQ tref
                    return (TimerDe tno,TimerAlarm)

       mkEvent fd d = do
           (window,fev) <- {-motionCompress display =<<-} getNextEvent display
	   return (descriptor,XEvent (window,fev))
         where descriptor@(DisplayDe display) = d
         
       lookAi = lookupWithDefault ai (error "getAsyncInput2")
       dispde x@(fd,DisplayDe _) = Just x
       dispde _ = Nothing
   case mapMaybe dispde ai of
       [] -> doSelect
       (fd,d@(DisplayDe display)):_ -> do
         q <- xPending display
--       eprint ("pending",q)
         if q>0 then mkEvent fd d else doSelect

foreign import ccall "asyncinput.h get_errno" errno :: IO Int

foreign import ccall "stdio.h" fopen :: CString -> CString -> IO Int -- hmm
foreign import ccall "stdio.h" fclose :: Int -> IO Int

doSocketRequest (XCallState aitable tref) sr =
 case sr of
   CreateTimer interval first ->
          returnS . Timer =<< createTimer tref interval first
   DestroyTimer t -> do destroyTimer tref t
	                return Success
   OpenSocket host port -> returnS . Socket =<< connectTo host port
   OpenLSocket port -> returnS . LSocket =<< listenOn port
   WriteSocket s str -> Success <$ writeSocket s str
   WriteSocketPS s str -> returnS . Wrote . fromIntegral =<< writeSocket s str
   CloseSocket so -> Success <$ closeS so
   CloseLSocket ls -> Success <$ closeLs ls
   GetStdinSocket -> returnS $ Socket stdinS
   GetSocketName (So s) -> socketname s
   GetLSocketName (LSo s) -> socketname s
   StartProcess cmd doIn doOut doErr -> startProcess cmd doIn doOut doErr
   DLOpen path -> do dh <- dlopen path [RTLD_LAZY]
                     case dh of
                       Null -> failu =<< dlerror
                       _ -> returnS $ S.DLHandle (DL dh)
   DLClose (DL dh) -> do dlclose dh ; return Success
   DLSym (DL dh) name ->
       do FunPtr fp <- dlsym dh name
          case addrToAny# fp of
            (# hval #) -> returnS . DLVal $ DLValue (unsafeCoerce hval)
   OpenFileAsSocket name mode -> do
     cname <- marshallString name
     cmode <- marshallString mode
     f <- tryP "OpenSocketAsFile[fopen]" (/=0) $ fopen cname cmode
     freePtr cname
     freePtr cmode
     s <- fromEnum <$> (dup =<< fileno f)
     fclose f
     returnS $ (Socket . So) s
   _ -> error ("Not implemented: "++show sr)
 where returnS = return . SocketResponse
       socketname s =
          allocaInt $ \ lenp ->
          do sa <- newsockAddr
	     tryP "GetLSocketName" (==0) $ getsockname s sa lenp
	     len <- peek lenp
	     strp <- GETC(sockAddr,char *,CString,sa,sa_data) -- !!
	     Str <$> unmarshallString' strp len

writeSocket s str = sWrite s (C.pack str)

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

-- New: using file descriptors for socket and file I/O
--getfilep :: Fd -> String -> IO Int
--getfilep fd _mode = return (fromEnum fd)

get_fileno :: Int -> IO Fd
get_fileno file = return (toEnum file)

{- -- Old: using FILE * for socket and file I/O
get_fileno = fileno

getfilep s mode = tryP "fdopen" (/=0) $
  do cmode <- marshallString (mode::String)
--     _ccall_ fdopen (s::Int) cmode :: IO Int
     fdopen s cmode :: IO Int

foreign import ccall "stdio.h" fdopen :: Fd -> CString -> 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)

catchEOF r m = catchIOError m $ \ e -> if isEOFError e
                                       then return r
                                       else ioError e


doSelect :: XCallState -> [Descriptor] -> IO Response
doSelect (XCallState aitable _) dl =
    do writeIORef aitable . concat =<< mapM descriptor dl
       return Success
  where descriptor d = case d of
	   LSocketDe (LSo s) -> withd $ get_fileno s
	   SocketDe (So s) ->  withd $ get_fileno s
	   BinSocketDe (So s) ->  withd $ get_fileno s
	   OutputSocketDe (So s) ->  withd $ get_fileno s
	   DisplayDe d -> withd $ xConnectionNumber d -- hmm
	   TimerDe _ -> return []
--         _ -> do putStr "Unexpected descriptor: ";print d;return []
          where withd m = m >>= \fd -> return [(fd,d)]

foreign import ccall "asyncinput.h get_fileno" fileno :: Int -> IO Fd