diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/shapefile.cabal b/shapefile.cabal new file mode 100644 --- /dev/null +++ b/shapefile.cabal @@ -0,0 +1,32 @@ +name: shapefile +version: 0.0.0.1 +stability: experimental + +cabal-version: >= 1.2 +build-type: Simple + +author: James Cook +maintainer: James Cook +license: PublicDomain +homepage: http://code.haskell.org/~mokus/shapefile + +category: Database +synopsis: Parser and related tools for ESRI shapefile format +description: A very simple interface for processing data in ESRI + shapefile format. Includes functions for reading or + writing whole .shp and .shx files, as well as for + generating .shx index files from .shp data files. + Also includes an interface to read individual records + on-demand from shapefiles, useful for very large databases. + +Library + hs-source-dirs: src + exposed-modules: Database.Shapefile + Database.Shapefile.ShapeTypes + Database.Shapefile.Shp + Database.Shapefile.Shp.Handle + Database.Shapefile.Shx + Database.Shapefile.Shx.Handle + other-modules: Database.Shapefile.Misc + build-depends: base >= 3 && <5, binary, bytestring, dbf >= 0.0.0.2, + data-binary-ieee754, filepath, rwlock diff --git a/src/Database/Shapefile.hs b/src/Database/Shapefile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Shapefile.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE RecordWildCards #-} +module Database.Shapefile + ( module Database.Shapefile + , module Database.Shapefile.ShapeTypes + , module Database.Shapefile.Shp + , module Database.Shapefile.Shx + , module Database.Shapefile.Shp.Handle + , module Database.Shapefile.Shx.Handle + , module Database.XBase.Dbf + , BBox(..) + ) where + +import Database.Shapefile.Misc +import Database.Shapefile.ShapeTypes +import Database.Shapefile.Shp +import Database.Shapefile.Shx +import Database.Shapefile.Shp.Handle +import Database.Shapefile.Shx.Handle +import Database.XBase.Dbf + +import Data.Binary.Get +import Data.Binary.Put + +import qualified Data.ByteString.Lazy as BS + +readShpFile path = do + file <- BS.readFile path + return (runGet getShpFile file) + +writeShpFile path shp = do + BS.writeFile path (runPut (uncurry putShpFile shp)) + +readShxFile path = do + file <- BS.readFile path + return (runGet getShxFile file) + +writeShxFile path shx = do + BS.writeFile path (runPut (uncurry putShxFile shx)) diff --git a/src/Database/Shapefile/Misc.hs b/src/Database/Shapefile/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Database/Shapefile/Misc.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RecordWildCards #-} +module Database.Shapefile.Misc where + +import Data.Binary +import Data.Binary.Get + +expecting :: (Eq t, Show t) => Get t -> t -> Get () +get `expecting` result = do + off <- bytesRead + x <- get + if (x == result) then return () + else fail $ unwords + ["Found", show x, "at offset", show off, "but expected", show result] + +putPair :: (a -> Put) -> (a,a) -> Put +putPair putPart (x,y) = do + putPart x + putPart y +getPair :: Get a -> Get (a,a) +getPair getPart = do + x <- getPart + y <- getPart + return (x,y) + +putBBox :: (a -> Put) -> BBox a -> Put +putBBox putPoint BBox {..} = do + putPoint bbMin + putPoint bbMax +getBBox :: Get a -> Get (BBox a) +getBBox getPoint = do + bbMin <- getPoint + bbMax <- getPoint + return (BBox bbMin bbMax) + +data BBox point = BBox + { bbMin :: point + , bbMax :: point + } deriving (Eq, Show) + diff --git a/src/Database/Shapefile/ShapeTypes.hs b/src/Database/Shapefile/ShapeTypes.hs new file mode 100644 --- /dev/null +++ b/src/Database/Shapefile/ShapeTypes.hs @@ -0,0 +1,94 @@ +module Database.Shapefile.ShapeTypes where + +import Data.Binary.Get +import Data.Binary.Put +import Data.Word +import Data.Function (on) + +data ESRIShapeType + = NullShape + | Point + | PolyLine + | Polygon + | MultiPoint + | PointZ + | PolyLineZ + | PolygonZ + | MultiPointZ + | PointM + | PolyLineM + | PolygonM + | MultiPointM + | MultiPatch + | Unknown Word32 + deriving (Show, Read) + +hasZ :: ESRIShapeType -> Bool +hasZ PointZ = True +hasZ PolyLineZ = True +hasZ PolygonZ = True +hasZ MultiPointZ = True +hasZ _ = False + +hasM :: ESRIShapeType -> Bool +hasM PointM = True +hasM PolyLineM = True +hasM PolygonM = True +hasM MultiPointM = True +hasM other = hasZ other + +instance Enum ESRIShapeType where + toEnum 0 = NullShape + toEnum 1 = Point + toEnum 3 = PolyLine + toEnum 5 = Polygon + toEnum 8 = MultiPoint + toEnum 11 = PointZ + toEnum 13 = PolyLineZ + toEnum 15 = PolygonZ + toEnum 18 = MultiPointZ + toEnum 21 = PointM + toEnum 23 = PolyLineM + toEnum 25 = PolygonM + toEnum 28 = MultiPointM + toEnum 31 = MultiPatch + toEnum x = Unknown (toEnum x) + + fromEnum NullShape = 0 + fromEnum Point = 1 + fromEnum PolyLine = 3 + fromEnum Polygon = 5 + fromEnum MultiPoint = 8 + fromEnum PointZ = 11 + fromEnum PolyLineZ = 13 + fromEnum PolygonZ = 15 + fromEnum MultiPointZ = 18 + fromEnum PointM = 21 + fromEnum PolyLineM = 23 + fromEnum PolygonM = 25 + fromEnum MultiPointM = 28 + fromEnum MultiPatch = 31 + fromEnum (Unknown x) = fromEnum x + +instance Bounded ESRIShapeType where + minBound = NullShape + maxBound = Unknown maxBound + +instance Eq ESRIShapeType where + (==) = (==) `on` fromEnum + +instance Ord ESRIShapeType where + compare = compare `on` fromEnum + +identifyShapeType :: ESRIShapeType -> ESRIShapeType +identifyShapeType = toEnum . fromEnum + +isKnownShapeType :: ESRIShapeType -> Bool +isKnownShapeType t = case identifyShapeType t of + Unknown _ -> False + _ -> True + +putShapeType32le :: ESRIShapeType -> Put +putShapeType32le = putWord32le . fromIntegral . fromEnum +getShapeType32le :: Get ESRIShapeType +getShapeType32le = fmap (toEnum . fromIntegral) getWord32le diff --git a/src/Database/Shapefile/Shp.hs b/src/Database/Shapefile/Shp.hs new file mode 100644 --- /dev/null +++ b/src/Database/Shapefile/Shp.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE RecordWildCards #-} +module Database.Shapefile.Shp where + +import Database.Shapefile.ShapeTypes +import Database.Shapefile.Misc + +import Data.Binary.Get +import Data.Binary.Put +import Data.Binary.IEEE754 +import Data.Word +import Data.Maybe +import qualified Data.ByteString.Lazy as BS + +data ShpFileHeader = ShpFileHeader + { -- |File length in 16-bit words. Unsigned, I assume - spec doesn't say. + shpFileLength :: Word32 + , shpFileShapeType :: ESRIShapeType + , shpFileBBox :: BBox (Double, Double) + , shpFileZBnd :: Maybe (Double, Double) + , shpFileMBnd :: Maybe (Double, Double) + } deriving (Eq, Show) + +-- |Shape file length in bytes +shpFileLengthBytes :: ShpFileHeader -> Integer +shpFileLengthBytes = (2*) . toInteger . shpFileLength + +putShpFileHeader :: ShpFileHeader -> Put +putShpFileHeader ShpFileHeader {..} = do + {- 0: File Code -} putWord32be 9994 + {- 4: Unused -} putWord32be 0 + {- 8: Unused -} putWord32be 0 + {- 12: Unused -} putWord32be 0 + {- 16: Unused -} putWord32be 0 + {- 20: Unused -} putWord32be 0 + {- 24: File Length -} putWord32be shpFileLength + {- 28: Version -} putWord32le 1000 + {- 32: Shape Type -} putShapeType32le shpFileShapeType + {- 36: Bounding Box -} putBBox (putPair putFloat64le) shpFileBBox + {- 68: Z Bounds -} putPair putFloat64le (fromMaybe (0,0) shpFileZBnd) + {- 84: M Bounds -} putPair putFloat64le (fromMaybe (0,0) shpFileMBnd) + {- 100 bytes total -} + +getShpFileHeader :: Get ShpFileHeader +getShpFileHeader = do + {- 0: File Code -} getWord32be `expecting` 9994 + {- 4: Unused -} getWord32be `expecting` 0 + {- 8: Unused -} getWord32be `expecting` 0 + {- 12: Unused -} getWord32be `expecting` 0 + {- 16: Unused -} getWord32be `expecting` 0 + {- 20: Unused -} getWord32be `expecting` 0 + {- 24: File Length -} shpFileLength <- getWord32be + {- 28: Version -} getWord32le `expecting` 1000 + {- 32: Shape Type -} shpFileShapeType <- getShapeType32le + {- 36: Bounding Box -} shpFileBBox <- getBBox (getPair getFloat64le) + {- 68: Z Bounds -} shpFileZBnd <- getPair getFloat64le + {- 84: M Bounds -} shpFileMBnd <- getPair getFloat64le + {- 100 bytes total -} + return $ ShpFileHeader + { shpFileLength = shpFileLength + , shpFileShapeType = shpFileShapeType + , shpFileBBox = shpFileBBox + , shpFileZBnd = if hasZ shpFileShapeType || nonZero shpFileZBnd + then Just shpFileZBnd + else Nothing + , shpFileMBnd = if hasM shpFileShapeType || nonZero shpFileMBnd + then Just shpFileMBnd + else Nothing + } + where + nonZero (0,0) = False + nonZero _ = True + + +data ShpRecHeader = ShpRecHeader + { -- |Index of the record. First index is 1. + shpRecNum :: Word32 + , -- |Size of the record in 16-bit words, excluding this header. + shpRecSize :: Word32 + } deriving (Eq, Show) + +-- |Size of the record in bytes, excluding the record header +shpRecSizeBytes :: ShpRecHeader -> Integer +shpRecSizeBytes = (*2) . toInteger . shpRecSize + +putShpRecHeader :: ShpRecHeader -> Put +putShpRecHeader ShpRecHeader {..} = do + {- 0 : Record Number -} putWord32be shpRecNum + {- 4 : Content Length -} putWord32be shpRecSize + +getShpRecHeader :: Get ShpRecHeader +getShpRecHeader = do + {- 0 : Record Number -} shpRecNum <- getWord32be + {- 4 : Content Length -} shpRecSize <- getWord32be + return ShpRecHeader + { shpRecNum = shpRecNum + , shpRecSize = shpRecSize + } + +data ShpRec = ShpRec + { shpRecHdr :: ShpRecHeader + , shpRecData :: BS.ByteString + } deriving (Eq, Show) + +-- |Total size of the shape record in bytes, including the header +shpRecTotalSizeBytes :: ShpRec -> Integer +shpRecTotalSizeBytes = (8 +) . shpRecSizeBytes . shpRecHdr + +-- |A shape record type isn't "part of" the header, but every shape format starts with +-- a word indicating the shape type. This function extracts it. +shpRecShapeType :: ShpRec -> ESRIShapeType +shpRecShapeType ShpRec{..} + | BS.length shpRecData < 4 = NullShape + | otherwise = runGet getShapeType32le shpRecData + +-- |Pack several raw shape records into 'ShpRec's, setting proper record numbers +-- and sizes. +mkShpRecs :: [BS.ByteString] -> [ShpRec] +mkShpRecs recData = zipWith mkShpRec [1..] recData + +-- |Pack the data for a shape into a 'ShpRec' with the specified record number +mkShpRec :: Word32 -> BS.ByteString -> ShpRec +mkShpRec n recData = ShpRec (ShpRecHeader n (bsLength recData)) recData + where + bsLength bs = case fromIntegral len `divMod` 2 of + (words, 0) -> words + (words, _) -> error ("uneven length shape record (" ++ show len ++ " bytes)") + where len = BS.length bs + +putShpRec :: ShpRec -> Put +putShpRec ShpRec {..} = do + {- 0 : Record Header -} putShpRecHeader shpRecHdr + {- 8 : Record content -} putLazyByteString shpRecData + {- (8 + BS.length shpRecData) bytes total -} + +getShpRec :: Get ShpRec +getShpRec = do + {- 0 : Record Header -} shpRecHdr@ShpRecHeader {shpRecSize = len} <- getShpRecHeader + {- 8 : Record content -} shpRecData <- getLazyByteString (2 * fromIntegral len) + {- (8 + len) bytes total -} return ShpRec + { shpRecHdr = shpRecHdr + , shpRecData = shpRecData + } + +putShpFile :: ShpFileHeader -> [ShpRec] -> Put +putShpFile shpHdr shpRecs = do + putShpFileHeader shpHdr + mapM_ putShpRec shpRecs + +getShpFile :: Get (ShpFileHeader, [ShpRec]) +getShpFile = do + hdr <- getShpFileHeader + rest <- getLazyByteString (fromInteger (shpFileLengthBytes hdr) - 100) + let n = shpFileLengthBytes hdr - 100 + return (hdr, slurp n rest) + + where + slurp 0 rest = [] + slurp n rest = flip runGet rest $ do + rec <- getShpRec + rest <- getRemainingLazyByteString + let n' = n - shpRecTotalSizeBytes rec + return (rec : slurp n' rest) + diff --git a/src/Database/Shapefile/Shp/Handle.hs b/src/Database/Shapefile/Shp/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Database/Shapefile/Shp/Handle.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE RecordWildCards #-} +module Database.Shapefile.Shp.Handle + ( ShpHandle + , openShp + , closeShp + , shpIsOpen + , shpHeader + , shpDbfFields + , getShpRecord + ) where + +import Database.Shapefile.Shp +import Database.Shapefile.Shx +import Database.Shapefile.Shx.Handle +import Database.XBase.Dbf.Handle + +import System.IO +import System.FilePath +import Control.Monad +import Control.Concurrent.RWLock +import qualified Data.ByteString.Lazy as BS +import Data.Binary.Get + +data ShpHandle = ShpHandle + { shpReadOnly :: Bool + , shpLock :: RWLock + , shpFile :: Handle + , shxHandle :: ShxHandle + , dbfHandle :: DbfHandle + } + +withShpFile_ :: ShpHandle -> IOMode -> (Handle -> IO a) -> IO a +withShpFile_ ShpHandle{..} mode action = withLock shpLock (action shpFile) + where withLock = case mode of + ReadMode -> withReadLock + _ -> withWriteLock + +withShpFile :: ShpHandle -> IOMode -> (Handle -> IO a) -> IO a +withShpFile shp@ShpHandle{..} mode action = case (mode, shpReadOnly) of + (ReadMode, _) -> allow + (_, False) -> allow + (_, True) -> deny + where + allow = withShpFile_ shp mode action + deny = fail "withShpFile: write attempted on shp which was opened as read-only" + +readShpBlock :: ShpHandle -> Integer -> Int -> IO BS.ByteString +readShpBlock shp pos len = withShpFile shp ReadMode $ \file -> do + hSeek file AbsoluteSeek pos + BS.hGet file len + +openShp :: FilePath -> Bool -> IO ShpHandle +openShp file shpReadOnly = do + let mode | shpReadOnly = ReadMode + | otherwise = ReadWriteMode + shpFile <- openBinaryFile file mode + shxHandle <- openShx (file `replaceExtension` "shx") shpReadOnly + dbfHandle <- openDbf (file `replaceExtension` "dbf") shpReadOnly + + shpLock <- newRWLockIO + return ShpHandle + { shpReadOnly = shpReadOnly + , shpLock = shpLock + , shpFile = shpFile + , shxHandle = shxHandle + , dbfHandle = dbfHandle + } + +closeShp :: ShpHandle -> IO () +closeShp shp = do + withShpFile_ shp WriteMode hClose + closeShx (shxHandle shp) + closeDbf (dbfHandle shp) + +shpIsOpen :: ShpHandle -> IO Bool +shpIsOpen ShpHandle{..} = hIsOpen shpFile + +shpHeader :: ShpHandle -> IO ShpFileHeader +shpHeader shp = do + hdr <- readShpBlock shp 0 100 + return (runGet getShpFileHeader hdr) + +shpDbfFields :: ShpHandle -> IO [DbfFieldHandle] +shpDbfFields = dbfFields . dbfHandle + +getShpRecord :: ShpHandle -> Int -> IO (ShpRec, Maybe DbfRecHandle) +getShpRecord shp n = do + shxRec <- getShxRecord (shxHandle shp) n + rec <- readShpBlock shp (shxOffsetBytes shxRec) (8 + fromInteger (shxLengthBytes shxRec)) + dbfRec <- dbfGetRecord (dbfHandle shp) (toInteger n) + return (runGet getShpRec rec, dbfRec) + diff --git a/src/Database/Shapefile/Shx.hs b/src/Database/Shapefile/Shx.hs new file mode 100644 --- /dev/null +++ b/src/Database/Shapefile/Shx.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE RecordWildCards #-} +module Database.Shapefile.Shx where + +import Database.Shapefile.Shp + +import Data.Word +import Data.Binary.Get +import Data.Binary.Put +import Data.List +import Control.Monad + +-- |offset and length of corresponding shape in 16-bit words +data ShxRec = ShxRec + { -- |Offset of the corresponding ShpRec in 16-bit words + shxOffset :: Word32 + , -- |Length of the corresponding ShpRec in 16-bit words + shxLength :: Word32 + } deriving (Eq, Show) + +-- |Construct a 'ShxRec' given the record offset and length in bytes +shxRecBytes :: Integer -> Integer -> ShxRec +shxRecBytes offBytes lenBytes + | odd offBytes = error "shxRecBytes: odd byte offset" + | offBytes > big = error "shxRecBytes: offset too large for Word32" + | odd lenBytes = error "shxRecBytes: odd byte length" + | lenBytes > big = error "shxRecBytes: length too large for Word32" + | otherwise = ShxRec (b2w offBytes) (b2w lenBytes) + where + big = 2 * toInteger (maxBound :: Word32) + b2w x = fromInteger (x `div` 2) + +shxOffsetBytes :: ShxRec -> Integer +shxOffsetBytes = (*2) . toInteger . shxOffset +shxLengthBytes :: ShxRec -> Integer +shxLengthBytes = (*2) . toInteger . shxLength + +putShxRec :: ShxRec -> Put +putShxRec ShxRec {..} = do + {- 0: Offset -} putWord32be shxOffset + {- 4: Length -} putWord32be shxLength + {- 8 bytes total -} + +getShxRec :: Get ShxRec +getShxRec = do + {- 0: Offset -} shxOffset <- getWord32be + {- 4: Length -} shxLength <- getWord32be + {- 8 bytes total -} return ShxRec + { shxOffset = shxOffset + , shxLength = shxLength + } + +-- |Construct an index for the provided .shp file contents +shxFromShp :: ShpFileHeader -> [ShpRec] -> (ShpFileHeader, [ShxRec]) +shxFromShp shpHdr shpRecs = (shxHdr, shxRecs) + where + nRecs = genericLength shpRecs + shxHdr = shpHdr { shpFileLength = 50 + nRecs * 4} + (shpFileLen, shxRecs) = mapAccumL mkShxRec 50 shpRecs + shpLen = shpRecSize . shpRecHdr + + mkShxRec off shp = let len = shpLen shp in (off + 4 + len, ShxRec off len) + +putShxFile :: ShpFileHeader -> [ShxRec] -> Put +putShxFile shxHdr shxRecs = do + putShpFileHeader shxHdr + mapM_ putShxRec shxRecs + +getShxFile :: Get (ShpFileHeader, [ShxRec]) +getShxFile = do + shxHdr <- getShpFileHeader + let nWords = shpFileLength shxHdr + divExact p q = case p `divMod` q of + (d,0) -> return d + _ -> fail ("getShxFile: size in header does not make sense (" ++ show p ++ " words)") + + nRecs <- (nWords - 50) `divExact` 4 + shxRecs <- replicateM (fromIntegral nRecs) getShxRec + return (shxHdr, shxRecs) diff --git a/src/Database/Shapefile/Shx/Handle.hs b/src/Database/Shapefile/Shx/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Database/Shapefile/Shx/Handle.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE RecordWildCards #-} +-- |Primarily for use internally by 'ShpHandle'. +-- Each 'ShpHandle' has an 'ShxHandle' that it uses to lookup arbitrary shape +-- records from the .shp file. +module Database.Shapefile.Shx.Handle + ( ShxHandle + , openShx + , closeShx + , shxIsOpen + , shxHeader + , getShxRecord + ) where + +import Database.Shapefile.Shp +import Database.Shapefile.Shx + +import System.IO +import Control.Concurrent.RWLock +import qualified Data.ByteString.Lazy as BS +import Data.Binary.Get + +data ShxHandle = ShxHandle + { shxReadOnly :: Bool + , shxLock :: RWLock + , shxFile :: Handle + } + +withShxFile_ :: ShxHandle -> IOMode -> (Handle -> IO a) -> IO a +withShxFile_ ShxHandle{..} mode action = withLock shxLock (action shxFile) + where withLock = case mode of + ReadMode -> withReadLock + _ -> withWriteLock + +withShxFile :: ShxHandle -> IOMode -> (Handle -> IO a) -> IO a +withShxFile shx@ShxHandle{..} mode action = case (mode, shxReadOnly) of + (ReadMode, _) -> allow + (_, False) -> allow + (_, True) -> deny + where + allow = withShxFile_ shx mode action + deny = fail "withShxFile: write attempted on shx which was opened as read-only" + +readShxBlock :: ShxHandle -> Integer -> Int -> IO BS.ByteString +readShxBlock shx pos len = withShxFile shx ReadMode $ \file -> do + hSeek file AbsoluteSeek pos + BS.hGet file len + +openShx :: FilePath -> Bool -> IO ShxHandle +openShx file shxReadOnly = do + let mode | shxReadOnly = ReadMode + | otherwise = ReadWriteMode + shxFile <- openBinaryFile file mode + + shxLock <- newRWLockIO + return ShxHandle + { shxReadOnly = shxReadOnly + , shxLock = shxLock + , shxFile = shxFile + } + +closeShx :: ShxHandle -> IO () +closeShx shx = withShxFile_ shx WriteMode hClose + +shxIsOpen :: ShxHandle -> IO Bool +shxIsOpen ShxHandle{..} = hIsOpen shxFile + +shxHeader :: ShxHandle -> IO ShpFileHeader +shxHeader shx = do + hdr <- readShxBlock shx 0 100 + return (runGet getShpFileHeader hdr) + +shxRecPos n = 100 + 8 * toInteger n + +getShxRecord :: ShxHandle -> Int -> IO ShxRec +getShxRecord shx n = do + rec <- readShxBlock shx (shxRecPos n) 8 + return (runGet getShxRec rec)