Xen.hs

{-# LANGUAGE RecordWildCards #-}

module Hans.Device.Xen where

import Hans.Device.Types
import Hans.Ethernet.Types (readMac)
import Hans.Threads (forkNamed)
import Hans.Types

import           Control.Concurrent (newMVar,modifyMVar_,killThread)
import           Control.Concurrent.BoundedChan
                     (BoundedChan,newBoundedChan,tryWriteChan,readChan)
import           Control.Exception(try)
import           Control.Monad (forever)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import           Hypervisor.ErrorCodes(ErrorCode)
import           Hypervisor.XenStore (XenStore)
import           XenDevice.NIC (NIC,listNICs,openNIC,setReceiveHandler,sendPacket)

listDevices :: XenStore -> IO [DeviceName]
listDevices xs =
  do nics <- listNICs xs
     return (map S8.pack nics)

openDevice :: XenStore -> NetworkStack -> DeviceName -> DeviceConfig -> IO Device
openDevice xs ns devName devConfig =
  do let macStr = S8.unpack devName
     nic <- openNIC xs macStr

     devStats     <- newDeviceStats
     devSendQueue <- newBoundedChan (dcSendQueueLen devConfig)

     thread <- newMVar Nothing

     devMac <- case readMac macStr of
                 [(x,_)] -> return x
                 _       -> fail ("Unable to parse mac address: " ++ macStr)

     let dev = Device { .. }

         devStart = modifyMVar_ thread $ \ mbTid ->
           case mbTid of

             Nothing ->
               do sendThread <- forkNamed "xenSendLoop"
                      (xenSendLoop devStats nic devSendQueue)

                  setReceiveHandler nic (xenRecv ns dev)

                  return (Just sendThread)

             Just {} ->
                  return mbTid

         devStop = modifyMVar_ thread $ \ mbTid ->
           case mbTid of

             Just tid ->
               do killThread tid
                  return Nothing

             Nothing ->
                  return Nothing

         -- NOTE: there's no way to cleanup a NIC
         devCleanup =
             return ()

     return dev


-- NOTE: No way to update stats here, as we can't tell if sendPacket failed.
xenSendLoop :: DeviceStats -> NIC -> BoundedChan L.ByteString -> IO ()
xenSendLoop stats nic chan = forever $
  do bs  <- readChan chan
     res <- try $ sendPacket nic bs

     case res :: Either ErrorCode () of
       Right () ->
         do updateBytes   statTX stats (fromIntegral (L.length bs))
            updatePackets statTX stats
       Left _ ->
            updateError   statTX stats

xenRecv :: NetworkStack -> Device -> L.ByteString -> IO ()
xenRecv ns dev @ Device { .. } = \ bytes ->
  do let bytes' = L.toStrict bytes
     success <- tryWriteChan (nsInput ns) $! FromDevice dev bytes'
     if success
        then do updateBytes   statRX devStats (S.length bytes')
                updatePackets statRX devStats

        else updateError statRX devStats