module Kernel.Driver.NE2000.Driver(initPCI,initialize) where

import H.IOPorts(Port)
import H.Interrupts(IRQ)
import Kernel.Interrupts(registerIRQHandler)
import Kernel.Driver.NE2000.Monad hiding (readChan,writeChan,newChan,putMVar)
import qualified Kernel.Driver.NE2000.Monad as NE
import Kernel.Bits

import Kernel.PCI.Device
import Kernel.PCI.ConfigSpace
import Kernel.PCI.BaseAddr


import qualified Net.Concurrent as IO
import qualified Net.Ethernet as Eth
import qualified Net.Interface as Net
import Net.Packet
import Net.PacketParsing(doParse)
import Net.Utils
import Net.H()
import Data.Maybe(fromMaybe)
import H.Monad(H)
import H.Concurrency




data Event          = CardEvent 
		    | Rx -- check buffer for more packets
                    | Tx (Eth.Packet OutPacket)

instance Show Event where
    show CardEvent = "CardEvent"
    show (Tx _)    = "Tx"
    show Rx        = "Rx"


initPCI            :: (String -> H())              -- ^ For debug.
                   -> Dev ()
                   -> H (Maybe (Eth.Interface H (Eth.Packet InPacket)
                               (Eth.Packet OutPacket)))
initPCI debug dev     
  = do base <- dev `getBAR` 0 
       prt ("base is "++show base)
       case base of
         Mem _ -> return Nothing
         IO base -> 
           do irq <- config dev `getB` 0x3C
              prt ("IRQ is " ++ show irq)
              eth <- initialize prt (toEnum (fromIntegral irq))
                                    (fromIntegral (addr base))
              return (Just eth)
  where
    prt = debug . ("NE2000: "++)

initialize         :: (String -> H())              -- ^ For debug.
                   -> IRQ                           -- ^ Interrupt for events.
                   -> Port                          -- ^ Base IO port.
                   -> H  (Eth.Interface H (Eth.Packet InPacket)
				          (Eth.Packet OutPacket))
initialize prt irq port 
    = do events <- newChan
	 irqAck <- newEmptyMVar 
	 let -- The interrupt handler should not return until it has told
             -- the device to deassert its interrupt signal.
             irqHandler = do writeChan events CardEvent
			     takeMVar irqAck
	 registerIRQHandler irq irqHandler
        
         macV   <- newEmptyMVar
         rxChan <- newChan
         forkH (neRun port prt (card macV rxChan events irqAck))
         mac    <- takeMVar macV 
        
         let io = Net.Interface { Net.rx = IO.readChan rxChan
		                , Net.tx = IO.writeChan events . Tx }
	 return Eth.Interface { Eth.myMAC = mac, Eth.io=io }



card macV rx events irqAck =
  initialize_NE2000 `neBind` NE.putMVar macV `neThen`
  NE.newChan        `neBind` \buffer ->

  let loop          = (NE.readChan events `neBind` handle) `neThen` loop 

       status = getEvents ` neBind ` \ events - > 
	        getCmd ` neBind ` \ cmd - > 
	        debug ( showBin cmd++ " " + + showBin events ) 
                                       
       handle ' ev = debug ( show ev ) ` neThen ` status ` neThen ` handle   
      status = getEvents `neBind` \ events ->
	       getCmd `neBind` \ cmd ->
	       debug (showBin cmd++" "++showBin events)
                                       
      handle' ev = debug (show ev) `neThen` status `neThen` handle ev
