diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.1.4 + +* Add library and test + ## 0.1.3 * Add README.md, ChangeLog.md and .travis.yml diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,137 +1,24 @@ -{-#LANGUAGE BangPatterns#-} +{-# LANGUAGE ScopedTypeVariables #-} -import Numeric -import Data.Word -import Data.List -import Data.Char (ord,isSpace) -import Data.Bits import qualified Control.Exception as E -import Control.Applicative -import Control.Monad -import System.Posix.Files -import System.Posix.Types -import System.Directory -import System.FilePath import System.Environment import System.Exit import System.IO - --- copy from https://github.com/haskell/cabal/blob/master/cabal-install/Distribution/Client/Sandbox.hs -sandboxBuildDir :: FilePath -> FilePath -sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash "" - where - sandboxDirHash = jenkins sandboxDir - - -- See http://en.wikipedia.org/wiki/Jenkins_hash_function - jenkins :: String -> Word32 - jenkins str = loop_finish $ foldl' loop 0 str - where - loop :: Word32 -> Char -> Word32 - loop hash key_i' = hash''' - where - key_i = toEnum . ord $ key_i' - hash' = hash + key_i - hash'' = hash' + (shiftL hash' 10) - hash''' = hash'' `xor` (shiftR hash'' 6) - - loop_finish :: Word32 -> Word32 - loop_finish hash = hash''' - where - hash' = hash + (shiftL hash 3) - hash'' = hash' `xor` (shiftR hash' 11) - hash''' = hash'' + (shiftL hash'' 15) - - - --- copy from https://hackage.haskell.org/package/cab-0.2.14/docs/src/Distribution-Cab-Sandbox.html#getSandbox - -configFile :: String -configFile = "cabal.sandbox.config" - -pkgDbKey :: String -pkgDbKey = "package-db:" - -pkgDbKeyLen :: Int -pkgDbKeyLen = length pkgDbKey - --- | Find a sandbox config file by tracing ancestor directories, --- parse it and return the package db path -getSandbox :: IO (Maybe FilePath) -getSandbox = (Just <$> getPkgDb) `E.catch` handler - where - getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir - handler :: E.SomeException -> IO (Maybe String) - handler _ = return Nothing - --- | Find a sandbox config file by tracing ancestor directories. --- Exception is thrown if not found -getSandboxConfigFile :: FilePath -> IO FilePath -getSandboxConfigFile dir = do - let cfile = dir configFile - exist <- doesFileExist cfile - if exist then - return cfile - else do - let dir' = takeDirectory dir - if dir == dir' then - E.throwIO $ userError "sandbox config file not found" - else - getSandboxConfigFile dir' - --- | Extract a package db directory from the sandbox config file. --- Exception is thrown if the sandbox config file is broken. -getPackageDbDir :: FilePath -> IO FilePath -getPackageDbDir sconf = do - -- Be strict to ensure that an error can be caught. - !path <- extractValue . parse <$> readFile sconf - return path - where - parse = head . filter ("package-db:" `isPrefixOf`) . lines - extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen - -type ProjectRootDir = FilePath -type BinaryName = FilePath - - -getTimeStamp :: FilePath -> IO (Either E.SomeException EpochTime) -getTimeStamp path = do - stat <- E.try $ getFileStatus path - return $ fmap modificationTime stat +import Test.Cabal.Path -searchBinary :: ProjectRootDir -> BinaryName -> IO FilePath -searchBinary rdir name = do - timeT <- getTimeStamp distTBin - msdir <- getSandbox - case msdir of - Just sdir -> do - let distS = sandboxBuildDir $ takeDirectory sdir - let distSBin = rdir distS "build" name name - timeS <- getTimeStamp distSBin - case (timeS,timeT) of - (Right s,Right t) -> return $ if t <= s then distSBin else distTBin - (Right _,Left _) -> return distSBin - (Left _,Right _) -> return distTBin - _ -> errorHandler [distSBin,distTBin] - Nothing -> do - case timeT of - (Right _) -> return distTBin - _ -> errorHandler [distTBin] - where - distTBin = rdir "dist" "build" name name - errorHandler paths = do - forM_ paths $ \path -> do - hPutStrLn stderr $ "Check:" ++ path - hPutStrLn stderr $ "Can not find exe-file:" ++ name - exitWith $ ExitFailure 2 - main :: IO () main = do args <- getArgs case args of (dir:binName:[]) -> do - binPath <- searchBinary dir binName - putStrLn binPath - exitWith $ ExitSuccess + eBinPath <- E.try $ getExePath dir binName + case eBinPath of + Right binPath -> do + putStrLn binPath + exitWith $ ExitSuccess + Left (err::E.SomeException) -> do + putStr $ show err + exitWith $ ExitFailure 1 _ -> do hPutStrLn stderr "Usage: cabal-test-bin \"project's root directory\" \"executable-program-name\"" exitWith $ ExitFailure 1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# cabal-test-bin: A program finding temploray build-binary for cabal-test +# cabal-test-bin: A program finding temporal build-binary for cabal-test [![Hackage version](https://img.shields.io/hackage/v/cabal-test-bin.svg?style=flat)](https://hackage.haskell.org/package/cabal-test-bin) [![Build Status](https://travis-ci.org/junjihashimoto/cabal-test-bin.png?branch=master)](https://travis-ci.org/junjihashimoto/cabal-test-bin) diff --git a/Test/Cabal/Path.hs b/Test/Cabal/Path.hs new file mode 100644 --- /dev/null +++ b/Test/Cabal/Path.hs @@ -0,0 +1,129 @@ +{-#LANGUAGE BangPatterns#-} + +module Test.Cabal.Path ( + getExePath +, getExeDir +, ProjectRootDir +, BinaryName +) where + +import Numeric +import Data.Word +import Data.List +import Data.Char (ord,isSpace) +import Data.Bits +import qualified Control.Exception as E +import Control.Applicative +import System.Posix.Files +import System.Posix.Types +import System.Directory +import System.FilePath + +-- copy from https://github.com/haskell/cabal/blob/master/cabal-install/Distribution/Client/Sandbox.hs +sandboxBuildDir :: FilePath -> FilePath +sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash "" + where + sandboxDirHash = jenkins sandboxDir + + -- See http://en.wikipedia.org/wiki/Jenkins_hash_function + jenkins :: String -> Word32 + jenkins str = loop_finish $ foldl' loop 0 str + where + loop :: Word32 -> Char -> Word32 + loop hash key_i' = hash''' + where + key_i = toEnum . ord $ key_i' + hash' = hash + key_i + hash'' = hash' + (shiftL hash' 10) + hash''' = hash'' `xor` (shiftR hash'' 6) + + loop_finish :: Word32 -> Word32 + loop_finish hash = hash''' + where + hash' = hash + (shiftL hash 3) + hash'' = hash' `xor` (shiftR hash' 11) + hash''' = hash'' + (shiftL hash'' 15) + + + +-- copy from https://hackage.haskell.org/package/cab-0.2.14/docs/src/Distribution-Cab-Sandbox.html#getSandbox +configFile :: String +configFile = "cabal.sandbox.config" + +pkgDbKey :: String +pkgDbKey = "package-db:" + +pkgDbKeyLen :: Int +pkgDbKeyLen = length pkgDbKey + +-- | Find a sandbox config file by tracing ancestor directories, +-- parse it and return the package db path +getSandbox :: IO (Maybe FilePath) +getSandbox = (Just <$> getPkgDb) `E.catch` handler + where + getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir + handler :: E.SomeException -> IO (Maybe String) + handler _ = return Nothing + +-- | Find a sandbox config file by tracing ancestor directories. +-- Exception is thrown if not found +getSandboxConfigFile :: FilePath -> IO FilePath +getSandboxConfigFile dir = do + let cfile = dir configFile + exist <- doesFileExist cfile + if exist then + return cfile + else do + let dir' = takeDirectory dir + if dir == dir' then + E.throwIO $ userError "sandbox config file not found" + else + getSandboxConfigFile dir' + +-- | Extract a package db directory from the sandbox config file. +-- Exception is thrown if the sandbox config file is broken. +getPackageDbDir :: FilePath -> IO FilePath +getPackageDbDir sconf = do + -- Be strict to ensure that an error can be caught. + !path <- extractValue . parse <$> readFile sconf + return path + where + parse = head . filter ("package-db:" `isPrefixOf`) . lines + extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen + +type ProjectRootDir = FilePath +type BinaryName = FilePath + +getTimeStamp :: FilePath -> IO (Either E.SomeException EpochTime) +getTimeStamp path = do + stat <- E.try $ getFileStatus path + return $ fmap modificationTime stat + +getExePath :: ProjectRootDir -> BinaryName -> IO FilePath +getExePath rdir name = do + timeT <- getTimeStamp distTBin + msdir <- getSandbox + case msdir of + Just sdir -> do + let distS = sandboxBuildDir $ takeDirectory sdir + let distSBin = rdir distS "build" name name + timeS <- getTimeStamp distSBin + case (timeS,timeT) of + (Right s,Right t) -> return $ if t <= s then distSBin else distTBin + (Right _,Left _) -> return distSBin + (Left _,Right _) -> return distTBin + _ -> errorHandler [distSBin,distTBin] + Nothing -> do + case timeT of + (Right _) -> return distTBin + _ -> errorHandler [distTBin] + where + distTBin = rdir "dist" "build" name name + errorHandler paths = E.throwIO $ userError $ + (foldr (\path msg -> msg ++ "Check:" ++ path ++ "\n") "\n" paths) + ++ "Can not find exe-file:" ++ name ++ "\n" + +getExeDir :: ProjectRootDir -> BinaryName -> IO FilePath +getExeDir rdir name = do + binpath <- getExePath rdir name + return $ takeDirectory binpath diff --git a/cabal-test-bin.cabal b/cabal-test-bin.cabal --- a/cabal-test-bin.cabal +++ b/cabal-test-bin.cabal @@ -1,5 +1,5 @@ name: cabal-test-bin -version: 0.1.3 +version: 0.1.4 synopsis: A program for finding temporary build file during cabal-test. description: cabal-test-bin finds exe-file for cabal test below . @@ -34,13 +34,38 @@ type: git location: https://github.com/junjihashimoto/cabal-test-bin.git + +Library + Exposed-modules: Test.Cabal.Path + Build-Depends: base >=4 && <5 + , directory + , filepath + , unix + Default-Language: Haskell2010 + ghc-options: -Wall + executable cabal-test-bin - main-is: Main.hs + main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >= 4 && < 5 - , directory - , filepath - , unix + build-depends: base >=4 && <5 + , directory + , filepath + , unix + , cabal-test-bin -- hs-source-dirs: - default-language: Haskell2010 + ghc-options: -Wall + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: test.hs + hs-source-dirs: tests,dist/build/autogen + ghc-options: -Wall + + build-depends: base + , hspec + , cabal-test-bin + , regex-posix + , process + Default-Language: Haskell2010 diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ScopedTypeVariables #-} +import Test.Hspec +import Test.Cabal.Path +import Text.Regex.Posix +import Control.Exception + +shouldReturnRegex :: IO String -> String -> IO () +shouldReturnRegex exe pattern = do + v <- exe + (v =~ pattern) `shouldBe` True + +main :: IO () +main = hspec $ do + describe "library-test" $ do + it "getExePath" $ do + (getExePath "." "cabal-test-bin" `shouldReturn` "./dist/build/cabal-test-bin/cabal-test-bin") + `catch` + (\(_::SomeException) -> (getExePath "." "cabal-test-bin" `shouldReturnRegex` "./dist/dist-sandbox-(.*)/cabal-test-bin/cabal-test-bin")) + it "getExeDir" $ do + (getExePath "." "cabal-test-bin" `shouldReturn` "./dist/build/cabal-test-bin") + `catch` + (\(_::SomeException) -> (getExePath "." "cabal-test-bin" `shouldReturnRegex` "./dist/dist-sandbox-(.*)/cabal-test-bin"))