module Data.Binary.ISO8583
(
getBitmapFieldNumbers,
getBitmap,
mergeFieldNumbers,
putBitmap, putBitmap',
embeddedLen,
asciiNumber, asciiNumberF,
putAsciiNumber, putEmbeddedLen,
putByteStringPad, putLazyByteStringPad,
toBS, fromBS ) where
import Control.Monad
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as C8
import Data.Int
import Data.Word
import Data.Bits
import Data.Char
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Text.Printf
bytes :: [(Word8, Word8)]
bytes = let digits = "0123456789ABCDEF"
in [(fromIntegral (ord digit), n) | (digit, n) <- zip digits [0..]]
bits :: [(Word8, [Int])]
bits = [(digit, [i | i <- [1..4] , testBit n (4i)]) | (digit, n) <- bytes]
bitsSet :: Int -> Word8 -> [Int]
bitsSet byteNr b =
let fs = case lookup b bits of
Just x -> x
Nothing -> error $ "Unknown byte: " ++ [chr (fromIntegral b)]
in [4*byteNr + n | n <- fs]
getBitmapFieldNumbers :: Get [Int]
getBitmapFieldNumbers = do
bm <- getByteString 16
let xs = [bitsSet i b | (i,b) <- zip [0..] (B.unpack bm)]
return $ concat xs
mergeFieldNumbersW :: [Int] -> [Word64]
mergeFieldNumbersW fs =
let (fs1,fs2) = partition (<65) fs
go b f = setBit b (63f)
w1 = foldl go 0 $ map (\f -> f 1) fs1
w2 = foldl go 0 $ map (\f -> f 65) fs2
in if w2 == 0
then [w1]
else [setBit w1 63, w2]
mergeFieldNumbers :: [Int] -> B.ByteString
mergeFieldNumbers fs =
let hex n = toBS $ map toUpper $ printf "%016x" n
in case mergeFieldNumbersW fs of
[w1] -> hex w1
[w1,w2] -> hex w1 `B.append` hex w2
getBitmap :: (Int -> Maybe (Get f))
-> Get (M.Map Int f)
getBitmap getter = do
fs1 <- getBitmapFieldNumbers
fs2 <- if 1 `elem` fs1
then getBitmapFieldNumbers
else return []
let fs = fs1 ++ map (64+) fs2
res <- forM fs $ \f ->
if f == 1
then return []
else
case getter f of
Nothing -> fail $ "Unsupported field #" ++ show f
Just fn -> do
offset <- bytesRead
fn >>= (\x -> return [(f, x)])
return $ M.fromList $ concat res
putBitmap :: [(Int, Put)]
-> Put
putBitmap fs = do
let fieldNumbers = map fst fs
putByteString $ mergeFieldNumbers fieldNumbers
mapM_ snd fs
putBitmap' :: [(Int, Maybe Put)]
-> Put
putBitmap' fs = do
let fs' = [(f, p) | (f, Just p) <- fs]
let fieldNumbers = map fst fs'
putByteString $ mergeFieldNumbers fieldNumbers
mapM_ snd fs'
embeddedLen :: Int
-> Int
-> Get B.ByteString
embeddedLen f n = do
sz <- asciiNumberF f n
getByteString (fromIntegral sz)
asciiNumberF :: Int
-> Int
-> Get Integer
asciiNumberF f n = do
bs <- getByteString n
case C8.readInteger bs of
Just (res, s)
| C8.null s -> return res
_ -> fail $ "Cannot parse number: <" ++ fromBS bs ++ "> in field #" ++ show f
asciiNumber :: Int
-> Get Int
asciiNumber n = do
bs <- getByteString n
case reads (fromBS bs) of
[(res, "")] -> return res
_ -> fail $ "Cannot parse number: " ++ fromBS bs
putAsciiNumber :: Int
-> Integer
-> Put
putAsciiNumber sz n = do
let s = show n
m = length s
s' = if m < sz
then replicate (szm) '0' ++ s
else if m == sz
then s
else drop (msz) s
bs = toBS s'
putByteString bs
putEmbeddedLen :: Int
-> B.ByteString
-> Put
putEmbeddedLen sz bstr = do
let len = fromIntegral $ B.length bstr
putAsciiNumber sz len
putByteString bstr
putByteStringPad :: Int
-> B.ByteString
-> Put
putByteStringPad sz bstr = do
let len = B.length bstr
let bstr' = if len < sz
then B.replicate (szlen) 0x20 `B.append` bstr
else bstr
putByteString bstr'
putLazyByteStringPad :: Int64
-> L.ByteString
-> Put
putLazyByteStringPad sz bstr = do
let len = L.length bstr
let bstr' = if len < sz
then L.replicate (szlen) 0x20 `L.append` bstr
else bstr
putLazyByteString bstr'
toBS :: String -> B.ByteString
toBS str = B.pack $ map (fromIntegral . ord) str
fromBS :: B.ByteString -> String
fromBS bstr = map (chr . fromIntegral) $ B.unpack bstr