module Database.XBase.Dbf.Structures
( DbfDate(..), DbfFieldDescriptor(..), DbfRecord(..)
, DbfDatabaseContainer, DbfFileHeader(..)
, putDbfShortDate, getDbfShortDate
, putDbfFieldName, getDbfFieldName
, putDbfFieldDescriptor, getDbfFieldDescriptor
, putDbfFileHeader, getDbfFileHeader
, putDbfRecord, getDbfRecord
, putDbfFile, getDbfFile
) where
import Database.XBase.Dbf.Year8
import Data.Binary.Put
import Data.Binary.Get
import Data.Word
import qualified Data.ByteString.Lazy as BS
import Control.Monad.Loops
import Data.Maybe
putFlag True = putWord8 1
putFlag False = putWord8 0
getFlag = do
f <- getWord8
return (f /= 0)
data DbfDate yearType = DbfDate
{ dbfYear :: yearType
, dbfMonth :: Word8
, dbfDay :: Word8
} deriving (Eq, Show)
putDbfShortDate DbfDate {..} = do
putYear8 dbfYear
putWord8 dbfMonth
putWord8 dbfDay
getDbfShortDate = do
dbfYear <- getYear8
dbfMonth <- getWord8
dbfDay <- getWord8
return (DbfDate dbfYear dbfMonth dbfDay)
data DbfFieldDescriptor = DbfFieldDescriptor
{ dbfFieldName :: BS.ByteString
, dbfFieldType :: Word8
, dbfFieldAddress :: Word32
, dbfFieldLength :: Word8
, dbfFieldDecimals :: Word8
, dbfFieldWorkArea :: Word8
, dbfFieldSetFieldsFlag :: Bool
, dbfFieldIndexedFlag :: Bool
} deriving (Eq, Show)
dbfRecLengthForFields fields = 1 + sum (map dbfFieldLength fields)
putDbfFieldName bs
| len > maxLen = fail ("putDbfFieldName: Field name too long (" ++ show len ++ " bytes)")
| otherwise = do
putLazyByteString bs
putLazyByteString (BS.replicate (maxLenlen) 0)
where
maxLen = 11
len = BS.length bs
getDbfFieldName = getLazyByteString 11
putDbfFieldDescriptor DbfFieldDescriptor {..} = do
putDbfFieldName dbfFieldName
putWord8 dbfFieldType
putWord32le dbfFieldAddress
putWord8 dbfFieldLength
putWord8 dbfFieldDecimals
putWord16le 0
putWord8 dbfFieldWorkArea
putWord16le 0
putFlag dbfFieldSetFieldsFlag
putLazyByteString (BS.replicate 7 0)
putFlag dbfFieldIndexedFlag
getDbfFieldDescriptor = do
dbfFieldName <- getDbfFieldName
dbfFieldType <- getWord8
dbfFieldAddress <- getWord32le
dbfFieldLength <- getWord8
dbfFieldDecimals <- getWord8
getWord16le
dbfFieldWorkArea <- getWord8
getWord16le
dbfFieldSetFieldsFlag <- getFlag
getLazyByteString 7
dbfFieldIndexedFlag <- getFlag
return DbfFieldDescriptor
{ dbfFieldName = dbfFieldName
, dbfFieldType = dbfFieldType
, dbfFieldAddress = dbfFieldAddress
, dbfFieldLength = dbfFieldLength
, dbfFieldDecimals = dbfFieldDecimals
, dbfFieldWorkArea = dbfFieldWorkArea
, dbfFieldSetFieldsFlag = dbfFieldSetFieldsFlag
, dbfFieldIndexedFlag = dbfFieldIndexedFlag
}
data DbfDatabaseContainer
instance Eq DbfDatabaseContainer
instance Show DbfDatabaseContainer
data DbfFileHeader = DbfFileHeader
{ dbfFileSignature :: Word8
, dbfFileUpdateDate :: DbfDate Year8
, dbfFileNumRecords :: Word32
, dbfFileHdrLength :: Word16
, dbfFileRecLength :: Word16
, dbfFileTxInc :: Bool
, dbfFileEncr :: Bool
, dbfFileMDX :: Bool
, dbfFileLangCode :: Word8
, dbfFileFields :: [DbfFieldDescriptor]
, dbfFileDbContainer :: Maybe DbfDatabaseContainer
} deriving (Eq, Show)
putDbfFileHeader DbfFileHeader {..} = do
putWord8 dbfFileSignature
putDbfShortDate dbfFileUpdateDate
putWord32le dbfFileNumRecords
putWord16le dbfFileHdrLength
putWord16le dbfFileRecLength
putWord16le 0
putFlag dbfFileTxInc
putFlag dbfFileEncr
putWord32le 0
putWord64le 0
putFlag dbfFileMDX
putWord8 dbfFileLangCode
putWord16le 0
mapM_ putDbfFieldDescriptor dbfFileFields
putWord8 0x0d
getDbfFileHeader = do start <- bytesRead
dbfFileSignature <- getWord8
dbfFileUpdateDate <- getDbfShortDate
dbfFileNumRecords <- getWord32le
dbfFileHdrLength <- getWord16le
dbfFileRecLength <- getWord16le
getWord16le
dbfFileTxInc <- getFlag
dbfFileEncr <- getFlag
getWord32le
getWord64le
dbfFileMDX <- getFlag
dbfFileLangCode <- getWord8
getWord16le
let notDone = do
x <- lookAhead getWord8
return (x /= 0x0d)
dbfFileFields <- whileM notDone getDbfFieldDescriptor
0x0d <- getWord8
here <- bytesRead
let consumed = here start
skip (fromIntegral dbfFileHdrLength fromIntegral consumed)
return DbfFileHeader
{ dbfFileSignature = dbfFileSignature
, dbfFileUpdateDate = dbfFileUpdateDate
, dbfFileNumRecords = dbfFileNumRecords
, dbfFileHdrLength = dbfFileHdrLength
, dbfFileRecLength = dbfFileRecLength
, dbfFileTxInc = dbfFileTxInc
, dbfFileEncr = dbfFileEncr
, dbfFileMDX = dbfFileMDX
, dbfFileLangCode = dbfFileLangCode
, dbfFileFields = dbfFileFields
, dbfFileDbContainer = Nothing
}
data DbfRecord = DbfRecord
{ dbfRecDeleted :: Bool
, dbfRecData :: BS.ByteString
} deriving (Eq, Show)
dbfRecordDeleted, dbfRecordNotDeleted, dbfRecordEOF :: Word8
dbfRecordDeleted = 0x2A
dbfRecordNotDeleted = 0x20
dbfRecordEOF = 0x1A
putDbfRecord DbfRecord{..} = do
putWord8 $ if dbfRecDeleted then 0x2A else 0x20
putLazyByteString dbfRecData
getDbfRecord recLen = do
tag <- getWord8
deleted <- case tag of
0x2A -> return (Just True)
0x20 -> return (Just False)
0x1A -> return Nothing
_ -> fail "getDbfRecord: corrupt or non-dbf file (invalid record marker found)"
whenJust deleted $ \deleted -> do
dat <- getLazyByteString (recLen 1)
return (Just (DbfRecord deleted dat))
whenJust Nothing f = return Nothing
whenJust (Just x) f = f x
putDbfFile hdr recs = do
putDbfFileHeader hdr
mapM_ putDbfRecord recs
putWord8 dbfRecordEOF
getDbfFile :: Get (DbfFileHeader, [DbfRecord])
getDbfFile = do
hdr <- getDbfFileHeader
recs <- unfoldM (getDbfRecord (fromIntegral (dbfFileRecLength hdr)))
return (hdr, recs)