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
sandboxBuildDir :: FilePath -> FilePath
sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash ""
where
sandboxDirHash = jenkins sandboxDir
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)
configFile :: String
configFile = "cabal.sandbox.config"
pkgDbKey :: String
pkgDbKey = "package-db:"
pkgDbKeyLen :: Int
pkgDbKeyLen = length pkgDbKey
getSandbox :: IO (Maybe FilePath)
getSandbox = (Just <$> getPkgDb) `E.catch` handler
where
getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir
handler :: E.SomeException -> IO (Maybe String)
handler _ = return Nothing
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'
getPackageDbDir :: FilePath -> IO FilePath
getPackageDbDir sconf = do
!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