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
{
shpFileLength :: Word32
, shpFileShapeType :: ESRIShapeType
, shpFileBBox :: BBox (Double, Double)
, shpFileZBnd :: Maybe (Double, Double)
, shpFileMBnd :: Maybe (Double, Double)
} deriving (Eq, Show)
shpFileLengthBytes :: ShpFileHeader -> Integer
shpFileLengthBytes = (2*) . toInteger . shpFileLength
putShpFileHeader :: ShpFileHeader -> Put
putShpFileHeader ShpFileHeader {..} = do
putWord32be 9994
putWord32be 0
putWord32be 0
putWord32be 0
putWord32be 0
putWord32be 0
putWord32be shpFileLength
putWord32le 1000
putShapeType32le shpFileShapeType
putBBox (putPair putFloat64le) shpFileBBox
putPair putFloat64le (fromMaybe (0,0) shpFileZBnd)
putPair putFloat64le (fromMaybe (0,0) shpFileMBnd)
getShpFileHeader :: Get ShpFileHeader
getShpFileHeader = do
getWord32be `expecting` 9994
getWord32be `expecting` 0
getWord32be `expecting` 0
getWord32be `expecting` 0
getWord32be `expecting` 0
getWord32be `expecting` 0
shpFileLength <- getWord32be
getWord32le `expecting` 1000
shpFileShapeType <- getShapeType32le
shpFileBBox <- getBBox (getPair getFloat64le)
shpFileZBnd <- getPair getFloat64le
shpFileMBnd <- getPair getFloat64le
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
{
shpRecNum :: Word32
,
shpRecSize :: Word32
} deriving (Eq, Show)
shpRecSizeBytes :: ShpRecHeader -> Integer
shpRecSizeBytes = (*2) . toInteger . shpRecSize
putShpRecHeader :: ShpRecHeader -> Put
putShpRecHeader ShpRecHeader {..} = do
putWord32be shpRecNum
putWord32be shpRecSize
getShpRecHeader :: Get ShpRecHeader
getShpRecHeader = do
shpRecNum <- getWord32be
shpRecSize <- getWord32be
return ShpRecHeader
{ shpRecNum = shpRecNum
, shpRecSize = shpRecSize
}
data ShpRec = ShpRec
{ shpRecHdr :: ShpRecHeader
, shpRecData :: BS.ByteString
} deriving (Eq, Show)
shpRecTotalSizeBytes :: ShpRec -> Integer
shpRecTotalSizeBytes = (8 +) . shpRecSizeBytes . shpRecHdr
shpRecShapeType :: ShpRec -> ESRIShapeType
shpRecShapeType ShpRec{..}
| BS.length shpRecData < 4 = NullShape
| otherwise = runGet getShapeType32le shpRecData
mkShpRecs :: [BS.ByteString] -> [ShpRec]
mkShpRecs recData = zipWith mkShpRec [1..] recData
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
putShpRecHeader shpRecHdr
putLazyByteString shpRecData
getShpRec :: Get ShpRec
getShpRec = do
shpRecHdr@ShpRecHeader {shpRecSize = len} <- getShpRecHeader
shpRecData <- getLazyByteString (2 * fromIntegral len)
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)