diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for keel-dyn + +## 0.1.0.0 -- 2026-08-18 + +* First release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Zhe Zhang + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,32 @@ +# keel-dyn + +Load native shared libraries at run time, cross-platform: +`LoadLibraryExW`/`GetProcAddress` on Windows, `dlopen`/`dlsym` elsewhere. + +This package is the keystone of the [keel](https://github.com/skymanbp/keel) +project: every native capability (OpenBLAS, ONNX Runtime, ...) is resolved +at run time through it, so no keel package carries a build-time C +dependency and `cabal install` can never fail on a missing native library. + +```haskell +import Keel.Dyn + +main :: IO () +main = do + r <- withLibrary "libcrypto.so.3" $ \lib -> do + Right fp <- resolveSym lib "OpenSSL_version_num" + callVersionNum fp -- your own "dynamic" wrapper for the C signature + print r +``` + +`Keel.Dyn.Locate` adds the keel search policy on top: an env-var +override, the per-user keel data directory, then the system search +path. On Windows the loader never consults the current directory +(DLL-planting hazard); `PATH` is walked explicitly instead. + +Failure is data, not an exception: loading and symbol resolution return +`Either DynError`. + +Part of the keel workspace — see the +[project repository](https://github.com/skymanbp/keel) for the other +packages (keel-abi, keel-linalg, keel-onnx, and the keel umbrella). diff --git a/keel-dyn.cabal b/keel-dyn.cabal new file mode 100644 --- /dev/null +++ b/keel-dyn.cabal @@ -0,0 +1,60 @@ +cabal-version: 3.0 +name: keel-dyn +version: 0.1.0.0 +synopsis: Load native shared libraries at run time, cross-platform +description: + Cross-platform runtime loading and symbol resolution for native shared + libraries: LoadLibraryExW/GetProcAddress on Windows, + dlopen/dlsym elsewhere. + . + This package is the keystone of the keel project: every native + capability (OpenBLAS, ONNX Runtime, ...) is resolved at run time + through it, so no keel package ever carries a build-time C dependency + and @cabal install@ can never fail on a missing native library. +license: MIT +license-file: LICENSE +author: Zhe Zhang +maintainer: Zhe Zhang +category: System, Foreign +build-type: Simple +homepage: https://github.com/skymanbp/keel +bug-reports: https://github.com/skymanbp/keel/issues +extra-doc-files: + CHANGELOG.md + README.md +tested-with: GHC ==9.10.3 || ==9.12.4 || ==9.14.1 + +source-repository head + type: git + location: https://github.com/skymanbp/keel + +common warnings + ghc-options: -Wall + default-language: GHC2021 + +library + import: warnings + exposed-modules: + Keel.Dyn + Keel.Dyn.Locate + other-modules: Keel.Dyn.Platform + hs-source-dirs: src + build-depends: + base >=4.20 && <4.23, + directory >=1.3 && <1.4, + filepath >=1.4 && <1.6 + if os(windows) + hs-source-dirs: src-windows + else + hs-source-dirs: src-posix + build-depends: unix >=2.8 && <2.9 + +test-suite keel-dyn-test + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base, + filepath, + keel-dyn diff --git a/src-posix/Keel/Dyn/Platform.hs b/src-posix/Keel/Dyn/Platform.hs new file mode 100644 --- /dev/null +++ b/src-posix/Keel/Dyn/Platform.hs @@ -0,0 +1,96 @@ +-- | POSIX implementation over @dlopen@\/@dlsym@\/@dlclose@ (via the unix +-- package). Search paths follow the platform loader: rpath, +-- @LD_LIBRARY_PATH@ \/ @DYLD_LIBRARY_PATH@, then system defaults. +module Keel.Dyn.Platform + ( Library + , libraryPath + , DynError (..) + , loadLibrary + , loadLibraryGlobal + , closeLibrary + , withLibrary + , resolveSym + , resolveOptional + , addSearchDir + ) where + +import Control.Exception (Exception, IOException, finally, mask, try) +import Control.Monad (void) +import Foreign.Ptr (FunPtr, castFunPtr) +import qualified System.Posix.DynamicLinker as DL + +-- | A loaded shared library. Constructor deliberately not exported. +data Library = Library + { libDL :: !DL.DL + , libraryPath :: !FilePath + -- ^ The path\/name the library was requested as. + } + +-- | Failure modes of loading and symbol resolution. +data DynError + = LibraryNotFound FilePath String + -- ^ Library could not be loaded; the 'String' carries OS detail. + | SymbolNotFound FilePath String + -- ^ The named symbol is absent from the named library. + deriving (Eq, Show) + +instance Exception DynError + +-- | Load a shared library by bare name or path. Search order is documented +-- in "Keel.Dyn". Symbols stay private to the handle (@RTLD_LOCAL@). +loadLibrary :: FilePath -> IO (Either DynError Library) +loadLibrary = loadWith [DL.RTLD_NOW, DL.RTLD_LOCAL] + +-- | Like 'loadLibrary' but with @RTLD_GLOBAL@: the library's symbols +-- become visible to everything loaded afterwards. Needed when later +-- loads expect this library's symbols to already be in the process — +-- the canonical case is @libpython@, whose extension modules +-- deliberately leave Python's symbols undefined (manylinux policy). +loadLibraryGlobal :: FilePath -> IO (Either DynError Library) +loadLibraryGlobal = loadWith [DL.RTLD_NOW, DL.RTLD_GLOBAL] + +loadWith :: [DL.RTLDFlags] -> FilePath -> IO (Either DynError Library) +loadWith flags path = do + r <- try (DL.dlopen path flags) + pure $ case r of + Left (e :: IOException) -> Left (LibraryNotFound path (show e)) + Right dl -> Right (Library dl path) + +-- | Release the OS handle, best-effort: a failed @dlclose@ is ignored — +-- matching the Windows side, there is no recovery, and 'withLibrary' +-- must not let a cleanup failure replace the action's own exception. +-- 'FunPtr's resolved from this 'Library' must not be called afterwards. +closeLibrary :: Library -> IO () +closeLibrary lib = void (try @IOException (DL.dlclose (libDL lib))) + +-- | 'loadLibrary' \/ 'closeLibrary' bracket, async-exception-safe: the +-- window between a successful load and the cleanup registration is +-- masked, so a timeout cannot leak the handle. +withLibrary :: FilePath -> (Library -> IO a) -> IO (Either DynError a) +withLibrary path act = mask $ \restore -> do + r <- loadLibrary path + case r of + Left e -> pure (Left e) + Right lib -> restore (Right <$> act lib) `finally` closeLibrary lib + +-- | Resolve an exported symbol to a 'FunPtr', to be invoked through a +-- @foreign import ccall \"dynamic\"@ wrapper. The result type is the +-- caller's unchecked claim about the C signature. +resolveSym :: Library -> String -> IO (Either DynError (FunPtr a)) +resolveSym lib name = do + r <- try (DL.dlsym (libDL lib) name) + pure $ case r of + Left (e :: IOException) -> + Left (SymbolNotFound (libraryPath lib) (name <> ": " <> show e)) + Right fp -> Right (castFunPtr fp) + +-- | 'resolveSym' flattened to 'Maybe', for symbols whose absence is an +-- expected, degradable condition rather than an error. +resolveOptional :: Library -> String -> IO (Maybe (FunPtr a)) +resolveOptional lib name = either (const Nothing) Just <$> resolveSym lib name + +-- | POSIX loaders take their search path from the environment +-- (@LD_LIBRARY_PATH@\/rpath) before process start; there is no runtime +-- registration equivalent to Windows' AddDllDirectory. Documented no-op. +addSearchDir :: FilePath -> IO Bool +addSearchDir _ = pure False diff --git a/src-windows/Keel/Dyn/Platform.hs b/src-windows/Keel/Dyn/Platform.hs new file mode 100644 --- /dev/null +++ b/src-windows/Keel/Dyn/Platform.hs @@ -0,0 +1,171 @@ +-- | Windows implementation: LoadLibraryExW \/ GetProcAddress \/ FreeLibrary. +-- +-- All imports come from kernel32, which GHC's mingw toolchain links by +-- default, so this module needs no headers, no import libraries and no +-- build-time configuration. +module Keel.Dyn.Platform + ( Library + , libraryPath + , DynError (..) + , loadLibrary + , loadLibraryGlobal + , closeLibrary + , withLibrary + , resolveSym + , resolveOptional + , addSearchDir + ) where + +import Control.Concurrent (rtsSupportsBoundThreads, runInBoundThread) +import Control.Exception (Exception, finally, mask) +import Control.Monad (void) +import Data.Bits ((.|.)) +import Data.Word (Word32) +import Foreign.C.String (CString, CWString, withCString, withCWString) +import Foreign.C.Types (CInt (..)) +import Foreign.Ptr (FunPtr, Ptr, castFunPtr, nullFunPtr, nullPtr) +import System.Environment (lookupEnv) +import System.FilePath (isAbsolute, splitSearchPath, ()) + +type HMODULE = Ptr () + +-- | A loaded shared library. Constructor deliberately not exported. +data Library = Library + { libHandle :: !HMODULE + , libraryPath :: !FilePath + -- ^ The path\/name the library was requested as. + } + +-- | Failure modes of loading and symbol resolution. +data DynError + = LibraryNotFound FilePath String + -- ^ Library could not be loaded; the 'String' carries OS detail. + | SymbolNotFound FilePath String + -- ^ The named symbol is absent from the named library. + deriving (Eq, Show) + +instance Exception DynError + +-- LoadLibrary runs the target's DllMain and pages the image in from +-- disk, and FreeLibrary runs DllMain again — both can block for a long +-- time, so they are imported safe: a slow load stalls only its own +-- thread, not every Haskell thread on the capability (the unix package +-- marks dlopen/dlclose safe for the same reason). GetProcAddress, +-- GetLastError and AddDllDirectory are cheap lookups and stay unsafe. +foreign import ccall safe "LoadLibraryExW" + c_LoadLibraryExW :: CWString -> Ptr () -> Word32 -> IO HMODULE + +foreign import ccall unsafe "GetProcAddress" + c_GetProcAddress :: HMODULE -> CString -> IO (FunPtr ()) + +foreign import ccall safe "FreeLibrary" + c_FreeLibrary :: HMODULE -> IO CInt + +foreign import ccall unsafe "GetLastError" + c_GetLastError :: IO Word32 + +foreign import ccall unsafe "AddDllDirectory" + c_AddDllDirectory :: CWString -> IO (Ptr ()) + +-- LOAD_LIBRARY_SEARCH_DEFAULT_DIRS: application dir + System32 + directories +-- registered through AddDllDirectory. Deliberately excludes CWD (a classic +-- DLL-planting hazard); PATH is only reached via the explicit walk below, +-- which never consults CWD either. +searchDefaultDirs :: Word32 +searchDefaultDirs = 0x00001000 + +-- LOAD_LIBRARY_SEARCH_DLL_LOAD_DIR: also resolve the loaded DLL's own +-- dependencies from the directory the DLL itself lives in. Only legal when +-- the requested path is fully qualified; essential for multi-DLL packages +-- (onnxruntime.dll finds its provider DLLs next to itself). +searchDllLoadDir :: Word32 +searchDllLoadDir = 0x00000100 + +-- | Load a shared library by bare name or path. Search order is documented +-- in "Keel.Dyn". The current directory is never searched: the primary +-- lookup uses the safe default-directories set, and the @PATH@ fallback +-- for bare names walks the @PATH@ entries explicitly instead of handing +-- the name to the legacy loader search (whose order includes CWD). +loadLibrary :: FilePath -> IO (Either DynError Library) +loadLibrary path = inBound $ withCWString path $ \wpath -> do + let flags + | isAbsolute path = searchDllLoadDir .|. searchDefaultDirs + | otherwise = searchDefaultDirs + hEx <- c_LoadLibraryExW wpath nullPtr flags + if hEx /= nullPtr + then pure (Right (Library hEx path)) + else do + -- read the primary attempt's error before any further calls + code <- c_GetLastError + h <- if isAbsolute path then pure nullPtr else tryPath path + pure $ + if h == nullPtr + then Left (LibraryNotFound path ("Win32 error " <> show code)) + else Right (Library h path) + +-- Walk PATH ourselves: each candidate is loaded by absolute path (with +-- own-directory dependency resolution), relative PATH entries are +-- skipped, and CWD is never consulted. +tryPath :: FilePath -> IO HMODULE +tryPath name = do + dirs <- maybe [] splitSearchPath <$> lookupEnv "PATH" + go (filter isAbsolute dirs) + where + go [] = pure nullPtr + go (d : ds) = do + h <- withCWString (d name) $ \w -> + c_LoadLibraryExW w nullPtr (searchDllLoadDir .|. searchDefaultDirs) + if h /= nullPtr then pure h else go ds + +-- GetLastError is only meaningful on the OS thread that made the failing +-- call, and an unbound Haskell thread may migrate between two foreign +-- calls; a bound thread pins the whole load-and-diagnose sequence to one +-- OS thread. A non-threaded RTS has a single OS thread already. +inBound :: IO a -> IO a +inBound = if rtsSupportsBoundThreads then runInBoundThread else id + +-- | On Windows this is identical to 'loadLibrary': PE imports are +-- resolved per-module from the DLL's import table, so there is no +-- POSIX-style global symbol namespace to opt into. +loadLibraryGlobal :: FilePath -> IO (Either DynError Library) +loadLibraryGlobal = loadLibrary + +-- | Release the OS handle, best-effort: a failed FreeLibrary is ignored — +-- there is no recovery, and 'withLibrary' must not let a cleanup failure +-- replace the action's own exception. 'FunPtr's resolved from this +-- 'Library' must not be called afterwards. +closeLibrary :: Library -> IO () +closeLibrary = void . c_FreeLibrary . libHandle + +-- | 'loadLibrary' \/ 'closeLibrary' bracket, async-exception-safe: the +-- window between a successful load and the cleanup registration is +-- masked, so a timeout cannot leak the handle. +withLibrary :: FilePath -> (Library -> IO a) -> IO (Either DynError a) +withLibrary path act = mask $ \restore -> do + r <- loadLibrary path + case r of + Left e -> pure (Left e) + Right lib -> restore (Right <$> act lib) `finally` closeLibrary lib + +-- | Resolve an exported symbol to a 'FunPtr', to be invoked through a +-- @foreign import ccall \"dynamic\"@ wrapper. The result type is the +-- caller's unchecked claim about the C signature. +resolveSym :: Library -> String -> IO (Either DynError (FunPtr a)) +resolveSym lib name = withCString name $ \cname -> do + fp <- c_GetProcAddress (libHandle lib) cname + if fp == nullFunPtr + then pure (Left (SymbolNotFound (libraryPath lib) name)) + else pure (Right (castFunPtr fp)) + +-- | 'resolveSym' flattened to 'Maybe', for symbols whose absence is an +-- expected, degradable condition rather than an error. +resolveOptional :: Library -> String -> IO (Maybe (FunPtr a)) +resolveOptional lib name = either (const Nothing) Just <$> resolveSym lib name + +-- | Register an extra DLL search directory for subsequent 'loadLibrary' +-- calls. The directory must be an absolute path (AddDllDirectory refuses +-- relative ones). Returns 'False' if the OS refused it. +addSearchDir :: FilePath -> IO Bool +addSearchDir dir = withCWString dir $ \wdir -> do + cookie <- c_AddDllDirectory wdir + pure (cookie /= nullPtr) diff --git a/src/Keel/Dyn.hs b/src/Keel/Dyn.hs new file mode 100644 --- /dev/null +++ b/src/Keel/Dyn.hs @@ -0,0 +1,86 @@ +-- | Cross-platform runtime loading of native shared libraries. +-- +-- This module is the keystone of keel: every native capability (OpenBLAS, +-- ONNX Runtime, ...) is resolved at run time through it, so no keel package +-- carries a build-time C dependency and @cabal install@ can never fail on a +-- missing native library. +-- +-- Search-path behaviour: +-- +-- * Windows: 'loadLibrary' first tries @LoadLibraryExW@ with +-- @LOAD_LIBRARY_SEARCH_DEFAULT_DIRS@ (application dir, System32, and any +-- directory registered via 'addSearchDir'; for absolute paths also the +-- library's own directory, so multi-DLL packages find their siblings), +-- then falls back to the legacy @LoadLibraryW@ search (PATH, CWD) so +-- bare names on PATH keep working. +-- * POSIX: @dlopen@ semantics (rpath, @LD_LIBRARY_PATH@\/@DYLD_*@, system +-- default dirs). 'addSearchDir' is a documented no-op returning 'False' — +-- POSIX search paths must be set before process start. +-- +-- For the full env-var → data-dir → system policy that capability packages +-- use, see "Keel.Dyn.Locate". +-- +-- == Building a capability record +-- +-- Resolve each function once at load time into a record of 'FunPtr's, +-- invoked through @foreign import ccall \"dynamic\"@ wrappers. Required +-- symbols use 'requireSym' (throws 'DynError'); symbols that may be absent +-- in older library builds use 'resolveOptional', so a missing symbol +-- degrades that one operation instead of failing the whole library: +-- +-- > data BlasOps = BlasOps +-- > { ddot :: FunPtr CblasDdotT -- required +-- > , dgemm :: FunPtr CblasDgemmT -- required +-- > , sbgemm :: Maybe (FunPtr CblasSbgemmT) -- bfloat16: newer builds only +-- > } +-- > +-- > openBlas :: Library -> IO (Capability BlasOps) +-- > openBlas lib = do +-- > ops <- BlasOps +-- > <$> requireSym lib "cblas_ddot" +-- > <*> requireSym lib "cblas_dgemm" +-- > <*> resolveOptional lib "cblas_sbgemm" +-- > version <- queryVersion lib -- e.g. via openblas_get_config +-- > pure (Capability lib version ops) +module Keel.Dyn + ( -- * Libraries + Library + , libraryPath + , loadLibrary + , loadLibraryGlobal + , closeLibrary + , withLibrary + + -- * Symbols + , resolveSym + , resolveOptional + , requireSym + + -- * Capability records + , Capability (..) + + -- * Search path + , addSearchDir + + -- * Errors + , DynError (..) + ) where + +import Control.Exception (throwIO) +import Foreign.Ptr (FunPtr) + +import Keel.Dyn.Platform + +-- | Like 'resolveSym' but throws the 'DynError' as an exception. Intended +-- for assembling capability records applicatively (see the module header). +requireSym :: Library -> String -> IO (FunPtr a) +requireSym lib name = resolveSym lib name >>= either throwIO pure + +-- | A loaded native capability: the library it came from, a version tag +-- queried from the library itself (shown by @keel doctor@), and a +-- caller-defined record of resolved 'FunPtr's. +data Capability ops = Capability + { capLibrary :: Library + , capVersion :: String + , capOps :: ops + } diff --git a/src/Keel/Dyn/Locate.hs b/src/Keel/Dyn/Locate.hs new file mode 100644 --- /dev/null +++ b/src/Keel/Dyn/Locate.hs @@ -0,0 +1,142 @@ +-- | Locate-and-load policy for native capabilities. +-- +-- 'locateLibrary' documents and implements keel's search order: +-- +-- 1. __Environment override__ ('specEnvVar'). If the variable is set and +-- non-empty it is authoritative: a file path is loaded exactly as +-- given, a directory is searched for 'specCandidates'. Failure of an +-- explicit override is an error — it deliberately does /not/ fall +-- through to the later stages, because silent fallback past a value +-- the user set by hand is undiagnosable. +-- 2. __Per-user data directory__ ('keelNativeDir'): +-- @~\/.local\/share\/keel\/native\/\@ per the XDG spec, or +-- @%APPDATA%\\keel\\native\\\@ on Windows. This is where +-- @keel setup@ installs checksum-pinned libraries. On Windows the +-- directory is also registered via 'addSearchDir' before loading, so +-- the library's transitive DLL dependencies resolve from it. A +-- candidate that exists here but fails to load is an error, not a +-- fallthrough, for the same reason as above. +-- 3. __System search__: each candidate is tried as a bare name through +-- the operating system's default lookup (PATH \/ @ld.so@ cache \/ +-- @DYLD_*@ \/ System32). +module Keel.Dyn.Locate + ( LibrarySpec (..) + , Located (..) + , Origin (..) + , locateLibrary + , keelNativeDir + ) where + +import Control.Monad (filterM) +import System.Directory + ( XdgDirectory (XdgData) + , doesDirectoryExist + , doesFileExist + , getXdgDirectory + ) +import System.Environment (lookupEnv) +import System.FilePath (()) + +import Keel.Dyn.Platform + +-- | What to look for and where the user may override it. +data LibrarySpec = LibrarySpec + { specName :: String + -- ^ Capability name, e.g. @\"openblas\"@. Names the subdirectory of + -- the keel data dir and appears in error messages. + , specEnvVar :: String + -- ^ Override variable, e.g. @\"KEEL_OPENBLAS\"@. May point at a + -- library file or at a directory containing one of the candidates. + , specCandidates :: [FilePath] + -- ^ Platform-appropriate file names tried in order, e.g. + -- @[\"libopenblas.dll\"]@ \/ @[\"libopenblas.so.0\", \"libopenblas.so\"]@. + -- The caller chooses per platform ('System.Info.os'). + } + deriving (Eq, Show) + +-- | Where a successfully located library came from — 'Keel.Doctor' level +-- diagnostics report this verbatim. +data Origin + = FromEnvFile FilePath + -- ^ The override variable pointed directly at this file. + | FromEnvDir FilePath + -- ^ Loaded from the directory the override variable pointed at. + | FromDataDir FilePath + -- ^ Loaded from the per-user keel data directory. + | FromSystem FilePath + -- ^ Resolved by the OS default search under this bare name. + deriving (Eq, Show) + +-- | A successfully located and loaded library, tagged with where the +-- search found it. +data Located = Located + { locLibrary :: Library + , locOrigin :: Origin + } + +-- | The per-user directory for one capability's native libraries: +-- XDG data dir (Windows: @%APPDATA%@) @\/keel\/native\/\@. +-- Derived at run time; never assumed to exist. +keelNativeDir :: String -> IO FilePath +keelNativeDir name = getXdgDirectory XdgData ("keel" "native" name) + +-- | Locate and load a native library following the search order in the +-- module header. On success the 'Origin' says which stage matched. +locateLibrary :: LibrarySpec -> IO (Either DynError Located) +locateLibrary spec = do + mOverride <- lookupEnv (specEnvVar spec) + case mOverride of + Just v | not (null v) -> fromEnv spec v + _ -> do + dir <- keelNativeDir (specName spec) + fromDataDir spec dir + +-- The override is authoritative: no fallthrough on failure. +fromEnv :: LibrarySpec -> FilePath -> IO (Either DynError Located) +fromEnv spec v = do + isDir <- doesDirectoryExist v + if isDir + then do + found <- firstExistingIn v (specCandidates spec) + case found of + Nothing -> + pure . Left . LibraryNotFound v $ + specEnvVar spec + <> " is a directory containing none of " + <> show (specCandidates spec) + Just path -> do + _ <- addSearchDir v + fmap (\lib -> Located lib (FromEnvDir path)) <$> loadLibrary path + else fmap (\lib -> Located lib (FromEnvFile v)) <$> loadLibrary v + +-- A candidate present in the data dir must load; only absence falls +-- through to the system search. +fromDataDir :: LibrarySpec -> FilePath -> IO (Either DynError Located) +fromDataDir spec dir = do + found <- firstExistingIn dir (specCandidates spec) + case found of + Just path -> do + _ <- addSearchDir dir + fmap (\lib -> Located lib (FromDataDir path)) <$> loadLibrary path + Nothing -> fromSystem spec (specCandidates spec) + +fromSystem :: LibrarySpec -> [FilePath] -> IO (Either DynError Located) +fromSystem spec [] = + pure . Left . LibraryNotFound (specName spec) $ + "none of " + <> show (specCandidates spec) + <> " found via " + <> specEnvVar spec + <> ", the keel data dir, or the system search path" +fromSystem spec (c : cs) = do + r <- loadLibrary c + case r of + Right lib -> pure (Right (Located lib (FromSystem c))) + Left _ -> fromSystem spec cs + +firstExistingIn :: FilePath -> [FilePath] -> IO (Maybe FilePath) +firstExistingIn dir names = do + hits <- filterM doesFileExist (map (dir ) names) + pure $ case hits of + (h : _) -> Just h + [] -> Nothing diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,116 @@ +-- | Smoke tests: real dlopen/resolve/call round-trip on each OS, the +-- negative paths (missing library, missing symbol), and the +-- "Keel.Dyn.Locate" search-order contract. +module Main (main) where + +import Control.Exception (try) +import Control.Monad (unless) +import Data.Word (Word64) +import Foreign.Ptr (FunPtr) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (()) +import System.Info (os) + +import Keel.Dyn +import Keel.Dyn.Locate + +foreign import ccall "dynamic" mkTick :: FunPtr (IO Word64) -> IO Word64 +foreign import ccall "dynamic" mkCos :: FunPtr (Double -> Double) -> Double -> Double + +orDie :: Show e => String -> Either e a -> IO a +orDie ctx = either (\e -> fail (ctx <> ": " <> show e)) pure + +expect :: Bool -> String -> IO () +expect ok msg = unless ok (fail msg) + +testEnvVar :: String +testEnvVar = "KEEL_DYN_TEST_LIB" + +-- The spec name is chosen so its per-user data dir cannot exist, keeping +-- the data-dir stage of locateLibrary an empty pass-through in this test. +mkSpec :: [FilePath] -> LibrarySpec +mkSpec cands = LibrarySpec + { specName = "keel-dyn-smoke-zzz" + , specEnvVar = testEnvVar + , specCandidates = cands + } + +main :: IO () +main = do + let (libName, symName) = case os of + "mingw32" -> ("kernel32.dll", "GetTickCount64") + "darwin" -> ("/usr/lib/libSystem.B.dylib", "cos") + _ -> ("libm.so.6", "cos") + + -- 1. positive path: load, resolve (via requireSym), call through the + -- FunPtr. The resolve happens inside each branch because the FunPtr + -- type differs per OS. + lib <- orDie ("load " <> libName) =<< loadLibrary libName + case os of + "mingw32" -> do + fp <- requireSym lib symName + t <- mkTick fp + expect (t > 0) "GetTickCount64 returned 0" + _ -> do + fp <- requireSym lib symName + expect (abs (mkCos fp 0 - 1) < 1e-12) "cos 0 /= 1" + + -- 2. negative path: a library that cannot exist + neg <- loadLibrary "keel-definitely-missing-library-zzz" + expect (either (const True) (const False) neg) "bogus library loaded" + + -- 3. negative path: a symbol that cannot exist, through both interfaces + msym <- resolveOptional lib "keel_definitely_missing_symbol_zzz" + :: IO (Maybe (FunPtr ())) + expect (maybe True (const False) msym) "bogus symbol resolved" + thrown <- try (requireSym lib "keel_definitely_missing_symbol_zzz") + :: IO (Either DynError (FunPtr ())) + case thrown of + Left (SymbolNotFound _ _) -> pure () + Left e -> fail ("requireSym threw the wrong error: " <> show e) + Right _ -> fail "requireSym resolved a bogus symbol" + + -- 4. locate: with no override and no data dir, the system-search stage + -- must find the library under its bare name (absolute on darwin). + unsetEnv testEnvVar + l1 <- orDie "locate via system search" =<< locateLibrary (mkSpec [libName]) + expect (locOrigin l1 == FromSystem libName) + ("wrong origin: " <> show (locOrigin l1)) + closeLibrary (locLibrary l1) + + -- 5. locate: a broken explicit override must FAIL, never fall through + -- to the system search (where the candidate would have resolved). + setEnv testEnvVar ("keel-no-such-dir-zzz" "keel-no-such-lib-zzz") + l2 <- locateLibrary (mkSpec [libName]) + expect (either (const True) (const False) l2) + "broken override fell through to system search" + unsetEnv testEnvVar + + -- 6. locate: env-file and env-dir overrides. Windows-only because only + -- there is the system library's absolute location derivable portably + -- (%SystemRoot%\System32); POSIX paths vary per distro and are covered + -- by the publish-stage CI matrix instead. + case os of + "mingw32" -> do + mroot <- lookupEnv "SystemRoot" + case mroot of + Nothing -> fail "SystemRoot unset; cannot exercise env override" + Just root -> do + let sys32 = root "System32" + k32 = sys32 "kernel32.dll" + setEnv testEnvVar k32 + l3 <- orDie "locate via env file" =<< locateLibrary (mkSpec ["kernel32.dll"]) + expect (locOrigin l3 == FromEnvFile k32) + ("wrong origin: " <> show (locOrigin l3)) + closeLibrary (locLibrary l3) + + setEnv testEnvVar sys32 + l4 <- orDie "locate via env dir" =<< locateLibrary (mkSpec ["kernel32.dll"]) + expect (locOrigin l4 == FromEnvDir k32) + ("wrong origin: " <> show (locOrigin l4)) + closeLibrary (locLibrary l4) + unsetEnv testEnvVar + _ -> pure () + + closeLibrary lib + putStrLn "keel-dyn: all smoke tests passed"