module System.Xen
	( Xen
	, runXen
	, runXen_
	, execXen
	, mkCallback
	, xcInterfaceOpen
	, xcInterfaceClose
	, xcFindDeviceNumber
	, xcDomainCreate
	, xcDomainDumpcore
	, xcDomainDumpcoreViaCallback
	, xcDomainMaxVCPUs
	, xcDomainPause
	, xcDomainUnpause
	, xcDomainResume
	, xcDomainShutdown
	, xcVCPUSetAffinity
	, xcVCPUGetAffinity
	, xcDomainGetInfo
	, xcDomainGetInfoList
	, xcDomainHVMGetContext
	, xcDomainHVMSetContext
	, xcVCPUGetInfo
	, xcDomainSetCPUWeight
	, xcDomainGetCPUUsage
	, xcDomainSetHandle
	, xcSedfDomainSet
	, xcSedfDomainGet
	, xcDomainSendTrigger
	, xcEvtChanAllocUnbound
	, xcEvtChanReset
	, xcEvtChanOpen
	, xcEvtChanClose
	, xcEvtChanNotify
	, xcEvtChanBindUnboundPort
	, xcEvtChanBindInterdomain
	, xcEvtChanBindVIRQ
	, xcEvtChanUnbind
	, xcEvtChanPending
	, xcEvtChanUnmask
	, xcVersion
	, getXenVersion
	-- Types
	, System.Xen.CBindings.DomId(..)
	, DumpcoreCallback
	, XCEHandle
	, EventChannelPort
	) where

