{-# LANGUAGE CPP, ExistentialQuantification, ScopedTypeVariables #-}
module Util.DynamicLinker ( ForeignFun(..)
, DynamicLib(..)
, tryLoadLib
, tryLoadFn
) where
#ifdef IDRIS_FFI
import System.Directory
#ifdef mingw32_HOST_OS
import qualified Control.Exception as Exception (IOException, catch)
import Foreign.Ptr (FunPtr, castPtrToFunPtr, nullFunPtr, nullPtr)
import System.FilePath.Windows ((</>))
import System.Win32.DLL
import System.Win32.Types
#else
import Control.Exception (IOException, throwIO, try)
import Foreign.Ptr (FunPtr, nullFunPtr, nullPtr)
#ifdef linux_HOST_OS
import Data.Array (bounds, inRange, (!))
import Data.Maybe (catMaybes)
#else
import Data.Array (bounds, (!))
#endif
import System.FilePath.Posix ((</>))
import System.Posix.DynamicLinker
import Text.Regex.TDFA
#endif
#ifdef mingw32_HOST_OS
type DL = HMODULE
#endif
hostDynamicLibExt :: String
#if defined(linux_HOST_OS) || defined(freebsd_HOST_OS) \
|| defined(dragonfly_HOST_OS) || defined(openbsd_HOST_OS) \
|| defined(netbsd_HOST_OS)
hostDynamicLibExt :: String
hostDynamicLibExt = String
"so"
#elif defined(darwin_HOST_OS)
hostDynamicLibExt = "dylib"
#elif defined(mingw32_HOST_OS)
hostDynamicLibExt = "dll"
#else
hostDynamicLibExt = error $ unwords
[ "Undefined file extension for dynamic libraries"
, "in Idris' Util.DynamicLinker."
]
#endif
data ForeignFun = forall a. Fun { ForeignFun -> String
fun_name :: String
, ()
fun_handle :: FunPtr a
}
data DynamicLib = Lib { DynamicLib -> String
lib_name :: String
, DynamicLib -> DL
lib_handle :: DL
}
instance Eq DynamicLib where
(Lib String
a DL
_) == :: DynamicLib -> DynamicLib -> Bool
== (Lib String
b DL
_) = String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b
firstExisting :: [FilePath] -> IO (Maybe FilePath)
firstExisting :: [String] -> IO (Maybe String)
firstExisting [] = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
firstExisting (String
f:[String]
fs) = do Bool
exists <- String -> IO Bool
doesFileExist String
f
if Bool
exists
then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
f)
else [String] -> IO (Maybe String)
firstExisting [String]
fs
libFileName :: [FilePath] -> String -> IO String
libFileName :: [String] -> String -> IO String
libFileName [String]
dirs String
lib = do let names :: [String]
names = [String
lib, String
lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hostDynamicLibExt]
String
cwd <- IO String
getCurrentDirectory
Maybe String
found <- [String] -> IO (Maybe String)
firstExisting ([String] -> IO (Maybe String)) -> [String] -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"."String -> String -> String
</>) [String]
names [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
d String -> String -> String
</> String
f | String
d <- String
cwdString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
dirs, String
f <- [String]
names]
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hostDynamicLibExt) String -> String
forall a. a -> a
id Maybe String
found
#ifndef mingw32_HOST_OS
tryLoadLib :: [FilePath] -> String -> IO (Maybe DynamicLib)
tryLoadLib :: [String] -> String -> IO (Maybe DynamicLib)
tryLoadLib [String]
dirs String
lib = do
String
filename <- [String] -> String -> IO String
libFileName [String]
dirs String
lib
Either IOException DL
res :: Either IOException DL <- IO DL -> IO (Either IOException DL)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO DL -> IO (Either IOException DL))
-> IO DL -> IO (Either IOException DL)
forall a b. (a -> b) -> a -> b
$
String -> [RTLDFlags] -> IO DL
dlopen String
filename [RTLDFlags
RTLD_NOW, RTLDFlags
RTLD_GLOBAL]
Maybe DL
mbDL <- case Either IOException DL
res of
Right DL
handle -> Maybe DL -> IO (Maybe DL)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DL -> IO (Maybe DL)) -> Maybe DL -> IO (Maybe DL)
forall a b. (a -> b) -> a -> b
$ DL -> Maybe DL
forall a. a -> Maybe a
Just DL
handle
#ifdef linux_HOST_OS
Left IOException
ex ->
case Regex -> String -> [MatchText String]
forall regex source.
RegexLike regex source =>
regex -> source -> [MatchText source]
matchAllText Regex
invalidLibRegex (IOException -> String
forall a. Show a => a -> String
show IOException
ex) of
(MatchText String
x:[MatchText String]
_) -> do
if (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (MatchText String -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds MatchText String
x) Int
1
then do
let realPath :: String
realPath = (String, (Int, Int)) -> String
forall a b. (a, b) -> a
fst ((String, (Int, Int)) -> String) -> (String, (Int, Int)) -> String
forall a b. (a -> b) -> a -> b
$ MatchText String
x MatchText String -> Int -> (String, (Int, Int))
forall i e. Ix i => Array i e -> i -> e
! Int
1
[String]
fileLines <- String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
realPath
let matches :: [String]
matches = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe String) -> [String] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map
([MatchText String] -> Maybe String
getLastMatch ([MatchText String] -> Maybe String)
-> (String -> [MatchText String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> String -> [MatchText String]
forall regex source.
RegexLike regex source =>
regex -> source -> [MatchText source]
matchAllText Regex
linkerScriptRegex)
[String]
fileLines
(String -> IO DL) -> [String] -> IO (Maybe DL)
forall a b. (a -> IO b) -> [a] -> IO (Maybe b)
mapMFirst (\String
f -> String -> [RTLDFlags] -> IO DL
dlopen String
f [RTLDFlags
RTLD_NOW, RTLDFlags
RTLD_GLOBAL]) [String]
matches
else Maybe DL -> IO (Maybe DL)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DL
forall a. Maybe a
Nothing
[] -> Maybe DL -> IO (Maybe DL)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DL
forall a. Maybe a
Nothing
#else
Left ex -> throwIO ex
#endif
case Maybe DL
mbDL of
Just DL
handle -> if DL -> Ptr ()
undl DL
handle Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
then Maybe DynamicLib -> IO (Maybe DynamicLib)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynamicLib
forall a. Maybe a
Nothing
else Maybe DynamicLib -> IO (Maybe DynamicLib)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DynamicLib -> IO (Maybe DynamicLib))
-> (DynamicLib -> Maybe DynamicLib)
-> DynamicLib
-> IO (Maybe DynamicLib)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicLib -> Maybe DynamicLib
forall a. a -> Maybe a
Just (DynamicLib -> IO (Maybe DynamicLib))
-> DynamicLib -> IO (Maybe DynamicLib)
forall a b. (a -> b) -> a -> b
$ String -> DL -> DynamicLib
Lib String
lib DL
handle
Maybe DL
Nothing -> Maybe DynamicLib -> IO (Maybe DynamicLib)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynamicLib
forall a. Maybe a
Nothing
getLastMatch :: [MatchText String] -> Maybe String
getLastMatch :: [MatchText String] -> Maybe String
getLastMatch [] = Maybe String
forall a. Maybe a
Nothing
getLastMatch (MatchText String
x:[MatchText String]
_) = case MatchText String -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds MatchText String
x of
(Int
low, Int
high) -> if Int
low Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
high
then Maybe String
forall a. Maybe a
Nothing
else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (String, (Int, Int)) -> String
forall a b. (a, b) -> a
fst ((String, (Int, Int)) -> String) -> (String, (Int, Int)) -> String
forall a b. (a -> b) -> a -> b
$ MatchText String
x MatchText String -> Int -> (String, (Int, Int))
forall i e. Ix i => Array i e -> i -> e
! Int
high
mapMFirst :: (a -> IO b) -> [a] -> IO (Maybe b)
mapMFirst :: forall a b. (a -> IO b) -> [a] -> IO (Maybe b)
mapMFirst a -> IO b
f [] = Maybe b -> IO (Maybe b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
mapMFirst a -> IO b
f (a
a:[a]
as) = do Either IOException b
res <- IO b -> IO (Either IOException b)
forall e a. Exception e => IO a -> IO (Either e a)
try (a -> IO b
f a
a)
case Either IOException b
res of
Left (IOException
ex :: IOException) -> (a -> IO b) -> [a] -> IO (Maybe b)
forall a b. (a -> IO b) -> [a] -> IO (Maybe b)
mapMFirst a -> IO b
f [a]
as
Right b
res -> Maybe b -> IO (Maybe b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> IO (Maybe b)) -> Maybe b -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just b
res
invalidLibRegex :: Regex
invalidLibRegex :: Regex
invalidLibRegex = String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex String
"(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)"
linkerScriptRegex :: Regex
linkerScriptRegex :: Regex
linkerScriptRegex = String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex String
"(GROUP|INPUT) *\\( *([^ )]+)"
tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
tryLoadFn String
fn (Lib String
_ DL
h) = do FunPtr Any
cFn <- DL -> String -> IO (FunPtr Any)
forall a. DL -> String -> IO (FunPtr a)
dlsym DL
h String
fn
if FunPtr Any
cFn FunPtr Any -> FunPtr Any -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr Any
forall a. FunPtr a
nullFunPtr
then Maybe ForeignFun -> IO (Maybe ForeignFun)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ForeignFun
forall a. Maybe a
Nothing
else Maybe ForeignFun -> IO (Maybe ForeignFun)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ForeignFun -> IO (Maybe ForeignFun))
-> (ForeignFun -> Maybe ForeignFun)
-> ForeignFun
-> IO (Maybe ForeignFun)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignFun -> Maybe ForeignFun
forall a. a -> Maybe a
Just (ForeignFun -> IO (Maybe ForeignFun))
-> ForeignFun -> IO (Maybe ForeignFun)
forall a b. (a -> b) -> a -> b
$ String -> FunPtr Any -> ForeignFun
forall a. String -> FunPtr a -> ForeignFun
Fun String
fn FunPtr Any
cFn
#else
tryLoadLib :: [FilePath] -> String -> IO (Maybe DynamicLib)
tryLoadLib dirs lib = do filename <- libFileName dirs lib
handle <- Exception.catch (loadLibrary filename) nullPtrOnException
if handle == nullPtr
then return Nothing
else return . Just $ Lib lib handle
where nullPtrOnException :: Exception.IOException -> IO DL
nullPtrOnException e = return nullPtr
tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
tryLoadFn fn (Lib _ h) = do cFn <- getProcAddress h fn
if cFn == nullPtr
then return Nothing
else return . Just $ Fun fn (castPtrToFunPtr cFn)
#endif
#else
data DynamicLib = Lib { lib_name :: String
, lib_handle :: ()
}
deriving Eq
data ForeignFun = forall a. Fun { fun_name :: String
, fun_handle :: ()
}
tryLoadLib :: [FilePath] -> String -> IO (Maybe DynamicLib)
tryLoadLib fps lib = do putStrLn $ "WARNING: Cannot load '" ++ lib ++ "' at compile time because Idris was compiled without libffi support."
return Nothing
tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
tryLoadFn fn lib = do putStrLn $ "WARNING: Cannot load '" ++ fn ++ "' at compile time because Idris was compiled without libffi support."
return Nothing
#endif