{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE ConstraintKinds  #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE GADTs  #-}
module Control.Distributed.Process.Serializable
  ( Serializable
  , encodeFingerprint
  , decodeFingerprint
  , fingerprint
  , sizeOfFingerprint
  , Fingerprint
  , showFingerprint
  , SerializableDict(SerializableDict)
  , TypeableDict(TypeableDict)
  ) where

import Data.Binary (Binary)

import Data.Typeable (Typeable, typeRepFingerprint, typeOf)

import Numeric (showHex)
import Control.Exception (throw)
import GHC.Fingerprint.Type (Fingerprint(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BSI ( unsafeCreate, toForeignPtr )
import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)
import Foreign.ForeignPtr (withForeignPtr)
import System.IO.Unsafe (unsafePerformIO)

-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")
data SerializableDict a where
    SerializableDict :: Serializable a => SerializableDict a
  deriving (Typeable)

-- | Reification of 'Typeable'.
data TypeableDict a where
    TypeableDict :: Typeable a => TypeableDict a
  deriving (Typeable)

-- | Objects that can be sent across the network
type Serializable a = (Binary a, Typeable a)

-- | Encode type representation as a bytestring
encodeFingerprint :: Fingerprint -> ByteString
encodeFingerprint :: Fingerprint -> ByteString
encodeFingerprint Fingerprint
fp =
  -- Since all CH nodes will run precisely the same binary, we don't have to
  -- worry about cross-arch issues here (like endianness)
  Int -> (Ptr Word8 -> IO ()) -> ByteString
BSI.unsafeCreate Int
sizeOfFingerprint ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> Fingerprint -> IO ()
forall b. Ptr b -> Int -> Fingerprint -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
p Int
0 Fingerprint
fp

-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure
decodeFingerprint :: ByteString -> Fingerprint
decodeFingerprint :: ByteString -> Fingerprint
decodeFingerprint ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
sizeOfFingerprint =
      IOError -> Fingerprint
forall a e. Exception e => e -> a
throw (IOError -> Fingerprint) -> IOError -> Fingerprint
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"decodeFingerprint: Invalid length"
  | Bool
otherwise = IO Fingerprint -> Fingerprint
forall a. IO a -> a
unsafePerformIO (IO Fingerprint -> Fingerprint) -> IO Fingerprint -> Fingerprint
forall a b. (a -> b) -> a -> b
$ do
      let (ForeignPtr Word8
fp, Int
offset, Int
_) = ByteString -> (ForeignPtr Word8, Int, Int)
BSI.toForeignPtr ByteString
bs
      ForeignPtr Word8 -> (Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO Fingerprint) -> IO Fingerprint)
-> (Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> IO Fingerprint
forall b. Ptr b -> Int -> IO Fingerprint
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
p Int
offset

-- | Size of a fingerprint
sizeOfFingerprint :: Int
sizeOfFingerprint :: Int
sizeOfFingerprint = Fingerprint -> Int
forall a. Storable a => a -> Int
sizeOf (Fingerprint
forall a. HasCallStack => a
undefined :: Fingerprint)

-- | The fingerprint of the typeRep of the argument
fingerprint :: Typeable a => a -> Fingerprint
fingerprint :: forall a. Typeable a => a -> Fingerprint
fingerprint = TypeRep -> Fingerprint
typeRepFingerprint (TypeRep -> Fingerprint) -> (a -> TypeRep) -> a -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf

-- | Show fingerprint (for debugging purposes)
showFingerprint :: Fingerprint -> ShowS
showFingerprint :: Fingerprint -> ShowS
showFingerprint (Fingerprint Word64
hi Word64
lo) =
  String -> ShowS
showString String
"(" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word64
hi ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"," ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word64
lo ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"