Merge pull request #27 from lfborjas/fix-tests-memory-patch

Fix tests, memory patch

.github/workflows/haskell.yml

@@ -4,7 +4,7 @@ on:
   push:
     branches: [ master ]
   pull_request:
-    branches: [ master ]
+    branches: [ master, rc ]
 
 jobs:
   build:

ChangeLog.md

@@ -1,5 +1,14 @@
 # Changelog for swiss-ephemeris
 
+## v1.3.0.1 
+
+A couple of memory safety patches:
+
+* Attempt to rein in memory unsafety by keeping all pointer peeking in IO for gravGroup fns.
+* Always allocate 256 chars for error messages. 
+* [dev] Bundle test ephemeris into the hackage tarball, to allow hackage CI and nixOS to
+  successfully run tests.
+
 ## v1.3.0.0 (2021-06-18)
 
 * **Drops support for base < 4.10**, which effectively excludes GHC versions less

package.yaml

@@ -1,5 +1,5 @@
 name:                swiss-ephemeris
-version:             1.3.0.0
+version:             1.3.0.1
 github:              "lfborjas/swiss-ephemeris"
 license:             AGPL-3
 author:              "Luis Borjas Reyes"
@@ -8,6 +8,7 @@ maintainer:          "[email protected]"
 extra-source-files:
 - README.md
 - ChangeLog.md
+- swedist/sweph_18/*.se1
 
 # Metadata used when publishing your package
 synopsis:            Haskell bindings for the Swiss Ephemeris C library

src/SwissEphemeris.hs

@@ -175,7 +175,7 @@ calculateObliquity time = do
 -- ones!
 calculateCoordinates' :: CalcFlag -> JulianTime -> PlanetNumber -> IO (Either String [Double])
 calculateCoordinates' options time planet =
-  allocaArray 6 $ \coords -> withCAString "" $ \serr -> do
+  allocaArray 6 $ \coords -> allocaErrorMessage $ \serr -> do
     iflgret <-
       c_swe_calc_ut
         (realToFrac . unJulianTime $ time)
@@ -293,7 +293,7 @@ calculateHousePositionSimple sys time loc pos = do
 -- in those cases, see `calculateHousePositionSimple`.
 calculateHousePosition :: HouseSystem -> Double -> GeographicPosition -> ObliquityInformation -> EclipticPosition -> IO (Either String HousePosition)
 calculateHousePosition sys armc' geoCoords obliq eclipticCoords =
-  withArray [realToFrac $ lng eclipticCoords, realToFrac $ lat eclipticCoords] $ \xpin -> withCAString "" $ \serr -> do
+  withArray [realToFrac $ lng eclipticCoords, realToFrac $ lat eclipticCoords] $ \xpin -> allocaErrorMessage $ \serr -> do
     housePos <-
       c_swe_house_pos
         (realToFrac armc')

src/SwissEphemeris/ChartUtils.hs

@@ -111,7 +111,7 @@ gravGroup sz positions sectors =
   unsafePerformIO $ do
     withArray (map (planetPositionToGlyph sz) positions) $ \grobs ->
       withArray (map realToFrac sectors) $ \sbdy ->
-        withCAString "" $ \serr -> do
+        allocaErrorMessage $ \serr -> do
           let nob = fromIntegral $ length positions
               nsectors = fromIntegral $ length sectors - 1
           retval <-
@@ -122,7 +122,8 @@ gravGroup sz positions sectors =
             pure $ Left msg
           else do
             repositioned <- peekArray (fromIntegral  nob) grobs
-            pure . Right $ map glyphInfo repositioned
+            glyphInfos <- mapM glyphInfo repositioned
+            pure . Right $ glyphInfos
 
 -- | /Easy/ version of 'gravGroup' that assumes:
 --
@@ -166,7 +167,7 @@ gravGroup2 sz positions sectors allowShift =
   in unsafePerformIO $ do
     withArray (map (planetPositionToGlyph sz) positions) $ \grobs ->
       withArray (map realToFrac sectors') $ \sbdy ->
-        withCAString "" $ \serr -> do
+        allocaErrorMessage $ \serr -> do
           let nob = fromIntegral $ length positions
               -- empty sector lists are allowed:
               nsectors = max 0 $ fromIntegral $ length sectors - 1
@@ -179,7 +180,8 @@ gravGroup2 sz positions sectors allowShift =
             pure $ Left msg
           else do
             repositioned <- peekArray (fromIntegral  nob) grobs
-            pure . Right $ map glyphInfo repositioned
+            glyphInfos <- mapM glyphInfo repositioned
+            pure . Right $ glyphInfos
 
 
 -- | /Easy/ version of 'gravGroup2', same provisions as 'gravGroupEasy'
@@ -215,8 +217,8 @@ planetPositionToGlyph (lwidth, rwidth) (planet, pos) = unsafePerformIO $ do
       , dp = planetPtr
       }
 
-glyphInfo :: PlanetGlyph -> PlanetGlyphInfo
-glyphInfo GravityObject{pos, lsize, rsize, ppos, sector_no, sequence_no, level_no, scale, dp} = unsafePerformIO $ do
+glyphInfo :: PlanetGlyph -> IO PlanetGlyphInfo
+glyphInfo GravityObject{pos, lsize, rsize, ppos, sector_no, sequence_no, level_no, scale, dp} = do
   planet' <- peek dp
   pure $
     GlyphInfo {

src/SwissEphemeris/Internal.hs

@@ -9,7 +9,7 @@ module SwissEphemeris.Internal where
 
 import Data.Bits
 import Data.Char (ord)
-import Foreign (Int32, castPtr)
+import Foreign (Int32, castPtr, allocaArray, Ptr)
 import Foreign.C.Types
 import Foreign.SwissEphemeris
 import GHC.Generics
@@ -326,3 +326,11 @@ planetNumber p = PlanetNumber $ CInt y
 numberToPlanet :: PlanetNumber -> Planet
 numberToPlanet (PlanetNumber (CInt n)) =
   toEnum . fromIntegral $ n
+
+-- | As per the programmers manual, error output strings
+-- should accommodate at most 256 characters:
+-- see @sweodef.h#266@ and the manual:
+-- https://www.astro.com/swisseph/swephprg.htm
+-- in e.g. 
+allocaErrorMessage :: (Ptr CChar -> IO b) -> IO b
+allocaErrorMessage = allocaArray 256

swiss-ephemeris.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 6c21f106ee90782f9b105cc708ee7e2f928126c74260238af93fb1673b03e365
+-- hash: 72302ec5122b3419ff8eba21d0affbe5a8e9e9839ca792c61e2bcd38b2aff97e
 
 name:           swiss-ephemeris
-version:        1.3.0.0
+version:        1.3.0.1
 synopsis:       Haskell bindings for the Swiss Ephemeris C library
 description:    Please see the README on GitHub at <https://github.com/lfborjas/swiss-ephemeris#readme>
 category:       Data, Astrology
@@ -21,6 +21,9 @@ build-type:     Simple
 extra-source-files:
     README.md
     ChangeLog.md
+    swedist/sweph_18/seas_18.se1
+    swedist/sweph_18/semo_18.se1
+    swedist/sweph_18/sepl_18.se1
 
 source-repository head
   type: git