diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2016 Reuben D'Netto + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. 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/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,18 @@ +import Criterion.Main +import qualified System.Directory.Glob as GP -- glob-posix +import qualified System.FilePath.Glob as G -- Glob +import qualified System.Path.Glob as MH -- MissingH + +main :: IO () +main = defaultMain [ + bgroup "glob-posix" $ cases (GP.glob GP.globDefaults), + bgroup "MissingH" $ cases MH.glob, + bgroup "Glob" $ cases G.glob + ] + where + cases glob = [ + bench "Simple path" . whnfIO $ glob "/usr/bin", + bench "Python versions" . whnfIO $ glob "/usr/lib/python?.?", + bench "Python site" . whnfIO $ glob "/usr/lib/python?.?/site-packages/test" + ] + diff --git a/glob-posix.cabal b/glob-posix.cabal new file mode 100644 --- /dev/null +++ b/glob-posix.cabal @@ -0,0 +1,57 @@ +name: glob-posix +version: 0.1.0.0 +synopsis: Haskell bindings for POSIX glob library. +description: Wrapper for the glob(3) function. The key functions are glob and globMany. + GNU extensions are supported but contained in a different module to encourage portability. +homepage: https://github.com/rdnetto/glob-posix#readme +license: Apache +license-file: LICENSE +author: Reuben D'Netto +maintainer: rdnetto@gmail.com +copyright: 2016 Reuben D'Netto +category: System +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: System.Directory.Glob, + System.Directory.Glob.GNU, + System.Directory.Glob.GNU.Compat + other-modules: System.Directory.Glob.Internal + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + ghc-options: -O2 -Wall + +test-suite glob-posix-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base, + directory, + filepath, + glob-posix, + tasty, + tasty-expected-failure, + tasty-hunit, + unix + default-language: Haskell2010 + ghc-options: -O2 -Wall + +benchmark glob-posix-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + build-depends: base, + criterion, + MissingH, + Glob, + glob-posix + default-language: Haskell2010 + ghc-options: -O2 -Wall + + +source-repository head + type: git + location: https://github.com/rdnetto/glob-posix + diff --git a/src/System/Directory/Glob.hsc b/src/System/Directory/Glob.hsc new file mode 100644 --- /dev/null +++ b/src/System/Directory/Glob.hsc @@ -0,0 +1,113 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +{-| +Module : System.Directory.Glob +Copyright : (c) Reuben D'Netto 2016 +License : Apache 2.0 +Maintainer : rdnetto@gmail.com +Portability : POSIX + +This module provides a wrapper around the C function, which finds file paths matching a given pattern. +All of the standard flags are supported, though GNU extensions are contained in the "System.Directory.Glob.GNU" module to encourage portability. +-} +module System.Directory.Glob ( + (<>), + glob, + globDefaults, + globMany, + GlobFlag, + -- Only export standard flags by default + globMark, + globNoCheck, + globNoEscape, + globNoSort + ) where + +import Control.Monad (unless, forM_) +import Data.Monoid ((<>)) +import Foreign (alloca, peekArray) +import Foreign.C.String (CString, peekCString, withCString) +import Foreign.C.Types (CInt(..)) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable(..)) + +import System.Directory.Glob.Internal +#include + + +-- Each call to glob() involves String marshalling and return code checking +c_glob' :: Ptr CGlob -> GlobFlag -> String -> IO () +c_glob' globPtr (GlobFlag f) p = withCString p $ \p' -> do + errCode <- c_glob p' f nullPtr globPtr + + unless (errCode == 0 || errCode == (#const GLOB_NOMATCH)) + (error $ "glob failed with exit code: " ++ show errCode) + +-- | Finds pathnames matching a pattern. e.g @foo*@, @prog_v?@, @ba[zr]@, etc. +glob :: GlobFlag -- ^ The control flags to apply. + -> String -- ^ The pattern. + -> IO [FilePath] -- ^ The paths matching the pattern. +glob flags pat = alloca $ \globPtr -> do + -- Call glob + c_glob' globPtr flags pat + + -- Unpack results + CGlob strs <- peek globPtr + res <- mapM peekCString strs + + -- Cleanup + c_globfree globPtr + return res + +-- | Like glob, but matches against multiple patterns. +-- This function only allocates and marshals data once, making it more efficient than multiple glob calls. +globMany :: GlobFlag -- ^ The control flags to apply. + -> [String] -- ^ A list of patterns to apply. + -> IO [FilePath] -- ^ The paths matching the patterns. +globMany _ [] = return [] -- Need to handle this explicitly, or we'll free an uninitiallized glob_t. +globMany flags (p0:ps) = alloca $ \globPtr -> do + -- First call to glob must be *without* GLOB_APPEND + c_glob' globPtr flags p0 + + -- Call glob for the remaining patterns with GLOB_APPEND + forM_ ps . c_glob' globPtr $ flags <> globAppend + + -- Unpack paths + CGlob strs <- peek globPtr + res <- mapM peekCString strs + + -- Cleanup + c_globfree globPtr + return res + +{- + typedef struct { + size_t gl_pathc; /* Count of paths matched so far */ + char **gl_pathv; /* List of matched pathnames. */ + size_t gl_offs; /* Slots to reserve in gl_pathv. */ + } glob_t; +-} +newtype CGlob = CGlob [CString] + +instance Storable CGlob where + sizeOf _ = #size glob_t + alignment _ = #alignment glob_t + peek ptr = do + pathC <- (#peek glob_t, gl_pathc) ptr + pathV <- peekArray pathC =<< (#peek glob_t, gl_pathv) ptr + return $ CGlob pathV + + poke _ _ = error "Poke unsupported for CGlob" + +-- We don't use this, so its type doesn't matter +type C_ErrorFunc = Ptr () + + +-- int glob(const char *pattern, int flags, int (*errfunc) (const char *epath, int eerrno), glob_t *pglob); +foreign import ccall "glob.h glob" + c_glob :: CString -> CInt -> C_ErrorFunc -> Ptr CGlob -> IO CInt + +-- void globfree(glob_t *pglob); +foreign import ccall "glob.h globfree" + c_globfree :: Ptr CGlob -> IO () + diff --git a/src/System/Directory/Glob/GNU.hsc b/src/System/Directory/Glob/GNU.hsc new file mode 100644 --- /dev/null +++ b/src/System/Directory/Glob/GNU.hsc @@ -0,0 +1,28 @@ +{-| +Module : System.Directory.Glob.GNU +Copyright : (c) Reuben D'Netto 2016 +License : Apache 2.0 +Maintainer : rdnetto@gmail.com +Portability : GNU + +This module exports 'GlobFlag' values which are only supported on platforms using the GNU implementation of glob. +Using them on non-GNU platforms will result in a compile-time failure. +If you wish to defer the failure to run-time, you should also import "System.Directory.Glob.GNU.Compat". +-} +module System.Directory.Glob.GNU +#ifdef linux_HOST_OS + ( + globBrace, + globNoMagic, + globOnlyDir, + globPeriod, + globTilde, + globTildeCheck + ) where + +import System.Directory.Glob.Internal + +#else + () where + +#endif diff --git a/src/System/Directory/Glob/GNU/Compat.hsc b/src/System/Directory/Glob/GNU/Compat.hsc new file mode 100644 --- /dev/null +++ b/src/System/Directory/Glob/GNU/Compat.hsc @@ -0,0 +1,23 @@ +{-| +Module : System.Directory.Glob.GNU.Compat +Copyright : (c) Reuben D'Netto 2016 +License : Apache 2.0 +Maintainer : rdnetto@gmail.com + +On non-GNU platforms, this module exports values for 'GlobFlag' which will throw an exception on use. +They can be used to defer the failure to runtime, when you wish to avoid adding @#ifdef@ checks to your code. +-} +module System.Directory.Glob.GNU.Compat where + +#ifndef linux_HOST_OS +import System.Directory.Glob.Internal (GlobFlag) + +globBrace, globNoMagic, globOnlyDir, globPeriod, globTilde, globTildeCheck :: GlobFlag +globBrace = error "Unsupported: GLOB_BRACE is a GNU extension" +globNoMagic = error "Unsupported: GLOB_NOMAGIC is a GNU extension" +globOnlyDir = error "Unsupported: GLOB_ONLYDIR is a GNU extension" +globPeriod = error "Unsupported: GLOB_PERIOD is a GNU extension" +globTilde = error "Unsupported: GLOB_TILDE is a GNU extension" +globTildeCheck = error "Unsupported: GLOB_TILDE_CHECK is a GNU extension" +#endif + diff --git a/src/System/Directory/Glob/Internal.hsc b/src/System/Directory/Glob/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/System/Directory/Glob/Internal.hsc @@ -0,0 +1,56 @@ +{-| +Module : System.Directory.Glob.Internal +Copyright : (c) Reuben D'Netto 2016 +License : Apache 2.0 +Maintainer : rdnetto@gmail.com +Portability : POSIX +-} +module System.Directory.Glob.Internal where + +import Data.Bits ((.|.)) +import Data.Monoid ((<>)) +import Foreign.C.Types (CInt(..)) + +#include + + +-- | Control flags for glob. Use 'globDefaults' if you have no special requirements. +-- To combine multiple flags, use the '<>' operator (re-exported here for convenience). +-- See for more information. +data GlobFlag = GlobFlag !CInt + +-- | Default value - equivalent to 0 for the C function. +globDefaults = GlobFlag 0 + +instance Monoid GlobFlag where + mempty = globDefaults + mappend (GlobFlag a) (GlobFlag b) = GlobFlag (a .|. b) + + +-- | Used for mutation of an existing structure - for internal use only. +#enum GlobFlag, GlobFlag, GLOB_APPEND +-- | Append a @/@ to each entry that is the path of a directory. +#enum GlobFlag, GlobFlag, GLOB_MARK +-- | If there are no matches, return the original pattern. +#enum GlobFlag, GlobFlag, globNoCheck = GLOB_NOCHECK +-- | Disable the use of @\@ for escaping metacharacters. +#enum GlobFlag, GlobFlag, globNoEscape = GLOB_NOESCAPE +-- | Do not sort the entries before returning them. +#enum GlobFlag, GlobFlag, globNoSort = GLOB_NOSORT + +-- GNU extensions +#ifdef linux_HOST_OS +-- | Enable CSH-style brace expansion. e.g. foo.{txt,md}. Supports nested braces. (GNU extension) +#enum GlobFlag, GlobFlag, GLOB_BRACE +-- | Enables globNoCheck if the pattern contains no metacharacters. (GNU extension) +#enum GlobFlag, GlobFlag, globNoMagic = GLOB_NOMAGIC +-- | Only return directories, if it is cheap to do so. (GNU extension) +#enum GlobFlag, GlobFlag, globOnlyDir = GLOB_ONLYDIR +-- | Allow leading '.' to be matched by metacharacters. +#enum GlobFlag, GlobFlag, GLOB_PERIOD +-- | Substitute home directory for '~' or '~user' prefixes. +#enum GlobFlag, GlobFlag, GLOB_TILDE +-- | Like globTilde, but return no matches if there is no such user. +#enum GlobFlag, GlobFlag, GLOB_TILDE_CHECK +#endif + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,114 @@ +import Control.Exception (bracket_) +import System.Directory +import System.FilePath (()) +import System.Info (os) +import System.IO (IOMode(..), withFile) +import System.Posix.User +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit + +import System.Directory.Glob +import System.Directory.Glob.GNU +import System.Directory.Glob.GNU.Compat + + +main :: IO () +main = do + putStrLn $ "\nRunning on " ++ os + tmp <- getTemporaryDirectory + + -- We only expect Linux to have GNU extensions + let gnuHandling = if os == "linux" + then id + else ignoreTest + + defaultMain $ testGroup "Tests" [ + testGroup "POSIX Functionality" (posixTests tmp), + gnuHandling $ testGroup "GNU Extensions" (gnuTests tmp) + ] + +posixTests :: FilePath -> [TestTree] +posixTests tmp = [ + testCase "Basic case" $ + glob globDefaults "/usr/bin" !@?= ["/usr/bin"], + + testCase "Non-existant path" $ + glob globDefaults "/foo" !@?= [], + + testCase "globMany" . withTempFile "foo" $ \f1 -> + withTempFile "bar" $ \f2 -> + globMany globDefaults [tmp "foo", tmp "bar"] !@?= [f1, f2], + + testCase "GLOB_MARK" $ + glob globMark "/usr/bin" !@?= ["/usr/bin/"], + + testCase "GLOB_NOCHECK" $ + glob globNoCheck "/foo" !@?= ["/foo"], + + testCase "GLOB_ESCAPE" . withTempFile "a?b" $ \f -> + glob globDefaults (tmp "a\\?b") !@?= [f], + + testCase "GLOB_NOESCAPE" . withTempFile "a\\?b" $ \f -> + glob globNoEscape (tmp "a\\?b") !@?= [f] + + ] + +gnuTests :: FilePath -> [TestTree] +gnuTests tmp = [ + testCase "GLOB_NOMAGIC" $ + glob globNoMagic "/foo" !@?= ["/foo"], + + + testCase "GLOB_PERIOD" . withTempFile ".ab" $ \f -> do + glob globDefaults (tmp "?ab") !@?= [] + glob globPeriod (tmp "?ab") !@?= [f], + + testCase "GLOB_BRACE" . withTempFile "foo" $ \f1 -> + withTempFile "far" $ \f2 -> do + glob globDefaults (tmp "f{oo,ar}") !@?= [] + glob globBrace (tmp "f{oo,ar}") !@?= [f1, f2], + + testCase "GLOB_TILDE" $ do + h <- getHomeDirectory + user <- getUserName + glob globDefaults ('~':user) !@?= [] + glob globTilde ('~':user) !@?= [h] + + ] + + +-- Convenience operator that eliminates the need to bind the actual result before asserting it is equal to the expected result +(!@?=) :: (Eq a, Show a) => IO a -> a -> Assertion +(!@?=) x y = do + x' <- x + x' @?= y + +-- Deterministic temp file creation & deletion +withTempFile :: FilePath -> (FilePath -> IO a) -> IO a +withTempFile f cb = do + d <- getTemporaryDirectory + let f' = d f + let createFile fp = withFile fp WriteMode (\_ -> return ()) + + bracket_ + (createFile f') + (removeFile f') + (cb f') + +-- Creates a temporary directory that we can't read from. +-- Used for testing error handling. +withUnreadableDir :: (FilePath -> IO a) -> IO a +withUnreadableDir cb = do + fp <- ( "foo") <$> getTemporaryDirectory + + bracket_ + (createDirectory fp >> setPermissions fp emptyPermissions) + (setPermissions fp emptyPermissions {writable = True} >> removeDirectory fp) + (cb fp) + +-- Gets the username of the current user +-- We can't use getLoginName here because it requires a controlling tty +getUserName :: IO String +getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID) +