{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE MultiWayIf           #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hans.Socket.Handle(makeHansHandle) where

import           Control.Concurrent(threadDelay)
import           Control.Exception(throwIO)
import qualified Data.ByteString as BSS
import qualified Data.ByteString.Lazy as BS
import           Data.Typeable(Typeable)
import           Foreign.Ptr(Ptr, castPtr, plusPtr)
import           GHC.IO.Buffer(newByteBuffer)
import           GHC.IO.BufferedIO(BufferedIO(..),
                                   readBuf, readBufNonBlocking,
                                   writeBuf, writeBufNonBlocking)
import           GHC.IO.Device(IODevice(..), RawIO(..), IODeviceType(..))
import           GHC.IO.Handle(mkFileHandle, noNewlineTranslation)
import           Hans.Network(Network(..))
import           Hans.Socket(Socket(..), DataSocket(..))
import           Prelude hiding (read)
import           System.IO(Handle, IOMode)


instance (Socket sock, DataSocket sock, Network addr) =>
            IODevice (sock addr) where
  ready dev forWrite msecs =
    do let tester = if forWrite then sCanWrite else sCanRead
       canDo <- tester dev
       if | canDo      -> return True
          | msecs <= 0 -> return False
          | otherwise  -> do let delay = min msecs 100
                             threadDelay (delay * 1000)
                             ready dev forWrite (msecs - delay)
  close bs     = sClose bs
  isTerminal _ = return False
  isSeekable _ = return False
  seek _ _ _   = throwIO (userError "Seek on HaNS socket.")
  tell _       = throwIO (userError "Tell on HaNS socket.")
  getSize _    = throwIO (userError "getSize on HaNS socket.")
  setSize _ _  = throwIO (userError "setSize on HaNS socket.")
  setEcho _ _  = throwIO (userError "setEcho on HaNS socket.")
  getEcho _    = throwIO (userError "getEcho on HaNS socket.")
  setRaw _ _   = return ()
  devType _    = return Stream
  dup _        = throwIO (userError "dup on HaNS socket.")
  dup2 _ _     = throwIO (userError "dup2 on HaNS socket.")

instance (Socket sock, DataSocket sock, Network addr) =>
            RawIO (sock addr) where
  read sock dptr sz =
    do bstr <- sRead sock (fromIntegral sz)
       copyToPtr dptr sz bstr
  readNonBlocking sock dptr sz =
    do mbstr <- sTryRead sock (fromIntegral sz)
       case mbstr of
         Nothing   -> return Nothing
         Just bstr -> Just `fmap` copyToPtr dptr sz bstr
  write sock ptr sz =
    do bstr <- BSS.packCStringLen (castPtr ptr, sz)
       sendAll (BS.fromStrict bstr)
   where
    sendAll bstr
      | BS.null bstr = return ()
      | otherwise    = do num <- sWrite sock bstr
                          sendAll (BS.drop (fromIntegral num) bstr)
  writeNonBlocking sock ptr sz =
    do bstr <- BSS.packCStringLen (castPtr ptr, sz)
       num  <- sWrite sock (BS.fromStrict bstr)
       return (fromIntegral num)

instance (Socket sock, DataSocket sock, Network addr) =>
            BufferedIO (sock addr) where
  newBuffer         _ = newByteBuffer (64 * 1024)
  fillReadBuffer      = readBuf
  fillReadBuffer0     = readBufNonBlocking
  flushWriteBuffer    = writeBuf
  flushWriteBuffer0   = writeBufNonBlocking

-- |Make a GHC Handle from a Hans handle.
makeHansHandle :: (Socket sock, DataSocket sock, Network addr, Typeable sock) =>
                  sock addr -> IOMode -> IO Handle
makeHansHandle socket mode =
  mkFileHandle socket "<socket>" mode Nothing noNewlineTranslation

copyToPtr :: Num a => Ptr b -> Int -> BS.ByteString -> IO a
copyToPtr ptr sz bstr
  | BS.length bstr == 0              = return 0
  | BS.length bstr > fromIntegral sz = fail "Too big a chunk for copy!"
  | otherwise                        =
      do copyBS (BS.toChunks bstr) ptr sz
         return (fromIntegral (BS.length bstr))

copyBS :: [BSS.ByteString] -> Ptr a -> Int -> IO ()
copyBS [] _ _ = return ()
copyBS (f:rest) sptr szLeft
  | BSS.null f   = copyBS rest sptr szLeft
  | szLeft <= 0  = return ()
  | otherwise    =
      do let (chunk1, chunk2) = BSS.splitAt szLeft f
             amt              = fromIntegral (BSS.length chunk1)
         BSS.useAsCString chunk1 $ \ dptr -> memcpy dptr sptr amt
         copyBS (chunk2 : rest) (sptr `plusPtr` amt) (szLeft - amt)

foreign import ccall unsafe "string.h memcpy"
  memcpy :: Ptr a -> Ptr b -> Int -> IO ()