├── Setup.hs ├── .gitignore ├── examples ├── dynamicloader │ └── www │ │ ├── files │ │ ├── index.upp │ │ └── index.html │ │ ├── README │ │ ├── Makefile │ │ ├── plugins │ │ └── Upper.hs │ │ └── Main.hs ├── nameloader │ └── www │ │ ├── Page.hs │ │ ├── Sub │ │ └── Page.hs │ │ ├── README │ │ ├── Makefile │ │ └── Main.hs └── pathloader │ └── www │ ├── Page.hs │ ├── Sub │ └── Page.hs │ ├── README │ ├── Makefile │ └── Main.hs ├── .travis.yml ├── dynamic-linker.pdf ├── circle.yml ├── System └── Plugins │ ├── Criteria │ ├── UnsafeCriterion.hs │ └── LoadCriterion.hs │ ├── PathLoader.hs │ ├── NameLoader.hs │ └── DynamicLoader.hs ├── README.md ├── LICENSE └── dynamic-loader.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | 8 | *~ 9 | -------------------------------------------------------------------------------- /examples/dynamicloader/www/files/index.upp: -------------------------------------------------------------------------------- 1 | it works if everything is in uppercase! 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - 7.8 5 | - 7.6 6 | 7 | sudo: false 8 | -------------------------------------------------------------------------------- /dynamic-linker.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ggreif/dynamic-loader/HEAD/dynamic-linker.pdf -------------------------------------------------------------------------------- /examples/dynamicloader/www/files/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | It works! 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /examples/nameloader/www/Page.hs: -------------------------------------------------------------------------------- 1 | module Page where 2 | 3 | page :: IO String 4 | page = return "Hello World!" 5 | -------------------------------------------------------------------------------- /examples/pathloader/www/Page.hs: -------------------------------------------------------------------------------- 1 | module Page where 2 | 3 | page :: IO String 4 | page = return "Hello World!" 5 | -------------------------------------------------------------------------------- /examples/nameloader/www/Sub/Page.hs: -------------------------------------------------------------------------------- 1 | module Sub.Page where 2 | 3 | page :: IO String 4 | page = return "Hello World in a subpage!" 5 | -------------------------------------------------------------------------------- /examples/pathloader/www/Sub/Page.hs: -------------------------------------------------------------------------------- 1 | module Sub.Page where 2 | 3 | page :: IO String 4 | page = return "Hello World in a subpage!" 5 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | # /for/ version: 2 2 | ## ^^^ consult https://circleci.com/docs/2.0/migrating-from-1-2 3 | ## and https://circleci.com/docs/2.0/ 4 | 5 | machine: 6 | ghc: 7 | version: 7.10.2 8 | -------------------------------------------------------------------------------- /examples/dynamicloader/www/README: -------------------------------------------------------------------------------- 1 | A very simple webserver with support for plugins. 2 | 3 | Compile example with command: 4 | make 5 | 6 | To test server run: 7 | a.out 8 | 9 | then bring up a web browser and visit: 10 | 11 | http://127.0.0.1:8080/files/index.html 12 | http://127.0.0.1:8080/files/index.upp 13 | -------------------------------------------------------------------------------- /examples/nameloader/www/README: -------------------------------------------------------------------------------- 1 | A simple, somewhat special web server. It only uses precompiled 2 | Haskell objects as pages. 3 | 4 | To compile run the following command: 5 | make 6 | 7 | To test the server run: 8 | ./a.out 9 | 10 | then visit the pages with a web browser: 11 | 12 | http://127.0.0.1:8080/Page 13 | http://127.0.0.1:8080/Sub/Page 14 | -------------------------------------------------------------------------------- /examples/pathloader/www/README: -------------------------------------------------------------------------------- 1 | A simple, somewhat special web server. It only uses precompiled 2 | Haskell objects as pages. 3 | 4 | To compile run the following command: 5 | make 6 | 7 | To test the server run: 8 | ./a.out 9 | 10 | then visit the pages with a web browser: 11 | 12 | http://127.0.0.1:8080/Page 13 | http://127.0.0.1:8080/Sub/Page 14 | -------------------------------------------------------------------------------- /examples/dynamicloader/www/Makefile: -------------------------------------------------------------------------------- 1 | GHC=ghc 2 | 3 | all: 4 | if [ ! -d out ]; then mkdir out; fi 5 | if [ ! -d out/DynamicLoader ]; then mkdir out/DynamicLoader; fi 6 | $(GHC) -odir out -hidir out -iout -i../../.. --make Main.hs 7 | $(GHC) -hidir out -iout -c plugins/Upper.hs -o plugins/Upper.plugin 8 | 9 | clean: 10 | rm -rf out 11 | rm -f plugins/Upper.plugin 12 | rm -f a.out 13 | -------------------------------------------------------------------------------- /examples/dynamicloader/www/plugins/Upper.hs: -------------------------------------------------------------------------------- 1 | module Upper (plugin) where 2 | 3 | import Char (toUpper) 4 | 5 | -- a plugin should export a function "plugin" which tells 6 | -- the web browser which extension to handle as well as which 7 | -- function to run with each page content 8 | 9 | plugin = ("upp", handleUpper) 10 | 11 | handleUpper :: String -> IO String 12 | handleUpper str = return (map toUpper str) 13 | -------------------------------------------------------------------------------- /examples/nameloader/www/Makefile: -------------------------------------------------------------------------------- 1 | GHC=ghc 2 | 3 | all: 4 | if [ ! -d out ]; then mkdir out; fi 5 | if [ ! -d out/DynamicLoader ]; then mkdir out/DynamicLoader; fi 6 | $(GHC) -odir out -hidir out -iout -i../../.. --make Main.hs 7 | $(GHC) -odir out -hidir out -iout -c Page.hs -o Page.o 8 | $(GHC) -odir out -hidir out -iout -c Sub/Page.hs -o Sub/Page.o 9 | 10 | clean: 11 | rm -rf out 12 | rm -f Page.o 13 | rm -f Sub/Page.o 14 | rm -f a.out 15 | -------------------------------------------------------------------------------- /examples/pathloader/www/Makefile: -------------------------------------------------------------------------------- 1 | GHC=ghc 2 | 3 | all: 4 | if [ ! -d out ]; then mkdir out; fi 5 | if [ ! -d out/DynamicLoader ]; then mkdir out/DynamicLoader; fi 6 | $(GHC) -odir out -hidir out -iout -i../../.. --make Main.hs 7 | $(GHC) -odir out -hidir out -iout -c Page.hs -o Page.o 8 | $(GHC) -odir out -hidir out -iout -c Sub/Page.hs -o Sub/Page.o 9 | 10 | clean: 11 | rm -rf out 12 | rm -f Page.o 13 | rm -f Sub/Page.o 14 | rm -f a.out 15 | -------------------------------------------------------------------------------- /System/Plugins/Criteria/UnsafeCriterion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures, ConstraintKinds, TypeFamilies, 2 | MultiParamTypeClasses, FlexibleInstances #-} 3 | 4 | module System.Plugins.Criteria.UnsafeCriterion (Criterion(..)) where 5 | 6 | import System.Plugins.Criteria.LoadCriterion 7 | import System.Plugins.DynamicLoader 8 | 9 | instance LoadCriterion () t where 10 | data Criterion () t = UnsafeCriterion 11 | type Effective () t = IO t 12 | loadQualified UnsafeCriterion = loadQualifiedFunction 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | dynamic-loader 2 | ============== 3 | 4 | [![Build Status Travis](https://travis-ci.org/ggreif/dynamic-loader.svg)](https://travis-ci.org/ggreif/dynamic-loader) 5 | [![Build Status CircleCI](https://circleci.com/gh/ggreif/dynamic-loader.svg?&style=shield)](https://circleci.com/gh/ggreif/dynamic-loader) 6 | [![Hackage](https://img.shields.io/hackage/v/dynamic-loader.svg)](https://hackage.haskell.org/package/dynamic-loader) 7 | [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/dynamic-loader.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=exact%3Adynamic-loader) 8 | 9 | 10 | Lightweight Haskell dynamic loading library originally written by Copyright © 2004 Hampus Ram. 11 | 12 | For the original homepage please refer to http://www.bandersnatch.se/dynamic 13 | -------------------------------------------------------------------------------- /examples/pathloader/www/Main.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | import System.Directory 3 | import Data.List 4 | import qualified Data.HashTable as HT 5 | import Control.Monad 6 | import Control.Concurrent 7 | import Network 8 | 9 | import DynamicLoader.PathLoader 10 | 11 | 12 | main 13 | = do basep <- loadModule "/usr/lib/ghc-6.2/HSbase.o" MT_Package 14 | h98p <- loadModule "/usr/lib/ghc-6.2/HShaskell98.o" MT_Package 15 | 16 | socket <- listenOn (PortNumber 8080) 17 | 18 | server socket 19 | 20 | server socket 21 | = do (handle, name, _) <- accept socket 22 | forkIO (client handle) 23 | server socket 24 | 25 | client handle 26 | = do req <- hGetLine handle 27 | 28 | let mfile = parseRequest req 29 | 30 | maybe (errorPage handle) (responsePage handle) mfile 31 | 32 | hClose handle 33 | 34 | parseRequest str 35 | = let parts = words str 36 | in case parts of 37 | ["GET", name, "HTTP/1.1"] -> Just (drop 1 name) 38 | _ -> Nothing 39 | 40 | responsePage handle file 41 | = do cwd <- getCurrentDirectory 42 | lm <- loadModule (cwd ++ "/" ++ file) MT_Module 43 | 44 | func <- loadFunction lm "page" 45 | str <- func 46 | 47 | unloadModule lm 48 | 49 | hPutStr handle hdr 50 | hPutStr handle str 51 | 52 | where hdr = "HTTP/1.1 200 Ok\n\n" 53 | 54 | errorPage handle 55 | = do hPutStrLn handle "HTTP/1.1 400 Bad Request\n" 56 | hPutStr handle "400 Bad Request" 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2003-2004, Hampus Ram 2 | Copyright (c) 2012, Gabor Greif 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of Hampus Ram nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /examples/nameloader/www/Main.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | import Data.List 3 | import qualified Data.HashTable as HT 4 | import Control.Monad 5 | import Control.Concurrent 6 | import Network 7 | 8 | import DynamicLoader.NameLoader 9 | 10 | 11 | main 12 | = do moduleh <- HT.new (==) HT.hashString 13 | 14 | setEnvironment Nothing Nothing (Just ppath) Nothing Nothing 15 | 16 | basep <- loadModule "base" 17 | h98p <- loadModule "haskell98" 18 | 19 | socket <- listenOn (PortNumber 8080) 20 | 21 | server moduleh socket 22 | 23 | where ppath = "/usr/lib/ghc-6.2/" 24 | 25 | server moduleh socket 26 | = do (handle, name, _) <- accept socket 27 | forkIO (client moduleh handle) 28 | server moduleh socket 29 | 30 | client moduleh handle 31 | = do req <- hGetLine handle 32 | 33 | let mfile = parseRequest req 34 | 35 | maybe (errorPage handle) (responsePage moduleh handle) mfile 36 | 37 | hClose handle 38 | 39 | parseRequest str 40 | = let parts = words str 41 | in case parts of 42 | ["GET", name, "HTTP/1.1"] -> Just (toDot $ drop 1 name) 43 | _ -> Nothing 44 | where toDot str = map (\a -> case a of { '/' -> '.'; a -> a }) str 45 | 46 | responsePage moduleh handle file 47 | = do mlm <- HT.lookup moduleh file 48 | lm <- case mlm of 49 | Just lm -> do reloadModule lm True 50 | return lm 51 | Nothing -> do lm <- loadModule file 52 | HT.insert moduleh file lm 53 | return lm 54 | 55 | func <- loadFunction lm "page" 56 | str <- func 57 | 58 | hPutStr handle hdr 59 | hPutStr handle str 60 | 61 | where hdr = "HTTP/1.1 200 Ok\n\n" 62 | 63 | errorPage handle 64 | = do hPutStrLn handle "HTTP/1.1 400 Bad Request\n" 65 | hPutStr handle "400 Bad Request" 66 | -------------------------------------------------------------------------------- /System/Plugins/Criteria/LoadCriterion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures, ConstraintKinds, 2 | TypeFamilies, MultiParamTypeClasses #-} 3 | 4 | module System.Plugins.Criteria.LoadCriterion (LoadCriterion(..), Criterion(..)) where 5 | 6 | -- The 'Constraint' kind is defined in 'GHC.Exts' 7 | 8 | import GHC.Exts 9 | import System.Plugins.DynamicLoader 10 | import Data.Dynamic 11 | import Control.Monad.IO.Class 12 | 13 | class LoadCriterion (c :: Constraint) t where 14 | data Criterion c t 15 | type Effective c t :: * 16 | addDynamicLibrary :: Criterion c t -> String -> IO () 17 | addDynamicLibrary _ = addDLL 18 | resolveSymbols :: Criterion c t -> IO () 19 | resolveSymbols _ = resolveFunctions 20 | loadQualified :: c => Criterion c t -> String -> Effective c t 21 | 22 | 23 | -- Safe criteria follow 24 | 25 | -- | When the symbol's type is Typeable we load from the suffixed symbol and 26 | -- | try to resolve it. 27 | instance LoadCriterion (Typeable t) t where 28 | data Criterion (Typeable t) t = DynamicCriterion 29 | type Effective (Typeable t) t = IO (Maybe t) 30 | loadQualified DynamicCriterion name = loadQualifiedDynFunction (adornSymbol name) 31 | where adornSymbol n = n ++ "Dyn" 32 | 33 | 34 | loadQualifiedDynFunction :: Typeable t => String -> IO (Maybe t) 35 | loadQualifiedDynFunction name = fmap fromDynamic dyn 36 | where dyn :: IO Dynamic 37 | dyn = loadQualifiedFunction name 38 | 39 | 40 | -- | When the symbol's type is Typeable and we are in a monad that can 41 | -- | reliably fail, we load from the suffixed symbol and try to resolve it, 42 | -- | failing when the type does not correspond with the expectation. 43 | instance LoadCriterion (Typeable t, MonadIO m) t where 44 | data Criterion (Typeable t, MonadIO m) t = DynamicFailableCriterion 45 | type Effective (Typeable t, MonadIO m) t = m t 46 | loadQualified DynamicFailableCriterion name = do sym <- liftIO $ loadQualifiedDynFunction (adornSymbol name) 47 | case sym of 48 | Nothing -> liftIO $ fail ("symbol " ++ name ++ " does not have the expected type") 49 | Just it -> return it 50 | where adornSymbol n = n ++ "Dyn" 51 | 52 | -------------------------------------------------------------------------------- /examples/dynamicloader/www/Main.hs: -------------------------------------------------------------------------------- 1 | import System.Directory 2 | import System.IO 3 | import Data.List 4 | import Control.Monad 5 | import Network 6 | 7 | import DynamicLoader.DynamicLoader 8 | 9 | main 10 | = do cwd <- getCurrentDirectory 11 | 12 | basep <- loadPackage "base" (Just ppath) Nothing Nothing 13 | h98p <- loadPackage "haskell98" (Just ppath) Nothing Nothing 14 | 15 | (mods, plugins) <- loadPlugins cwd 16 | 17 | socket <- listenOn (PortNumber 8080) 18 | server cwd plugins socket 19 | 20 | unloadPlugins mods 21 | 22 | unloadPackage basep 23 | unloadPackage h98p 24 | 25 | where ppath = "/usr/lib/ghc-6.2/" 26 | 27 | server cwd plugins socket 28 | = do (handle, name, _) <- accept socket 29 | req <- hGetLine handle 30 | 31 | let mfile = parseRequest cwd req 32 | 33 | maybe (errorPage handle) (responsePage plugins handle) mfile 34 | 35 | hClose handle 36 | 37 | server cwd plugins socket 38 | 39 | 40 | loadPlugins cwd 41 | = do files <- getDirectoryContents ppath 42 | let plugs = filter (\a -> "plugin" `isSuffixOf` a) files 43 | names = map (\s -> reverse $ drop 7 (reverse s)) plugs 44 | 45 | lms <- mapM (\n -> loadModule n (Just ppath) (Just "plugin")) names 46 | 47 | resolveFunctions 48 | 49 | initfuncs <- mapM (\lm -> loadFunction lm "plugin") lms 50 | 51 | plugins <- mapM return 52 | (initfuncs :: [(String, String -> IO String)]) 53 | 54 | return (lms, plugins) 55 | 56 | where ppath = cwd ++ "/plugins" 57 | 58 | unloadPlugins plugins 59 | = do mapM_ unloadModule plugins 60 | 61 | parseRequest cwd str 62 | = let parts = words str 63 | in case parts of 64 | ["GET", name, "HTTP/1.1"] -> Just (cwd ++ name) 65 | _ -> Nothing 66 | 67 | responsePage plugins handle file 68 | = do let mpfunc = find (\(suff, func) -> isSuffixOf suff file) plugins 69 | str <- catch (readFile file) (\_ -> return "") 70 | hPutStrLn handle "HTTP/1.1 200 Ok\n" 71 | case mpfunc of 72 | Just (_, f) -> do str' <- f str 73 | hPutStr handle str' 74 | Nothing -> hPutStr handle str 75 | 76 | errorPage handle 77 | = do hPutStrLn handle "HTTP/1.1 400 Bad Request\n" 78 | hPutStr handle "400 Bad Request" 79 | -------------------------------------------------------------------------------- /dynamic-loader.cabal: -------------------------------------------------------------------------------- 1 | Name: dynamic-loader 2 | 3 | Version: 0.0.1 4 | 5 | Synopsis: lightweight loader of GHC-based modules or packages 6 | 7 | Description: This package allows the linking against GHC-compiled 8 | object files and shared libraries. Specialized modules 9 | are provided for navigating directory structure and 10 | dependency checking. 11 | . 12 | No attempt at type-safe loading of symbols is made. 13 | . 14 | Release history: 15 | . 16 | [0.0] Initial version (testing Hackage build) 17 | . 18 | [0.0.1] Added support for archives 19 | 20 | Homepage: https://github.com/ggreif/dynamic-loader 21 | Bug-reports: https://github.com/ggreif/dynamic-loader/issues 22 | 23 | License: BSD3 24 | License-file: LICENSE 25 | 26 | -- The package author(s). 27 | Author: Hampus Ram 28 | 29 | Maintainer: Gabor Greif 30 | 31 | Copyright: Copyright (c) 2003-2004, Hampus Ram; 32 | (c) 2012-2016, Gabor Greif 33 | 34 | Category: System 35 | 36 | Stability: experimental 37 | Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 38 | 39 | Build-type: Simple 40 | 41 | Data-files: dynamic-linker.pdf 42 | 43 | Cabal-version: >= 1.6 44 | 45 | Library 46 | -- Modules exported by the library. 47 | Exposed-modules: System.Plugins.DynamicLoader, System.Plugins.PathLoader, System.Plugins.NameLoader 48 | System.Plugins.Criteria.LoadCriterion, System.Plugins.Criteria.UnsafeCriterion 49 | 50 | Extensions: CPP, ForeignFunctionInterface, MagicHash, ScopedTypeVariables, UnboxedTuples 51 | KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances 52 | ConstraintKinds 53 | 54 | -- Packages needed in order to build this package. 55 | Build-depends: base >= 4.5 && < 5, directory, time, ghc-prim >= 0.2, 56 | hashable, hashtables, transformers 57 | 58 | -- Modules not exported by this package. 59 | -- Other-modules: 60 | 61 | -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. 62 | -- Build-tools: 63 | 64 | Ghc-Options: -Wall 65 | 66 | Source-repository head 67 | type: git 68 | location: git://github.com/ggreif/dynamic-loader.git 69 | -------------------------------------------------------------------------------- /System/Plugins/PathLoader.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : PathLoader 4 | -- Copyright : (c) Hampus Ram 2004, Gabor Greif 2012 5 | -- License : BSD-style (see LICENSE) 6 | -- 7 | -- Maintainer : ggreif+dynamic@gmail.com 8 | -- Stability : experimental 9 | -- Portability : non-portable (ghc >= 7.6 only) 10 | -- 11 | -- A module that implements dynamic loading. 12 | -- Has smart handling of dependencies and 13 | -- is thread safe. 14 | -- 15 | ---------------------------------------------------------------------------- 16 | {-# LANGUAGE ScopedTypeVariables, ConstraintKinds #-} 17 | 18 | module System.Plugins.PathLoader (LoadedModule, 19 | ModuleType (..), 20 | setBasePath, 21 | addDependency, 22 | setDependencies, 23 | delDependency, 24 | delAllDeps, 25 | withDependencies, 26 | loadModule, 27 | unloadModule, 28 | unloadModuleQuiet, 29 | loadFunction, 30 | loadQualifiedFunction, 31 | moduleLoadedAt, 32 | loadedModules, 33 | DL.addDLL) where 34 | 35 | import Control.Concurrent.MVar 36 | import Data.List 37 | import qualified Data.HashTable.IO as HT 38 | import Data.Hashable 39 | import Data.IORef 40 | import System.IO.Unsafe 41 | import System.Directory 42 | import Data.Time 43 | import Control.Exception (catch, SomeException) 44 | import System.Plugins.Criteria.LoadCriterion 45 | import System.Plugins.Criteria.UnsafeCriterion 46 | 47 | import qualified System.Plugins.DynamicLoader as DL 48 | 49 | type Loadable c t t' = (LoadCriterion c t, Effective c t ~ IO t') 50 | 51 | data LoadedModule = LM FilePath ModuleType 52 | 53 | data ModuleType = MT_Module 54 | | MT_Package 55 | deriving (Eq, Ord, Show) 56 | 57 | type ModuleWT = (ModuleType, FilePath) 58 | 59 | type PathDynamics = Either DL.DynamicModule DL.DynamicPackage 60 | 61 | type PathDep = [ModuleWT] 62 | 63 | -- PM reference_count type time module 64 | data PathModule = PM { pm_refc :: !Int, 65 | pm_time :: UTCTime, 66 | pm_deps :: PathDep, 67 | pm_module :: PathDynamics } 68 | 69 | 70 | -- base_path dependency_map modules 71 | type PathEnvData = (Maybe FilePath, 72 | HT.BasicHashTable String [ModuleWT], 73 | HT.BasicHashTable String PathModule) 74 | 75 | 76 | {- 77 | 78 | New PathEnv that uses both an IORef and a MVar 79 | to make it possible to have non blocking functions 80 | that inspect the state. 81 | 82 | -} 83 | type PathEnv = (MVar (), IORef PathEnvData) 84 | 85 | withPathEnv :: Loadable c t t' => Criterion c t -> PathEnv -> (PathEnvData -> Effective c t) -> Effective c t 86 | withPathEnv _ (mvar, ioref) f 87 | = withMVar mvar (\_ -> readIORef ioref >>= f) 88 | 89 | withPathEnvNB :: PathEnv -> (PathEnvData -> IO b) -> IO b 90 | withPathEnvNB (_, ioref) f = readIORef ioref >>= f 91 | 92 | modifyPathEnv_ :: PathEnv -> (PathEnvData -> IO PathEnvData) -> IO () 93 | modifyPathEnv_ (mvar, ioref) f 94 | = withMVar mvar (\_ -> readIORef ioref >>= f >>= writeIORef ioref) 95 | 96 | {-# NOINLINE env #-} 97 | env :: PathEnv 98 | env = unsafePerformIO (do modh <- HT.new 99 | deph <- HT.new 100 | mvar <- newMVar () 101 | ioref <- newIORef (Nothing, deph, modh) 102 | return (mvar, ioref)) 103 | 104 | {-| 105 | 106 | Set the base path used in figuring out module names. If not set the default 107 | (i.e. currentDirectory) will be used. 108 | 109 | -} 110 | setBasePath :: Maybe FilePath -> IO () 111 | setBasePath mpath 112 | = modifyPathEnv_ env (\(_, deph, modh) -> return (mpath, deph, modh)) 113 | 114 | 115 | {-| 116 | 117 | Add a module dependency. Any dependencies must be added /before/ any 118 | calls to loadModule\/loadPackage or symbols will not be resolved with a 119 | crash as result. 120 | 121 | -} 122 | addDependency :: FilePath -> (ModuleType, FilePath) -> IO () 123 | addDependency from to = withPathEnv UnsafeCriterion env (addDependency' from to) 124 | 125 | addDependency' :: FilePath -> (ModuleType, FilePath) -> PathEnvData -> IO () 126 | addDependency' from to (_, deph, _) 127 | = insertHT_C union deph from [to] 128 | 129 | {-| 130 | 131 | Set all dependencies. All previous dependencies are removed. 132 | 133 | -} 134 | 135 | setDependencies :: FilePath -> [(ModuleType, FilePath)] -> IO () 136 | setDependencies from to = withPathEnv UnsafeCriterion env (setDependencies' from to) 137 | 138 | setDependencies' :: FilePath -> [(ModuleType, FilePath)] -> 139 | PathEnvData -> IO () 140 | setDependencies' from to (_, deph, _) 141 | = insertHT deph from to 142 | 143 | {-| 144 | 145 | Delete a module dependency. 146 | 147 | -} 148 | delDependency :: FilePath -> (ModuleType, FilePath) -> IO () 149 | delDependency from to = withPathEnv UnsafeCriterion env (delDependency' from to) 150 | 151 | delDependency' :: FilePath -> (ModuleType, FilePath) -> PathEnvData -> IO () 152 | delDependency' from to (_, deph, _) 153 | = modifyHT (\\[to]) deph from 154 | 155 | {-| 156 | 157 | Delete all dependencies for a module. Same behaviour as 158 | @setDependencies path []@. 159 | 160 | -} 161 | 162 | delAllDeps :: FilePath -> IO () 163 | delAllDeps from = withPathEnv UnsafeCriterion env (delAllDeps' from) 164 | 165 | delAllDeps' :: FilePath -> PathEnvData -> IO () 166 | delAllDeps' from (_, deph, _) 167 | = deleteHT deph from 168 | 169 | {-| 170 | 171 | Do something with the current dependencies of a module. You can't use 172 | (blocking) functions from this module in the function given to 173 | withDependencies. If you do so, a deadlock will occur. 174 | 175 | -} 176 | withDependencies :: Loadable c t t' => Criterion c t -> FilePath 177 | -> (Maybe [(ModuleType, FilePath)] -> Effective c t) -> Effective c t 178 | withDependencies crit from f 179 | = withPathEnv crit env (\(_,deph,_) -> lookupHT deph from >>= f) 180 | 181 | {-| 182 | 183 | Load a module (or package) and modules (or packages) it depends on. It 184 | is possible to load a module many times without any error 185 | occuring. However to unload a module one needs to call @unloadModule@ 186 | the same number of times. 187 | 188 | Before loading any modules you should add wich dependencies it has 189 | with addDependency (and which dependencies the modules upon which it 190 | depends have). 191 | 192 | If the module already has been loaded nothing will be done except 193 | updating the reference count. I.e. if dependencies have been updated 194 | they will be ignored until the module has been completely unloaded and 195 | loaded again. 196 | 197 | If any error occurs an exception is thrown. 198 | 199 | -} 200 | loadModule :: FilePath -> ModuleType -> IO LoadedModule 201 | loadModule m mt 202 | = do withPathEnv UnsafeCriterion env (\env -> do loadModuleWithDep (mt, m) env 203 | DL.resolveFunctions 204 | return (LM m mt)) 205 | 206 | loadModuleWithDep :: (ModuleType, FilePath) -> PathEnvData -> IO () 207 | loadModuleWithDep nwt@(_, name) env@(_, _, modh) 208 | = do mpm <- lookupHT modh name 209 | (pm, depmods) <- midLoadModule mpm nwt env 210 | 211 | insertHT modh name pm 212 | 213 | mapM_ (\modwt -> loadModuleWithDep modwt env) depmods 214 | 215 | midLoadModule :: Maybe PathModule -> (ModuleType, FilePath) -> 216 | PathEnvData -> IO (PathModule, PathDep) 217 | midLoadModule (Just pm) _ _ = return $ (pm { pm_refc = pm_refc pm + 1 }, 218 | pm_deps pm) 219 | midLoadModule Nothing nwt@(_, name) env@(_, deph, _) 220 | = do (sd, time) <- lowLoadModule nwt env 221 | depmods <- lookupDefHT deph [] name 222 | return (PM 1 time depmods sd, depmods) 223 | 224 | lowLoadModule :: ModuleWT -> PathEnvData -> IO (PathDynamics, UTCTime) 225 | lowLoadModule (MT_Package, name) (_, _, _) 226 | = do lp <- DL.loadPackageFromPath name 227 | time <- getModificationTime (DL.dp_path lp) 228 | return (Right lp, time) 229 | lowLoadModule (MT_Module, name) (mpath, _, _) 230 | = do lm <- DL.loadModuleFromPath name mpath 231 | time <- getModificationTime (DL.dm_path lm) 232 | return (Left lm, time) 233 | 234 | {-| 235 | 236 | Unload a module and all modules it depends on. This unloading only 237 | occurs if the module isn't needed by any other libraries or hasn't 238 | been loaded more than once. An exception is thrown in case of error. 239 | 240 | -} 241 | unloadModule :: LoadedModule -> IO () 242 | unloadModule (LM name _) 243 | = withPathEnv UnsafeCriterion env (unloadModuleWithDep name) 244 | 245 | {-| 246 | 247 | Same as @unloadModule@ just doesn't trow any exceptions on error. 248 | 249 | -} 250 | unloadModuleQuiet :: LoadedModule -> IO () 251 | unloadModuleQuiet (LM name _) 252 | = withPathEnv UnsafeCriterion env (\env -> catch (unloadModuleWithDep name env) 253 | (\(_ :: SomeException) -> return ())) 254 | 255 | unloadModuleWithDep :: FilePath -> PathEnvData -> IO () 256 | unloadModuleWithDep name env@(_, _, modh) 257 | = do mpm <- lookupHT modh name 258 | pm <- maybe (fail $ "Module " ++ name ++ " not loaded") 259 | return mpm 260 | 261 | if pm_refc pm > 1 262 | then do insertHT modh name (pm { pm_refc = pm_refc pm - 1 }) 263 | else do lowUnloadModule (pm_module pm) 264 | deleteHT modh name 265 | 266 | mapM_ (\(_, m) -> unloadModuleWithDep m env) (pm_deps pm) 267 | 268 | lowUnloadModule :: PathDynamics -> IO () 269 | lowUnloadModule (Left lm) = DL.unloadModule lm 270 | lowUnloadModule (Right lp) = DL.unloadPackage lp 271 | 272 | {-| 273 | 274 | Load a function from a module. It cannot load functions from packages 275 | and will throw an exception if one tries to do so. Also throws if an 276 | error occurs. 277 | 278 | It seems (but I'm unsure) like any functions loaded will continue to 279 | be valid even after the module it resides in is unloaded. It will also 280 | still be valid if a new version of that module is loaded (it will thus 281 | still call the old function). 282 | 283 | -} 284 | loadFunction :: Loadable c t t' => Criterion c t -> LoadedModule -> String -> Effective c t 285 | loadFunction crit (LM m MT_Module) name 286 | = withPathEnv crit env (loadFunction' m name) 287 | where loadFunction' mname fname (_, _, modh) 288 | = do mpm <- HT.lookup modh mname 289 | pm <- maybe (fail $ "Module " ++ mname ++ " isn't loaded") 290 | return mpm 291 | let Left dm = pm_module pm 292 | DL.loadFunction dm fname 293 | 294 | loadFunction _ _ _ = fail "You cannot load functions from a package." 295 | 296 | {-| 297 | 298 | Load a qualified function from a module or package. It will throw an 299 | exception if an error occurs. Same restriction as for 300 | DynamicLinker.loadQualifiedFunction applies here too. 301 | 302 | -} 303 | loadQualifiedFunction :: Loadable c t t' => Criterion c t -> String -> Effective c t 304 | loadQualifiedFunction crit name 305 | = withPathEnv crit env (loadQualifiedFunction' name) 306 | where loadQualifiedFunction' qname _ = DL.loadQualifiedFunction qname 307 | 308 | 309 | {-| 310 | 311 | Give the modification time for a loded module. Will throw an exception 312 | if the module isn't loaded. 313 | 314 | -} 315 | moduleLoadedAt :: LoadedModule -> IO UTCTime 316 | moduleLoadedAt (LM m _) 317 | = withPathEnvNB env (moduleLoadedAt' m) 318 | 319 | moduleLoadedAt' :: FilePath -> PathEnvData -> IO UTCTime 320 | moduleLoadedAt' name (_, _, modh) 321 | = do mpm <- HT.lookup modh name 322 | pm <- maybe (fail $ "Module " ++ name ++ " not loaded") 323 | return mpm 324 | return (pm_time pm) 325 | 326 | loadedModules :: IO [String] 327 | loadedModules = withPathEnvNB env loadedModules' 328 | 329 | loadedModules' :: PathEnvData -> IO [String] 330 | loadedModules' (_, _, modh) = HT.toList modh >>= (\lst -> return (map fst lst)) 331 | 332 | -- functions to handle HashTables in a better way 333 | 334 | -- it seems like it doesn't replace the old value on insert 335 | insertHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> val -> IO () 336 | insertHT ht key val 337 | = do HT.delete ht key 338 | HT.insert ht key val 339 | 340 | insertHT_C :: (Eq key, Hashable key) => (val -> val -> val) -> HT.BasicHashTable key val -> key -> val -> IO () 341 | insertHT_C func ht key val 342 | = do mval <- HT.lookup ht key 343 | case mval of 344 | Just val' -> insertHT ht key (func val val') 345 | Nothing -> insertHT ht key val 346 | 347 | modifyHT :: (Eq key, Hashable key) => (val -> val) -> HT.BasicHashTable key val -> key -> IO () 348 | modifyHT func ht key 349 | = do mval <- HT.lookup ht key 350 | case mval of 351 | Just val -> insertHT ht key (func val) 352 | Nothing -> return () 353 | 354 | lookupHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO (Maybe val) 355 | lookupHT ht key = HT.lookup ht key 356 | 357 | deleteHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO () 358 | deleteHT ht key = HT.delete ht key 359 | 360 | lookupDefHT :: (Eq key, Hashable key) => HT.BasicHashTable key b -> b -> key -> IO b 361 | lookupDefHT ht val key 362 | = do mval <- HT.lookup ht key 363 | case mval of 364 | Just val -> return val 365 | Nothing -> return val 366 | -------------------------------------------------------------------------------- /System/Plugins/NameLoader.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : NameLoader 4 | -- Copyright : (c) Hampus Ram 2004, Gabor Greif 2012 5 | -- License : BSD-style (see LICENSE) 6 | -- 7 | -- Maintainer : ggreif+dynamic@gmail.com 8 | -- Stability : experimental 9 | -- Portability : non-portable (ghc >= 7.6 only) 10 | -- 11 | -- A module that implements dynamic loading. 12 | -- Has smart handling of dependencies and 13 | -- is thread safe. 14 | -- 15 | ---------------------------------------------------------------------------- 16 | {-# LANGUAGE ScopedTypeVariables, ConstraintKinds #-} 17 | 18 | module System.Plugins.NameLoader (Module, LoadedModule, 19 | ModuleType(..), 20 | setEnvironment, 21 | addDependency, 22 | delDependency, 23 | delAllDeps, 24 | withDependencies, 25 | loadModule, 26 | unloadModule, 27 | unloadModuleQuiet, 28 | loadFunction, 29 | moduleLoadedAt, 30 | loadedModules, 31 | sm_path, 32 | DL.addDLL) where 33 | 34 | import Data.Char (isUpper) 35 | 36 | import Control.Concurrent.MVar 37 | import Data.List 38 | import qualified Data.HashTable.IO as HT 39 | import Data.Hashable 40 | import Data.IORef 41 | import System.IO.Unsafe 42 | import System.Directory 43 | import Data.Time 44 | import Control.Exception (catch, SomeException) 45 | import System.Plugins.Criteria.LoadCriterion 46 | import System.Plugins.Criteria.UnsafeCriterion 47 | 48 | import qualified System.Plugins.DynamicLoader as DL 49 | 50 | type Loadable c t t' = (LoadCriterion c t, Effective c t ~ IO t') 51 | 52 | type Module = String 53 | 54 | newtype LoadedModule = LM Module 55 | 56 | data ModuleType = MT_Module 57 | | MT_Package 58 | deriving (Eq, Ord, Show) 59 | 60 | type ModuleWT = (String, ModuleType) 61 | 62 | type NameDynamics = Either DL.DynamicModule DL.DynamicPackage 63 | 64 | type NameDep = [Module] 65 | 66 | -- SM reference_count type time module 67 | data NameModule = SM { sm_refc :: !Int, 68 | sm_time :: UTCTime, 69 | sm_deps :: NameDep, 70 | sm_module :: NameDynamics } 71 | 72 | -- module_path modudle_suff 73 | -- pkg_path pkg_prefix pkg_suffix 74 | -- dependency_map modules 75 | type NameEnvData = (Maybe FilePath, Maybe String, 76 | Maybe FilePath, Maybe String, Maybe String, 77 | HT.BasicHashTable String [Module], 78 | HT.BasicHashTable String NameModule) 79 | 80 | {- 81 | 82 | New NameEnv that uses both an IORef and a MVar 83 | to make it possible to have non blocking functions 84 | that inspect the state. 85 | 86 | Could perhaps change it to only use IORef (with atomicModifyIORef) 87 | but let's play safe and have an MVar too. 88 | 89 | -} 90 | type NameEnv = (MVar (), IORef NameEnvData) 91 | 92 | withNameEnv :: Loadable c t t' => Criterion c t -> NameEnv -> (NameEnvData -> Effective c t) -> Effective c t 93 | withNameEnv _ (mvar, ioref) f 94 | = withMVar mvar (\_ -> readIORef ioref >>= f) 95 | 96 | withNameEnvNB :: NameEnv -> (NameEnvData -> IO b) -> IO b 97 | withNameEnvNB (_, ioref) f = readIORef ioref >>= f 98 | 99 | modifyNameEnv_ :: NameEnv -> (NameEnvData -> IO NameEnvData) -> IO () 100 | modifyNameEnv_ (mvar, ioref) f 101 | = withMVar mvar (\_ -> readIORef ioref >>= f >>= writeIORef ioref) 102 | 103 | {-# NOINLINE env #-} 104 | env :: NameEnv 105 | env = unsafePerformIO (do modh <- HT.new 106 | deph <- HT.new 107 | mvar <- newMVar () 108 | ioref <- newIORef (Nothing, Nothing, Nothing, 109 | Nothing, Nothing, deph, modh) 110 | return (mvar, ioref)) 111 | 112 | {-| 113 | 114 | Set the environment in wich all module loading will reside. If this 115 | function isn't called the defaults will be used. 116 | 117 | The parameters are: Path to modules, module suffix, path to packages, 118 | package prefix and package suffix. The paths will default to current 119 | directory and the rest (in order) to /o/, /HS/ and /o/. 120 | 121 | -} 122 | setEnvironment :: Maybe FilePath -> Maybe String -> 123 | Maybe FilePath -> Maybe String -> Maybe String -> IO () 124 | setEnvironment mpath msuff ppath ppre psuff 125 | = modifyNameEnv_ env (\(_, _, _, _, _, deph, modh) -> 126 | return (mpath, msuff, ppath, ppre, psuff, 127 | deph, modh)) 128 | 129 | 130 | {-| 131 | 132 | Add a module dependency. Any dependencies must be added /before/ any 133 | calls to loadModule or symbols will not be resolved with a crash as 134 | result. 135 | 136 | -} 137 | addDependency :: Module -> Module -> IO () 138 | addDependency from to = withNameEnv UnsafeCriterion env (addDependency' from to) 139 | 140 | addDependency' :: Module -> Module -> NameEnvData -> IO () 141 | addDependency' from to (_, _, _, _, _, deph, _) 142 | = insertHT_C union deph from [to] 143 | 144 | {-| 145 | 146 | Delete a module dependency. 147 | 148 | -} 149 | delDependency :: Module -> Module -> IO () 150 | delDependency from to = withNameEnv UnsafeCriterion env (delDependency' from to) 151 | 152 | delDependency' :: Module -> Module -> NameEnvData -> IO () 153 | delDependency' from to (_, _, _, _, _, deph, _) 154 | = modifyHT (\\[to]) deph from 155 | 156 | {-| 157 | 158 | Delete all dependencies for a module. 159 | 160 | -} 161 | 162 | delAllDeps :: Module -> IO () 163 | delAllDeps from = withNameEnv UnsafeCriterion env (delAllDeps' from) 164 | 165 | delAllDeps' :: Module -> NameEnvData -> IO () 166 | delAllDeps' from (_, _, _, _, _, deph, _) 167 | = deleteHT deph from 168 | 169 | {-| 170 | 171 | Do something with the current dependencies of a module. You can't use 172 | (blocking) functions from this module in the function given to 173 | withDependencies. If you do so, a deadlock will occur. 174 | 175 | -} 176 | withDependencies :: Loadable c t t' => Criterion c t -> Module -> (Maybe [Module] -> Effective c t) -> Effective c t 177 | withDependencies crit from f 178 | = withNameEnv crit env (\(_,_,_,_,_,deph,_) -> lookupHT deph from >>= f) 179 | 180 | {-| 181 | 182 | Load a module (or package) and modules it depends on. It is possible 183 | to load a module many times without any error occuring. However to 184 | unload a module one needs to call @unloadModule@ the same number of 185 | times. 186 | 187 | Before loading any modules you should add wich dependencies it has 188 | with addDependency (and which dependencies the modules upon which it 189 | depends have). 190 | 191 | If the module already has been loaded nothing will be done except 192 | updating the reference count. I.e. if dependencies have been updated 193 | they will be ignored until the module has been completely unloaded and 194 | loaded again. 195 | 196 | It treats names begining with uppercase letters (such as @Foo.Bar@) as 197 | modules and other names (such as @base@) as packages. 198 | 199 | If any error occurs an exception is thrown. 200 | 201 | -} 202 | loadModule :: Module -> IO LoadedModule 203 | loadModule m 204 | = do withNameEnv UnsafeCriterion env (\env -> do loadModuleWithDep m env 205 | DL.resolveFunctions 206 | return (LM m)) 207 | 208 | loadModuleWithDep :: Module -> NameEnvData -> IO () 209 | loadModuleWithDep name 210 | env@(_, _, _, _, _, _, modh) 211 | = do msm <- HT.lookup modh name 212 | (sm, depmods) <- midLoadModule msm name env 213 | 214 | insertHT modh name sm 215 | 216 | mapM_ (\modwt -> loadModuleWithDep modwt env) depmods 217 | 218 | midLoadModule :: Maybe NameModule -> Module -> NameEnvData -> 219 | IO (NameModule, NameDep) 220 | midLoadModule (Just sm) _ _ = return $ (sm { sm_refc = sm_refc sm + 1 }, 221 | sm_deps sm) 222 | midLoadModule Nothing name env@(_, _, _, _, _, deph, _) 223 | = do (sd, time) <- lowLoadModule (nameToMWT name) env 224 | depmods <- lookupDefHT deph [] name 225 | return (SM 1 time depmods sd, depmods) 226 | 227 | lowLoadModule :: ModuleWT -> NameEnvData -> IO (NameDynamics, UTCTime) 228 | lowLoadModule (name, MT_Package) (_, _, ppath, ppre, psuff, _, _) 229 | = do lp <- DL.loadPackage name ppath ppre psuff 230 | time <- getModificationTime (DL.dp_path lp) 231 | return (Right lp, time) 232 | lowLoadModule (name, MT_Module) (mpath, msuff, _, _, _, _, _) 233 | = do lm <- DL.loadModule name mpath msuff 234 | time <- getModificationTime (DL.dm_path lm) 235 | return (Left lm, time) 236 | 237 | {-| 238 | 239 | Unload a module and all modules it depends on. This unloading only 240 | occurs if the module isn't needed by any other libraries or hasn't 241 | been loaded more than once. An exception is thrown in case of error. 242 | 243 | -} 244 | unloadModule :: LoadedModule -> IO () 245 | unloadModule (LM name) 246 | = withNameEnv UnsafeCriterion env (unloadModuleWithDep name) 247 | 248 | {-| 249 | 250 | Same as @unloadModule@ just doesn't trow any exceptions on error. 251 | 252 | -} 253 | unloadModuleQuiet :: LoadedModule -> IO () 254 | unloadModuleQuiet (LM name) 255 | = withNameEnv UnsafeCriterion env (\env -> catch (unloadModuleWithDep name env) 256 | (\(_ :: SomeException) -> return ())) 257 | 258 | unloadModuleWithDep :: Module -> NameEnvData -> IO () 259 | unloadModuleWithDep name env@(_, _, _, _, _, _, modh) 260 | = do msm <- lookupHT modh name 261 | sm <- maybe (fail $ "Module " ++ name ++ " not loaded") 262 | return msm 263 | 264 | if sm_refc sm > 1 265 | then do insertHT modh name (sm { sm_refc = sm_refc sm - 1 }) 266 | else do lowUnloadModule (sm_module sm) 267 | deleteHT modh name 268 | 269 | mapM_ (\m -> unloadModuleWithDep m env) (sm_deps sm) 270 | 271 | lowUnloadModule :: NameDynamics -> IO () 272 | lowUnloadModule (Left lm) = DL.unloadModule lm 273 | lowUnloadModule (Right lp) = DL.unloadPackage lp 274 | 275 | {-| 276 | 277 | Load a function from a module. It cannot load functions from packages 278 | and will throw an exception if one tries to do so. Also throws if an 279 | error occurs. 280 | 281 | It seems (but I'm unsure) like any functions loaded will continue to 282 | be valid even after the module it resides in is unloaded. It will also 283 | still be valid if a new version of that module is loaded (it will thus 284 | still call the old function). 285 | 286 | -} 287 | loadFunction :: Loadable c t t' => Criterion c t -> LoadedModule -> String -> Effective c t 288 | loadFunction crit (LM m) name 289 | = withNameEnv crit env (loadFunction' (nameToMWT m) name) 290 | where loadFunction' (_, MT_Package) _ _ = fail "Cannot load functions from packages" 291 | loadFunction' (mname, _) fname (_, _, _, _, _, _, modh) 292 | = do msm <- HT.lookup modh mname 293 | sm <- maybe (fail $ "Module " ++ mname ++ " isn't loaded") 294 | return msm 295 | let Left dm = sm_module sm 296 | DL.loadFunction dm fname 297 | 298 | 299 | {-| 300 | 301 | Give the modification time for a loded module. Will throw an exception 302 | if the module isn't loaded. 303 | 304 | -} 305 | moduleLoadedAt :: LoadedModule -> IO UTCTime 306 | moduleLoadedAt (LM m) 307 | = withNameEnvNB env (moduleLoadedAt' m) 308 | 309 | moduleLoadedAt' :: Module -> NameEnvData -> IO UTCTime 310 | moduleLoadedAt' name (_, _, _, _, _, _, modh) 311 | = do msm <- HT.lookup modh name 312 | sm <- maybe (fail $ "Module " ++ name ++ " not loaded") 313 | return msm 314 | return (sm_time sm) 315 | 316 | loadedModules :: IO [String] 317 | loadedModules = withNameEnvNB env loadedModules' 318 | 319 | loadedModules' :: NameEnvData -> IO [String] 320 | loadedModules' (_, _, _, _, _, _, modh) 321 | = HT.toList modh >>= (\lst -> return (map fst lst)) 322 | 323 | -- Some helper functions 324 | 325 | sm_path :: NameModule -> FilePath 326 | sm_path sm = case sm_module sm of 327 | Left dm -> DL.dm_path dm 328 | Right dp -> DL.dp_path dp 329 | 330 | nameToMWT :: String -> ModuleWT 331 | nameToMWT (c:cs) 332 | | isUpper c = (c:cs, MT_Module) 333 | | otherwise = (c:cs, MT_Package) 334 | nameToMWT _ = error "empty module names not allowed" 335 | 336 | -- functions to handle HashTables in a better way 337 | 338 | -- it seems like it doesn't replace the old value on insert 339 | insertHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> val -> IO () 340 | insertHT ht key val 341 | = do HT.delete ht key 342 | HT.insert ht key val 343 | 344 | insertHT_C :: (Eq key, Hashable key) => (val -> val -> val) -> HT.BasicHashTable key val -> key -> val -> IO () 345 | insertHT_C func ht key val 346 | = do mval <- HT.lookup ht key 347 | case mval of 348 | Just val' -> insertHT ht key (func val val') 349 | Nothing -> insertHT ht key val 350 | 351 | modifyHT :: (Eq key, Hashable key) => (val -> val) -> HT.BasicHashTable key val -> key -> IO () 352 | modifyHT func ht key 353 | = do mval <- HT.lookup ht key 354 | case mval of 355 | Just val -> insertHT ht key (func val) 356 | Nothing -> return () 357 | 358 | lookupHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO (Maybe val) 359 | lookupHT ht key = HT.lookup ht key 360 | 361 | deleteHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO () 362 | deleteHT ht key = HT.delete ht key 363 | 364 | lookupDefHT :: (Eq key, Hashable key) => HT.BasicHashTable key b -> b -> key -> IO b 365 | lookupDefHT ht val key 366 | = do mval <- HT.lookup ht key 367 | case mval of 368 | Just val -> return val 369 | Nothing -> return val 370 | -------------------------------------------------------------------------------- /System/Plugins/DynamicLoader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash, UnboxedTuples #-} 2 | ---------------------------------------------------------------------------- 3 | -- | 4 | -- Module : DynamicLoader 5 | -- Copyright : (c) Hampus Ram 2003-2004, Gabor Greif 2012 6 | -- License : BSD-style (see LICENSE) 7 | -- 8 | -- Maintainer : ggreif+dynamic@gmail.com 9 | -- Stability : experimental 10 | -- Portability : non-portable (ghc >= 7.6 only) 11 | -- 12 | -- A module that implements dynamic loading. You can load 13 | -- and use GHC object files and packages dynamically at runtime. 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module System.Plugins.DynamicLoader (DynamicModule, 17 | dm_path, 18 | DynamicPackage, 19 | dp_path, 20 | DynamicArchive, 21 | da_path, 22 | 23 | addDLL, 24 | 25 | loadModule, 26 | loadModuleFromPath, 27 | loadPackage, 28 | loadPackageFromPath, 29 | loadArchiveFromPath, 30 | unloadModule, 31 | unloadPackage, 32 | unloadArchive, 33 | loadFunction, 34 | loadQualifiedFunction, 35 | resolveFunctions) where 36 | 37 | import Data.Char (ord) 38 | import Data.List 39 | import Control.Monad 40 | 41 | import GHC.Exts 42 | import Foreign.Ptr (Ptr, nullPtr) 43 | import Foreign.C.String (CString, withCString, peekCString) 44 | import System.Directory (getCurrentDirectory, doesFileExist) 45 | import GHC.Prim 46 | import System.Info (os) 47 | 48 | {- 49 | 50 | Foreign imports, hooks into the GHC RTS. 51 | 52 | -} 53 | 54 | foreign import ccall unsafe "initLinker" 55 | c_initLinker :: IO () 56 | 57 | foreign import ccall unsafe "loadObj" 58 | c_loadObj :: CString -> IO Int 59 | 60 | foreign import ccall unsafe "unloadObj" 61 | c_unloadObj :: CString -> IO Int 62 | 63 | foreign import ccall unsafe "loadArchive" 64 | c_loadArchive :: CString -> IO Int 65 | 66 | foreign import ccall unsafe "resolveObjs" 67 | c_resolveObjs :: IO Int 68 | 69 | foreign import ccall unsafe "lookupSymbol" 70 | c_lookupSymbol :: CString -> IO (Ptr a) 71 | 72 | foreign import ccall unsafe "addDLL" 73 | c_addDLL :: CString -> IO CString 74 | 75 | -- split up qualified name so one could easily transform it 76 | -- into A.B.C or A/B/C depending on context 77 | data DynamicModule = RTM { dm_qname :: [String], 78 | dm_path :: FilePath } 79 | 80 | data DynamicPackage = RTP { dp_path :: FilePath, 81 | dp_cbits :: Maybe DynamicPackage } 82 | 83 | newtype DynamicArchive = RTA { da_path :: FilePath } 84 | 85 | {-| 86 | 87 | Dynamically load a shared library (DLL or .so). A shared library can't 88 | be unloaded using this interface, if you need it use 89 | System.Posix.DynamicLinker instead. 90 | 91 | -} 92 | 93 | addDLL :: String -> IO () 94 | addDLL str 95 | = do c_initLinker 96 | withCString str 97 | (\s -> do err <- c_addDLL s 98 | unless (err == nullPtr) 99 | (do msg <- peekCString err 100 | fail $ "Unable to load library: " ++ str ++ "\n " ++ msg)) 101 | 102 | {-| 103 | 104 | Load a module given its name (for instance @Data.FiniteMap@), maybe a 105 | path to the base directory and maybe a file extension. If no such path 106 | is given the current working directory is used and if no file suffix 107 | is given \"o\" is used. 108 | 109 | If we have our module hierarchy in @\/usr\/lib\/modules@ and we want to 110 | load the module @Foo.Bar@ located in @\/usr\/lib\/modules\/Foo\/Bar.o@ we 111 | could issue the command: 112 | 113 | @loadModule \"Foo.Bar\" (Just \"\/usr\/lib\/modules\") Nothing@ 114 | 115 | If our current directory was @\/tmp@ and we wanted to load the module 116 | @Foo@ located in the file @\/tmp\/Foo.obj@ we would write: 117 | 118 | @loadModule \"Foo\" Nothing (Just \"obj\")@ 119 | 120 | If it cannot load the object it will throw an exception. 121 | 122 | -} 123 | loadModule :: String -> Maybe FilePath -> Maybe String -> IO DynamicModule 124 | loadModule name mpath msuff 125 | = do c_initLinker 126 | 127 | base <- maybe getCurrentDirectory return mpath 128 | 129 | let qname = split '.' name 130 | suff = maybe "o" id msuff 131 | path = base ++ '/' : concat (intersperse "/" qname) ++ 132 | '.' : suff 133 | ret <- withCString path c_loadObj 134 | if ret /= 0 135 | then return (RTM qname path) 136 | else fail $ "Unable to load module: " ++ path 137 | 138 | {-| 139 | 140 | Load a module given its full path and maybe a base directory to use in 141 | figuring out the module's hierarchical name. If no base directory is 142 | given, it is set to the current directory. 143 | 144 | For instance if one wants to load module @Foo.Bar@ located in 145 | @\/usr\/modules\/Foo\/Bar.o@ one would issue the command: 146 | 147 | @loadModuleFromPath \"\/usr\/modules\/Foo\/Bar.o\" (Just 148 | \"\/usr\/modules\")@ 149 | 150 | If it cannot load the object it will throw an exception. 151 | 152 | -} 153 | loadModuleFromPath :: FilePath -> Maybe FilePath -> IO DynamicModule 154 | loadModuleFromPath path mbase 155 | = do c_initLinker 156 | base <- maybe getCurrentDirectory return mbase 157 | 158 | qual <- dropIsEq base path 159 | 160 | -- not very smart but simple... 161 | let name = reverse $ drop 1 $ dropWhile (/='.') $ 162 | reverse $ if head qual == '/' then drop 1 qual else qual 163 | 164 | qname = split '/' name 165 | 166 | ret <- withCString path c_loadObj 167 | if ret /= 0 168 | then return (RTM qname path) 169 | else fail $ "Unable to load module: " ++ path 170 | 171 | where dropIsEq [] ys = return ys 172 | dropIsEq (x:xs) (y:ys) 173 | | x == y = dropIsEq xs ys 174 | | otherwise = fail $ "Unable to get qualified name from: " 175 | ++ path 176 | dropIsEq _ _ = fail $ "Unable to get qualified name from: " ++ path 177 | 178 | split :: Char -> String -> [String] 179 | split _ "" = [] 180 | split c s = let (l,s') = break (c==) s 181 | in l : case s' of [] -> [] 182 | (_:s'') -> split c s'' 183 | 184 | {-| 185 | 186 | Load a GHC package such as \"base\" or \"text\". Takes the package name, 187 | maybe a path to the packages, maybe a package prefix and maybe a 188 | package suffix. 189 | 190 | Path defaults to the current directory, package prefix to \"HS\" and 191 | package suffix to \"o\". 192 | 193 | This function also loads accompanying cbits-packages. I.e. if you load 194 | the package @base@ located in @\/usr\/modules@ using @HS@ and @o@ as 195 | prefix and suffix, @loadPackage@ will also look for the file 196 | @\/usr\/modules\/HSbase_cbits.o@ and load it if present. 197 | 198 | If it fails to load a package it will throw an exception. You will 199 | need to resolve functions before you use any functions loaded. 200 | 201 | -} 202 | loadPackage :: String -> Maybe FilePath -> Maybe String -> Maybe String -> 203 | IO DynamicPackage 204 | loadPackage name mpath mpre msuff 205 | = do c_initLinker 206 | base <- case mpath of 207 | Just a -> return a 208 | _ -> getCurrentDirectory 209 | 210 | let path = packageName name base mpre msuff 211 | 212 | ret <- withCString path c_loadObj 213 | unless (ret /= 0) (fail $ "Unable to load package: " ++ name) 214 | 215 | let cbits_path = packageName (name ++ "_cbits") base mpre msuff 216 | 217 | -- this will generate an extra unnecessary call checking for 218 | -- FOO_cbits_cbits, but it looks nicer! 219 | cbitsExist <- doesFileExist cbits_path 220 | if cbitsExist 221 | then do rtp <- loadPackage (name ++ "_cbits") mpath mpre msuff 222 | return (RTP path (Just rtp)) 223 | else return (RTP path Nothing) 224 | 225 | where packageName :: String -> FilePath -> Maybe String -> 226 | Maybe String -> FilePath 227 | packageName name path mpre msuff 228 | = let prefix = maybe "HS" id mpre 229 | suffix = maybe "o" id msuff 230 | in path ++ '/' : prefix ++ name ++ '.' : suffix 231 | 232 | {-| 233 | 234 | Load a GHC package such as \"base\" or \"text\". Takes the full path to 235 | the package. 236 | 237 | This function also loads accompanying cbits-packages. I.e. if you load 238 | the package @\/usr\/modules\/HSbase.o@ it will deduce that @o@ is the 239 | suffix and @loadPackageFromPath@ will then also look for the file 240 | @\/usr\/modules\/HSbase_cbits.o@ and load it if present. 241 | 242 | If it fails to load a package it will throw an exception. You will 243 | need to resolve functions before you use any functions loaded. 244 | 245 | -} 246 | loadPackageFromPath :: FilePath -> IO DynamicPackage 247 | loadPackageFromPath path 248 | = do c_initLinker 249 | ret <- withCString path c_loadObj 250 | unless (ret /= 0) (fail $ "Unable to load package: " ++ path) 251 | 252 | let cbits_path = cbitsName path 253 | 254 | -- this will generate an extra unnecessary call checking for 255 | -- FOO_cbits_cbits, but it looks nicer! 256 | cbitsExist <- doesFileExist cbits_path 257 | if cbitsExist 258 | then do rtp <- loadPackageFromPath cbits_path 259 | return (RTP path (Just rtp)) 260 | else return (RTP path Nothing) 261 | 262 | where cbitsName :: FilePath -> String 263 | cbitsName name 264 | = let suffix = reverse $! takeWhile (/='.') rname 265 | rname = reverse name 266 | in reverse (drop (length suffix + 1) rname) ++ 267 | "_cbits." ++ suffix -- wrong but simple... 268 | 269 | {-| 270 | 271 | Load an archive of GHC modules. Recent versions of GHC store packages 272 | as archives. 273 | 274 | If it fails to load the archive it will throw an exception. You will 275 | need to resolve functions before you use any functions loaded. 276 | 277 | -} 278 | loadArchiveFromPath :: FilePath -> IO DynamicArchive 279 | loadArchiveFromPath path 280 | = do c_initLinker 281 | ret <- withCString path c_loadArchive 282 | unless (ret /= 0) (fail $ "Unable to load archive: " ++ path) 283 | return (RTA path) 284 | 285 | {-| 286 | 287 | Unload an archive. Throws an exception if any unloading fails. 288 | 289 | -} 290 | unloadArchive :: DynamicArchive -> IO () 291 | unloadArchive (RTA { da_path = path }) 292 | = do c_initLinker 293 | ret <- withCString path c_unloadObj 294 | unless (ret /= 0) (fail $ "Unable to unload archive: " ++ path) 295 | 296 | {-| 297 | 298 | Unload a package (such as @base@) and its cbits-package (if 299 | any). Throws an exception if any unloading fails. 300 | 301 | -} 302 | unloadPackage :: DynamicPackage -> IO () 303 | unloadPackage (RTP { dp_path = path, dp_cbits = cbits }) 304 | = do c_initLinker 305 | ret <- withCString path c_unloadObj 306 | unless (ret /= 0) (fail $ "Unable to unload package: " ++ path) 307 | maybe (return ()) unloadPackage cbits 308 | 309 | {-| 310 | 311 | Unload a previously loaded module. If it cannot unload it an exception 312 | will be thrown. 313 | 314 | -} 315 | unloadModule :: DynamicModule -> IO () 316 | unloadModule (RTM { dm_path = path }) 317 | = do c_initLinker 318 | ret <- withCString path c_unloadObj 319 | unless (ret /= 0) (fail $ "Unable to unload module: " ++ path) 320 | 321 | {-| 322 | 323 | Load a function from a given module. If the function can't be found an 324 | exception will be thrown. You should have called @resolveFunctions@ before 325 | you call this. 326 | 327 | Beware that this function isn't type-safe in any way! 328 | 329 | -} 330 | loadFunction :: DynamicModule -> String -> IO a 331 | loadFunction dm functionName 332 | = do c_initLinker 333 | Ptr addr <- lookupSymbol (dm_qname dm) functionName 334 | case addrToAny# addr of 335 | (# hval #) -> return hval 336 | 337 | {-| 338 | 339 | Load a function from package (or module) given the fully qualified 340 | name (e.g. @Data.FiniteMap.emptyFM@). If the function can't be found an 341 | exception will be thrown. You should have called @resolveFunctions@ 342 | before you call this. 343 | 344 | You must take care that you load the function qualified with the name 345 | of the module it's defined in! You can for instance not load 346 | @Data.Bool.not@ because it is only reexported in that module (from 347 | GHC.Base). 348 | 349 | Beware that this function isn't type-safe in any way! 350 | 351 | -} 352 | loadQualifiedFunction :: String -> IO a 353 | loadQualifiedFunction functionName 354 | = do c_initLinker 355 | let qfunc = split '.' functionName 356 | Ptr addr <- lookupSymbol (init qfunc) (last qfunc) 357 | case addrToAny# addr of 358 | (# hval #) -> return hval 359 | 360 | {-| 361 | 362 | Resolve all loaded functions. Should be called before any functions 363 | are loaded. If it is unable to resolve all functions it will throw an 364 | exception. 365 | 366 | -} 367 | resolveFunctions :: IO () 368 | resolveFunctions 369 | = do c_initLinker 370 | ret <- c_resolveObjs 371 | when (ret == 0) (fail "Unable to resolve functions!") 372 | 373 | {-| 374 | 375 | Find a symbol in a module's symbol-table. Throw an exception if it 376 | isn't found. 377 | 378 | -} 379 | lookupSymbol :: [String] -> String -> IO (Ptr a) 380 | lookupSymbol qname functionName 381 | = do ptr <- withCString symbolName c_lookupSymbol 382 | if ptr /= nullPtr 383 | then return ptr 384 | else fail $ "Could not load symbol: " ++ symbolName 385 | where 386 | moduleName = encode $ concat (intersperse "." qname) 387 | realFunctionName = encode functionName 388 | 389 | -- On OS X all functions have an extra _. 390 | symbolName = (if os == "darwin" then "_" else "") ++ moduleName ++ "_" ++ realFunctionName ++ "_closure" 391 | 392 | encode :: String -> String 393 | encode str = concatMap encode_ch str 394 | 395 | unencodedChar :: Char -> Bool -- True for chars that don't need encoding 396 | unencodedChar 'Z' = False 397 | unencodedChar 'z' = False 398 | unencodedChar c = c >= 'a' && c <= 'z' 399 | || c >= 'A' && c <= 'Z' 400 | || c >= '0' && c <= '9' 401 | 402 | encode_ch c | unencodedChar c = [c] -- Common case first 403 | encode_ch 'Z' = "ZZ" 404 | encode_ch 'z' = "zz" 405 | encode_ch '&' = "za" 406 | encode_ch '|' = "zb" 407 | encode_ch '^' = "zc" 408 | encode_ch '$' = "zd" 409 | encode_ch '=' = "ze" 410 | encode_ch '>' = "zg" 411 | encode_ch '#' = "zh" 412 | encode_ch '.' = "zi" 413 | encode_ch '<' = "zl" 414 | encode_ch '-' = "zm" 415 | encode_ch '!' = "zn" 416 | encode_ch '+' = "zp" 417 | encode_ch '\'' = "zq" 418 | encode_ch '\\' = "zr" 419 | encode_ch '/' = "zs" 420 | encode_ch '*' = "zt" 421 | encode_ch '_' = "zu" 422 | encode_ch '%' = "zv" 423 | encode_ch c = 'z' : shows (ord c) "U" 424 | --------------------------------------------------------------------------------