diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hpath-posix + +## 0.1.0.0 -- 2020-01-29 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, Julian Ospald + +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 Julian Ospald 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 OR CONTRIBUTORS 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/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/cbits/dirutils.c b/cbits/dirutils.c new file mode 100644 --- /dev/null +++ b/cbits/dirutils.c @@ -0,0 +1,7 @@ +#include "dirutils.h" +unsigned int + __posixdir_d_type(struct dirent* d) + { + return(d -> d_type); + } + diff --git a/cbits/dirutils.h b/cbits/dirutils.h new file mode 100644 --- /dev/null +++ b/cbits/dirutils.h @@ -0,0 +1,13 @@ +#ifndef POSIXPATHS_CBITS_DIRUTILS_H +#define POSIXPATHS_CBITS_DIRUTILS_H + +#include +#include +#include +#include +#include + +extern unsigned int + __posixdir_d_type(struct dirent* d) + ; +#endif diff --git a/hpath-posix.cabal b/hpath-posix.cabal new file mode 100644 --- /dev/null +++ b/hpath-posix.cabal @@ -0,0 +1,56 @@ +cabal-version: >=1.10 + +name: hpath-posix +version: 0.13.0 +synopsis: Some low-level POSIX glue code, that is not in 'unix' +homepage: https://github.com/hasufell/hpath +bug-reports: https://github.com/hasufell/hpath/issues +license: BSD3 +license-file: LICENSE +author: Julian Ospald +maintainer: Julian Ospald +copyright: Julian Ospald 2020 +category: Filesystem +build-type: Simple +extra-source-files: CHANGELOG.md + cbits/dirutils.h +tested-with: GHC==7.10.3 + , GHC==8.0.2 + , GHC==8.2.2 + , GHC==8.4.4 + , GHC==8.6.5 + , GHC==8.8.1 + +library + if os(windows) + build-depends: unbuildable<0 + buildable: False + exposed-modules: System.Posix.RawFilePath.Directory.Traversals + System.Posix.Foreign + System.Posix.FD + -- other-modules: + -- other-extensions: + c-sources: cbits/dirutils.c + build-depends: base >= 4.8 && <5 + , IfElse + , bytestring >= 0.10 + , exceptions >= 0.10 + , hpath-filepath >= 0.10.3 + , safe-exceptions >= 0.1 + , streamly >= 0.7 + , streamly-bytestring >= 0.1.0.1 + , time >= 1.8 + , unix >= 2.5 + , unix-bytestring >= 0.3 + , utf8-string + if impl(ghc < 8.0) + build-depends: + fail >= 4.9 + + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: PackageImports + +source-repository head + type: git + location: https://github.com/hasufell/hpath diff --git a/src/System/Posix/FD.hs b/src/System/Posix/FD.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/FD.hs @@ -0,0 +1,75 @@ +-- | +-- Module : System.Posix.FD +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Provides an alternative for `System.Posix.IO.ByteString.openFd` +-- which gives us more control on what status flags to pass to the +-- low-level @open(2)@ call, in contrast to the unix package. + + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wall #-} + + +module System.Posix.FD ( + openFd +) where + + +import Foreign.C.String +import Foreign.C.Types +import System.Posix.Foreign +import qualified System.Posix as Posix +import System.Posix.ByteString.FilePath + + +foreign import ccall unsafe "open" + c_open :: CString -> CInt -> Posix.CMode -> IO CInt + + +open_ :: CString + -> Posix.OpenMode + -> [Flags] + -> Maybe Posix.FileMode + -> IO Posix.Fd +open_ str how optional_flags maybe_mode = do + fd <- c_open str all_flags mode_w + return (Posix.Fd fd) + where + all_flags = unionFlags $ optional_flags ++ [open_mode] ++ creat + + + (creat, mode_w) = case maybe_mode of + Nothing -> ([],0) + Just x -> ([oCreat], x) + + open_mode = case how of + Posix.ReadOnly -> oRdonly + Posix.WriteOnly -> oWronly + Posix.ReadWrite -> oRdwr + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +-- +-- Note that passing @Just x@ as the 4th argument triggers the +-- `oCreat` status flag, which must be set when you pass in `oExcl` +-- to the status flags. Also see the manpage for @open(2)@. +openFd :: RawFilePath + -> Posix.OpenMode + -> [Flags] -- ^ status flags of @open(2)@ + -> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist. + -> IO Posix.Fd +openFd name how optional_flags maybe_mode = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how optional_flags maybe_mode + diff --git a/src/System/Posix/Foreign.hsc b/src/System/Posix/Foreign.hsc new file mode 100644 --- /dev/null +++ b/src/System/Posix/Foreign.hsc @@ -0,0 +1,55 @@ +module System.Posix.Foreign where + +import Data.Bits +import Data.List (foldl') +import Foreign.C.Types + +#include +#include +#include +#include +#include +#include + +newtype DirType = DirType Int deriving (Eq, Show) +data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show) + +unFlags :: Flags -> Int +unFlags (Flags i) = i +unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform") + +-- |Returns @True@ if posix-paths was compiled with support for the provided +-- flag. (As of this writing, the only flag for which this check may be +-- necessary is 'oCloexec'; all other flags will always yield @True@.) +isSupported :: Flags -> Bool +isSupported (Flags _) = True +isSupported _ = False + +-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use +-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was +-- compiled into your version of posix-paths. (If not, using @oCloexec@ will +-- throw an exception.) +oCloexec :: Flags +#ifdef O_CLOEXEC +oCloexec = Flags #{const O_CLOEXEC} +#else +{-# WARNING oCloexec + "This version of posix-paths was compiled without @O_CLOEXEC@ support." #-} +oCloexec = UnsupportedFlag "O_CLOEXEC" +#endif + + + +-- If these enum declarations occur earlier in the file, haddock +-- gets royally confused about the above doc comments. +-- Probably http://trac.haskell.org/haddock/ticket/138 + +#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN} + +#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC} + +pathMax :: Int +pathMax = #{const PATH_MAX} + +unionFlags :: [Flags] -> CInt +unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0 diff --git a/src/System/Posix/RawFilePath/Directory/Traversals.hs b/src/System/Posix/RawFilePath/Directory/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/RawFilePath/Directory/Traversals.hs @@ -0,0 +1,263 @@ +-- | +-- Module : System.Posix.RawFilePath.Directory.Traversals +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Traversal and read operations on directories. + + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} + + +module System.Posix.RawFilePath.Directory.Traversals ( + + getDirectoryContents +, getDirectoryContents' + +, allDirectoryContents +, allDirectoryContents' +, traverseDirectory + +-- lower-level stuff +, readDirEnt +, packDirStream +, unpackDirStream +, fdOpendir + +, realpath +) where + + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Monad +import System.Posix.FilePath (()) +import System.Posix.Foreign + +import qualified System.Posix as Posix +import System.IO.Error +import Control.Exception +import qualified Data.ByteString.Char8 as BS +import System.Posix.ByteString.FilePath +import System.Posix.Directory.ByteString as PosixBS +import System.Posix.Files.ByteString + +import System.IO.Unsafe +import "unix" System.Posix.IO.ByteString (closeFd) +import Unsafe.Coerce (unsafeCoerce) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca,allocaBytes) +import Foreign.Ptr +import Foreign.Storable + + + + +---------------------------------------------------------- + +-- | Get all files from a directory and its subdirectories. +-- +-- Upon entering a directory, 'allDirectoryContents' will get all entries +-- strictly. However the returned list is lazy in that directories will only +-- be accessed on demand. +-- +-- Follows symbolic links for the input dir. +allDirectoryContents :: RawFilePath -> IO [RawFilePath] +allDirectoryContents topdir = do + namesAndTypes <- getDirectoryContents topdir + let properNames = filter ((`notElem` [".", ".."]) . snd) namesAndTypes + paths <- forM properNames $ \(typ,name) -> unsafeInterleaveIO $ do + let path = topdir name + case () of + () | typ == dtDir -> allDirectoryContents path + | typ == dtUnknown -> do + isDir <- isDirectory <$> getFileStatus path + if isDir + then allDirectoryContents path + else return [path] + | otherwise -> return [path] + return (topdir : concat paths) + +-- | Get all files from a directory and its subdirectories strictly. +-- +-- Follows symbolic links for the input dir. +allDirectoryContents' :: RawFilePath -> IO [RawFilePath] +allDirectoryContents' = fmap reverse . traverseDirectory (\acc fp -> return (fp:acc)) [] +-- this uses traverseDirectory because it's more efficient than forcing the +-- lazy version. + +-- | Recursively apply the 'action' to the parent directory and all +-- files/subdirectories. +-- +-- This function allows for memory-efficient traversals. +-- +-- Follows symbolic links for the input dir. +traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s +traverseDirectory act s0 topdir = toploop + where + toploop = do + isDir <- isDirectory <$> getFileStatus topdir + s' <- act s0 topdir + if isDir then actOnDirContents topdir s' loop + else return s' + loop typ path acc = do + isDir <- case () of + () | typ == dtDir -> return True + | typ == dtUnknown -> isDirectory <$> getFileStatus path + | otherwise -> return False + if isDir + then act acc path >>= \acc' -> actOnDirContents path acc' loop + else act acc path + +actOnDirContents :: RawFilePath + -> b + -> (DirType -> RawFilePath -> b -> IO b) + -> IO b +actOnDirContents pathRelToTop b f = + modifyIOError ((`ioeSetFileName` (BS.unpack pathRelToTop)) . + (`ioeSetLocation` "findBSTypRel")) $ + bracket + (openDirStream pathRelToTop) + Posix.closeDirStream + (\dirp -> loop dirp b) + where + loop dirp b' = do + (typ,e) <- readDirEnt dirp + if (e == "") + then return b' + else + if (e == "." || e == "..") + then loop dirp b' + else f typ (pathRelToTop e) b' >>= loop dirp + + +---------------------------------------------------------- +-- dodgy stuff + +type CDir = () +type CDirent = () + +-- Posix doesn't export DirStream, so to re-use that type we need to use +-- unsafeCoerce. It's just a newtype, so this is a legitimate usage. +-- ugly trick. +unpackDirStream :: DirStream -> Ptr CDir +unpackDirStream = unsafeCoerce + +packDirStream :: Ptr CDir -> DirStream +packDirStream = unsafeCoerce + +-- the __hscore_* functions are defined in the unix package. We can import them and let +-- the linker figure it out. +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_d_name" + c_name :: Ptr CDirent -> IO CString + +foreign import ccall unsafe "__posixdir_d_type" + c_type :: Ptr CDirent -> IO DirType + +foreign import ccall "realpath" + c_realpath :: CString -> CString -> IO CString + +foreign import ccall unsafe "fdopendir" + c_fdopendir :: Posix.Fd -> IO (Ptr ()) + +---------------------------------------------------------- +-- less dodgy but still lower-level + + +readDirEnt :: DirStream -> IO (DirType, RawFilePath) +readDirEnt (unpackDirStream -> dirp) = + alloca $ \ptr_dEnt -> loop ptr_dEnt + where + loop ptr_dEnt = do + resetErrno + r <- c_readdir dirp ptr_dEnt + if (r == 0) + then do + dEnt <- peek ptr_dEnt + if (dEnt == nullPtr) + then return (dtUnknown,BS.empty) + else do + dName <- c_name dEnt >>= peekFilePath + dType <- c_type dEnt + c_freeDirEnt dEnt + return (dType, dName) + else do + errno <- getErrno + if (errno == eINTR) + then loop ptr_dEnt + else do + let (Errno eo) = errno + if (eo == 0) + then return (dtUnknown,BS.empty) + else throwErrno "readDirEnt" + + +-- |Gets all directory contents (not recursively). +getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)] +getDirectoryContents path = + modifyIOError ((`ioeSetFileName` (BS.unpack path)) . + (`ioeSetLocation` "System.Posix.RawFilePath.Directory.Traversals.getDirectoryContents")) $ + bracket + (PosixBS.openDirStream path) + PosixBS.closeDirStream + _dirloop + + +-- |Binding to @fdopendir(3)@. +fdOpendir :: Posix.Fd -> IO DirStream +fdOpendir fd = + packDirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd) + + +-- |Like `getDirectoryContents` except for a file descriptor. +-- +-- To avoid complicated error checks, the file descriptor is +-- __always__ closed, even if `fdOpendir` fails. Usually, this +-- only happens on successful `fdOpendir` and after the directory +-- stream is closed. Also see the manpage of @fdopendir(3)@ for +-- more details. +getDirectoryContents' :: Posix.Fd -> IO [(DirType, RawFilePath)] +getDirectoryContents' fd = do + dirstream <- fdOpendir fd `catchIOError` \e -> do + closeFd fd + ioError e + -- closeDirStream closes the filedescriptor + finally (_dirloop dirstream) (PosixBS.closeDirStream dirstream) + + +_dirloop :: DirStream -> IO [(DirType, RawFilePath)] +{-# INLINE _dirloop #-} +_dirloop dirp = do + t@(_typ,e) <- readDirEnt dirp + if BS.null e then return [] else do + es <- _dirloop dirp + return (t:es) + + +-- | return the canonicalized absolute pathname +-- +-- like canonicalizePath, but uses @realpath(3)@ +realpath :: RawFilePath -> IO RawFilePath +realpath inp = + allocaBytes pathMax $ \tmp -> do + void $ BS.useAsCString inp $ \cstr -> throwErrnoIfNull "realpath" $ c_realpath cstr tmp + BS.packCString tmp