diff --git a/examples/Example01.hs b/examples/Example01.hs new file mode 100644 --- /dev/null +++ b/examples/Example01.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} + +module Main where + +import System.Installer +import Foreign +import Foreign.C +import System.IO (putStr, getLine, hFlush, stdout) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + + +$(installBinariesFunc "myInstallerFunc" + [("first","file01.txt"), + ("second","file02.txt") + ]) + +main :: IO () +main = do { putStr "Enter path to install files in: " + ; hFlush stdout + ; path <- getLine + ; myInstallerFunc Installer_myInstallerFunc_first path + ; myInstallerFunc Installer_myInstallerFunc_second path + ; return () + } + diff --git a/examples/file01.txt b/examples/file01.txt new file mode 100644 --- /dev/null +++ b/examples/file01.txt @@ -0,0 +1,7 @@ +This is the first file. + __ _ _ ___ _ + / _(_) | ___ / _ \/ | +| |_| | |/ _ \ | | | | | +| _| | | __/ | |_| | | +|_| |_|_|\___| \___/|_| + diff --git a/examples/file02.txt b/examples/file02.txt new file mode 100644 --- /dev/null +++ b/examples/file02.txt @@ -0,0 +1,19 @@ +This is the second file... + + + + + + + + + + + + + + + + + +With some text in it. diff --git a/hinstaller.cabal b/hinstaller.cabal --- a/hinstaller.cabal +++ b/hinstaller.cabal @@ -1,5 +1,5 @@ name: hinstaller -version: 2007.4.21 +version: 2007.4.23 stability: Alpha copyright: Matthew Sackman category: System @@ -17,10 +17,15 @@ files when run. Thus this can be considered in the same model as Java .jar files or executable zip or other file archives. . - Note that the current implementation is very inefficient, converting the - included files as Strings. On any non-trivial sized file, you'll need to - increase GHC's stack with +RTS -K32M -RTS to avoid stack overflows. + Note that the current implementation is now reasonably efficient. However, + either use -fvia-C which will take care of all compilation for you (but + will be slow) or use -fasm which will probably fail at the linking stage. + Compile the generated .c files and manually link together to complete the + installation. On any non-trivial sized file, you may need to increase GHC's + stack with +RTS -K32M -RTS to avoid stack overflows. exposed-modules: System.Installer -other-modules: System.Installer.TH +other-modules: System.Installer.TH, System.Installer.Foreign ghc-options: -O2 -Wall -fno-warn-name-shadowing -hs-source-dirs: src +hs-source-dirs: src, examples +extra-source-files: examples/Example01.hs, examples/file01.txt, examples/file02.txt + diff --git a/src/System/Installer.hs b/src/System/Installer.hs --- a/src/System/Installer.hs +++ b/src/System/Installer.hs @@ -53,46 +53,44 @@ -- -- Note that the files written out are not set executable so you -- must correct file permissions yourself. --- --- Also note that the current implementation includes the entire --- file content as a String. This is horribly inefficient. --- Consequently GHC may well stack overflow during compilation. --- Set the stack bigger with @+RTS -K32M -RTS@. Compilation will --- be /very/ slow, especially with any optimisations enabled. + +-- Note that the current implementation is now reasonably +-- efficient. However, either use -fvia-C which will take care of all +-- compilation for you (but will be slow) or use -fasm which will +-- probably fail at the linking stage. Compile the generated .c files +-- and manually link together to complete the installation. On any +-- non-trivial sized file, you may need to increase GHC's stack with +-- @+RTS -K32M -RTS@ to avoid stack overflows. module System.Installer (installBinariesFunc ) where -import System.Directory import System.IO import qualified System.Installer.TH as TH +import System.Installer.Foreign import Language.Haskell.TH.Syntax installBinariesFunc :: String -> [(String, FilePath)] -> Q [Dec] installBinariesFunc funcName binaries - = do { func <- TH.makeInstallFunc funcName clauses + = do { binariesWithTmp <- runIO + (convertFilesToCHeaders funcName binaries) + ; importDecls <- mapM (TH.makeImportDecl funcName) + binariesWithTmp + ; func <- TH.makeInstallFunc funcName clauses ; dataDecls <- TH.makeDataDecls funcName binaries - ; return $ func : dataDecls + ; return $ (concat importDecls) ++ (func : dataDecls) } where - clauses = map (loadAndMakeClause funcName) binaries - -loadAndMakeClause :: String -> (String, FilePath) -> Q Clause -loadAndMakeClause funcName (name, bin) - = do { contents <- runIO (loadBinary bin) - ; TH.makeInstallFuncCase funcName name bin contents - } + clauses = map (TH.makeInstallFuncCase funcName) binaries -loadBinary :: FilePath -> IO String -loadBinary path - = do { exists <- doesFileExist path - ; case exists of - True -> do { hdl <- openBinaryFile path ReadMode - ; contents <- hGetContents hdl - ; length contents `seq` return () - ; hClose hdl - ; return contents - } - False -> error $ "Unable to find file at " ++ path +convertFilesToCHeaders :: String -> [(String, FilePath)] -> + IO [(String, FilePath, FilePath)] +convertFilesToCHeaders _ [] = return [] +convertFilesToCHeaders funcName ((clauseName, filePath):rest) + = do { result <- convertFilesToCHeaders funcName rest + ; tmpFileName <- convertFileToCHeader filePath clauseName' + ; return $ (clauseName, filePath, tmpFileName):result } + where + clauseName' = "installer_" ++ funcName ++ "_" ++ clauseName diff --git a/src/System/Installer/Foreign.hs b/src/System/Installer/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/System/Installer/Foreign.hs @@ -0,0 +1,76 @@ +module System.Installer.Foreign +where + +import Foreign +import Foreign.C +import System.Directory +import System.FilePath +import System.IO +import Data.Word +import qualified Data.ByteString as B + +writeCHeaderFile :: Handle -> String -> IO () +writeCHeaderFile outH name + = do { hPutStrLn outH lenDeclFuncSig + ; hPutStrLn outH arrayDeclFuncSig + } + where + lenDeclFuncSig = "const int " ++ name ++ "_length ();" + arrayDeclFuncSig = "const unsigned char* " ++ name ++ " ();" + +writeCFile :: Handle -> String -> B.ByteString -> FilePath -> IO () +writeCFile outH name content header + = do { hPutStrLn outH includeLine + ; hPutStrLn outH lenDecl + ; hPutStrLn outH arrayDecl + ; mapM_ writeWord (B.unpack content) + ; hPutStrLn outH tailDecl + ; hPutStrLn outH lenDeclFunc + ; hPutStrLn outH arrayDeclFunc + } + where + len = show . B.length $ content + includeLine = "#include \"" ++ header ++ "\"" + lenDecl = "const int " ++ name ++ "_length_raw = " ++ len ++ ";" + arrayDecl = "const unsigned char " ++ name ++ + "_raw[" ++ len ++ "] = {" + tailDecl = "};" + lenDeclFunc = "const int " ++ name ++ "_length () { return " ++ + name ++ "_length_raw" ++ "; }" + arrayDeclFunc = "const unsigned char* " ++ name ++ " () { return " ++ + name ++ "_raw" ++ "; }" + writeWord :: Word8 -> IO () + writeWord wrd = hPutStrLn outH numTxt + where + numTxt = (show wrd) ++ "," + +convertFileToCHeader :: FilePath -> String -> IO (FilePath) +convertFileToCHeader file clauseName + = do { (tmpFileHPath, tmpFileHHdl) <- openBinaryTempFile "" leafNameH + ; writeCHeaderFile tmpFileHHdl clauseName + ; hClose tmpFileHHdl + ; contentsB <- B.readFile file + ; (tmpFileCPath, tmpFileCHdl) <- openBinaryTempFile "" leafNameC + ; writeCFile tmpFileCHdl clauseName contentsB tmpFileHPath + ; hClose tmpFileCHdl + ; return tmpFileCPath + } + where + leafName = takeFileName file + leafNameNoExts = dropExtensions leafName + leafNameH = addExtension leafNameNoExts "h" + leafNameC = addExtension leafNameNoExts "c" + +writeFromPtrToFile :: Ptr CUChar -> Int -> FilePath -> IO () +writeFromPtrToFile ptr len filePath + = do { outH <- openBinaryFile filePath WriteMode + ; hPutBuf outH ptr len + ; hClose outH + } + +writeFileData :: Ptr CUChar -> CInt -> String -> FilePath -> IO () +writeFileData ptr len origName path + = do { isDir <- doesDirectoryExist path + ; let path' = if isDir then combine path origName else path + ; writeFromPtrToFile ptr (fromIntegral len) path' + } diff --git a/src/System/Installer/TH.hs b/src/System/Installer/TH.hs --- a/src/System/Installer/TH.hs +++ b/src/System/Installer/TH.hs @@ -23,41 +23,32 @@ module System.Installer.TH (makeInstallFuncCase, makeDataDecls, - makeInstallFunc) + makeInstallFunc, + makeImportDecl + ) where -import System.IO -import System.Directory import System.FilePath import Language.Haskell.TH import Language.Haskell.TH.Syntax +import System.Installer.Foreign -makeInstallFuncCase :: String -> String -> FilePath -> String -> Q Clause -makeInstallFuncCase funcName name filepath contents +makeInstallFuncCase :: String -> (String, FilePath) -> Q Clause +makeInstallFuncCase funcName (clauseName, filepath) = result where result = clause [conP dataName []] - (normalB [| writeFileData filename $contentsQ |]) [] - contentsQ = liftString contents - dataName = mkName $ "Installer_" ++ funcName ++ "_" ++ name + (normalB [| writeFileData $ptr $len filename |]) [] filename = takeFileName filepath + dataName = mkName $ "Installer_" ++ fullName + fullName = funcName ++ "_" ++ clauseName + ptr = varE $ mkName ("installer_" ++ fullName) + len = varE $ mkName ("installer_" ++ fullName ++ "_length") makeInstallFunc :: String -> [Q Clause] -> Q Dec makeInstallFunc funcName clauses = funD (mkName funcName) clauses -writeFileData :: String -> String -> FilePath -> IO () -writeFileData origName content path - = do { isDir <- doesDirectoryExist path - ; let path' = if isDir then combine path origName else path - ; h <- openFile path' WriteMode - ; hPutStr h content - ; hClose h - } - -liftString :: String -> Q Exp -liftString = return . LitE . StringL - makeDataDecls :: String -> [(String, FilePath)] -> Q [Dec] makeDataDecls base names = do { dataDecl' <- dataDecl @@ -81,3 +72,27 @@ = clause [conP dataName []] (normalB . litE . stringL $ name) [] where dataName = mkName $ "Installer_" ++ base ++ "_" ++ name + +makeImportDecl :: String -> (String, FilePath, FilePath) -> Q [Dec] +makeImportDecl funcName (clauseName, _, tmpPathCHeader) + = makeImportDecl' ("installer_" ++ funcName ++ "_" ++ clauseName) + tmpPathCHeader + +makeImportDecl' :: String -> FilePath -> Q [Dec] +makeImportDecl' prefix headerFile + = return [fileDataImport, fileLengthImport] + where + fileLengthImport = ForeignD + (ImportF CCall Safe + ("static " ++ headerFile ++ " " ++ prefix ++ "_length") + (mkName $ prefix ++ "_length") + (ConT (mkName "CInt")) + ) + fileDataImport = ForeignD + (ImportF CCall Safe + ("static " ++ headerFile ++ " " ++ prefix) + (mkName $ prefix) + (AppT (ConT (mkName "Ptr")) + (ConT (mkName "CUChar")) + ) + )