packages feed

shapefile (empty) → 0.0.0.1

raw patch · 9 files changed

+618/−0 lines, 9 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, data-binary-ieee754, dbf, filepath, rwlock

Files

+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ shapefile.cabal view
@@ -0,0 +1,32 @@+name:                   shapefile+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/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
+ src/Database/Shapefile.hs view
@@ -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))
+ src/Database/Shapefile/Misc.hs view
@@ -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)+
+ src/Database/Shapefile/ShapeTypes.hs view
@@ -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
+ src/Database/Shapefile/Shp.hs view
@@ -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)+
+ src/Database/Shapefile/Shp/Handle.hs view
@@ -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)+
+ src/Database/Shapefile/Shx.hs view
@@ -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)
+ src/Database/Shapefile/Shx/Handle.hs view
@@ -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)