--}
      --handle' ev = debug "." `neThen` handle ev

      handle (Tx p) = txing `neBind` \busy ->
                      if busy then NE.writeChan buffer p
                              else doTxPacket p

      handle Rx         = rxPackets
      handle CardEvent  = --debug "*" `neThen`
                          turnToPage Page0 `neThen`
			  getEvents `neBind` \isr -> 
			  let rx = isr `testBit` 0
			      tx = isr `testBit` 1
                          in
			  -- Acknowledge interrupts early
			  neWhen rx (ackEvent 0) `neThen`
			  neWhen tx (ackEvent 1) `neThen`
			  NE.putMVar irqAck () `neThen`
                          neWhen rx rxPackets `neThen`
                          neWhen tx txPackets



  | Receive up to 10 packets from the card 's buffer .
  Note : 10 is arb .
      rxPackets     = --ackEvent 0 `neThen`
                      getBoundary `neBind` loop 10
        where 
        loop 0 b    = NE.writeChan events Rx   -- to resume later
        loop n b    = neWhenM (havePacket b) (
                           doRxPacket b `neBind` \(p,b) ->
                           NE.writeChan rx p `neThen`
                           loop (n-1) b
                        )

      txPackets     =  --ackEvent 1 `neThen`
                       neWhenM (not `neMap` NE.emptyChan buffer) (
                        NE.readChan buffer `neBind` doTxPacket 
                      )

  in loop
  where
  -- | Check if there seems to be a packet in the card's buffer.
  -- Having to turn pages here seems very silly.
  havePacket bdry   = turnToPage Page1  `neThen`
                      getCurrent        `neBind` \c ->
                      turnToPage Page0  `neThen`
                      neReturn (not (bdry == c))



-- | Receive a packet.  As argument we get the boundary of the packet.
-- PRE: We have a packet, i.e. boundary /= current
doRxPacket         :: Word8 ->                          -- initial boundary
                        NE2000 (Page0,On) (Page0,On) 
                                 ( Eth.Packet InPacket  -- a packet
                                 , Word8                -- the new boundary
                                 )
doRxPacket bdry     = --debug "?" `neThen`
                      packetHeader bdry `neBind` \hdr -> 
                      let base = bdry `nextTo` (4::Word8) 
                          next = nextBuffer hdr in
                      readMem base (byteCount hdr) `neBind` \bytes ->
                      setBoundary next `neThen`
                      neReturn (fromMaybe err (doParse bytes), next)
  where err = error "NE2000.Driver error: short ethernet packet recevied"

-- | Transmit a packet.
-- PRE: Card is not already transmitting a packet.
-- PRE: The packet is not too short or too long (XXX: Check this here?)
doTxPacket         :: Eth.Packet OutPacket -> NE2000 (Page0,On) (Page0,On) ()
doTxPacket p        = --debug "!" `neThen` 
                      let pack    = Eth.unparse p
                          addr    = transmitBuffer `nextTo` (0::Word8)
                      in writeMem addr pack        `neThen`
                         txByteCount (max 64 (outLen pack)) `neThen`
                         txStart

  | Write a packet to the NIC 's buffer .
writeMem           :: Word16 -> OutPacket -> NE2000 (Page0,On) (Page0,On) ()
writeMem addr pack  = remoteAddress addr                            `neThen`
                      remoteByteCount (fromIntegral (outLen pack))  `neThen`
                      remoteWrite                                   `neThen`
                      neMapM_ dmaTxArray (chunks pack)              `neThen`
                      waitForDMA

  | Busy loop while DMA completes .
-- XXX: We could put a limit on this.
-- XXX: Looping is not too bad as we expect only a few loops?
waitForDMA         :: NE2000 (Page0,s) (Page0,s) ()
waitForDMA          = getEvents `neBind` \isr ->
                      neWhen (not (isr `testBit` 6)) waitForDMA `neThen`
                      ackEvent 6

  | Read a packet from the NIC 's buffer .
readMem            :: Word16 -> Int -> NE2000 (Page0,On) (Page0,On) InPacket
readMem addr len    = remoteAddress addr                  `neThen`
                      remoteByteCount len                 `neThen`
                      remoteRead                          `neThen`
                      dmaRxArray (fromIntegral len)       `neBind` \bytes ->
                      waitForDMA                          `neThen` 
                      -- Prolly not neccessary, do the ack though.
                      neReturn (toInPack bytes)

data NE2000Header   = NE_Hdr
                    { rxStatus    :: !Word8
                    , nextBuffer  :: !Word8
                    , byteCount   :: !Int
                    }

