diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2012-2014 Krzysztof Kardzis + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# System.RTLD [![Build Status][travis.img]][travis.htm] + +Dynamic linker tools for Haskell. + + +[![Analytics][ga.img]][ga.htm] + +[ga.img]: https://ga-beacon.appspot.com/UA-53767359-1/github/rtld +[ga.htm]: https://github.com/igrigorik/ga-beacon + +[travis.img]: https://travis-ci.org/kkardzis/rtld.svg +[travis.htm]: https://travis-ci.org/kkardzis/rtld + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/RTLD.h b/System/RTLD.h new file mode 100644 --- /dev/null +++ b/System/RTLD.h @@ -0,0 +1,174 @@ +/* ------------------------------------------------------------------------- */ +/* | */ +/* Module : System.RTLD */ +/* Copyright : Copyright © 2012-2014 Krzysztof Kardzis */ +/* License : ISC License (MIT/BSD-style, see LICENSE file for details) */ +/* */ +/* Maintainer : Krzysztof Kardzis */ +/* Stability : experimental */ +/* Portability : non-portable */ +/* */ +/* ------------------------------------------------------------------------- */ + +#include +#include + + +/* ------------------------------------------------------------------------- */ +/* SYMTABENTRY structure and some macros (for hsc2hs) */ +/* ------------------------------------------------------------------------- */ +typedef struct {int vmin; int vmax; char* name;} SYMTABENTRY; + +#define TABLEN (sizeof (SYMTAB) / sizeof (*SYMTAB)) + +#define hsc_FPID(fn) \ + { int i; for (i = 0; i < TABLEN; i++) { \ + if (strcmp(#fn, SYMTAB[i].name) == 0) { \ + printf("("); hsc_const(i); printf(")"); \ + break; \ + }; \ + }; \ + } + +#define hsc_alignof(type) \ + printf("(%ld)", (long) offsetof (struct {char x; type y;}, y)); + + +/* ------------------------------------------------------------------------- */ +/* function import macros (for hsc2hs) */ +/* ------------------------------------------------------------------------- */ + +#ifdef STDCALLCONV +# define hsc_SAFECALL(fn,ft...) CALL(fn, TYPE(ft), stdcall safe, ARGS(ft)); +# define hsc_FASTCALL(fn,ft...) CALL(fn, TYPE(ft), stdcall unsafe, ARGS(ft)); +#else +# define hsc_SAFECALL(fn,ft...) CALL(fn, TYPE(ft), ccall safe, ARGS(ft)); +# define hsc_FASTCALL(fn,ft...) CALL(fn, TYPE(ft), ccall unsafe, ARGS(ft)); +#endif + +#define CALL(fn, ft, conv, args) \ + printf("\n"); \ + printf("{-# NOINLINE " #fn " #-}\n"); \ + printf(#fn " :: " str(ft) "\n"); \ + printf(#fn " " str(args) " = peekFP "); hsc_FPID(fn); \ + printf(" >>= \\fp -> " #fn "FC fp " str(args) "\n"); \ + printf("\n"); \ + printf("type FT" #fn " = " str(ft) "\n"); \ + printf("foreign import " #conv " \"dynamic\"\n"); \ + printf(" " #fn "FC :: FunPtr FT" #fn " -> FT" #fn "\n"); + +#define CASE(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,X,...) X + +#define TYPE(...) CASE(__VA_ARGS__ \ + , T16(__VA_ARGS__) , T15(__VA_ARGS__) \ + , T14(__VA_ARGS__) , T13(__VA_ARGS__) \ + , T12(__VA_ARGS__) , T11(__VA_ARGS__) \ + , T10(__VA_ARGS__) , T09(__VA_ARGS__) \ + , T08(__VA_ARGS__) , T07(__VA_ARGS__) \ + , T06(__VA_ARGS__) , T05(__VA_ARGS__) \ + , T04(__VA_ARGS__) , T03(__VA_ARGS__) \ + , T02(__VA_ARGS__) , T01(__VA_ARGS__) \ + ) + +#define T16(a, ...) a -> T15(__VA_ARGS__) +#define T15(a, ...) a -> T14(__VA_ARGS__) +#define T14(a, ...) a -> T13(__VA_ARGS__) +#define T13(a, ...) a -> T12(__VA_ARGS__) +#define T12(a, ...) a -> T11(__VA_ARGS__) +#define T11(a, ...) a -> T10(__VA_ARGS__) +#define T10(a, ...) a -> T09(__VA_ARGS__) +#define T09(a, ...) a -> T08(__VA_ARGS__) +#define T08(a, ...) a -> T07(__VA_ARGS__) +#define T07(a, ...) a -> T06(__VA_ARGS__) +#define T06(a, ...) a -> T05(__VA_ARGS__) +#define T05(a, ...) a -> T04(__VA_ARGS__) +#define T04(a, ...) a -> T03(__VA_ARGS__) +#define T03(a, ...) a -> T02(__VA_ARGS__) +#define T02(a, ...) a -> T01(__VA_ARGS__) +#define T01(a ) a + +#define ARGS(...) CASE(__VA_ARGS__ \ + , a b c d e f g h i j k l m n o \ + , a b c d e f g h i j k l m n \ + , a b c d e f g h i j k l m \ + , a b c d e f g h i j k l \ + , a b c d e f g h i j k \ + , a b c d e f g h i j \ + , a b c d e f g h i \ + , a b c d e f g h \ + , a b c d e f g \ + , a b c d e f \ + , a b c d e \ + , a b c d \ + , a b c \ + , a b \ + , a \ + , \ + ) + +#define str(s) #s + + +/* ------------------------------------------------------------------------- */ +/* callback import macros (for hsc2hs) */ +/* ------------------------------------------------------------------------- */ + +#ifdef STDBACKCONV +# define BACKCONV "stdcall" +#else +# define BACKCONV "ccall" +#endif + +#define hsc_WRAP(fn, ft) \ + printf("\n"); \ + printf("type " #fn " = " #ft "\n"); \ + printf("\n"); \ + printf("foreign import " BACKCONV " \"wrapper\"\n"); \ + printf(" wrap" #fn " :: " #fn " -> IO (FunPtr " #fn ")\n"); \ + + +/* ------------------------------------------------------------------------- */ +/* constant import macros (for hsc2hs) */ +/* ------------------------------------------------------------------------- */ + +#define hsc_ENUM(type, ...) \ + printf("data " #type "\n"); \ + { char *x, xs[] = #__VA_ARGS__; \ + printf(" = %s\n", strtok(xs,",")); \ + while ((x=strtok(NULL,",")) != NULL) { \ + printf(" |%s\n", x); \ + }; \ + }; \ + printf("\n"); \ + printf("instance ENUM " #type " where\n"); \ + printf(" enumlist = [ " #__VA_ARGS__ " ]\n"); \ + printf(" toENUM x = case x of\n"); \ + { char *x, xs[] = #__VA_ARGS__; \ + long long vs[] = {__VA_ARGS__}; int i=1; \ + printf(" %s -> %lld\n", strtok(xs,","), vs[0]); \ + while ((x=strtok(NULL,",")) != NULL) { \ + printf(" %s -> %lld\n", x, vs[i++]); \ + }; \ + }; \ + +#define hsc_GADT(type, ...) \ + printf("data " #type " where\n"); \ + { int i=0; struct {int v; char *s;} vs[] = {__VA_ARGS__}; \ + char xs[] = #__VA_ARGS__; char *x = strtok(xs,","); \ + do { printf(" %s :: %s\n", x+1, vs[i++].s); strtok(NULL,","); \ + } while ((x=strtok(NULL,",")) != NULL); \ + }; \ + printf("\ninstance ENUM (" #type ") where\n"); \ + printf(" enumlist = []\n"); \ + printf(" toENUM x = case x of\n"); \ + { int i=0; struct {long long v; char *s;} vs[] = {__VA_ARGS__}; \ + char xs[] = #__VA_ARGS__; char *x = strtok(xs,","); \ + do { printf(" %s -> %lld\n", x+1, vs[i++].v); strtok(NULL,","); \ + } while ((x=strtok(NULL,",")) != NULL); \ + }; \ + +#define T4(x) "(" #x ", " #x ", " #x ", " #x ")" +#define T3(x) "(" #x ", " #x ", " #x ")" +#define T2(x) "(" #x ", " #x ")" +#define T1(x) "(" #x ")" + diff --git a/System/RTLD.hsc b/System/RTLD.hsc new file mode 100644 --- /dev/null +++ b/System/RTLD.hsc @@ -0,0 +1,275 @@ +------------------------------------------------------------------------------- +-- | +-- Module : System.RTLD +-- Copyright : Copyright © 2012-2014 Krzysztof Kardzis +-- License : ISC License (MIT/BSD-style, see LICENSE file for details) +-- +-- Maintainer : Krzysztof Kardzis +-- Stability : experimental +-- Portability : non-portable +-- +-- <> +------------------------------------------------------------------------------- +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.RTLD + ( RTLD (..) + + , LIBH, dynload, dynfree, dynfunc, dynfail + + , SYMTABENTRY (..) + , RTSO (..) + , rtload + , rtfree + + ) where + +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Array +import Foreign.Marshal.Utils (toBool) +#ifdef WINRTLD +import Foreign.Marshal.Alloc (alloca) +#endif + +import Control.Concurrent (MVar, modifyMVar_) +import Control.Exception (bracket_, bracketOnError) +import Control.Monad (when, void, foldM) + +#include "RTLD.h" + + +------------------------------------------------------------------------------- +class RTLD so where + withlib :: so -> IO a -> IO a + loadlib :: so -> IO () + freelib :: so -> IO () + + withlib so = bracket_ (loadlib so) (freelib so) + + +------------------------------------------------------------------------------- +type LIBH = Ptr () + + +------------------------------------------------------------------------------- +#ifdef WINRTLD + +#define WIN32_LEAN_AND_MEAN +#include + +dynload :: String -> IO LIBH +dynload xs = withCString xs loadLibrary + +dynfunc :: LIBH -> Ptr CChar -> IO (FunPtr ()) +dynfunc = getProcAddress + +dynfree :: LIBH -> IO Bool +dynfree hm = fmap toBool (freeLibrary hm) + +dynfail :: IO String +dynfail = alloca $ \csptr -> do + err <- getLastError + st <- formatMessage dwflags nullPtr err 0 csptr 0 nullPtr + xs <- if (st==0) then return "" else peek csptr >>= peekCString + _ <- peek csptr >>= \cs -> localFree (castPtr cs) + return $ concat ["(", show err, ") ", xs] + +dwflags :: DWORD +dwflags = #{const (FORMAT_MESSAGE_ALLOCATE_BUFFER|FORMAT_MESSAGE_FROM_SYSTEM)} + +type FARPROC = FunPtr () +type HMODULE = Ptr () +type HLOCAL = Ptr () +type LPCVOID = Ptr () +type LPCSTR = Ptr CChar +type LPSTR = Ptr (Ptr CChar) -- actually should be (Ptr CChar) +type DWORD = CULong +type BOOL = CInt + +foreign import stdcall "LoadLibraryA" + loadLibrary :: LPCSTR -> IO HMODULE + +foreign import stdcall "GetProcAddress" + getProcAddress :: HMODULE -> LPCSTR -> IO FARPROC + +foreign import stdcall "FreeLibrary" + freeLibrary :: HMODULE -> IO BOOL + +foreign import stdcall "GetLastError" + getLastError :: IO DWORD + +foreign import stdcall "FormatMessageA" + formatMessage :: DWORD -> LPCVOID -> DWORD -> DWORD + -> LPSTR -> DWORD -> Ptr () -> IO DWORD + +foreign import stdcall "LocalFree" + localFree :: HLOCAL -> IO HLOCAL + + + +------------------------------------------------------------------------------- +#else + +#include + +dynload :: String -> IO LIBH +dynload xs = withCString xs (\cs -> dlopen cs #{const RTLD_LAZY}) + +dynfunc :: LIBH -> Ptr CChar -> IO (FunPtr ()) +dynfunc = dlsym + +dynfree :: LIBH -> IO Bool +dynfree hm = fmap (not . toBool) (dlclose hm) + +dynfail :: IO String +dynfail = dlerror >>= peekCString + +foreign import ccall "dlopen" dlopen :: Ptr CChar -> CInt -> IO (Ptr ()) +foreign import ccall "dlsym" dlsym :: Ptr () -> Ptr CChar -> IO (FunPtr ()) +foreign import ccall "dlclose" dlclose :: Ptr () -> IO CInt +foreign import ccall "dlerror" dlerror :: IO (Ptr CChar) + +#endif + + + + + +------------------------------------------------------------------------------- +newtype SYMTABENTRY = RTSYM (CInt,CInt,(Ptr CChar)) + +instance Storable SYMTABENTRY where + sizeOf _ = #{size SYMTABENTRY} + alignment _ = #{alignof SYMTABENTRY} + poke _ _ = undefined + peek ptr = do + vmin <- #{peek SYMTABENTRY, vmin} ptr + vmax <- #{peek SYMTABENTRY, vmax} ptr + name <- #{peek SYMTABENTRY, name} ptr + return (RTSYM (vmin,vmax,name)) + + +------------------------------------------------------------------------------- +data RTSO a = RTSO + { rtPKGMVAR :: MVar (Maybe (a, LIBH, Int)) + , rtPKGNAME :: String + , rtLIBNAME :: a -> String + , rtSONAMES :: a -> [String] + , rtONLOAD :: a -> IO () + , rtONFREE :: a -> IO () + , rtGETAPI :: a -> IO (Maybe a) + , rtSYMTAB :: Ptr SYMTABENTRY + , rtADRTAB :: Ptr (FunPtr ()) + , rtTABLEN :: Int + } + + +------------------------------------------------------------------------------- +rtload :: (Ord a, Enum a, Bounded a) => RTSO a -> a -> IO () +rtload rtso rqApi = + modifyMVar_ (rtPKGMVAR rtso) $ \state -> case state of + Nothing -> libloadA rtso rqApi >>= \(ldApi,h) -> return (Just (ldApi,h,1)) + Just (ldApi,h,x) -> libtest rtso rqApi ldApi >> return (Just (ldApi,h,x+1)) + +rtfree :: RTSO a -> IO () +rtfree rtso = + modifyMVar_ (rtPKGMVAR rtso) $ \state -> case state of + Nothing -> return Nothing + Just (ldApi,h,1) -> libfree rtso ldApi h >> return Nothing + Just (ldApi,h,x) -> return (Just (ldApi,h,x-1)) + + +------------------------------------------------------------------------------- +libloadA :: (Ord a, Enum a, Bounded a) => RTSO a -> a -> IO (a, LIBH) +libloadA rtso rqApi = + bracketOnError + (foldM mloadfile Nothing (rtSONAMES rtso rqApi)) + (maybe (return ()) (void . dynfree . fst)) + (maybe (libloadfailA rtso rqApi) (libloadB rtso rqApi)) + +mloadfile :: Maybe (LIBH, String) -> String -> IO (Maybe (LIBH, String)) +mloadfile mlh@(Just _) _ = return mlh +mloadfile Nothing soname = + let check libh = if (libh==nullPtr) then Nothing else (Just (libh,soname)) + in fmap check (dynload soname) + +libloadfailA :: RTSO a -> a -> IO (a, LIBH) +libloadfailA rtso rqApi = error $ concat + [ rtPKGNAME rtso, " failed to load ", rtLIBNAME rtso rqApi + , " ", show (rtSONAMES rtso rqApi) ] + + +------------------------------------------------------------------------------- +libloadB :: (Ord a, Enum a, Bounded a) + => RTSO a -> a -> (LIBH, String) -> IO (a, LIBH) +libloadB rtso rqApi so@(libh, soname) = + bracketOnError (symload rtso libh) (const $ symfree rtso) + (maybe (libloadfailB rtso rqApi soname) (libloadC rtso rqApi so)) + +libloadC :: (Ord a) => RTSO a -> a -> (LIBH, String) -> a -> IO (a, LIBH) +libloadC rtso rqApi (libh, soname) smApi = + bracketOnError (rtONLOAD rtso smApi) (\_ -> rtONFREE rtso smApi) + $ \_ -> do + ldApiM <- rtGETAPI rtso smApi + case ldApiM of + Nothing -> libloadfailB rtso rqApi soname + Just ldApi -> if (ldApi>=rqApi && smApi>=rqApi) + then return ((min ldApi smApi), libh) + else libloadfailB rtso rqApi soname + +libloadfailB :: RTSO a -> a -> String -> IO (a, LIBH) +libloadfailB rtso rqApi soname = error $ concat + [ rtPKGNAME rtso, " failed to load ", rtLIBNAME rtso rqApi + , " ('", soname, "' found, but version doesn't match)" ] + + +------------------------------------------------------------------------------- +libtest :: (Ord a) => RTSO a -> a -> a -> IO () +libtest rtso rqApi ldApi = when (rqApi > ldApi) (libtestfail rtso rqApi ldApi) + +libtestfail :: RTSO a -> a -> a -> IO () +libtestfail rtso rqApi ldApi = error $ concat + [ rtPKGNAME rtso, " version mismatch: " + , rtLIBNAME rtso rqApi, " required, but " + , rtLIBNAME rtso ldApi, " already loaded" ] + + +------------------------------------------------------------------------------- +libfree :: RTSO a -> a -> LIBH -> IO () +libfree rtso ldApi libh = do + rtONFREE rtso ldApi + x <- symfree rtso >> dynfree libh + when (not x) (libfreefail rtso ldApi) + +libfreefail :: RTSO a -> a -> IO () +libfreefail rtso ldApi = error $ concat + [ rtPKGNAME rtso, " failed to free ", rtLIBNAME rtso ldApi ] + + +------------------------------------------------------------------------------- +symload :: (Ord a, Enum a, Bounded a) => RTSO a -> LIBH -> IO (Maybe a) +symload rtso libh = do + (vmins,vmaxs,names) <- fmap vpack $ peekArray (rtTABLEN rtso) (rtSYMTAB rtso) + addrs <- mapM (dynfunc libh) names + pokeArray (rtADRTAB rtso) addrs + return $ case (vtags (zip3 vmins vmaxs addrs)) of + [] -> Nothing + xs -> Just (maximum xs) + +symfree :: RTSO a -> IO () +symfree rtso = + pokeArray (rtADRTAB rtso) (take (rtTABLEN rtso) (repeat nullFunPtr)) + +vpack :: (Enum a) => [SYMTABENTRY] -> ([a], [a], [Ptr CChar]) +vpack xs = unzip3 $ map (\(RTSYM (x,y,z)) -> (foo x, foo y, z)) xs + where foo = toEnum . fromIntegral + +vtags :: (Ord a, Enum a, Bounded a) => [(a,a,FunPtr ())] -> [a] +vtags xs = filter (\x -> all (vtest x) xs) [minBound .. maxBound] + +vtest :: (Ord a, Enum a, Bounded a) => a -> (a,a,FunPtr ()) -> Bool +vtest vnom (vmin,vmax,addr) = (addr/=nullFunPtr) || (vnomvmax) + diff --git a/rtld.cabal b/rtld.cabal new file mode 100644 --- /dev/null +++ b/rtld.cabal @@ -0,0 +1,54 @@ +name: rtld +version: 0.0.2 +synopsis: dynamic linker tools for Haskell +author: Krzysztof Kardzis +maintainer: Krzysztof Kardzis +copyright: Copyright © 2012-2014 Krzysztof Kardzis +-- license: ISC License (MIT/BSD-style, see LICENSE file for details) +license: OtherLicense +license-file: LICENSE +category: System +stability: Experimental +build-type: Simple +cabal-version: >=1.6 +homepage: https://github.com/kkardzis/rtld + +description: + Package @rtld@ provides simplistic interface to the dynamic linker/loader. + It wraps 'dlopen/dlclose' family of functions ('LoadLibrary/FreeLibrary' + on Windows) and tries to provide a common interface to dynamically load + foreign libraries at runtime. It is used currently as a helper package + for @curlhs@ (), but is not + ready for the public use (more tests and design decisions needed). + . + Package is distributed under ISC License (MIT/BSD-style, see LICENSE file + for details). It is marked as @OtherLicense@ due to limitations of Cabal. + . + <> + +extra-source-files: + README.md + +library + ghc-options: -Wall -fwarn-tabs + build-depends: base ==4.* + exposed-modules: System.RTLD + install-includes: RTLD.h + include-dirs: System + + if os(windows) + cpp-options: -DWINRTLD + + if os(OSX) + cpp-options: -DOSXRTLD + + if os(linux) + cpp-options: -DGNURTLD + + if os(freebsd) + cpp-options: -DBSDRTLD + +source-repository head + location: https://github.com/kkardzis/rtld + type: git +