diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Richard Cook + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/hgeos.cabal b/hgeos.cabal new file mode 100644 --- /dev/null +++ b/hgeos.cabal @@ -0,0 +1,48 @@ +name: hgeos +version: 0.1.0.0 +synopsis: Haskell bindings to GEOS C API +description: Please see README.md +homepage: https://github.com/rcook/hgeos#readme +license: MIT +license-file: LICENSE +author: Richard Cook +maintainer: rcook@rcook.org +copyright: 2016 Richard Cook +category: Web +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/rcook/hgeos.git + +library + hs-source-dirs: src/lib + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + extra-libraries: geos_c + c-sources: src/lib/helpers.c + includes: src/lib/helpers.h + cc-options: -std=c99 -pthread + exposed-modules: Data.Geolocation.GEOS + , Data.Geolocation.GEOS.Imports + if os(windows) + include-dirs: C:/OSGeo4W64/include + extra-lib-dirs: C:/OSGeo4W64/lib + +executable hgeos + hs-source-dirs: src/app + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , hgeos + other-modules: Main + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + default-language: Haskell2010 + build-depends: Glob + , base >= 4.7 && < 5 + , doctest diff --git a/src/app/Main.hs b/src/app/Main.hs new file mode 100644 --- /dev/null +++ b/src/app/Main.hs @@ -0,0 +1,63 @@ +module Main (main) where + +import Control.Exception +import Data.Geolocation.GEOS +import Data.Geolocation.GEOS.Imports +import Foreign.C +import Foreign.Ptr + +-- Demonstrates direct use of imports +-- Lifetimes of various GEOS objects, including readers, writers and +-- geometries, must be managed explicitly by clients using explicit calls to +-- various destroy/free functions +lowLevelAPIDemo :: IO () +lowLevelAPIDemo = do + wkt0 <- newCString "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" + wkt1 <- newCString "POLYGON (( 11 11, 11 12, 12 12, 12 11, 11 11 ))" + + withGEOS $ \ctx -> do + withWKTReader ctx $ \reader -> do + withGeometry ctx reader wkt0 $ \g0 -> do + withGeometry ctx reader wkt1 $ \g1 -> do + bracket (c_GEOSIntersection_r ctx g0 g1) (c_GEOSGeom_destroy_r ctx) $ \g2 -> do + withWKTWriter ctx $ \writer -> do + str <- bracket + (c_GEOSWKTWriter_write_r ctx writer g2) + (c_GEOSFree_r_CChar ctx) + peekCString + putStrLn str + putStrLn "lowLevelAPIDemo done" + where + withGEOS :: (GEOSContextHandle_t -> IO a) -> IO a + withGEOS = bracket c_initializeGEOSWithHandlers c_uninitializeGEOS + withWKTReader :: GEOSContextHandle_t -> (GEOSWKTReaderPtr -> IO a) -> IO a + withWKTReader ctx = bracket (c_GEOSWKTReader_create_r ctx) (c_GEOSWKTReader_destroy_r ctx) + withWKTWriter :: GEOSContextHandle_t -> (GEOSWKTWriterPtr -> IO a) -> IO a + withWKTWriter ctx = bracket (c_GEOSWKTWriter_create_r ctx) (c_GEOSWKTWriter_destroy_r ctx) + withGeometry :: GEOSContextHandle_t -> GEOSWKTReaderPtr -> CString -> (GEOSGeometryPtr -> IO a) -> IO a + withGeometry ctx reader wkt = + bracket + (c_GEOSWKTReader_read_r ctx reader wkt) + (c_GEOSGeom_destroy_r ctx) + +-- Demonstrates use of high-level API +-- Lifetimes of GEOS objects are automatically managed by the context objects +-- which guarantees that they are released when the context goes out of scope +highLevelAPIDemo :: IO () +highLevelAPIDemo = do + withContext $ \ctx -> do + reader <- mkReader ctx + g0 <- readGeometry reader "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" + g1 <- readGeometry reader "POLYGON (( 11 11, 11 12, 12 12, 12 11, 11 11 ))" + g2 <- intersection g0 g1 + writer <- mkWriter ctx + str <- writeGeometry writer g2 + putStrLn str + putStrLn "highLevelAPIDemo done" + +main :: IO () +main = do + s <- peekCString c_GEOSversion + putStrLn s + lowLevelAPIDemo + highLevelAPIDemo diff --git a/src/lib/Data/Geolocation/GEOS.hs b/src/lib/Data/Geolocation/GEOS.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Geolocation/GEOS.hs @@ -0,0 +1,197 @@ +{-| +Module : Data.Geolocation.GEOS +Description : High-level API for interoperating with GEOS C API +Copyright : (C) Richard Cook, 2016 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : experimental +Portability : POSIX + +A high-level API for interoperating with GEOS C API which includes automatic +management of lifetimes of objects such as readers, writers and geometries. + +For the low-level FFI bindings, see "Data.Geolocation.GEOS.Imports". +-} + +{-# LANGUAGE RecordWildCards #-} + +module Data.Geolocation.GEOS + ( Context() + , Geometry() + , Reader() + , Writer() + , intersection + , mkReader + , mkWriter + , readGeometry + , withContext + , writeGeometry + ) where + +import Control.Exception +import Data.Geolocation.GEOS.Imports +import Data.IORef +import Foreign.C + +data ContextState = ContextState + { hCtx :: GEOSContextHandle_t + , hReaders :: [GEOSWKTReaderPtr] + , hWriters :: [GEOSWKTWriterPtr] + , hGeometries :: [GEOSGeometryPtr] + } + +type ContextStateRef = IORef ContextState + +-- |Represents a context +data Context = Context ContextStateRef + +-- |Represents a reader +data Reader = Reader ContextStateRef GEOSWKTReaderPtr + +-- |Represents a writer +data Writer = Writer ContextStateRef GEOSWKTWriterPtr + +-- |Represents a geometry +data Geometry = Geometry ContextStateRef GEOSGeometryPtr + +mkContext :: IO Context +mkContext = do + hCtx <- c_initializeGEOSWithHandlers + sr <- newIORef $ ContextState hCtx [] [] [] + return $ Context sr + +releaseContext :: Context -> IO () +releaseContext (Context sr) = do + ContextState{..} <- readIORef sr + mapM_ (c_GEOSGeom_destroy_r hCtx) hGeometries + mapM_ (c_GEOSWKTWriter_destroy_r hCtx) hWriters + mapM_ (c_GEOSWKTReader_destroy_r hCtx) hReaders + c_uninitializeGEOS hCtx + +-- |Creates a context, passes it to a block +-- and releases the context and all associated objects such as readers, writers +-- and geometries at the end: +-- +-- @ +-- withContext $ \ctx -> do +-- +-- -- Use context +-- +-- return () +-- @ +withContext :: (Context -> IO a) -> IO a +withContext = bracket mkContext releaseContext + +-- |Creates a reader used to deserialize 'Geometry' instances from +-- -format text: +-- +-- @ +-- withContext $ \ctx -> do +-- reader <- mkReader ctx +-- +-- -- Use reader +-- +-- return () +-- @ +-- +-- The reader is associated with the 'Context' and released when the 'Context' +-- is released. +mkReader :: Context -> IO Reader +mkReader (Context sr) = do + ContextState{..} <- readIORef sr + hReader <- c_GEOSWKTReader_create_r hCtx + modifyIORef' sr (\p@ContextState{..} -> p { hReaders = hReader : hReaders }) + return $ Reader sr hReader + +-- |Creates a writer used to serialize 'Geometry' instances to +-- -format text: +-- +-- @ +-- withContext $ \ctx -> do +-- writer <- mkWriter ctx +-- +-- -- Use writer +-- +-- return () +-- @ +-- +-- The writer is associated with the 'Context' and released when the 'Context' +-- is released. +mkWriter :: Context -> IO Writer +mkWriter (Context sr) = do + ContextState{..} <- readIORef sr + hWriter <- c_GEOSWKTWriter_create_r hCtx + modifyIORef' sr (\p@ContextState{..} -> p { hWriters = hWriter : hWriters }) + return $ Writer sr hWriter + +-- |Deserializes a 'Geometry' instance from the given 'String' using the +-- supplied 'Reader': +-- +-- @ +-- withContext $ \ctx -> do +-- reader <- mkReader ctx +-- geometry <- readGeometry read "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" +-- +-- -- Use geometry +-- +-- return () +-- @ +-- +-- The geometry is associated with the 'Context' and released when the 'Context' +-- is released. +readGeometry :: Reader -> String -> IO Geometry +readGeometry (Reader sr hReader) str = withCString str $ \cs -> do + ContextState{..} <- readIORef sr + hGeometry <- c_GEOSWKTReader_read_r hCtx hReader cs + modifyIORef' sr (\p@ContextState{..} -> p { hGeometries = hGeometry : hGeometries }) + return $ Geometry sr hGeometry + +-- |Serializes a 'Geometry' instance to a 'String' using the supplied 'Writer': +-- +-- @ +-- withContext $ \ctx -> do +-- reader <- mkReader ctx +-- geometry <- readGeometry read "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" +-- +-- writer <- mkWriter ctx +-- str <- writeGeometry writer geometry +-- +-- -- Use string +-- +-- return () +-- @ +-- +-- The geometry is associated with the 'Context' and released when the 'Context' +-- is released. +writeGeometry :: Writer -> Geometry -> IO String +writeGeometry (Writer sr hWriter) (Geometry _ hGeometry) = do + ContextState{..} <- readIORef sr + str <- bracket + (c_GEOSWKTWriter_write_r hCtx hWriter hGeometry) + (c_GEOSFree_r_CChar hCtx) + peekCString + return str + +-- |Returns the 'Geometry' instance representing the intersection of the two +-- supplied 'Geometry' instances: +-- +-- @ +-- withContext $ \ctx -> do +-- reader <- mkReader ctx +-- g0 <- readGeometry reader "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" +-- g1 <- readGeometry reader "POLYGON (( 11 11, 11 12, 12 12, 12 11, 11 11 ))" +-- +-- g2 <- intersection g0 g1 +-- +-- -- Use geometry +-- +-- putStrLn str +-- @ +-- +-- The geometry is associated with the 'Context' and released when the 'Context' +-- is released. +intersection :: Geometry -> Geometry -> IO Geometry +intersection (Geometry sr0 hGeometry0) (Geometry sr1 hGeometry1) = do + ContextState{..} <- readIORef sr0 + hGeometry <- c_GEOSIntersection_r hCtx hGeometry0 hGeometry1 + return $ Geometry sr0 hGeometry diff --git a/src/lib/Data/Geolocation/GEOS/Imports.hs b/src/lib/Data/Geolocation/GEOS/Imports.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Geolocation/GEOS/Imports.hs @@ -0,0 +1,89 @@ +{-| +Module : Data.Geolocation.GEOS.Imports +Description : FFI bindings for GEOS C API +Copyright : (C) Richard Cook, 2016 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : experimental +Portability : POSIX + +These are low-level FFI bindings for the GEOS C API derived from +. These enable +low-level access to the native functions for parts of the C API for which +high-level wrappers do not yet exist. + +For the high-level API, see "Data.Geolocation.GEOS". +-} + +module Data.Geolocation.GEOS.Imports where + +import Foreign.C +import Foreign.Ptr + +-- |Wraps @GEOSContextHandle_t@ +newtype GEOSContextHandle_t = GEOSContextHandle_t (Ptr GEOSContextHandle_t) + +-- |Wraps @GEOSGeometry*@ +newtype GEOSGeometryPtr = GEOSGeometryPtr (Ptr GEOSGeometryPtr) + +-- |Wraps @GEOSWKTReader*@ +newtype GEOSWKTReaderPtr = GEOSWKTReaderPtr (Ptr GEOSWKTReaderPtr) + +-- |Wraps @GEOSWKTWriter*@ +newtype GEOSWKTWriterPtr = GEOSWKTWriterPtr (Ptr GEOSWKTWriterPtr) + +-- |Wraps @GEOSversion@ +foreign import ccall "GEOSversion" + c_GEOSversion :: CString + +-- |Wraps @GEOSFree_r@ specialized to @const char*@ +foreign import ccall "GEOSFree_r" + c_GEOSFree_r_CChar :: GEOSContextHandle_t -> Ptr CChar -> IO () + +-- |Wraps @initializeGEOSWithHandlers@ helper function +foreign import ccall "helpers.h initializeGEOSWithHandlers" + c_initializeGEOSWithHandlers :: IO GEOSContextHandle_t + +-- |Wraps @uninitializeGEOS@ helper function +foreign import ccall "helpers.h uninitializeGEOS" + c_uninitializeGEOS :: GEOSContextHandle_t -> IO () + +-- |Wraps @getNoticeMessage@ helper function +foreign import ccall "helpers.h getNoticeMessage" + c_getNoticeMessage :: IO CString + +-- |Wraps @getErrorMessage@ helper function +foreign import ccall "helpers.h getErrorMessage" + c_getErrorMessage :: IO CString + +-- |Wraps @GEOSGeom_destroy_r@ +foreign import ccall "GEOSGeom_destroy_r" + c_GEOSGeom_destroy_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO () + +-- |Wraps @GEOSWKTReader_create_r@ +foreign import ccall "GEOSWKTReader_create_r" + c_GEOSWKTReader_create_r :: GEOSContextHandle_t -> IO GEOSWKTReaderPtr + +-- |Wraps @GEOSWKTReader_destroy_r@ +foreign import ccall "GEOSWKTReader_destroy_r" + c_GEOSWKTReader_destroy_r :: GEOSContextHandle_t -> GEOSWKTReaderPtr -> IO () + +-- |Wraps @GEOSWKTReader_read_r@ +foreign import ccall "GEOSWKTReader_read_r" + c_GEOSWKTReader_read_r :: GEOSContextHandle_t -> GEOSWKTReaderPtr -> CString -> IO GEOSGeometryPtr + +-- |Wraps @GEOSWKTWriter_create_r@ +foreign import ccall "GEOSWKTWriter_create_r" + c_GEOSWKTWriter_create_r :: GEOSContextHandle_t -> IO GEOSWKTWriterPtr + +-- |Wraps @GEOSWKTWriter_destroy_r@ +foreign import ccall "GEOSWKTWriter_destroy_r" + c_GEOSWKTWriter_destroy_r :: GEOSContextHandle_t -> GEOSWKTWriterPtr -> IO () + +-- |Wraps @GEOSWKTWriter_write_r@ +foreign import ccall "GEOSWKTWriter_write_r" + c_GEOSWKTWriter_write_r :: GEOSContextHandle_t -> GEOSWKTWriterPtr -> GEOSGeometryPtr -> IO CString + +-- |Wraps @GEOSIntersection_r@ +foreign import ccall "GEOSIntersection_r" + c_GEOSIntersection_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> GEOSGeometryPtr -> IO GEOSGeometryPtr diff --git a/src/lib/helpers.c b/src/lib/helpers.c new file mode 100644 --- /dev/null +++ b/src/lib/helpers.c @@ -0,0 +1,48 @@ +#include "helpers.h" +#include +#include +#include + +//#define TRACE(message) printf(message "\n") +#define TRACE(message) do {} while (0) + +__thread char g_noticeMessage[256]; +static const size_t s_noticeMessageLen = sizeof(g_noticeMessage) / sizeof(g_noticeMessage[0]); +__thread char g_errorMessage[256]; +static const size_t s_errorMessageLen = sizeof(g_errorMessage) / sizeof(g_errorMessage[0]); + +static void noticeHandler(const char* format, ...) +{ + va_list args; + va_start(args, format); + vsnprintf(g_noticeMessage, s_noticeMessageLen, format, args); + va_end(args); +} + +static void errorHandler(const char* format, ...) +{ + va_list args; + va_start(args, format); + vsnprintf(g_errorMessage, s_errorMessageLen, format, args); + va_end(args); +} + +GEOSContextHandle_t initializeGEOSWithHandlers() +{ + return initGEOS_r(noticeHandler, errorHandler); +} + +void uninitializeGEOS(GEOSContextHandle_t handle) +{ + finishGEOS_r(handle); +} + +const char* getNoticeMessage() +{ + return g_noticeMessage; +} + +const char* getErrorMessage() +{ + return g_errorMessage; +} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import qualified System.FilePath.Glob as Glob +import qualified Test.DocTest as DocTest + +includeDirs :: [String] +includeDirs = [] + +doctestWithIncludeDirs :: [String] -> IO () +doctestWithIncludeDirs fs = DocTest.doctest (map ("-I" ++) includeDirs ++ fs) + +main :: IO () +main = Glob.glob "src/**/*.hs" >>= doctestWithIncludeDirs