packetHeader       :: Word8 -> NE2000 (Page0,s) (Page0,s) NE2000Header
packetHeader bdry   = let base = bdry `nextTo` (0::Word8) in
                      remoteAddress base  `neThen`
                      remoteByteCount 4   `neThen`
                      getDMA              `neBind` \w1 ->
                      getDMA              `neBind` \w2 ->
                      neReturn $ NE_Hdr 
                        { rxStatus   = w1 .!. 0
                        , nextBuffer = w1 .!. 1
                        , byteCount  = fromIntegral w2
                        }

nicPROM             = remoteAddress 0     `neThen`
                      remoteByteCount 32  `neThen`
                      dmaRxArray 32       `neBind` \b -> 
                      neReturn (Eth.Addr (b ! 0) (b ! 2) (b ! 4) (b ! 6) 
                                                            (b ! 8) (b ! 10)) 
                    


transmitBuffer      = 0x40  :: Word8
receiveBufferStart  = 0x46  :: Word8
receiveBufferStop   = 0x80  :: Word8

  NOTE : qemu does not implement the filtering of packets .

initialize_NE2000  :: NE2000 (page,start) (Page0,On) Eth.Addr
initialize_NE2000   = 
  stop              `neThen`
  turnToPage Page0  `neThen`

  little endian , 16 bit data transfers
  remoteByteCount 0 `neThen`
  rxConfig 0x00     `neThen` -- accept only normal packet 
                             -- (we still get broadcast, why?)
  txConfig 0x02     `neThen` -- internal loop back

  -- receive buffer
  rxBufferStart receiveBufferStart  `neThen`
  rxBufferEnd receiveBufferStop     `neThen`
  setBoundary receiveBufferStart    `neThen`
                        
  currently we only use 1 page , so set it here
  for 2 page transmit buffer we need to adjust this

  txPage transmitBuffer   `neThen`
  clearEvents             `neThen`
  interruptMask 0x00      `neThen`
  nicPROM                 `neBind` \addr -> 

  turnToPage Page1              `neThen`
  physAddr addr                 `neThen`
  multicast (replicate 8 0xFF)  `neThen`  -- accept all 
  setCurrent receiveBufferStart `neThen`  -- put incoming packets here

  turnToPage Page0      `neThen`
  interruptMask 0x03    `neThen` -- we get only receive & transmit events 
  start                 `neThen`
  txConfig 0x00         `neThen` -- normal mode
  neReturn addr

 check buffer for more packets
 ^ For debug.
 ^ For debug.
 ^ Interrupt for events.
 ^ Base IO port.
 The interrupt handler should not return until it has told
 the device to deassert its interrupt signal.
}
handle' ev = debug "." `neThen` handle ev
debug "*" `neThen`
 Acknowledge interrupts early
ackEvent 0 `neThen`
 to resume later
ackEvent 1 `neThen`
 | Check if there seems to be a packet in the card's buffer.
 Having to turn pages here seems very silly.
 | Receive a packet.  As argument we get the boundary of the packet.
 PRE: We have a packet, i.e. boundary /= current
 initial boundary
 a packet
 the new boundary
debug "?" `neThen`
 | Transmit a packet.
 PRE: Card is not already transmitting a packet.
 PRE: The packet is not too short or too long (XXX: Check this here?)
debug "!" `neThen` 
 XXX: We could put a limit on this.
 XXX: Looping is not too bad as we expect only a few loops?
 Prolly not neccessary, do the ack though.
 accept only normal packet 
 (we still get broadcast, why?)
 internal loop back
 receive buffer
 accept all 
 put incoming packets here
 we get only receive & transmit events 
 normal mode
module Kernel.Driver.NE2000.Driver(initPCI,initialize) where

import H.IOPorts(Port)
import H.Interrupts(IRQ)
import Kernel.Interrupts(registerIRQHandler)
import Kernel.Driver.NE2000.Monad hiding (readChan,writeChan,newChan,putMVar)
import qualified Kernel.Driver.NE2000.Monad as NE
import Kernel.Bits