import System.Xen.CBindings
import Control.Monad (liftM, ap)
import Control.Monad.Writer
import Control.Monad.Error
import Control.Monad.Trans (lift)
import Data.DList hiding (unfoldr)
import Data.List (foldl', unfoldr)
import Data.Bits ((.|.), testBit, shiftR)
import Data.Word
import Foreign.C (Errno(..), getErrno, CInt)
import Foreign.Ptr
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.C.String (withCString, CString)
import Foreign.C.Types (CChar)
import Foreign.C (CInt, CUInt)
import Foreign.Storable (peek, sizeOf)
import qualified Data.ByteString as B

instance Ord Errno where
	(Errno a) `compare` (Errno b) = a `compare` b

data XenMessage = XmFunctionCall String | XmError String | XmWarn String | XmInfo String
    deriving (Eq, Ord, Show)

type XenMessages = DList XenMessage

instance Show Errno where
	showsPrec _ (Errno e) = \s -> ("Errno " ++ (show e)) ++ s


data XenError = XeErrno Errno | XeUnspec | XeString String | XeHandleTNot16Bytes
    deriving (Eq, Ord, Show)

instance Error XenError where
	noMsg = XeUnspec
	strMsg = XeString

-- |Xen is a monad transformer stack consisting of ErrorT, WritterT and IO.
newtype Xen a = X { unXen ::  ErrorT XenError (WriterT XenMessages IO) a }
	deriving (Monad, MonadIO, MonadWriter XenMessages, MonadError XenError)

-- |Given a Xen action and a default value, will run the action returning the result on success
-- or the default value on failure.
runXen :: Xen a -> a -> IO a
runXen act def = do
    res <- execXen act
    case res of
        (Left  _, _) -> return def
        (Right x, _) -> return x

-- |Executes the Xen action
runXen_ :: Xen a -> IO ()
runXen_ act = execXen act >> return ()

-- |Runs the Xen action, returning the result (or Left error) and a trace of messages.
execXen :: Xen a -> IO (Either XenError a, XenMessages)
execXen act = do
    err <- runWriterT (runErrorT $ unXen act)
    case err of
        (Right a,w) -> return (Right a,w)
	(Left e,w) -> return (Left e,w)

errnoOnNegOne :: CInt -> a -> Xen a
errnoOnNegOne (-1) _ = liftIO getErrno >>= throwError . XeErrno
errnoOnNegOne e a    = return a

-- Log Xen Function == lxf
lxf = tell . singleton . XmFunctionCall

xcInterfaceOpen :: Xen XCHandle
xcInterfaceOpen = do
	lxf "xcInterfaceOpen"
	h <- liftIO xc_interface_open
	errnoOnNegOne h (XCHdl h)

xcInterfaceClose :: XCHandle -> Xen ()
xcInterfaceClose hdl = do
	lxf "xcInterfaceClose"
	r <- liftIO $ xc_interface_close hdl
	errnoOnNegOne r ()

xcFindDeviceNumber :: String -> Xen ()
xcFindDeviceNumber str = do
	lxf "xcFindDeviceNumber"
	r <- liftIO (withCString str xc_find_device_number)
	errnoOnNegOne r ()

-- FIXME figure out these arguments
xcDomainCreate :: XCHandle -> Word32 -> XenDomainHandleT -> Word32 -> Ptr Word32 -> Xen ()
xcDomainCreate xh ssid domHdl flags ptr = do
	lxf "xcDomainCreate"
	r <- liftIO $ xc_domain_create xh ssid domHdl flags ptr
	errnoOnNegOne r ()

xcDomainDumpcore :: XCHandle -> DomId -> String -> Xen () 
xcDomainDumpcore hdl dom str = do
	lxf "xcDomainDumpcore"
	r <- liftIO (withCString str (xc_domain_dumpcore hdl dom))
	errnoOnNegOne r ()

type DumpcoreCallback = B.ByteString -> IO Int

xcDomainDumpcoreViaCallback :: XCHandle -> DomId -> DumpcoreCallback -> Xen ()
xcDomainDumpcoreViaCallback hdl dom cb = do
	lxf "xcDomainDumpCoreviaCallback"
	r <- liftIO doDump
	errnoOnNegOne r ()
  where
  cbWrapper :: Ptr Word8 -> CString -> CUInt -> IO CInt
  cbWrapper _ buf len = do
		bs <- B.packCStringLen (buf, fromIntegral len)
		r <- cb bs
		return $ fromIntegral r
  doDump = do
	c <- mkCallback cbWrapper
	r <- xc_domain_dumpcore_via_callback hdl dom nullPtr c
	return $ fromIntegral r

foreign import ccall "wrapper"
    mkCallback :: Dumpcore_rtn_t -> IO (FunPtr Dumpcore_rtn_t)

xcDomainMaxVCPUs :: XCHandle -> DomId -> Int -> Xen ()
xcDomainMaxVCPUs hdl dom nr = do
	lxf "xcDomainMaxVCPUs"
	r <- liftIO $ xc_domain_max_vcpus hdl dom (fromIntegral nr)
	errnoOnNegOne r ()

xcDomainPause :: XCHandle -> DomId -> Xen ()
xcDomainPause hdl dom = do
	lxf "xcDomainPause"
	r <- liftIO $ xc_domain_pause hdl dom
	errnoOnNegOne r ()

xcDomainUnpause :: XCHandle -> DomId -> Xen ()
xcDomainUnpause hdl dom = do
	lxf "xcDomainUnpause"
	r <- liftIO $ xc_domain_unpause hdl dom
	errnoOnNegOne r ()

xcDomainDestroy :: XCHandle -> DomId -> Xen ()
xcDomainDestroy hdl dom = do
	lxf "xcDomainDestroy"
	r <- liftIO $ xc_domain_destroy hdl dom
	errnoOnNegOne r ()

xcDomainResume :: XCHandle -> DomId -> Bool -> Xen ()
xcDomainResume hdl dom fast = do
	lxf "xcDomainResume"
	r <- liftIO $ xc_domain_resume hdl dom (fromIntegral $ fromEnum fast)
	errnoOnNegOne r ()

xcDomainShutdown :: XCHandle -> DomId -> XCShutdown -> Xen ()
xcDomainShutdown hdl dom s = do
	lxf "xcDomainShutdown"
	r <- liftIO $ xc_domain_shutdown hdl dom (fromIntegral $ fromEnum s)
	errnoOnNegOne r ()

xcVCPUSetAffinity :: XCHandle -> DomId -> Int -> [Int] -> Xen ()
xcVCPUSetAffinity hdl dom cpu mapping = do
	lxf "xcVCPUSetAffinity"
	let w = foldl' (\a b -> a .|. fromIntegral b) 0 mapping
	r <- liftIO $ xc_vcpu_setaffinity hdl dom (fromIntegral cpu) w
	errnoOnNegOne r ()

xcVCPUGetAffinity :: XCHandle -> DomId -> Int -> Xen [Int]
xcVCPUGetAffinity hdl dom cpu = do
	lxf "xcVCPUGetAffinity"
	(r,m) <- liftIO $ allocaBytes 8 $ \ptr -> do
		r <- xc_vcpu_getaffinity hdl dom (fromIntegral cpu) ptr
		w <- peek ptr
		let mapping = unfoldr bitDecomp (w,0)
		return (r,mapping)
	errnoOnNegOne r m
  where
  bitDecomp :: (Word64, Int) -> Maybe (Int, (Word64, Int))
  bitDecomp (0,_) = Nothing
  bitDecomp (w,c) = if (testBit w 0) then Just (c, (w `shiftR` 1, c + 1)) else bitDecomp (w `shiftR` 1, c + 1)

xcDomainGetInfo :: XCHandle -> DomId -> Int -> Xen XCDomInfo
xcDomainGetInfo hdl dom s = do
	lxf "xcDomainGetInfo"
	(r,i) <- liftIO $ allocaBytes (s * sizeOf (undefined :: XCDomInfo)) $ \ptr -> do
		r <- xc_domain_getinfo hdl dom (fromIntegral s) ptr
		i <- peek ptr
		return (r,i)
	errnoOnNegOne r i

-- FIXME how is this different than xcDomainGetInfo?  Am I using it right?
xcDomainGetInfoList :: XCHandle -> DomId -> Int -> Xen XCDomInfo
xcDomainGetInfoList hdl dom s = do
	lxf "xcDomainGetInfoList" 
	(r,i) <- liftIO $ allocaBytes (s * sizeOf (undefined :: XCDomInfo)) $ \ptr -> do
		r <- xc_domain_getinfo hdl dom (fromIntegral s) ptr
		i <- peek ptr
		return (r,i)
	errnoOnNegOne r i

-- according to libxc, xc_domain_hvm_getcontext returns the context size when given a null ptr
xcDomainHVMGetContext :: XCHandle -> DomId -> Xen B.ByteString
xcDomainHVMGetContext hdl dom = do
	lxf "xcDomainHVMGetContext"
	r <- liftIO $ xc_domain_hvm_getcontext hdl dom nullPtr 0
	errnoOnNegOne r ()
	(r',bs) <- liftIO $ allocaBytes (fromIntegral r) $ \ptr -> do
		res <- xc_domain_hvm_getcontext hdl dom ptr (fromIntegral r)
		bs <- B.packCStringLen (castPtr ptr, fromIntegral r)
		return (res, bs)
	errnoOnNegOne r' bs

xcDomainHVMSetContext :: XCHandle -> DomId -> B.ByteString -> Xen ()
xcDomainHVMSetContext hdl dom ctx = do
	lxf "xcDomainHVMSetContext"
	r <- liftIO $ B.useAsCStringLen ctx $ \(ptr,len) ->
		xc_domain_hvm_setcontext hdl dom (castPtr ptr) (fromIntegral len)
	errnoOnNegOne r ()

xcVCPUGetInfo :: XCHandle -> DomId -> Int -> Xen VCPUInfo
xcVCPUGetInfo hdl dom cpu = do
	lxf "xcVCPUGetInfo"
	(r,i) <- liftIO $ allocaBytes (sizeOf (undefined :: VCPUInfo)) $ \ptr -> do
		r <- xc_vcpu_getinfo hdl dom (fromIntegral cpu) ptr
		i <- peek ptr
		return (r,i)
	errnoOnNegOne r i

xcDomainSetCPUWeight :: XCHandle -> DomId -> Float -> Xen ()
xcDomainSetCPUWeight hdl dom w = do
	lxf "xcDomainSetCPUWeight"
	r <- liftIO $ xc_domain_setcpuweight hdl dom (realToFrac w)
	errnoOnNegOne r ()

xcDomainGetCPUUsage :: XCHandle -> DomId -> Int -> Xen Integer
xcDomainGetCPUUsage hdl dom cpu = do
	lxf "xcDomainGetCPUUsage"
	r <- liftIO $ xc_domain_get_cpu_usage hdl dom (fromIntegral cpu)
	errnoOnNegOne (fromIntegral r) (fromIntegral r)

xcDomainSetHandle :: XCHandle -> DomId -> B.ByteString -> Xen ()
xcDomainSetHandle hdl dom h = do
	lxf "xcDomainSetHandle"
	if B.length h /= 16
		then throwError XeHandleTNot16Bytes
		else do r <- liftIO $ B.useAsCString h $ \ptr -> xc_domain_sethandle hdl dom (castPtr ptr)
			errnoOnNegOne r ()


xcSedfDomainSet :: XCHandle -> DomId -> 
			Word64 ->	-- Period
			Word64 ->	-- Slice
			Word64 ->	-- Latency
			Word16 ->	-- Extra time
			Word16 ->	-- Weight
			Xen ()
xcSedfDomainSet hdl dom per slice latency et weight = do
	lxf "xcSedfDomainSet"
	r <- liftIO $ xc_sedf_domain_set hdl dom per slice latency et weight
	errnoOnNegOne r ()

xcSedfDomainGet :: XCHandle -> DomId -> Xen (Word64,Word64,Word64,Word16,Word16)
xcSedfDomainGet hdl dom = do
	lxf "xcSedfDomainGet"
	(r,p,s,l,e,w) <- liftIO $ do
		let w64 = sizeOf (undefined :: Word64)
		    w16 = sizeOf (undefined :: Word16)
		allocaBytes w64 $ \period -> allocaBytes w64 $ \slice -> allocaBytes w64 $ \latency -> do
		allocaBytes w16 $ \extraTime -> allocaBytes w16 $ \weight -> do
		r <- xc_sedf_domain_get hdl dom period slice latency extraTime weight
		p <- peek period
		s <- peek slice
		l <- peek latency
		e <- peek extraTime
		w <- peek weight
		return (r,p,s,l,e,w)
	errnoOnNegOne r (p,s,l,e,w)

xcDomainSendTrigger :: XCHandle -> DomId -> Int -> Int -> Xen ()
xcDomainSendTrigger hdl dom triggerType vcpu = do
	lxf "xcDomainSendTrigger"
	r <- liftIO $ xc_domain_send_trigger hdl dom (fromIntegral triggerType) (fromIntegral vcpu)
	errnoOnNegOne r ()

xcEvtChanAllocUnbound :: XCHandle -> DomId -> DomId -> Xen XCEHandle
xcEvtChanAllocUnbound hdl domA domB = do
	lxf "xcEvtChanAllocUnbound"
	r <- liftIO $ xc_evtchn_alloc_unbound hdl domA domB
	errnoOnNegOne r (XCEHandle r)

xcEvtChanReset :: XCHandle -> DomId -> Xen ()
xcEvtChanReset hdl dom = do
	lxf "xcEvtChanReset"
	r <- liftIO $ xc_evtchn_reset hdl dom
	errnoOnNegOne r ()

xcEvtChanOpen :: Xen XCEHandle
xcEvtChanOpen = do
	lxf "xcEvtChanOpen"
	r <- liftIO xc_evtchn_open
	errnoOnNegOne r (XCEHandle r)

xcEvtChanClose :: XCEHandle -> Xen ()
xcEvtChanClose hdl = do
	lxf "xcEvtChanClose"
	r <- liftIO $ xc_evtchn_close hdl
	errnoOnNegOne r ()

xcEvtChanNotify :: XCEHandle -> EventChannelPort -> Xen ()
xcEvtChanNotify hdl port = do
	lxf "xcEvChanNotify"
	r <- liftIO $ xc_evtchn_notify hdl port
	errnoOnNegOne r ()

xcEvtChanBindUnboundPort :: XCEHandle -> DomId -> Xen EventChannelPort
xcEvtChanBindUnboundPort hdl dom = do
	lxf "xcEvtChanBindUnboundPort"
	r <- liftIO $ xc_evtchn_bind_unbound_port hdl dom
	errnoOnNegOne r (ECPort $ fromIntegral r)

xcEvtChanBindInterdomain :: XCEHandle -> DomId -> EventChannelPort -> Xen EventChannelPort
xcEvtChanBindInterdomain hdl dom port = do
	lxf "xcEvtChanBindInterdomain"
	r <- liftIO $ xc_evtchn_bind_interdomain hdl dom port
	errnoOnNegOne r (ECPort $ fromIntegral r)

xcEvtChanBindVIRQ :: XCEHandle -> Int -> Xen EventChannelPort
xcEvtChanBindVIRQ hdl virq = do
	lxf "xcEvtChanBindVIRQ"
	r <- liftIO $ xc_evtchn_bind_virq hdl (fromIntegral virq)
	errnoOnNegOne r (ECPort $ fromIntegral r)

xcEvtChanUnbind :: XCEHandle -> EventChannelPort -> Xen ()
xcEvtChanUnbind hdl port = do
	lxf "xcEvtChanUnbind"
	r <- liftIO $ xc_evtchn_unbind hdl port
	errnoOnNegOne r ()

xcEvtChanPending :: XCEHandle -> Xen EventChannelPort
xcEvtChanPending hdl = do
	lxf "xcEvtChanPending"
	r <- liftIO $ xc_evtchn_pending hdl
	errnoOnNegOne r (ECPort $ fromIntegral r)

xcEvtChanUnmask :: XCEHandle -> EventChannelPort -> Xen ()
xcEvtChanUnmask hdl port = do
	lxf "xcEvtChanUnmask"
	r <- liftIO $ xc_evtchn_unmask hdl port
	errnoOnNegOne r ()

xcVersion :: XCHandle -> XenVersion -> Xen String
xcVersion hdl ver = do
	lxf "xcVersion"
	r <- liftIO $ xc_version hdl ver nullPtr
	errnoOnNegOne r "Error"
	return (show r)

getXenVersion :: Xen String
getXenVersion = do
	h <- xcInterfaceOpen
	r <- liftIO $ xc_version h xENVER_version nullPtr
	xcInterfaceClose h
	return (show r)