{-# LANGUAGE ForeignFunctionInterface #-}

module EIBd.Client (
	-- * Connection
	Connection,
	connectRemote,
	connectLocal,
	defaultPort,

	-- * Individual Address
	IndividualAddress (..),
	fromIndividualAddress,

	-- * Group Address
	GroupAddress (..),
	fromGroupAddress,
	toGroupAddress,

	-- * Messaging
	Message (..),
	recvMessage,
	sendMessage,

	-- * Group Messaging
	GroupMessage,
	recvGroupMessage,
	sendGroupMessage,

	-- * GroupM Monad
	GroupM,
	execGroupM,
	tryGroupM,
	tryGroupM_,
	putGroup,
	getGroup,
	clearGroups,
	uncacheGroup,

	-- * External Modules
	module EIBd.Client.Types
) where

import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import Control.Applicative
import Control.Exception

import Data.Bits
import Data.List
import Data.String
import Data.Char

import qualified Data.ByteString as B
import qualified Data.Map.Strict as M

import Foreign hiding (void)
import Foreign.C

import EIBd.Client.Types

-- | Connect to a remote socket using a host name and port number.
foreign import ccall "EIBSocketRemote"
	socketRemote :: CString -> CInt -> IO (Ptr ConnStruct)

-- | Connect to a local unix socket.
foreign import ccall "EIBSocketLocal"
	socketLocal :: CString -> IO (Ptr ConnStruct)

-- | Function pointer to the 'EIBClose_sync' procedure
foreign import ccall "&EIBClose_sync"
	closeSync :: FunPtr (Ptr ConnStruct -> IO ())

-- | Open a GroupSocket connection.
foreign import ccall "EIBOpen_GroupSocket"
	openGroupSocket :: Ptr ConnStruct -> CInt -> IO CInt

-- | Get an APDU from the bus.
foreign import ccall "EIBGetGroup_Src"
	recvGroup :: Ptr ConnStruct -> CInt -> Ptr Word8 -> Ptr Word16 -> Ptr Word16 -> IO CInt

-- | Send an APDU to the bus.
foreign import ccall "EIBSendGroup"
	sendGroup :: Ptr ConnStruct -> CUShort -> CInt -> Ptr CChar -> IO CInt

-- | Opaque Connect Structure
data ConnStruct

-- | EIBd Server Connection
newtype Connection
	= Connection { connHandle :: ForeignPtr ConnStruct }
	deriving Show

-- | Interact with the low-level structure.
withHandle :: Connection -> (Ptr ConnStruct -> IO a) -> IO a
withHandle = withForeignPtr . connHandle

-- | Connect to an EIBd server via a TCP Socket.
connectRemote :: B.ByteString -> Word16 -> IO Connection
connectRemote host' port' = B.useAsCString host' $ \host -> do
	cs <- socketRemote host (fromIntegral port')
	when (cs == nullPtr) (fail "Failed to connect")
	openGroupSocket cs 0
	fmap Connection (newForeignPtr closeSync cs)

-- | Connect to an EIBd server via a Unix Socket.
connectLocal :: B.ByteString -> IO Connection
connectLocal path' = B.useAsCString path' $ \path -> do
	cs <- socketLocal path
	when (cs == nullPtr) (fail "Failed to connect")
	openGroupSocket cs 0
	fmap Connection (newForeignPtr closeSync cs)

-- | EIBd Default Port
defaultPort :: Word16
defaultPort = 6720

-- | Group numbers
groupNumbers :: String -> [String]
groupNumbers = groupBy (\a b -> (isDigit a && isDigit b) || not (isDigit a || isDigit b))

-- | Individual Address
newtype IndividualAddress = IndividualAddress Word16
	deriving (Eq, Ord)

-- | Disect individual address
fromIndividualAddress :: IndividualAddress -> (Word8, Word8, Word8)
fromIndividualAddress (IndividualAddress n) =
	(fromIntegral (shift n (-12)),
	 fromIntegral (shift n (-8) .&. 15),
	 fromIntegral (n .&. 255))

-- | Create individual address
toIndividualAddress :: Word8 -> Word8 -> Word8 -> IndividualAddress
toIndividualAddress a b c = IndividualAddress (shift (fromIntegral a .&. 15) 12
                                          .|. shift (fromIntegral b .&. 15) 8
                                          .|. fromIntegral c)

-- | Instance for the OverloadedStrings extension
instance IsString IndividualAddress where
	fromString str =
		case groupNumbers str of
			[a, ".", b, ".", c] -> toIndividualAddress (read a) (read b) (read c)
			_ -> error "Ill formated individual address"

instance Show IndividualAddress where
	show i = show a ++ "." ++ show b ++ "." ++ show c where
		(a, b, c) = fromIndividualAddress i

-- | Group Address
newtype GroupAddress = GroupAddress Word16
	deriving (Eq, Ord)

-- | Disect group address
fromGroupAddress :: GroupAddress -> (Word8, Word8, Word8)
fromGroupAddress (GroupAddress n) =
	(fromIntegral (shift n (-11)),
	 fromIntegral (shift n (-8) .&. 7),
	 fromIntegral (n .&. 255))

-- | Create group address
toGroupAddress :: Word8 -> Word8 -> Word8 -> GroupAddress
toGroupAddress a b c = GroupAddress (shift (fromIntegral a .&. 15) 11
                                     .|. shift (fromIntegral b .&. 7) 8
                                     .|. fromIntegral c)

-- | Instance for the OverloadedStrings extension
instance IsString GroupAddress where
	fromString str =
		case groupNumbers str of
			[a, "/", b, "/", c] -> toGroupAddress (read a) (read b) (read c)
			_ -> error "Ill formated group address"

instance Show GroupAddress where
	show g = show a ++ "/" ++ show b ++ "/" ++ show c where
		(a, b, c) = fromGroupAddress g

-- | APCI
data APCI
	= GroupAddrRead
	| GroupAddrResponse
	| GroupAddrWrite
	| IndividualWrite
	| IndividualRequest
	| IndividualResponse
	| AdcRead
	| AdcResponse
	| MemoryRead
	| MemoryResponse
	| MemoryWrite
	| UserMessage
	| MaskVersionRead
	| MaskVersionResponse
	| Restart
	| Escape
	deriving (Show, Eq, Ord)

-- | Message
data Message = Message { messageSource      :: IndividualAddress
                       , messageDestination :: GroupAddress
                       , messageTPCI        :: Word8
                       , messageAPCI        :: APCI
                       , messagePayload     :: B.ByteString }
	deriving (Show, Eq)

-- | Word8 to APCI.
toAPCI :: Word8 -> APCI
toAPCI 0 = GroupAddrRead
toAPCI 1 = GroupAddrResponse
toAPCI 2 = GroupAddrWrite
toAPCI 3 = IndividualWrite
toAPCI 4 = IndividualRequest
toAPCI 5 = IndividualResponse
toAPCI 6 = AdcRead
toAPCI 7 = AdcResponse
toAPCI 8 = MemoryRead
toAPCI 9 = MemoryResponse
toAPCI 10 = MemoryWrite
toAPCI 11 = UserMessage
toAPCI 12 = MaskVersionRead
toAPCI 13 = MaskVersionResponse
toAPCI 14 = Restart
toAPCI 15 = Escape
toAPCI _ = undefined

-- | APCI to Word8.
fromAPCI :: APCI -> Word8
fromAPCI GroupAddrRead = 0
fromAPCI GroupAddrResponse = 1
fromAPCI GroupAddrWrite = 2
fromAPCI IndividualWrite = 3
fromAPCI IndividualRequest = 4
fromAPCI IndividualResponse = 5
fromAPCI AdcRead = 6
fromAPCI AdcResponse = 7
fromAPCI MemoryRead = 8
fromAPCI MemoryResponse = 9
fromAPCI MemoryWrite = 10
fromAPCI UserMessage = 11
fromAPCI MaskVersionRead = 12
fromAPCI MaskVersionResponse = 13
fromAPCI Restart = 14
fromAPCI Escape = 15

-- | Read a message.
recvMessage :: Connection -> IO Message
recvMessage conn = withHandle conn $ \ptr ->
	bracket allocStuff freeStuff $ \(buf, srcPtr, dstPtr) -> do
		len <- recvGroup ptr 32 buf srcPtr dstPtr

		-- Exit on failure
		when (len < 2) (fail "Failed to read group message")

		-- Fetch contents and make sure they are evaluated
		arr <- evaluate =<< peekArray (fromIntegral len) buf
		src <- evaluate =<< peek srcPtr
		dst <- evaluate =<< peek dstPtr

		-- Disect data
		let t : a : xs = arr
		let tpci = shift t (-2)
		let payload = B.pack (a .&. 63 : xs)
		let apci = toAPCI ((shift t 2 .&. 12) .|. (shift a (-6) .&. 3))

		-- Pack structure
		return (Message (IndividualAddress src)
		                (GroupAddress dst)
		                tpci
		                apci
		                payload)
	where
		-- Allocate buffer, source and destination address
		allocStuff = (,,) <$> mallocArray 32
		                  <*> malloc
		                  <*> malloc

		-- Free the previously allocated memory
		freeStuff (buf, srcPtr, dstPtr) = do
			free buf
			free srcPtr
			free dstPtr

-- | Send a message.
sendMessage :: Connection -> GroupAddress -> Word8 -> APCI -> B.ByteString -> IO Bool
sendMessage conn (GroupAddress dst) tpci apci' payload = fmap (>= 0) . withHandle conn $ \ptr ->
	B.useAsCStringLen apdu $ \(buf, len) ->
		sendGroup ptr (CUShort dst) (fromIntegral len) buf
	where
		apci = fromAPCI apci'
		octet0 = shift tpci 2 .|. (shift apci (-2) .&. 3)
		octet1Mask = shift (apci .&. 3) 6
		apdu = case B.unpack payload of
			[]     -> B.pack [octet0, octet1Mask]
			x : xs -> B.pack (octet0 : (octet1Mask .|. x) : xs)

-- | Group Message
data GroupMessage
	= GroupRead
	| GroupResponse B.ByteString
	| GroupWrite    B.ByteString
	deriving (Show, Eq)

-- | Receive a group message.
recvGroupMessage :: Connection -> IO (IndividualAddress, GroupAddress, GroupMessage)
recvGroupMessage conn = do
	Message src dst _ cmd payload <- recvMessage conn
	case cmd of
		GroupAddrRead     -> return (src, dst, GroupRead)
		GroupAddrResponse -> return (src, dst, GroupResponse payload)
		GroupAddrWrite    -> return (src, dst, GroupWrite payload)
		_                 -> recvGroupMessage conn

-- | Send a group message.
sendGroupMessage :: Connection -> GroupAddress -> GroupMessage -> IO Bool
sendGroupMessage conn dst GroupRead =
	sendMessage conn dst 0 GroupAddrRead B.empty
sendGroupMessage conn dst (GroupResponse payload) =
	sendMessage conn dst 0 GroupAddrResponse payload
sendGroupMessage conn dst (GroupWrite payload) =
	sendMessage conn dst 0 GroupAddrWrite payload

-- | Group Cache
type GroupCache = M.Map GroupAddress B.ByteString

-- | Handle cached group values
type GroupM = MaybeT (StateT GroupCache IO)

-- | Execute a GroupM action. Changes to group values will be send to
--   EIBd after the GroupM action has run.
execGroupM :: GroupM a -> Connection -> GroupCache -> IO GroupCache
execGroupM handler conn cache = do
	-- Generate the new group cache map
	newCache <- execStateT (runMaybeT handler) cache

	-- Commit changed groups
	M.foldlWithKey' updateGroup (return ()) (toBeUpdated newCache)

	return newCache

	where
		-- Figure out which groups have been updated
		toBeUpdated newCache = M.differenceWith (const . Just) newCache cache

		-- Used to generate an IO action which commits
		-- all changed groups to EIBd
		updateGroup prev dst val = do
			sendMessage conn dst 0 GroupAddrWrite val
			prev

-- | Try to execute a GroupM action. If it fails return the given alternative value.
tryGroupM :: a -> GroupM a -> GroupM a
tryGroupM a ch = ch <|> return a

-- | Similar to "tryGroupM" but without an alternative return value.
tryGroupM_ :: GroupM a -> GroupM ()
tryGroupM_ = tryGroupM () . void

-- | Update a group value. The new value will ne commited to the cache
--   immediately but not to the bus. See "execGroupM" for more.
putGroup :: DatapointType a => GroupAddress -> a -> GroupM ()
putGroup dst val = lift (modify (M.insert dst (fromDPT val)))

-- | Fetch a group value.
--   If a group value is not cached yet, this function will fail silently and
--   stop further instructions. Even in a case of failure, previous changes to
--   group values will be commited to EIBd.
getGroup :: DatapointType a => GroupAddress -> GroupM a
getGroup adr = MaybeT (gets (\m -> M.lookup adr m >>= toDPT))

-- | Clear the entire cache.
clearGroups :: GroupM ()
clearGroups = lift (put M.empty)

-- | Remove one group from the cache.
uncacheGroup :: GroupAddress -> GroupM ()
uncacheGroup = lift . modify . M.delete