module Darcs.Repository.External
( cloneTree
, cloneFile
, fetchFilePS
, fetchFileLazyPS
, gzFetchFilePS
, speculateFileOrUrl
, copyFileOrUrl
, Cachable(..)
, backupByRenaming
, backupByCopying
, environmentHelpProtocols
) where
import Prelude hiding ( catch )
import Control.Exception ( catch, IOException )
import System.Posix.Files
( getSymbolicLinkStatus
, isRegularFile
, isDirectory
, createLink
)
import System.Directory
( createDirectory
, getDirectoryContents
, doesDirectoryExist
, doesFileExist
, renameFile
, renameDirectory
, copyFile
)
import System.Exit ( ExitCode(..) )
import System.Environment ( getEnv )
import System.FilePath.Posix ( (</>), normalise )
import System.IO.Error ( isDoesNotExistError )
import Control.Monad
( unless
, when
, zipWithM_
)
import Data.Char ( toUpper )
import Darcs.Util.Exec ( exec, Redirect(..) )
import Darcs.Util.Download
( copyUrl
, copyUrlFirst
, waitUrl
, Cachable(..)
)
import Darcs.Util.URL
( isValidLocalPath
, isHttpUrl
, isSshUrl
, splitSshUrl
)
import Darcs.Util.Text ( breakCommand )
import Darcs.Util.Exception ( catchall )
import Darcs.Repository.Flags ( RemoteDarcs(..) )
import Darcs.Repository.Lock ( withTemp )
import Darcs.Repository.Ssh ( copySSH )
import Darcs.Util.ByteString ( gzReadFilePS )
import qualified Data.ByteString as B (ByteString, readFile )
import qualified Data.ByteString.Lazy as BL
#ifdef HAVE_HTTP
import Network.Browser
( browse
, request
, setErrHandler
, setOutHandler
, setAllowRedirects
)
import Network.HTTP
( RequestMethod(GET)
, rspCode
, rspBody
, rspReason
, mkRequest
)
import Network.URI
( parseURI
, uriScheme
)
#endif
copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO ()
copyFileOrUrl _ fou out _ | isValidLocalPath fou = copyLocal fou out
copyFileOrUrl _ fou out cache | isHttpUrl fou = copyRemote fou out cache
copyFileOrUrl rd fou out _ | isSshUrl fou = copySSH rd (splitSshUrl fou) out
copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou
copyLocal :: String -> FilePath -> IO ()
copyLocal fou out = createLink fou out `catchall` cloneFile fou out
copyRemote :: String -> FilePath -> Cachable -> IO ()
copyRemote u v cache =
do maybeget <- maybeURLCmd "GET" u
case maybeget of
Nothing -> copyRemoteNormal u v cache
Just get ->
do let (cmd,args) = breakCommand get
r <- exec cmd (args++[u]) (Null, File v, AsIs)
when (r /= ExitSuccess) $
fail $ "(" ++ get ++ ") failed to fetch: " ++ u
cloneTree :: FilePath -> FilePath -> IO ()
cloneTree = cloneTreeExcept []
cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()
cloneTreeExcept except source dest =
do fs <- getSymbolicLinkStatus source
if isDirectory fs then do
fps <- getDirectoryContents source
let fps' = filter (`notElem` (".":"..":except)) fps
mk_source fp = source </> fp
mk_dest fp = dest </> fp
zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
else fail ("cloneTreeExcept: Bad source " ++ source)
`catch` \(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source)
cloneSubTree :: FilePath -> FilePath -> IO ()
cloneSubTree source dest =
do fs <- getSymbolicLinkStatus source
if isDirectory fs then do
createDirectory dest
fps <- getDirectoryContents source
let fps' = filter (`notElem` [".", ".."]) fps
mk_source fp = source </> fp
mk_dest fp = dest </> fp
zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
else if isRegularFile fs then
cloneFile source dest
else fail ("cloneSubTree: Bad source "++ source)
`catch` (\e -> unless (isDoesNotExistError e) $ ioError e)
cloneFile :: FilePath -> FilePath -> IO ()
cloneFile = copyFile
backupByRenaming :: FilePath -> IO ()
backupByRenaming = backupBy rename
where rename x y = do
isD <- doesDirectoryExist x
if isD then renameDirectory x y else renameFile x y
backupByCopying :: FilePath -> IO ()
backupByCopying = backupBy copy
where
copy x y = do
isD <- doesDirectoryExist x
if isD then do createDirectory y
cloneTree (normalise x) (normalise y)
else copyFile x y
backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()
backupBy backup f =
do hasBF <- doesFileExist f
hasBD <- doesDirectoryExist f
when (hasBF || hasBD) $ helper 0
where
helper :: Int -> IO ()
helper i = do existsF <- doesFileExist next
existsD <- doesDirectoryExist next
if existsF || existsD
then helper (i + 1)
else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"
backup f next
where next = f ++ suffix
suffix = ".~" ++ show i ++ "~"
copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a
copyAndReadFile readfn fou _ | isValidLocalPath fou = readfn fou
copyAndReadFile readfn fou cache = withTemp $ \t -> do
copyFileOrUrl DefaultRemoteDarcs fou t cache
readfn t
fetchFilePS :: String -> Cachable -> IO B.ByteString
fetchFilePS = copyAndReadFile (B.readFile)
fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString
#ifdef HAVE_HTTP
fetchFileLazyPS x c = case parseURI x of
Just x' | uriScheme x' == "http:" -> do
rsp <- fmap snd . browse $ do
setErrHandler . const $ return ()
setOutHandler . const $ return ()
setAllowRedirects True
request $ mkRequest GET x'
if rspCode rsp /= (2, 0, 0)
then fail $ "fetchFileLazyPS: " ++ rspReason rsp
else return $ rspBody rsp
_ -> copyAndReadFile BL.readFile x c
#else
fetchFileLazyPS = copyAndReadFile BL.readFile
#endif
gzFetchFilePS :: String -> Cachable -> IO B.ByteString
gzFetchFilePS = copyAndReadFile gzReadFilePS
maybeURLCmd :: String -> String -> IO (Maybe String)
maybeURLCmd what url =
do let prot = map toUpper $ takeWhile (/= ':') url
fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))
`catch` \(_ :: IOException) -> return Nothing
copyRemoteNormal :: String -> FilePath -> Cachable -> IO ()
copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u
speculateFileOrUrl :: String -> FilePath -> IO ()
speculateFileOrUrl fou out | isHttpUrl fou = speculateRemote fou out
| otherwise = return ()
speculateRemote :: String -> FilePath -> IO ()
#if defined(HAVE_CURL) || defined(HAVE_HTTP)
speculateRemote u v =
do maybeget <- maybeURLCmd "GET" u
case maybeget of
Just _ -> return ()
Nothing -> copyUrl u v Cachable
#else
speculateRemote u _ = const () `fmap` maybeURLCmd "GET" u
#endif
environmentHelpProtocols :: ([String], [String])
environmentHelpProtocols = (["DARCS_GET_FOO", "DARCS_APPLY_FOO"],[
"When trying to access a repository with a URL beginning foo://,",
"darcs will invoke the program specified by the DARCS_GET_FOO",
"environment variable (if defined) to download each file, and the",
"command specified by the DARCS_APPLY_FOO environment variable (if",
"defined) when pushing to a foo:// URL.",
"",
"This method overrides all other ways of getting `foo://xxx` URLs.",
"",
"Note that each command should be constructed so that it sends the downloaded",
"content to STDOUT, and the next argument to it should be the URL.",
"Here are some examples that should work for DARCS_GET_HTTP:",
"",
" fetch -q -o -",
" curl -s -f",
" lynx -source",
" wget -q -O -",
"",
"Apart from such toy examples, it is likely that you will need to",
"manipulate the argument before passing it to the actual fetcher",
"program. For example, consider the problem of getting read access to",
"a repository on a CIFS (SMB) share without mount privileges:",
"",
" export DARCS_GET_SMB='smbclient -c get'",
" darcs get smb://fs/twb/Desktop/hello-world",
"",
"The above command will not work for several reasons. Firstly, Darcs",
"will pass it an argument beginning with `smb:`, which smbclient does",
"not understand. Secondly, the host and share `//fs/twb` must be",
"presented as a separate argument to the path `Desktop/hello-world`.",
"Thirdly, smbclient requires that `get` and the path be a single",
"argument (including a space), rather than two separate arguments.",
"Finally, smbclient's `get` command writes the file to disk, while",
"Darcs expects it to be printed to standard output.",
"",
"In principle, we could get around such problems by making the variable",
"contain a shell script, unfortunately, Darcs splits the command on",
"whitespace and does not understand quotation or escaping. Therefore,",
"we instead need to put commands in separate, executable scripts.",
"",
"Continuing our smbclient example, we create an executable script",
"`~/.darcs/libexec/get_smb` with the following contents:",
"",
" #!/bin/bash -e",
" IFS=/ read host share file <<<'${1#smb://}'",
" smbclient //$host/$share -c 'get $file -'",
"",
"And at last we can say",
"",
" export DARCS_GET_SMB=~/.darcs/libexec/get_smb",
" darcs get smb://fs/twb/Desktop/hello-world",
"",
"The APPLY command will be called with a darcs patchfile piped into",
"its standard input."
])