diff --git a/License b/License new file mode 100644 --- /dev/null +++ b/License @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2024-2026 yaml.com + +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/lib/YAMLStar.hs b/lib/YAMLStar.hs new file mode 100644 --- /dev/null +++ b/lib/YAMLStar.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module YAMLStar + ( YAMLStarError(..) + , loadYAMLStar + , loadYAMLStarAll + , dumpYAMLStar + , dumpYAMLStarAll + , versionYAMLStar + ) where + +import Control.Exception (Exception, throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import YAMLStar.FFI + +data YAMLStarError + = YAMLStarParseError String + | YAMLStarRuntimeError String + | YAMLStarFFIError String + deriving (Show, Eq) + +instance Exception YAMLStarError + +loadYAMLStar :: MonadIO m => T.Text -> m Aeson.Value +loadYAMLStar input = + liftIO $ handleData =<< yamlstarLoadFFI (TE.encodeUtf8 input) + +loadYAMLStarAll :: MonadIO m => T.Text -> m Aeson.Value +loadYAMLStarAll input = + liftIO $ handleData =<< yamlstarLoadAllFFI (TE.encodeUtf8 input) + +dumpYAMLStar :: MonadIO m => Aeson.Value -> m T.Text +dumpYAMLStar value = + liftIO $ handleTextData =<< yamlstarDumpFFI (LBS.toStrict $ Aeson.encode value) + +dumpYAMLStarAll :: MonadIO m => Aeson.Value -> m T.Text +dumpYAMLStarAll value = + liftIO $ handleTextData =<< yamlstarDumpAllFFI (LBS.toStrict $ Aeson.encode value) + +versionYAMLStar :: MonadIO m => m T.Text +versionYAMLStar = + liftIO $ TE.decodeUtf8 <$> yamlstarVersionFFI + +handleData :: LBS.ByteString -> IO Aeson.Value +handleData response = + case Aeson.eitherDecode response of + Left err -> throwIO $ YAMLStarParseError err + Right (Aeson.Object obj) -> + case (KeyMap.lookup (Key.fromString "error") obj, KeyMap.lookup (Key.fromString "data") obj) of + (Just err, _) -> throwIO $ YAMLStarRuntimeError (show err) + (_, Just value) -> return value + _ -> throwIO $ YAMLStarFFIError "Unexpected response from 'libyamlstar'" + Right _ -> throwIO $ YAMLStarFFIError "Unexpected response from 'libyamlstar'" + +handleTextData :: LBS.ByteString -> IO T.Text +handleTextData response = do + value <- handleData response + case value of + Aeson.String text -> return text + _ -> throwIO $ YAMLStarFFIError "Expected text response from 'libyamlstar'" diff --git a/lib/YAMLStar/FFI.hs b/lib/YAMLStar/FFI.hs new file mode 100644 --- /dev/null +++ b/lib/YAMLStar/FFI.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module YAMLStar.FFI + ( yamlstarLoadFFI + , yamlstarLoadAllFFI + , yamlstarDumpFFI + , yamlstarDumpAllFFI + , yamlstarVersionFFI + ) where + +import Control.Exception (bracket) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Unsafe as BSU +import Foreign +import Foreign.C.String +import Foreign.C.Types + +data GraalCreateIsolateParams +data GraalIsolate +data GraalIsolateThread + +type GraalIsolateThreadPtr = Ptr GraalIsolateThread + +foreign import ccall "graal_create_isolate" + c_graal_create_isolate + :: Ptr GraalCreateIsolateParams + -> Ptr (Ptr GraalIsolate) + -> Ptr GraalIsolateThreadPtr + -> IO CInt + +foreign import ccall "graal_tear_down_isolate" + c_graal_tear_down_isolate :: GraalIsolateThreadPtr -> IO CInt + +foreign import ccall "yamlstar_load" + c_yamlstar_load :: CLLong -> CString -> IO CString + +foreign import ccall "yamlstar_load_all" + c_yamlstar_load_all :: CLLong -> CString -> IO CString + +foreign import ccall "yamlstar_dump" + c_yamlstar_dump :: CLLong -> CString -> IO CString + +foreign import ccall "yamlstar_dump_all" + c_yamlstar_dump_all :: CLLong -> CString -> IO CString + +foreign import ccall "yamlstar_version" + c_yamlstar_version :: CLLong -> IO CString + +withGraalIsolate :: (GraalIsolateThreadPtr -> IO a) -> IO a +withGraalIsolate action = + alloca $ \(isolateThreadPtr :: Ptr GraalIsolateThreadPtr) -> do + rc <- c_graal_create_isolate nullPtr nullPtr isolateThreadPtr + if rc /= 0 + then error $ "Failed to create GraalVM isolate (code " ++ show rc ++ ")" + else do + isolateThread <- peek isolateThreadPtr + bracket + (return isolateThread) + (\thread -> do + rc' <- c_graal_tear_down_isolate thread + if rc' /= 0 + then error $ "Failed to tear down GraalVM isolate (code " ++ show rc' ++ ")" + else return ()) + action + +yamlstarLoadFFI :: BS.ByteString -> IO LBS.ByteString +yamlstarLoadFFI = callWithInput c_yamlstar_load + +yamlstarLoadAllFFI :: BS.ByteString -> IO LBS.ByteString +yamlstarLoadAllFFI = callWithInput c_yamlstar_load_all + +yamlstarDumpFFI :: BS.ByteString -> IO LBS.ByteString +yamlstarDumpFFI = callWithInput c_yamlstar_dump + +yamlstarDumpAllFFI :: BS.ByteString -> IO LBS.ByteString +yamlstarDumpAllFFI = callWithInput c_yamlstar_dump_all + +yamlstarVersionFFI :: IO BS.ByteString +yamlstarVersionFFI = + withGraalIsolate $ \isolateThread -> do + cResult <- c_yamlstar_version (threadId isolateThread) + if cResult == nullPtr + then return BS.empty + else BS.packCString cResult + +callWithInput :: (CLLong -> CString -> IO CString) -> BS.ByteString -> IO LBS.ByteString +callWithInput func input = + withGraalIsolate $ \isolateThread -> + BSU.unsafeUseAsCString input $ \cInput -> do + cResult <- func (threadId isolateThread) cInput + if cResult == nullPtr + then return LBS.empty + else LBS.fromStrict <$> BS.packCString cResult + +threadId :: GraalIsolateThreadPtr -> CLLong +threadId = fromIntegral . ptrToIntPtr diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Text as T +import System.Environment (getArgs) +import YAMLStar + +main :: IO () +main = do + args <- getArgs + case args of + [] -> putStrLn "Usage: yamlstar-test " + (code:_) -> do + result <- loadYAMLStar (T.pack code) + LBS.putStrLn $ Aeson.encodePretty result diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Data.Aeson as Aeson +import qualified Data.Text as T +import Test.Hspec +import YAMLStar +import YAMLStar.Tests + +main :: IO () +main = hspec $ do + describe "YAMLStar" $ do + basicTests + + it "dumps a mapping" $ do + result <- dumpYAMLStar $ Aeson.object [("key", Aeson.String "value")] + result `shouldBe` "key: value\n" + + it "reports the library version" $ do + result <- versionYAMLStar + T.unpack result `shouldSatisfy` (not . null) diff --git a/test/YAMLStar/Tests.hs b/test/YAMLStar/Tests.hs new file mode 100644 --- /dev/null +++ b/test/YAMLStar/Tests.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module YAMLStar.Tests where + +import qualified Data.Aeson as Aeson +import qualified Data.Vector as V +import Test.Hspec +import YAMLStar + +basicTests :: Spec +basicTests = describe "Basic YAML" $ do + it "parses simple key-value pairs" $ do + result <- loadYAMLStar "key: value" + result `shouldBe` Aeson.object [("key", Aeson.String "value")] + + it "parses lists" $ do + result <- loadYAMLStar "list: [1, 2, 3]" + result `shouldBe` Aeson.object + [ ("list", Aeson.Array $ V.fromList + [Aeson.Number 1, Aeson.Number 2, Aeson.Number 3]) + ] + + it "loads multiple documents" $ do + result <- loadYAMLStarAll "---\ndoc1\n---\na: 1\n" + result `shouldBe` Aeson.Array (V.fromList + [Aeson.String "doc1", Aeson.object [("a", Aeson.Number 1)]]) diff --git a/yamlstar.cabal b/yamlstar.cabal new file mode 100644 --- /dev/null +++ b/yamlstar.cabal @@ -0,0 +1,62 @@ +cabal-version: 3.0 +name: yamlstar +version: 0.1.11.0 +synopsis: Haskell bindings for YAMLStar +description: Haskell bindings for YAMLStar, a pure YAML 1.2 loader. +license: MIT +license-file: License +author: Ingy dot Net +maintainer: Ingy dot Net +category: Data, Text, YAML +homepage: https://yamlstar.org +bug-reports: https://github.com/yaml/yamlstar/issues +tested-with: GHC==9.4.7, GHC==9.6.3, GHC==9.8.1, GHC==9.12.1 + +library + exposed-modules: YAMLStar + other-modules: YAMLStar.FFI + build-depends: base >=4.17.0.0 && <5, + bytestring ^>=0.11.0.0, + text >=2.0.0.0 && <3, + aeson >=2.0.0.0 && <3, + unix >=2.7.0.0 && <3 + hs-source-dirs: lib + default-language: Haskell2010 + default-extensions: ForeignFunctionInterface + ghc-options: -Wall -Wcompat -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + include-dirs: /tmp/libyamlstar/lib + extra-libraries: yamlstar + extra-lib-dirs: /tmp/libyamlstar/lib + +executable yamlstar-test + main-is: Main.hs + build-depends: base >=4.17.0.0 && <5, + yamlstar, + text >=2.0.0.0 && <3, + aeson >=2.0.0.0 && <3, + aeson-pretty >=0.8.0.0 && <1, + bytestring ^>=0.11.0.0 + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + +test-suite yamlstar-tests + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: YAMLStar.Tests + build-depends: base >=4.17.0.0 && <5, + yamlstar, + hspec >=2.8.0.0 && <3, + aeson >=2.0.0.0 && <3, + text >=2.0.0.0 && <3, + unix >=2.7.0.0 && <3, + vector >=0.13.0.0 && <1 + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall +