diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2013-2019, Haskus organization +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of Sylvain Henry nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/haskus-utils-compat.cabal b/haskus-utils-compat.cabal new file mode 100644 --- /dev/null +++ b/haskus-utils-compat.cabal @@ -0,0 +1,39 @@ +name: haskus-utils-compat +version: 1.0 +synopsis: Compatibility modules with other external packages (ByteString, etc.) +license: BSD3 +license-file: LICENSE +author: Sylvain Henry +maintainer: sylvain@haskus.fr +homepage: http://docs.haskus.org/ +copyright: Sylvain Henry 2019 +category: System +build-type: Simple +cabal-version: 1.20 + +description: + Compatibility modules with other external packages (ByteString, etc.) + +source-repository head + type: git + location: git://github.com/haskus/haskus-utils.git + +library + exposed-modules: + Haskus.Utils.Embed.ByteString + + other-modules: + + build-depends: + base >= 4.9 && < 5 + , template-haskell >= 2.10 + , haskus-binary + , haskus-utils-data + , directory + , filepath + , bytestring + + build-tools: + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: src/lib diff --git a/src/lib/Haskus/Utils/Embed/ByteString.hs b/src/lib/Haskus/Utils/Embed/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Embed/ByteString.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} + +-- | Embed files as ByteStrings into an executable +module Haskus.Utils.Embed.ByteString + ( bufferToByteString + , embedBS + , embedBSFile + , embedBSOneFileOf + , embedBSDir + , module Haskus.Memory.Embed + ) +where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import GHC.Ptr +import System.IO.Unsafe +import System.Directory +import System.FilePath +import Control.Arrow + +import Haskus.Memory.Buffer +import Haskus.Memory.Embed +import Haskus.Utils.Monad + +---------------------------------------------------------------------- +-- File embedding adapted from file-embed package (BSD3). +-- +-- We use Haskus's buffer embedding facilities which are much faster then +-- file-embed's ones as of 2019-01-30. +-- +-- See: https://hsyl20.fr/home/posts/2019-01-15-fast-file-embedding-with-ghc.html +---------------------------------------------------------------------- + +-- | Embed a single file in your source code. +-- +-- > import qualified Data.ByteString +-- > +-- > myFile :: Data.ByteString.ByteString +-- > myFile = $(embedFile "dirName/fileName") +embedBSFile :: FilePath -> Q Exp +embedBSFile fp = do + qAddDependentFile fp + bs <- runIO $ BS.readFile fp + embedBS bs + +-- | Embed a single existing file in your source code +-- out of list a list of paths supplied. +-- +-- > import qualified Data.ByteString +-- > +-- > myFile :: Data.ByteString.ByteString +-- > myFile = $(embedOneFileOf [ "dirName/fileName", "src/dirName/fileName" ]) +embedBSOneFileOf :: [FilePath] -> Q Exp +embedBSOneFileOf ps = + (runIO $ readExistingFile ps) >>= \(path, content) -> do + qAddDependentFile path + embedBS content + where + readExistingFile :: [FilePath] -> IO (FilePath, BS.ByteString) + readExistingFile xs = do + ys <- filterM doesFileExist xs + case ys of + (p:_) -> BS.readFile p >>= \c -> return (p, c) + _ -> error "Cannot find file to embed as resource" + + + +-- | Embed a directory recursively in your source code. +-- +-- > import qualified Data.ByteString +-- > +-- > myDir :: [(FilePath, Data.ByteString.ByteString)] +-- > myDir = $(embedDir "dirName") +embedBSDir :: FilePath -> Q Exp +embedBSDir fp = do + typ <- [t| [(FilePath, BS.ByteString)] |] + bufToBs <- [| bufferToByteString |] + let embedPair (relpath,realpath) = do + exp' <- embedFile realpath False Nothing Nothing Nothing + return $! TupE [LitE $ StringL relpath, bufToBs `AppE` exp'] + e <- ListE <$> ((runIO $ listDirectoryRec fp) >>= mapM embedPair) + return $ SigE e typ + +-- | Embed a ByteString into an executable +embedBS :: BS.ByteString -> Q Exp +embedBS bs = do + bufToBs <- [| bufferToByteString |] + -- make an input BufferE from the ByteString + buf <- runIO $ BS.unsafeUseAsCStringLen bs $ \(Ptr addr, sz) -> do + return (BufferE addr (fromIntegral sz)) + -- embed it + outBuf <- embedBuffer buf False Nothing Nothing Nothing + -- keep the ByteString alive up to here + runIO $ touch bs + -- return an expression converting the embedded buffer into a ByteString + return $ bufToBs `AppE` outBuf + +-- | Convert an external buffer into a ByteString (O(1)) +bufferToByteString :: Buffer mut pin 'NotFinalized 'External -> BS.ByteString +bufferToByteString b = unsafePerformIO $ do + let pack addr sz = BS.unsafePackAddressLen (fromIntegral sz) addr + case b of + BufferE addr sz -> pack addr sz + BufferME addr sz -> pack addr sz + +-- | List a directory recursively, only returning non-hidden files. +-- +-- Return tuples (relative path, real path) +listDirectoryRec :: FilePath -> IO [(FilePath,FilePath)] +listDirectoryRec realTop = go "" + where + notHidden :: FilePath -> Bool + notHidden ('.':_) = False + notHidden _ = True + + go top = do + allContents <- filter notHidden <$> getDirectoryContents (realTop top) + let all' = map ((top ) &&& (\x -> realTop top x)) allContents + files <- filterM (doesFileExist . snd) all' + dirs <- filterM (doesDirectoryExist . snd) all' >>= mapM (go . fst) + return $ concat $ files : dirs +