import Kernel.PCI.Device
import Kernel.PCI.ConfigSpace
import Kernel.PCI.BaseAddr


import qualified Net.Concurrent as IO
import qualified Net.Ethernet as Eth
import qualified Net.Interface as Net
import Net.Packet
import Net.PacketParsing(doParse)
import Net.Utils
import Net.H()
import Data.Maybe(fromMaybe)
import H.Monad(H)
import H.Concurrency




data Event          = CardEvent 
                    | Tx (Eth.Packet OutPacket)

instance Show Event where
    show CardEvent = "CardEvent"
    show (Tx _)    = "Tx"
    show Rx        = "Rx"


                   -> Dev ()
                   -> H (Maybe (Eth.Interface H (Eth.Packet InPacket)
                               (Eth.Packet OutPacket)))
initPCI debug dev     
  = do base <- dev `getBAR` 0 
       prt ("base is "++show base)
       case base of
         Mem _ -> return Nothing
         IO base -> 
           do irq <- config dev `getB` 0x3C
              prt ("IRQ is " ++ show irq)
              eth <- initialize prt (toEnum (fromIntegral irq))
                                    (fromIntegral (addr base))
              return (Just eth)
  where
    prt = debug . ("NE2000: "++)

                   -> H  (Eth.Interface H (Eth.Packet InPacket)
				          (Eth.Packet OutPacket))
initialize prt irq port 
    = do events <- newChan
	 irqAck <- newEmptyMVar 
             irqHandler = do writeChan events CardEvent
			     takeMVar irqAck
	 registerIRQHandler irq irqHandler
        
         macV   <- newEmptyMVar
         rxChan <- newChan
         forkH (neRun port prt (card macV rxChan events irqAck))
         mac    <- takeMVar macV 
        
         let io = Net.Interface { Net.rx = IO.readChan rxChan
		                , Net.tx = IO.writeChan events . Tx }
	 return Eth.Interface { Eth.myMAC = mac, Eth.io=io }



card macV rx events irqAck =
  initialize_NE2000 `neBind` NE.putMVar macV `neThen`
  NE.newChan        `neBind` \buffer ->

  let loop          = (NE.readChan events `neBind` handle) `neThen` loop 

       status = getEvents ` neBind ` \ events - > 
	        getCmd ` neBind ` \ cmd - > 
	        debug ( showBin cmd++ " " + + showBin events ) 
                                       
       handle ' ev = debug ( show ev ) ` neThen ` status ` neThen ` handle   
      status = getEvents `neBind` \ events ->
	       getCmd `neBind` \ cmd ->
	       debug (showBin cmd++" "++showBin events)
                                       
      handle' ev = debug (show ev) `neThen` status `neThen` handle ev

      handle (Tx p) = txing `neBind` \busy ->
                      if busy then NE.writeChan buffer p
                              else doTxPacket p

      handle Rx         = rxPackets
                          turnToPage Page0 `neThen`
			  getEvents `neBind` \isr -> 
			  let rx = isr `testBit` 0
			      tx = isr `testBit` 1
                          in
			  neWhen rx (ackEvent 0) `neThen`
			  neWhen tx (ackEvent 1) `neThen`
			  NE.putMVar irqAck () `neThen`
                          neWhen rx rxPackets `neThen`
                          neWhen tx txPackets



  | Receive up to 10 packets from the card 's buffer .
  Note : 10 is arb .
                      getBoundary `neBind` loop 10
        where 
        loop n b    = neWhenM (havePacket b) (
                           doRxPacket b `neBind` \(p,b) ->
                           NE.writeChan rx p `neThen`
                           loop (n-1) b
                        )

                       neWhenM (not `neMap` NE.emptyChan buffer) (
                        NE.readChan buffer `neBind` doTxPacket 
                      )

  in loop
  where
  havePacket bdry   = turnToPage Page1  `neThen`
                      getCurrent        `neBind` \c ->
                      turnToPage Page0  `neThen`
                      neReturn (not (bdry == c))



                        NE2000 (Page0,On) (Page0,On) 
                                 )
                      packetHeader bdry `neBind` \hdr -> 
                      let base = bdry `nextTo` (4::Word8) 
                          next = nextBuffer hdr in
                      readMem base (byteCount hdr) `neBind` \bytes ->
                      setBoundary next `neThen`
                      neReturn (fromMaybe err (doParse bytes), next)
  where err = error "NE2000.Driver error: short ethernet packet recevied"

