From d7ca3e73c8282345d9de993a3132d9df1726b2a7 Mon Sep 17 00:00:00 2001 From: Francesco Gazzetta Date: Mon, 14 Mar 2022 16:04:00 +0100 Subject: [PATCH] Free c objects Let's not leak memory! --- src/Data/UCL.hs | 157 ++++++++++++++++++++++++++++++------------------ 1 file changed, 98 insertions(+), 59 deletions(-) diff --git a/src/Data/UCL.hs b/src/Data/UCL.hs index 061a430..4727488 100644 --- a/src/Data/UCL.hs +++ b/src/Data/UCL.hs @@ -10,9 +10,9 @@ module Data.UCL import Foreign.C ( CUInt(..), CInt(..), CSize(..), CDouble(..), CString, CStringLen - , newCString, newCStringLen, peekCString ) -import Foreign.Ptr (Ptr) -import System.IO.Unsafe (unsafePerformIO) + , withCString, withCStringLen, peekCString ) +import Foreign.Ptr (Ptr, FunPtr) +import Foreign.ForeignPtr import qualified Data.Text.Foreign as TF import Data.Text (Text) import qualified Data.Map as Map @@ -22,9 +22,12 @@ import Data.ByteString (ByteString, useAsCStringLen) import Control.Monad ((>=>)) -newtype ParserHandle = ParserHandle (Ptr ()) -newtype UCLObjectHandle = UCLObjectHandle (Ptr ()) -newtype UCLIterHandle = UCLIterHandle (Ptr ()) +-- Low-level bindings +--------------------- + +data Parser +data UCLObject +data UCLIter type UCL_TYPE = CUInt pattern UCL_OBJECT :: UCL_TYPE @@ -46,23 +49,49 @@ pattern UCL_USERDATA = 7 pattern UCL_NULL :: UCL_TYPE pattern UCL_NULL = 8 +foreign import ccall "ucl_parser_new" ucl_parser_new :: CInt -> IO (Ptr Parser) +foreign import ccall "ucl_parser_add_string" ucl_parser_add_string :: Ptr Parser -> CString -> CSize -> IO Bool +foreign import ccall "ucl_parser_add_file" ucl_parser_add_file :: Ptr Parser -> CString -> IO Bool +foreign import ccall "ucl_parser_get_object" ucl_parser_get_object :: Ptr Parser -> IO (Ptr UCLObject) +foreign import ccall "ucl_parser_get_error" ucl_parser_get_error :: Ptr Parser -> IO CString +foreign import ccall "&ucl_parser_free" p_ucl_parser_free :: FunPtr (Ptr Parser -> IO ()) + +foreign import ccall "ucl_object_iterate_new" ucl_object_iterate_new :: Ptr UCLObject -> IO (Ptr UCLIter) +foreign import ccall "ucl_object_iterate_safe" ucl_object_iterate_safe :: Ptr UCLIter -> Bool -> IO (Ptr UCLObject) +foreign import ccall "&ucl_object_iterate_free" p_ucl_object_iterate_free :: FunPtr (Ptr UCLIter -> IO ()) +foreign import ccall "ucl_object_type" ucl_object_type :: Ptr UCLObject -> IO UCL_TYPE +foreign import ccall "ucl_object_key" ucl_object_key :: Ptr UCLObject -> IO CString +foreign import ccall "ucl_object_toint" ucl_object_toint :: Ptr UCLObject -> IO CInt +foreign import ccall "ucl_object_todouble" ucl_object_todouble :: Ptr UCLObject -> IO CDouble +foreign import ccall "ucl_object_tostring" ucl_object_tostring :: Ptr UCLObject -> IO CString +foreign import ccall "ucl_object_toboolean" ucl_object_toboolean :: Ptr UCLObject -> IO Bool +foreign import ccall "&ucl_object_unref" p_ucl_object_unref :: FunPtr (Ptr UCLObject -> IO ()) + +foreign import ccall "strlen" c_strlen :: CString -> IO CSize -foreign import ccall "ucl_parser_new" ucl_parser_new :: CInt -> IO ParserHandle -foreign import ccall "ucl_parser_add_string" ucl_parser_add_string :: ParserHandle -> CString -> CSize -> IO Bool -foreign import ccall "ucl_parser_add_file" ucl_parser_add_file :: ParserHandle -> CString -> IO Bool -foreign import ccall "ucl_parser_get_object" ucl_parser_get_object :: ParserHandle -> IO UCLObjectHandle -foreign import ccall "ucl_parser_get_error" ucl_parser_get_error :: ParserHandle -> IO CString -foreign import ccall "ucl_object_iterate_new" ucl_object_iterate_new :: UCLObjectHandle -> IO UCLIterHandle -foreign import ccall "ucl_object_iterate_safe" ucl_object_iterate_safe :: UCLIterHandle -> Bool -> IO UCLObjectHandle -foreign import ccall "ucl_object_type" ucl_object_type :: UCLObjectHandle -> UCL_TYPE -foreign import ccall "ucl_object_key" ucl_object_key :: UCLObjectHandle -> CString -foreign import ccall "ucl_object_toint" ucl_object_toint :: UCLObjectHandle -> CInt -foreign import ccall "ucl_object_todouble" ucl_object_todouble :: UCLObjectHandle -> CDouble -foreign import ccall "ucl_object_tostring" ucl_object_tostring :: UCLObjectHandle -> CString -foreign import ccall "ucl_object_toboolean" ucl_object_toboolean :: UCLObjectHandle -> Bool +-- Mid level interface with ForeignPtr +-------------------------------------- -foreign import ccall "strlen" c_strlen :: CString -> IO CSize +newParser :: IO (ForeignPtr Parser) +newParser = ucl_parser_new 0x0 >>= newForeignPtr p_ucl_parser_free + +addString :: ForeignPtr Parser -> CStringLen -> IO Bool +addString fp (cs, len) = withForeignPtr fp $ \p -> + ucl_parser_add_string p cs $ fromIntegral len + +addFile :: ForeignPtr Parser -> FilePath -> IO Bool +addFile fp s = withCString s $ \cs -> + withForeignPtr fp $ \p -> ucl_parser_add_file p cs + +getObject :: ForeignPtr Parser -> IO (ForeignPtr UCLObject) +getObject = (`withForeignPtr` ucl_parser_get_object) >=> newForeignPtr p_ucl_object_unref + +getError :: ForeignPtr Parser -> IO String +getError = (`withForeignPtr` (ucl_parser_get_error >=> peekCString)) + +newIterator :: Ptr UCLObject -> IO (ForeignPtr UCLIter) +newIterator = ucl_object_iterate_new >=> newForeignPtr p_ucl_object_iterate_free peekCStringText :: CString -> IO Text @@ -98,15 +127,10 @@ parseByteString bs = useAsCStringLen bs parseCStringLen -- read files, make http requests, do "billion laughs" attacks, and possibly -- crash the parser. parseString :: String -> IO (Either String UCL) -parseString = newCStringLen >=> parseCStringLen +parseString = (`withCStringLen` parseCStringLen) parseCStringLen :: CStringLen -> IO (Either String UCL) -parseCStringLen (cs, len) = do - p <- ucl_parser_new 0x0 - didParse <- ucl_parser_add_string p cs $ fromIntegral len - if didParse - then Right . handleToUCL <$> ucl_parser_get_object p - else Left <$> (ucl_parser_get_error p >>= peekCString) +parseCStringLen = parseWith addString -- | Parse the contents of a file into a 'UCL', resolving includes, macros, -- variables... @@ -115,13 +139,15 @@ parseCStringLen (cs, len) = do -- read files, make http requests, do "billion laughs" attacks, and possibly -- crash the parser. parseFile :: FilePath -> IO (Either String UCL) -parseFile s = do - cs <- newCString s - p <- ucl_parser_new 0x0 - didParse <- ucl_parser_add_file p cs - if didParse - then Right . handleToUCL <$> ucl_parser_get_object p - else Left <$> (ucl_parser_get_error p >>= peekCString) +parseFile = parseWith addFile + +parseWith :: (ForeignPtr Parser -> a -> IO Bool) -> a -> IO (Either String UCL) +parseWith addX x = do + p <- newParser + didParse <- addX p x + if didParse + then Right <$> (getObject p >>= flip withForeignPtr foreignToUCL) + else Left <$> getError p -- | An UCL object data UCL = UCLMap (Map Text UCL) @@ -133,40 +159,53 @@ data UCL = UCLMap (Map Text UCL) | UCLTime DiffTime deriving (Show, Eq, Ord) -handleToUCL :: UCLObjectHandle -> UCL -handleToUCL o = typedHandleToUCL (ucl_object_type o) o - -typedHandleToUCL :: UCL_TYPE -> UCLObjectHandle -> UCL -typedHandleToUCL UCL_OBJECT obj = UCLMap $ uclObjectToMap obj -typedHandleToUCL UCL_ARRAY obj = UCLArray $ uclArrayToList obj -typedHandleToUCL UCL_INT obj = UCLInt $ fromIntegral $ ucl_object_toint obj -typedHandleToUCL UCL_FLOAT obj = UCLDouble $ realToFrac $ ucl_object_todouble obj -typedHandleToUCL UCL_STRING obj = UCLText $ unsafePerformIO $ peekCStringText $ ucl_object_tostring obj -typedHandleToUCL UCL_BOOLEAN obj = UCLBool $ ucl_object_toboolean obj -typedHandleToUCL UCL_TIME obj = UCLTime $ realToFrac $ ucl_object_todouble obj +foreignToUCL :: Ptr UCLObject -> IO UCL +foreignToUCL obj = do + ty <- ucl_object_type obj + typedHandleToUCL ty obj + +typedHandleToUCL :: UCL_TYPE -> Ptr UCLObject -> IO UCL +typedHandleToUCL UCL_OBJECT obj = UCLMap <$> uclObjectToMap obj +typedHandleToUCL UCL_ARRAY obj = UCLArray <$> uclArrayToList obj +typedHandleToUCL UCL_INT obj = UCLInt . fromIntegral <$> ucl_object_toint obj +typedHandleToUCL UCL_FLOAT obj = UCLDouble . realToFrac <$> ucl_object_todouble obj +typedHandleToUCL UCL_STRING obj = UCLText <$> (ucl_object_tostring obj >>= peekCStringText) +typedHandleToUCL UCL_BOOLEAN obj = UCLBool <$> ucl_object_toboolean obj +typedHandleToUCL UCL_TIME obj = UCLTime . realToFrac <$> ucl_object_todouble obj +-- TODO use Left instead of error typedHandleToUCL UCL_USERDATA _ = error "Userdata object" typedHandleToUCL UCL_NULL _ = error "Null object" typedHandleToUCL _ _ = error "Unknown Type" -uclObjectToMap :: UCLObjectHandle -> Map Text UCL -uclObjectToMap o = unsafePerformIO $ do - iter <- ucl_object_iterate_new o +uclObjectToMap :: Ptr UCLObject -> IO (Map Text UCL) +uclObjectToMap o = do + iter <- newIterator o go iter Map.empty where go it m = do - obj <- ucl_object_iterate_safe it True - case ucl_object_type obj of + -- NOTE: the reference count of the returned object is not increased, + -- so we don't use ForeignPtr + obj <- withForeignPtr it (`ucl_object_iterate_safe` True) + ty <- ucl_object_type obj + case ty of + -- FIXME this is not how we check for end of object UCL_NULL -> pure m - _ -> go it $ Map.insert (getUclKey obj) (handleToUCL obj) m - getUclKey obj = unsafePerformIO $ peekCStringText $ ucl_object_key obj - -uclArrayToList :: UCLObjectHandle -> [UCL] -uclArrayToList o = unsafePerformIO $ do - iter <- ucl_object_iterate_new o + _ -> do + k <- ucl_object_key obj >>= peekCStringText + v <- foreignToUCL obj + go it $ Map.insert k v m + +uclArrayToList :: Ptr UCLObject -> IO [UCL] +uclArrayToList o = do + iter <- newIterator o go iter where go it = do - obj <- ucl_object_iterate_safe it True - case ucl_object_type obj of + -- NOTE: the reference count of the returned object is not increased + -- so we don't use ForeignPtr + obj <- withForeignPtr it (`ucl_object_iterate_safe` True) + ty <- ucl_object_type obj + case ty of + -- FIXME this is not how we check for end of object UCL_NULL -> pure [] - _ -> (handleToUCL obj :) <$> go it + _ -> (:) <$> foreignToUCL obj <*> go it -- 2.45.2