packages feed

hinstaller 2007.4.21 → 2007.4.23

raw patch · 7 files changed

+199/−53 lines, 7 files

Files

+ examples/Example01.hs view
@@ -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 ()+          }+
+ examples/file01.txt view
@@ -0,0 +1,7 @@+This is the first file.+  __ _ _         ___  _ + / _(_) | ___   / _ \/ |+| |_| | |/ _ \ | | | | |+|  _| | |  __/ | |_| | |+|_| |_|_|\___|  \___/|_|+
+ examples/file02.txt view
@@ -0,0 +1,19 @@+This is the second file...++++++++++++++++++With some text in it.
hinstaller.cabal view
@@ -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+
src/System/Installer.hs view
@@ -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
+ src/System/Installer/Foreign.hs view
@@ -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'+         }
src/System/Installer/TH.hs view
@@ -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"))+                        )+                       )