doTxPacket         :: Eth.Packet OutPacket -> NE2000 (Page0,On) (Page0,On) ()
                      let pack    = Eth.unparse p
                          addr    = transmitBuffer `nextTo` (0::Word8)
                      in writeMem addr pack        `neThen`
                         txByteCount (max 64 (outLen pack)) `neThen`
                         txStart

  | Write a packet to the NIC 's buffer .
writeMem           :: Word16 -> OutPacket -> NE2000 (Page0,On) (Page0,On) ()
writeMem addr pack  = remoteAddress addr                            `neThen`
                      remoteByteCount (fromIntegral (outLen pack))  `neThen`
                      remoteWrite                                   `neThen`
                      neMapM_ dmaTxArray (chunks pack)              `neThen`
                      waitForDMA

  | Busy loop while DMA completes .
waitForDMA         :: NE2000 (Page0,s) (Page0,s) ()
waitForDMA          = getEvents `neBind` \isr ->
                      neWhen (not (isr `testBit` 6)) waitForDMA `neThen`
                      ackEvent 6

  | Read a packet from the NIC 's buffer .
readMem            :: Word16 -> Int -> NE2000 (Page0,On) (Page0,On) InPacket
readMem addr len    = remoteAddress addr                  `neThen`
                      remoteByteCount len                 `neThen`
                      remoteRead                          `neThen`
                      dmaRxArray (fromIntegral len)       `neBind` \bytes ->
                      waitForDMA                          `neThen` 
                      neReturn (toInPack bytes)

data NE2000Header   = NE_Hdr
                    { rxStatus    :: !Word8
                    , nextBuffer  :: !Word8
                    , byteCount   :: !Int
                    }

packetHeader       :: Word8 -> NE2000 (Page0,s) (Page0,s) NE2000Header
packetHeader bdry   = let base = bdry `nextTo` (0::Word8) in
                      remoteAddress base  `neThen`
                      remoteByteCount 4   `neThen`
                      getDMA              `neBind` \w1 ->
                      getDMA              `neBind` \w2 ->
                      neReturn $ NE_Hdr 
                        { rxStatus   = w1 .!. 0
                        , nextBuffer = w1 .!. 1
                        , byteCount  = fromIntegral w2
                        }

nicPROM             = remoteAddress 0     `neThen`
                      remoteByteCount 32  `neThen`
                      dmaRxArray 32       `neBind` \b -> 
                      neReturn (Eth.Addr (b ! 0) (b ! 2) (b ! 4) (b ! 6) 
                                                            (b ! 8) (b ! 10)) 
                    


transmitBuffer      = 0x40  :: Word8
receiveBufferStart  = 0x46  :: Word8
receiveBufferStop   = 0x80  :: Word8

  NOTE : qemu does not implement the filtering of packets .

initialize_NE2000  :: NE2000 (page,start) (Page0,On) Eth.Addr
initialize_NE2000   = 
  stop              `neThen`
  turnToPage Page0  `neThen`

  little endian , 16 bit data transfers
  remoteByteCount 0 `neThen`

  rxBufferStart receiveBufferStart  `neThen`
  rxBufferEnd receiveBufferStop     `neThen`
  setBoundary receiveBufferStart    `neThen`
                        
  currently we only use 1 page , so set it here
  for 2 page transmit buffer we need to adjust this

  txPage transmitBuffer   `neThen`
  clearEvents             `neThen`
  interruptMask 0x00      `neThen`
  nicPROM                 `neBind` \addr -> 

  turnToPage Page1              `neThen`
  physAddr addr                 `neThen`

  turnToPage Page0      `neThen`
  start                 `neThen`
  neReturn addr
