{-# LANGUAGE CPP, NamedFieldPuns, OverloadedStrings #-} module LTR.Transaction ( Transaction (..), Originator, mkOriginator, mkTransaction, putTransactionWithoutDigest, appendTransaction, getTransactions, Word32, Word16, #ifdef __TEST__ _testTransaction, #endif ) where import Control.Monad (unless) import Data.Binary import Data.Binary.Get import Data.Binary.Put import Data.ByteString.Lazy.Char8 (ByteString) import Data.Digest.Pure.MD5 import Data.Time.Clock (UTCTime, diffUTCTime, NominalDiffTime) import Data.Time.Format (readTime) import Data.Word (Word32, Word16) import Util.String () import System.IO (IOMode (..), withBinaryFile) import System.Locale (defaultTimeLocale) #ifdef __TEST__ import UnitTest #endif import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.ByteString.Char8 as BS {- Transaction Binary Format |---------------------------------------------------------------| | magic | v | length | |---------------------------------------------------------------| | application | flags | t-type | |---------------------------------------------------------------| | originator | |---------------------------------------------------------------| | timestamp | |---------------------------------------------------------------| . . . data . . . |---------------------------------------------------------------| | MD5 Digest | | | |---------------------------------------------------------------| Bits Name Description ----- --------------- --------------------------------------------------- 24 magic Identifies the start of a transaction; always "cjs". 08 version Transaction format version: currently 0. 48 length The length of the entire transaction, including the header and MD5 digest. 32 application The number assigned to the particular program or system that generates and uses this transaction. These numbers are assigned by a central authority. However, the range 0xff000000 through 0xfffeffff is desginated for "experimental" use, and will never be assigned. 16 flags Currently reserved and must be set to all zeros. (A "compressed data" flag will be added soon.) 16 t-type Transaction type; assigned by the application. 64 originator A globally-unique node ID for a particular generator of transactions. How this is assigned is yet to be determined. 64 timestamp Signed number of milliseconds since the Unix epoch, 1970-01-01 00:00:00 UTC. n data A variable amount of data. 128 digest An MD5 digest of the header (inc. length) and data. -} ---------------------------------------------------------------------- -- | A transaction and associated data, if valid. Note that because the -- constructors are exposed for pattern matching, it's possible to build -- an invalid 'Transaction'; expect writing such things to fail. Always -- use 'mkTransaction' to create a transaction. -- -- 'transRawData' does not include the digest at the end. -- data Transaction = InvalidTransaction String | Transaction { transApp :: Word32 , transType :: Word16 , transOriginator :: Originator , transTS :: NominalDiffTime , transData :: ByteString , transRawData :: ByteString , transID :: MD5Digest } deriving (Show, Eq) newtype Originator = Originator ByteString deriving (Show, Eq) ---------------------------------------------------------------------- -- XXX Temporarially, originators are always zero. mkOriginator :: Int -> Originator mkOriginator 0 = Originator "\0\0\0\0\0\0\0\0" mkOriginator _ = error "Transaction.mkOriginator: write me" epoch = readTime defaultTimeLocale "" "" :: UTCTime milliseconds :: NominalDiffTime -> Word64 milliseconds t = round $ 1000 * toRational t ---------------------------------------------------------------------- -- | Create a valid transaction. Transactions created using the data -- constructors directly are likely to be invalid, and be silently -- corrupted when written. -- mkTransaction :: Word32 -> Word16 -> Originator -> NominalDiffTime -> ByteString -> Transaction mkTransaction app ttype orig ts tdata = Transaction { transApp = app , transType = ttype , transOriginator = orig , transTS = ts , transData = tdata , transRawData = rawData , transID = digest } where rawData = runPut $ putTransactionWithoutDigest app ttype orig ts tdata digest = md5 rawData instance Binary Transaction where get = do magic <- getLazyByteString 3 unless (magic == "cjs") $ error $ "XXX Bad transaction magic number" version <- getWord8 unless (version == 0) $ error $ "XXX Bad transaction version: " ++ show version lengthHi <- getWord16be unless (lengthHi == 0) $ error $ "XXX Packet too long for this implementation: " ++ "lengthHi=" ++ show lengthHi lengthLo <- getWord32be let dataLen = (fromIntegral lengthLo) - (8 * 6) app <- getWord32be flags <- getWord16be ttype <- getWord16be orig <- get ts <- get tdata <- getLazyByteString dataLen let rawData = B.concat [magic, encode version, encode lengthHi, encode lengthLo, encode app, encode flags, encode ttype, encode orig, encode ts, tdata] digest <- get :: Get MD5Digest unless (digest == md5 rawData) $ error.concat $ [ "XXX transaction digest does not match: " , "expected=", show digest, ", " , "computed=", show (md5 rawData) ] return $! Transaction { transApp = app , transType = ttype , transOriginator = orig , transTS = ts , transData = tdata , transRawData = rawData , transID = digest } put InvalidTransaction{} = fail "Cannot put an InvalidTransaction" put Transaction{transRawData,transID} = do putLazyByteString transRawData put transID putTransactionWithoutDigest :: Word32 -> Word16 -> Originator -> NominalDiffTime -> ByteString -> Put putTransactionWithoutDigest app ttype orig ts tdata = do putLazyByteString magic putWord8 version putWord16be lengthHi -- XXX Should check length let lengthLo = (fromIntegral $ B.length tdata) + (8 * 6) putWord32be lengthLo putWord32be app putWord16be flags putWord16be ttype put orig put ts putLazyByteString tdata where magic = "cjs" :: ByteString version = 0 lengthHi = 0 flags = 0 instance Binary Originator where get = getLazyByteString 8 >>= return . Originator put (Originator o) = putLazyByteString o instance Binary NominalDiffTime where get = do ms <- getWord64be return $ fromIntegral ms / 1000 put = put . milliseconds ---------------------------------------------------------------------- -- |Safely appends the transaction to the given file, ensuring that no -- other process using this will write the file at the same time. -- appendTransaction :: FilePath -> Transaction -> IO () appendTransaction path trans = withBinaryFile path AppendMode (\h -> B.hPut h $ encode trans) getTransactions :: FilePath -> IO [Transaction] getTransactions path = withBinaryFile path ReadMode (\h -> -- get contents not lazily because after this block -- the handle will be closed do bs <- BS.hGetContents h (return . getList) (B.pack $ BS.unpack bs)) where getList bs | B.null bs = [] | otherwise = let (trans, rest, _) = runGetState get bs 0 in trans:(getList rest) ---------------------------------------------------------------------- #ifdef __TEST__ testdataOriginator = Originator "\0\1\2\3\4\5\6\7" testdataTime = oneMinute `diffUTCTime` epoch where oneMinute = readTime defaultTimeLocale "%M" "01" :: UTCTime testdataApp = 0xffeeddcc testdataType = 0xfedc testdataTransaction = mkTransaction testdataApp testdataType testdataOriginator testdataTime "Hello, world." testdataBinaryTransaction = B.concat [ "cjs", "\0", "\0\0\0\0\0\61" -- magic, ver, len , "\xff\xee\xdd\xcc", "\0\0", "\xfe\xdc" -- app, flags, type , "\0\1\2\3\4\5\6\7" -- originator , "\0\0\0\0\0\0\234\96" -- timestamp, 1 min. , "Hello, world." -- data , "_\166\201OjT\a\194a\ESC%o\DC3\148_\236" -- md5 ] _testTransaction = runTests $ "LTR.Transaction" ~: test [ show epoch ~?= "1970-01-01 00:00:00 UTC" , mkOriginator 0 ~?= Originator "\0\0\0\0\0\0\0\0" , encode testdataTransaction ~?= testdataBinaryTransaction , decode testdataBinaryTransaction ~?= testdataTransaction ] #endif