dbf-0.0.0.1: src/Database/XBase/Dbf/Structures.hs
{-# 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)