{-# LANGUAGE RecordWildCards, EmptyDataDecls #-} 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 {- 3 bytes total -} getDbfShortDate = do dbfYear <- getYear8 dbfMonth <- getWord8 dbfDay <- getWord8 return (DbfDate dbfYear dbfMonth dbfDay) {- 3 bytes total -} data DbfFieldDescriptor = DbfFieldDescriptor { dbfFieldName :: BS.ByteString {- max length (10? 11?) -} , dbfFieldType :: Word8 , dbfFieldAddress :: Word32 {- mem addr for DBase, offset in record for foxpro. -} , 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 (maxLen-len) 0) {- 11 bytes total -} where maxLen = 11 len = BS.length bs getDbfFieldName = getLazyByteString 11 putDbfFieldDescriptor DbfFieldDescriptor {..} = do {- 0: Field Name -} putDbfFieldName dbfFieldName {- 11: Field Type -} putWord8 dbfFieldType {- 12: Field Addr -} putWord32le dbfFieldAddress {- 16: Field Length -} putWord8 dbfFieldLength {- 17: Decimal Count -} putWord8 dbfFieldDecimals {- 18: Reserved (2 bytes) -} putWord16le 0 {- 20: Work Area ID -} putWord8 dbfFieldWorkArea {- 21: Reserved (2 bytes) -} putWord16le 0 {- 23: Flag for SET FIELDS -} putFlag dbfFieldSetFieldsFlag {- 24: Reserved (7 bytes) -} putLazyByteString (BS.replicate 7 0) {- 31: Index Field Flag -} putFlag dbfFieldIndexedFlag {- 32 bytes total -} getDbfFieldDescriptor = do {- 0: Field Name -} dbfFieldName <- getDbfFieldName {- 11: Field Type -} dbfFieldType <- getWord8 {- 12: Field Addr -} dbfFieldAddress <- getWord32le {- 16: Field Length -} dbfFieldLength <- getWord8 {- 17: Decimal Count -} dbfFieldDecimals <- getWord8 {- 18: Reserved (2 bytes) -} getWord16le -- discarding result {- 20: Work Area ID -} dbfFieldWorkArea <- getWord8 {- 21: Reserved (2 bytes) -} getWord16le -- discarding result {- 23: Flag for SET FIELDS -} dbfFieldSetFieldsFlag <- getFlag {- 24: Reserved (7 bytes) -} getLazyByteString 7 -- discarding result {- 31: Index Field Flag -} dbfFieldIndexedFlag <- getFlag {- 32 bytes total -} return DbfFieldDescriptor { dbfFieldName = dbfFieldName , dbfFieldType = dbfFieldType , dbfFieldAddress = dbfFieldAddress , dbfFieldLength = dbfFieldLength , dbfFieldDecimals = dbfFieldDecimals , dbfFieldWorkArea = dbfFieldWorkArea , dbfFieldSetFieldsFlag = dbfFieldSetFieldsFlag , dbfFieldIndexedFlag = dbfFieldIndexedFlag } data DbfDatabaseContainer -- not implemented 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 {- 0: Signature -} putWord8 dbfFileSignature {- 1: Date of last update -} putDbfShortDate dbfFileUpdateDate {- 4: Number of records -} putWord32le dbfFileNumRecords {- 8: Length of header -} putWord16le dbfFileHdrLength {- 10: Length of each record -} putWord16le dbfFileRecLength {- 12: reserved (2 bytes) -} putWord16le 0 {- 14: Incomplete TX -} putFlag dbfFileTxInc {- 15: Encryption flag -} putFlag dbfFileEncr {- 16: Free Rec Thread (n/i)-} putWord32le 0 {- 20: Reserved (8 bytes) -} putWord64le 0 {- 28: MDX flag -} putFlag dbfFileMDX {- 29: Language Driver -} putWord8 dbfFileLangCode {- 30: Reserved (2 bytes) -} putWord16le 0 {- 32: Field Descriptors -} mapM_ putDbfFieldDescriptor dbfFileFields {- _: Terminator (0x0d) -} putWord8 0x0d {- _: Database Container -} -- Not Implemented getDbfFileHeader = do start <- bytesRead {- 0: Signature -} dbfFileSignature <- getWord8 {- 1: Date of last update -} dbfFileUpdateDate <- getDbfShortDate {- 4: Number of records -} dbfFileNumRecords <- getWord32le {- 8: Length of header -} dbfFileHdrLength <- getWord16le {- 10: Length of each record -} dbfFileRecLength <- getWord16le {- 12: reserved (2 bytes) -} getWord16le -- discarding result {- 14: Incomplete TX -} dbfFileTxInc <- getFlag {- 15: Encryption flag -} dbfFileEncr <- getFlag {- 16: Free Rec Thread (n/i)-} getWord32le -- discarding result {- 20: Reserved (8 bytes) -} getWord64le -- discarding result {- 28: MDX flag -} dbfFileMDX <- getFlag {- 29: Language Driver -} dbfFileLangCode <- getWord8 {- 30: Reserved (2 bytes) -} getWord16le -- discarding result {- 32: Field Descriptors -} let notDone = do x <- lookAhead getWord8 return (x /= 0x0d) dbfFileFields <- whileM notDone getDbfFieldDescriptor {- _: Terminator (0x0d) -} 0x0d <- getWord8 -- should not fail! {- _: Database Container -} -- Not Implemented {- read to end and discard -} 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 {- 0: Deleted -} putWord8 $ if dbfRecDeleted then 0x2A else 0x20 {- 1: Data -} putLazyByteString dbfRecData getDbfRecord recLen = do {- 0: tag -} tag <- getWord8 deleted <- case tag of 0x2A {-deleted-} -> return (Just True) 0x20 {-valid-} -> return (Just False) 0x1A {-EOF-} -> return Nothing _ {-defective dbf-} -> 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)