dbf (empty) → 0.0.0.1
raw patch · 6 files changed
+600/−0 lines, 6 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, monad-loops, rwlock
Files
- Setup.lhs +5/−0
- dbf.cabal +26/−0
- src/Database/XBase/Dbf.hs +22/−0
- src/Database/XBase/Dbf/Handle.hs +261/−0
- src/Database/XBase/Dbf/Structures.hs +220/−0
- src/Database/XBase/Dbf/Year8.hs +66/−0
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ dbf.cabal view
@@ -0,0 +1,26 @@+name: dbf+version: 0.0.0.1+stability: experimental++cabal-version: >= 1.2+build-type: Simple++author: James Cook <james.cook@usma.edu>+maintainer: James Cook <james.cook@usma.edu>+license: PublicDomain+homepage: http://code.haskell.org/~mokus/dbf++category: Database+synopsis: Read and write XBase ".dbf" files+description: A simple interface for reading and writing XBase dbf+ files. Provides whole-file parser and serializer as+ well as a handle-based interface for reading and writing+ records from a file.++Library+ hs-source-dirs: src+ exposed-modules: Database.XBase.Dbf+ Database.XBase.Dbf.Handle+ Database.XBase.Dbf.Structures+ Database.XBase.Dbf.Year8+ build-depends: base >= 3 && <5, binary, bytestring, rwlock, monad-loops
+ src/Database/XBase/Dbf.hs view
@@ -0,0 +1,22 @@+module Database.XBase.Dbf+ ( module Database.XBase.Dbf.Structures+ , module Database.XBase.Dbf.Handle+ , module Database.XBase.Dbf.Year8+ ) where++import Database.XBase.Dbf.Structures+import Database.XBase.Dbf.Handle+import Database.XBase.Dbf.Year8++import Data.Binary.Get+import Data.Binary.Put++import qualified Data.ByteString.Lazy as BS++readDbfFile path = do+ file <- BS.readFile path+ return (runGet getDbfFile file)++writeDbfFile path dbf = do+ BS.writeFile path (runPut (uncurry putDbfFile dbf))+
+ src/Database/XBase/Dbf/Handle.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE RecordWildCards #-}+module Database.XBase.Dbf.Handle+ ( DbfHandle+ , openDbf+ , closeDbf+ , dbfIsOpen+ , dbfHeader+ + , DbfFieldHandle+ , fieldNum+ , fieldName+ , fieldDesc+ + , dbfNumFields+ , dbfFields+ , dbfGetField+ , dbfLookupField+ + , DbfRecHandle+ , recNum+ + , dbfRecords+ , dbfNumRecords+ , dbfGetRecord+ + , readDbfField+ + ) where++import Database.XBase.Dbf.Structures++import System.IO+import Control.Concurrent.RWLock+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BSC+import Data.Binary.Get++data DbfHandle = DbfHandle+ { dbfReadOnly :: Bool+ , dbfLock :: RWLock+ , dbfFile :: Handle+ }++instance Eq DbfHandle where+ h1 == h2 = dbfFile h1 == dbfFile h2++withDbfFile_ :: DbfHandle -> IOMode -> (Handle -> IO a) -> IO a+withDbfFile_ DbfHandle{..} mode action = withLock dbfLock (action dbfFile)+ where withLock = case mode of+ ReadMode -> withReadLock+ _ -> withWriteLock++withDbfFile :: DbfHandle -> IOMode -> (Handle -> IO a) -> IO a+withDbfFile dbf@DbfHandle{..} mode action = case (mode, dbfReadOnly) of+ (ReadMode, _) -> allow+ (_, False) -> allow+ (_, True) -> deny+ where+ allow = withDbfFile_ dbf mode action+ deny = fail "withDbfFile: write attempted on dbf which was opened as read-only"+ +readDbfBlock :: DbfHandle -> Integer -> Int -> IO BS.ByteString+readDbfBlock dbf pos len = withDbfFile dbf ReadMode $ \file -> do+ hSeek file AbsoluteSeek pos+ BS.hGet file len++writeDbfBlock :: DbfHandle -> Integer -> BS.ByteString -> IO ()+writeDbfBlock dbf pos dat = withDbfFile dbf WriteMode $ \file -> do+ hSeek file AbsoluteSeek pos+ BS.hPut file dat++data DbfFieldHandle = DbfFieldHandle+ { fieldDbf :: DbfHandle+ , fieldNum :: !Int+ , fieldOffset :: !Int+ , fieldDesc :: DbfFieldDescriptor+ }++instance Eq DbfFieldHandle where+ f1 == f2 = fieldDbf f1 == fieldDbf f2+ && fieldNum f1 == fieldNum f2++mkField dbf n off field = DbfFieldHandle+ { fieldDbf = dbf+ , fieldNum = n+ , fieldOffset = off+ , fieldDesc = field+ }++fieldName :: DbfFieldHandle -> String+fieldName DbfFieldHandle{..} = BSC.unpack rawName+ where rawName = BS.takeWhile (/= 0) (dbfFieldName fieldDesc)++fieldDescrOff :: Int -> Integer+fieldDescrOff n = toInteger (0x20 + 0x20*n)++fieldLength :: DbfFieldHandle -> Int+fieldLength = fromIntegral . dbfFieldLength . fieldDesc++data DbfRecHandle = DbfRecHandle+ { recDbf :: DbfHandle+ , recNum :: !Int+ , recOffset :: Int+ } deriving Eq++mkRec dbf n off = DbfRecHandle dbf n off++openDbf :: FilePath -> Bool -> IO DbfHandle+openDbf file dbfReadOnly = do+ let mode | dbfReadOnly = ReadMode+ | otherwise = ReadWriteMode+ dbfFile <- openBinaryFile file mode+ + dbfLock <- newRWLockIO+ return DbfHandle+ { dbfReadOnly = dbfReadOnly+ , dbfLock = dbfLock+ , dbfFile = dbfFile+ }++dbfIsOpen :: DbfHandle -> IO Bool+dbfIsOpen DbfHandle{..} = hIsOpen dbfFile++closeDbf :: DbfHandle -> IO ()+closeDbf dbf = withDbfFile_ dbf WriteMode hClose++getHeaderSize :: DbfHandle -> IO Int+getHeaderSize dbf = do+ sz <- readDbfBlock dbf 8 2+ return (fromIntegral (runGet getWord16le sz))++getRecordSize :: DbfHandle -> IO Int+getRecordSize dbf = do+ sz <- readDbfBlock dbf 10 2+ return (fromIntegral (runGet getWord16le sz))++dbfHeader :: DbfHandle -> IO DbfFileHeader+dbfHeader dbf = do+ sz <- getHeaderSize dbf+ hdr <- readDbfBlock dbf 0 sz+ return (runGet getDbfFileHeader hdr)++dbfNumFields :: DbfHandle -> IO Int+dbfNumFields = fmap length . dbfFields+dbfGetField :: DbfHandle -> Int -> IO DbfFieldHandle+dbfGetField dbf n = fmap (!!n) (dbfFields dbf)++dbfFields :: DbfHandle -> IO [DbfFieldHandle]+dbfFields dbf = go id 0 1+ where + go f n off = do+ fld <- getField dbf n+ case fld of+ Nothing -> return (f [])+ Just fld -> + let sz = fromIntegral (dbfFieldLength fld)+ in go (f . (mkField dbf n off fld:)) (succ n) (off + sz)++dbfLookupField :: DbfHandle -> String -> IO (Maybe DbfFieldHandle)+dbfLookupField dbf fName = lookupField dbf ((==fName) . fieldName)+ +getField dbf n = do+ let off = fieldDescrOff n+ fld <- readDbfBlock dbf off 1+ if fld `BS.index` 0 == 0x0D+ then return Nothing+ else do+ fld <- readDbfBlock dbf off 0x20+ return (Just (runGet getDbfFieldDescriptor fld))++lookupField dbf p = go 0 1+ where go n off = do+ fd <- getField dbf n+ case fd of+ Nothing -> return Nothing+ Just fd -> let sz = fromIntegral (dbfFieldLength fd)+ field = mkField dbf n off fd+ in if p field then return (Just field)+ else go (succ n) (off+sz)++ +dbfRecords :: DbfHandle -> IO [DbfRecHandle]+dbfRecords dbf = do+ start <- getHeaderSize dbf+ stride <- getRecordSize dbf+ + let go f n = do+ let pos = start + n * stride+ rec <- readDbfBlock dbf (toInteger pos) 1+ case rec `BS.index` 0 of+ 0x2A {-deleted-} -> go f $! succ n+ 0x20 {-valid-} -> go (f . (mkRec dbf n pos:)) $! succ n+ 0x1A {-EOF-} -> return (f [])+ _ {-defective dbf-} -> fail "dbfRecords: corrupt or non-dbf file (invalid record marker found)"+ + go id 0++dbfNumRecords :: DbfHandle -> IO Integer+dbfNumRecords dbf = do+ n <- readDbfBlock dbf 4 4+ return (toInteger (runGet getWord32le n))+ +dbfGetRecord :: DbfHandle -> Integer -> IO (Maybe DbfRecHandle)+dbfGetRecord dbf n = do+ nRecs <- dbfNumRecords dbf+ if n >= nRecs+ then return Nothing+ else do+ start <- getHeaderSize dbf+ stride <- getRecordSize dbf+ + let pos = toInteger start + n * toInteger stride+ rec <- readDbfBlock dbf (toInteger pos) 1+ if rec `BS.index` 0 == 0x20+ then return (Just (mkRec dbf (safeFromInteger n) (safeFromInteger pos)))+ else return Nothing++-- BS.hGet uses "Int" offset, which could be very bad if dealing with large+-- databases. That's not a big enough problem to make me feel like actually+-- fixing it, but it should at least "barf gracefully" if someone tries it.+safeFromInteger :: (Bounded b, Integral b) => Integer -> b+safeFromInteger n = x+ where+ mn = toInteger (minBound `asTypeOf` x)+ mx = toInteger (maxBound `asTypeOf` x)+ x | n < mn || n > mx+ = error ("safeFromInteger: integral value out of range: " ++ show n)+ | otherwise+ = fromInteger n++readDbfField :: DbfRecHandle -> DbfFieldHandle -> IO BS.ByteString+readDbfField DbfRecHandle{..} DbfFieldHandle{..}+ | recDbf /= fieldDbf = fail "readDbfField: Record and field are from different DbfHandles"+ | otherwise = do+ let dbf = recDbf+ pos = recOffset+ off = fieldOffset+ len = fromIntegral (dbfFieldLength fieldDesc)+ + readDbfBlock dbf (toInteger (pos+off)) len++writeDbfField :: DbfRecHandle -> DbfFieldHandle -> BS.ByteString -> IO ()+writeDbfField DbfRecHandle{..} fld@DbfFieldHandle{..} value+ | recDbf /= fieldDbf+ = fail "writeDbfField: Record and field are from different DbfHandles"+ | dataLen > fieldLen+ = fail ("writeDbfField: Value supplied is larger than target field (" ++ show value ++ " -> " ++ fieldName fld ++ ")")+ | otherwise = do+ let pos = recOffset+ off = fieldOffset+ padded + | fieldLen == dataLen + = value+ | otherwise -- fieldLen > dataLen+ = value `BS.append` BS.replicate (fieldLen - dataLen) 0x20+ + writeDbfBlock recDbf (toInteger (pos + off)) padded++ where + dataLen = BS.length value+ fieldLen = fromIntegral (dbfFieldLength fieldDesc)
+ src/Database/XBase/Dbf/Structures.hs view
@@ -0,0 +1,220 @@+{-# 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)+
+ src/Database/XBase/Dbf/Year8.hs view
@@ -0,0 +1,66 @@+module Database.XBase.Dbf.Year8+ ( Year8+ , putYear8+ , getYear8+ ) where++import Data.Binary++-- A custom "8-bit year" integral type whose values range from 1900 to 2155.+-- For obvious reasons, the arithmetic function implementations are+-- more or less useless, but they aren't the point.+newtype Year8 = Y19xx Word8+ deriving (Eq, Ord, Bounded)++instance Enum Year8 where+ toEnum x+ | x < 1900+ || x > 1900+255+ = error ("Year8: value out of range: " ++ show x)+ + | otherwise = Y19xx (toEnum (x - 1900))+ fromEnum (Y19xx x) = fromEnum x + 1900++instance Show Year8 where+ showsPrec p = showsPrec p . fromEnum++instance Read Year8 where+ readsPrec p str = + [ (toEnum x, ys)+ | (x, ys) <- readsPrec p str+ ]++liftY8 (*) a b = fromInteger (toInteger a * toInteger b)+instance Num Year8 where+ (+) = liftY8 (+)+ (-) = liftY8 (-)+ (*) = liftY8 (*)+ negate = toEnum . negate . fromEnum+ abs = id+ signum x = x `seq` 1+ + -- only really want to be able to use 'fromInteger'+ fromInteger x+ | x < 1900+ || x > 1900+255+ = error ("Year8: value out of range: " ++ show x)+ + | otherwise = Y19xx (fromInteger (x - 1900))++instance Real Year8 where+ toRational = toRational . fromEnum++instance Integral Year8 where+ quotRem p q = case quotRem (toInteger p) (toInteger q) of+ (q,r) -> (fromInteger q, fromInteger r)+ divMod p q = case divMod (toInteger p) (toInteger q) of+ (q,r) -> (fromInteger q, fromInteger r)+ -- only really want to be able to pattern-match+ toInteger (Y19xx x) = toInteger x + 1900++putYear8 (Y19xx x) = putWord8 x+getYear8 = fmap Y19xx getWord8++instance Binary Year8 where+ get = getYear8+ put = putYear8