#line 246 "src/wire.anansi"

#line 30 "src/introduction.anansi"
-- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

#line 247 "src/wire.anansi"

#line 52 "src/introduction.anansi"
{-# LANGUAGE OverloadedStrings #-}

#line 248 "src/wire.anansi"
{-# LANGUAGE TypeFamilies #-}
module DBus.Wire.Unmarshal where

#line 56 "src/introduction.anansi"
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL

#line 251 "src/wire.anansi"

#line 262 "src/wire.anansi"
import Control.Monad (liftM)
import qualified DBus.Util.MonadError as E
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL

#line 364 "src/wire.anansi"
import qualified Data.Binary.Get as G

#line 519 "src/wire.anansi"
import qualified Data.Binary.IEEE754 as IEEE

#line 616 "src/wire.anansi"
import DBus.Wire.Unicode (maybeDecodeUtf8)

#line 834 "src/wire.anansi"
import qualified DBus.Message.Internal as M

#line 840 "src/wire.anansi"
import Data.Bits ((.&.))
import qualified Data.Set as Set

#line 987 "src/wire.anansi"
import qualified DBus.Constants as C

#line 252 "src/wire.anansi"
import Control.Monad (when, unless)
import Data.Maybe (fromJust, listToMaybe, fromMaybe)
import Data.Word (Word8, Word32, Word64)
import Data.Int (Int16, Int32, Int64)

import DBus.Wire.Internal
import qualified DBus.Types.Internal as T

#line 272 "src/wire.anansi"
data UnmarshalState = UnmarshalState BL.ByteString {-# UNPACK #-} !Word64

data UnmarshalR a = UnmarshalRL UnmarshalError | UnmarshalRR a {-# UNPACK #-} !UnmarshalState

newtype Unmarshal a = Unmarshal { unUnmarshal :: Endianness -> UnmarshalState -> UnmarshalR a }

instance Monad Unmarshal where
	{-# INLINE return #-}
	return a = Unmarshal $ \_ s -> UnmarshalRR a s
	
	{-# INLINE (>>=) #-}
	m >>= k = Unmarshal $ \e s -> case unUnmarshal m e s of
		UnmarshalRL err -> UnmarshalRL err
		UnmarshalRR a s' -> unUnmarshal (k a) e s'
	
	{-# INLINE (>>) #-}
	m >> k = Unmarshal $ \e s -> case unUnmarshal m e s of
		UnmarshalRL err -> UnmarshalRL err
		UnmarshalRR _ s' -> unUnmarshal k e s'

throwError :: UnmarshalError -> Unmarshal a
throwError err = Unmarshal $ \_ _ -> UnmarshalRL err

{-# INLINE getState #-}
getState :: Unmarshal UnmarshalState
getState = Unmarshal $ \_ s -> UnmarshalRR s s

{-# INLINE putState #-}
putState :: UnmarshalState -> Unmarshal ()
putState s = Unmarshal $ \_ _ -> UnmarshalRR () s

#line 305 "src/wire.anansi"
runUnmarshal :: Unmarshal a -> Endianness -> BL.ByteString -> Either UnmarshalError a
runUnmarshal m e bytes = case unUnmarshal m e (UnmarshalState bytes 0) of
	UnmarshalRL err -> Left err
	UnmarshalRR a _ -> Right a

#line 312 "src/wire.anansi"
unmarshal :: T.Signature -> Unmarshal [T.Variant]
unmarshal = mapM unmarshalType . T.signatureTypes

unmarshalType :: T.Type -> Unmarshal T.Variant

#line 493 "src/wire.anansi"
unmarshalType T.DBusByte = liftM (T.toVariant . BL.head) $ consume 1
unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le
unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le
unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le

unmarshalType T.DBusInt16  = do
	x <- unmarshalGet 2 G.getWord16be G.getWord16le
	return . T.toVariant $ (fromIntegral x :: Int16)

unmarshalType T.DBusInt32  = do
	x <- unmarshalGet 4 G.getWord32be G.getWord32le
	return . T.toVariant $ (fromIntegral x :: Int32)

unmarshalType T.DBusInt64  = do
	x <- unmarshalGet 8 G.getWord64be G.getWord64le
	return . T.toVariant $ (fromIntegral x :: Int64)

#line 539 "src/wire.anansi"
unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le

#line 556 "src/wire.anansi"
unmarshalType T.DBusBoolean = unmarshalWord32 >>=
	fromMaybeU' "boolean" (\x -> case x of
		0 -> Just False
		1 -> Just True
		_ -> Nothing)

#line 639 "src/wire.anansi"
unmarshalType T.DBusString = liftM T.toVariant unmarshalText

unmarshalType T.DBusObjectPath = unmarshalText >>=
	fromMaybeU' "object path" T.mkObjectPath

#line 679 "src/wire.anansi"
unmarshalType T.DBusSignature = liftM T.toVariant unmarshalSignature

#line 695 "src/wire.anansi"
unmarshalType (T.DBusArray t) = T.toVariant `liftM` unmarshalArray t

#line 777 "src/wire.anansi"
unmarshalType (T.DBusDictionary kt vt) = do
	let pairType = T.DBusStructure [kt, vt]
	array <- unmarshalArray pairType
	fromMaybeU' "dictionary" T.arrayToDictionary array

#line 796 "src/wire.anansi"
unmarshalType (T.DBusStructure ts) = do
	skipPadding 8
	liftM (T.toVariant . T.Structure) $ mapM unmarshalType ts

#line 818 "src/wire.anansi"
unmarshalType T.DBusVariant = do
	let getType sig = case T.signatureTypes sig of
		[t] -> Just t
		_   -> Nothing
	
	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature
	T.toVariant `liftM` unmarshalType t

#line 322 "src/wire.anansi"
{-# INLINE consume #-}
consume :: Word64 -> Unmarshal BL.ByteString
consume count = Unmarshal $ \_ (UnmarshalState bytes offset) -> let
	count' = fromIntegral count
	(x, bytes') = BL.splitAt count' bytes
	in if BL.length x == count'
		then UnmarshalRR x (UnmarshalState bytes' (offset + count))
		else UnmarshalRL $ UnexpectedEOF offset

#line 333 "src/wire.anansi"
skipPadding :: Word8 -> Unmarshal ()
skipPadding count = do
	(UnmarshalState _ offset) <- getState
	bytes <- consume $ padding offset count
	unless (BL.all (== 0) bytes) $
		throwError $ InvalidPadding offset

#line 342 "src/wire.anansi"
skipTerminator :: Unmarshal ()
skipTerminator = do
	(UnmarshalState _ offset) <- getState
	bytes <- consume 1
	unless (BL.all (== 0) bytes) $
		throwError $ MissingTerminator offset

#line 351 "src/wire.anansi"
fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU label f x = case f x of
	Just x' -> return x'
	Nothing -> throwError . Invalid label . TL.pack . show $ x

fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a
           -> Unmarshal T.Variant
fromMaybeU' label f x = do
	x' <- fromMaybeU label f x
	return $ T.toVariant x'

#line 368 "src/wire.anansi"
unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a
unmarshalGet count be le = do
	skipPadding count
	bs <- consume . fromIntegral $ count
	
	Unmarshal $ \e s -> let
		get = case e of
			BigEndian -> be
			LittleEndian -> le
		in UnmarshalRR (G.runGet get bs) s

unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a
              -> Unmarshal T.Variant
unmarshalGet' count be le = T.toVariant `liftM` unmarshalGet count be le

#line 385 "src/wire.anansi"
untilM :: Monad m => m Bool -> m a -> m [a]
untilM test comp = do
	done <- test
	if done
		then return []
		else do
			x <- comp
			xs <- untilM test comp
			return $ x:xs

#line 412 "src/wire.anansi"
data UnmarshalError
	= UnsupportedProtocolVersion Word8
	| UnexpectedEOF Word64
	| Invalid Text Text
	| MissingHeaderField Text
	| InvalidHeaderField Text T.Variant
	| InvalidPadding Word64
	| MissingTerminator Word64
	| ArraySizeMismatch
	deriving (Eq)

instance Show UnmarshalError where
	show (UnsupportedProtocolVersion x) = concat
		["Unsupported protocol version: ", show x]
	show (UnexpectedEOF pos) = concat
		["Unexpected EOF at position ", show pos]
	show (Invalid label x) = TL.unpack $ TL.concat
		["Invalid ", label, ": ", x]
	show (MissingHeaderField x) = concat
		["Required field " , show x , " is missing."]
	show (InvalidHeaderField x got) = concat
		[ "Invalid header field ", show x, ": ", show got]
	show (InvalidPadding pos) = concat
		["Invalid padding at position ", show pos]
	show (MissingTerminator pos) = concat
		["Missing NUL terminator at position ", show pos]
	show ArraySizeMismatch = "Array size mismatch"

#line 478 "src/wire.anansi"
unmarshalWord32 :: Unmarshal Word32
unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le

#line 620 "src/wire.anansi"
unmarshalText :: Unmarshal Text
unmarshalText = do
	byteCount <- unmarshalWord32
	bytes <- consume . fromIntegral $ byteCount
	skipTerminator
	fromMaybeU "text" maybeDecodeUtf8 bytes

#line 661 "src/wire.anansi"
unmarshalSignature :: Unmarshal T.Signature
unmarshalSignature = do
	byteCount <- BL.head `liftM` consume 1
	lazy <- consume $ fromIntegral byteCount
	skipTerminator
	let bytes = B.concat $ BL.toChunks lazy
	fromMaybeU "signature" T.mkBytesSignature bytes

#line 744 "src/wire.anansi"
unmarshalArray :: T.Type -> Unmarshal T.Array
unmarshalArray T.DBusByte = do
	byteCount <- unmarshalWord32
	T.arrayFromBytes `liftM` consume (fromIntegral byteCount)

#line 751 "src/wire.anansi"
unmarshalArray itemType = do
	let getOffset = do
		(UnmarshalState _ o) <- getState
		return o
	byteCount <- unmarshalWord32
	skipPadding (alignment itemType)
	start <- getOffset
	let end = start + fromIntegral byteCount
	vs <- untilM (liftM (>= end) getOffset) (unmarshalType itemType)
	end' <- getOffset
	when (end' > end) $
		throwError ArraySizeMismatch
	fromMaybeU "array" (T.arrayFromItems itemType) vs

#line 857 "src/wire.anansi"
decodeFlags :: Word8 -> Set.Set M.Flag
decodeFlags word = Set.fromList flags where
	flagSet = [ (0x1, M.NoReplyExpected)
	          , (0x2, M.NoAutoStart)
	          ]
	flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]

#line 886 "src/wire.anansi"
decodeField :: T.Structure
            -> E.ErrorM UnmarshalError [M.HeaderField]
decodeField struct = case unpackField struct of
	(1, x) -> decodeField' x M.Path "path"
	(2, x) -> decodeField' x M.Interface "interface"
	(3, x) -> decodeField' x M.Member "member"
	(4, x) -> decodeField' x M.ErrorName "error name"
	(5, x) -> decodeField' x M.ReplySerial "reply serial"
	(6, x) -> decodeField' x M.Destination "destination"
	(7, x) -> decodeField' x M.Sender "sender"
	(8, x) -> decodeField' x M.Signature "signature"
	_      -> return []

decodeField' :: T.Variable a => T.Variant -> (a -> b) -> Text
             -> E.ErrorM UnmarshalError [b]
decodeField' x f label = case T.fromVariant x of
	Just x' -> return [f x']
	Nothing -> E.throwErrorM $ InvalidHeaderField label x

#line 907 "src/wire.anansi"
unpackField :: T.Structure -> (Word8, T.Variant)
unpackField struct = (c', v') where
	T.Structure [c, v] = struct
	c' = fromJust . T.fromVariant $ c
	v' = fromJust . T.fromVariant $ v

#line 995 "src/wire.anansi"

#line 169 "src/api-docs.anansi"
-- | Read bytes from a monad until a complete message has been received.

#line 996 "src/wire.anansi"
unmarshalMessage :: Monad m => (Word32 -> m BL.ByteString)
                 -> m (Either UnmarshalError M.ReceivedMessage)
unmarshalMessage getBytes' = E.runErrorT $ do
	let getBytes = E.ErrorT . liftM Right . getBytes'
	

#line 1011 "src/wire.anansi"
	let fixedSig = "yyyyuuu"
	fixedBytes <- getBytes 16

#line 1020 "src/wire.anansi"
	let messageVersion = BL.index fixedBytes 3
	when (messageVersion /= C.protocolVersion) $
		E.throwErrorT $ UnsupportedProtocolVersion messageVersion

#line 1028 "src/wire.anansi"
	let eByte = BL.index fixedBytes 0
	endianness <- case decodeEndianness eByte of
		Just x' -> return x'
		Nothing -> E.throwErrorT . Invalid "endianness" . TL.pack . show $ eByte

#line 1038 "src/wire.anansi"
	let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of
		Right x' -> return x'
		Left  e  -> E.throwErrorT e
	fixed <- unmarshal' fixedSig fixedBytes
	let typeCode = fromJust . T.fromVariant $ fixed !! 1
	let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2
	let bodyLength = fromJust . T.fromVariant $ fixed !! 4
	let serial = fromJust . T.fromVariant $ fixed !! 5

#line 1053 "src/wire.anansi"
	let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6

#line 1002 "src/wire.anansi"

#line 1060 "src/wire.anansi"
	let headerSig  = "yyyyuua(yv)"
	fieldBytes <- getBytes fieldByteCount
	let headerBytes = BL.append fixedBytes fieldBytes
	header <- unmarshal' headerSig headerBytes

#line 1069 "src/wire.anansi"
	let fieldArray = fromJust . T.fromVariant $ header !! 6
	let fieldStructures = fromJust . T.fromArray $ fieldArray
	fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldStructures of
		Left err -> E.throwErrorT err
		Right x -> return x

#line 1003 "src/wire.anansi"

#line 1080 "src/wire.anansi"
	let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8
	getBytes . fromIntegral $ bodyPadding

#line 1091 "src/wire.anansi"
	let bodySig = findBodySignature fields

#line 1097 "src/wire.anansi"
	bodyBytes <- getBytes bodyLength
	body <- unmarshal' bodySig bodyBytes

#line 1004 "src/wire.anansi"

#line 1105 "src/wire.anansi"
	y <- case E.runErrorM $ buildReceivedMessage typeCode fields of
		Right x -> return x
		Left err -> E.throwErrorT $ MissingHeaderField err
	return $ y serial flags body

#line 1085 "src/wire.anansi"
findBodySignature :: [M.HeaderField] -> T.Signature
findBodySignature fields = fromMaybe "" signature where
	signature = listToMaybe [x | M.Signature x <- fields]

#line 1114 "src/wire.anansi"
buildReceivedMessage :: Word8 -> [M.HeaderField] -> E.ErrorM Text
                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]
                         -> M.ReceivedMessage)

#line 1122 "src/wire.anansi"
buildReceivedMessage 1 fields = do
	path <- require "path" [x | M.Path x <- fields]
	member <- require "member name" [x | M.Member x <- fields]
	return $ \serial flags body -> let
		iface = listToMaybe [x | M.Interface x <- fields]
		dest = listToMaybe [x | M.Destination x <- fields]
		sender = listToMaybe [x | M.Sender x <- fields]
		msg = M.MethodCall path member iface dest flags body
		in M.ReceivedMethodCall serial sender msg

#line 1136 "src/wire.anansi"
buildReceivedMessage 2 fields = do
	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]
	return $ \serial _ body -> let
		dest = listToMaybe [x | M.Destination x <- fields]
		sender = listToMaybe [x | M.Sender x <- fields]
		msg = M.MethodReturn replySerial dest body
		in M.ReceivedMethodReturn serial sender msg

#line 1148 "src/wire.anansi"
buildReceivedMessage 3 fields = do
	name <- require "error name" [x | M.ErrorName x <- fields]
	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]
	return $ \serial _ body -> let
		dest = listToMaybe [x | M.Destination x <- fields]
		sender = listToMaybe [x | M.Sender x <- fields]
		msg = M.Error name replySerial dest body
		in M.ReceivedError serial sender msg

#line 1161 "src/wire.anansi"
buildReceivedMessage 4 fields = do
	path <- require "path" [x | M.Path x <- fields]
	member <- require "member name" [x | M.Member x <- fields]
	iface <- require "interface" [x | M.Interface x <- fields]
	return $ \serial _ body -> let
		dest = listToMaybe [x | M.Destination x <- fields]
		sender = listToMaybe [x | M.Sender x <- fields]
		msg = M.Signal path member iface dest body
		in M.ReceivedSignal serial sender msg

#line 1175 "src/wire.anansi"
buildReceivedMessage typeCode fields = return $ \serial flags body -> let
	sender = listToMaybe [x | M.Sender x <- fields]
	msg = M.Unknown typeCode flags body
	in M.ReceivedUnknown serial sender msg

#line 1182 "src/wire.anansi"
require :: Text -> [a] -> E.ErrorM Text a
require _     (x:_) = return x
require label _     = E.throwErrorM label