module Darcs.Util.External
( cloneTree
, cloneFile
, fetchFilePS
, fetchFileLazyPS
, gzFetchFilePS
, speculateFileOrUrl
, copyFileOrUrl
, Cachable(..)
, backupByRenaming
, backupByCopying
) where
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.FilePath.Posix ( (</>), normalise )
import System.IO.Error ( isDoesNotExistError )
import Control.Monad
( unless
, when
, zipWithM_
)
import Darcs.Util.Global ( defaultRemoteDarcsCmd )
import Darcs.Util.Download
( copyUrl
, copyUrlFirst
, waitUrl
, Cachable(..)
)
import Darcs.Util.URL
( isValidLocalPath
, isHttpUrl
, isSshUrl
, splitSshUrl
)
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Lock ( withTemp )
import Darcs.Util.Ssh ( copySSH )
import Darcs.Util.ByteString ( gzReadFilePS )
import qualified Data.ByteString as B (ByteString, readFile )
import qualified Data.ByteString.Lazy as BL
import Network.Browser
( browse
, request
, setErrHandler
, setOutHandler
, setAllowRedirects
)
import Network.HTTP
( RequestMethod(GET)
, rspCode
, rspBody
, rspReason
, mkRequest
)
import Network.URI
( parseURI
, uriScheme
)
copyFileOrUrl :: String
-> FilePath
-> FilePath
-> Cachable
-> IO ()
copyFileOrUrl :: String -> String -> String -> Cachable -> IO ()
copyFileOrUrl _ fou :: String
fou out :: String
out _ | String -> Bool
isValidLocalPath String
fou = String -> String -> IO ()
copyLocal String
fou String
out
copyFileOrUrl _ fou :: String
fou out :: String
out cache :: Cachable
cache | String -> Bool
isHttpUrl String
fou = String -> String -> Cachable -> IO ()
copyRemote String
fou String
out Cachable
cache
copyFileOrUrl rd :: String
rd fou :: String
fou out :: String
out _ | String -> Bool
isSshUrl String
fou = String -> SshFilePath -> String -> IO ()
copySSH String
rd (String -> SshFilePath
splitSshUrl String
fou) String
out
copyFileOrUrl _ fou :: String
fou _ _ = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "unknown transport protocol: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fou
copyLocal :: String -> FilePath -> IO ()
copyLocal :: String -> String -> IO ()
copyLocal fou :: String
fou out :: String
out = String -> String -> IO ()
createLink String
fou String
out IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` String -> String -> IO ()
cloneFile String
fou String
out
cloneTree :: FilePath -> FilePath -> IO ()
cloneTree :: String -> String -> IO ()
cloneTree = [String] -> String -> String -> IO ()
cloneTreeExcept []
cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()
cloneTreeExcept :: [String] -> String -> String -> IO ()
cloneTreeExcept except :: [String]
except source :: String
source dest :: String
dest =
do FileStatus
fs <- String -> IO FileStatus
getSymbolicLinkStatus String
source
if FileStatus -> Bool
isDirectory FileStatus
fs then do
[String]
fps <- String -> IO [String]
getDirectoryContents String
source
let fps' :: [String]
fps' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ("."String -> [String] -> [String]
forall a. a -> [a] -> [a]
:".."String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
except)) [String]
fps
mk_source :: String -> String
mk_source fp :: String
fp = String
source String -> String -> String
</> String
fp
mk_dest :: String -> String
mk_dest fp :: String
fp = String
dest String -> String -> String
</> String
fp
(String -> String -> IO ()) -> [String] -> [String] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ String -> String -> IO ()
cloneSubTree ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mk_source [String]
fps') ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mk_dest [String]
fps')
else String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("cloneTreeExcept: Bad source " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
source)
IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("cloneTreeExcept: Bad source " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
source)
cloneSubTree :: FilePath -> FilePath -> IO ()
cloneSubTree :: String -> String -> IO ()
cloneSubTree source :: String
source dest :: String
dest =
do FileStatus
fs <- String -> IO FileStatus
getSymbolicLinkStatus String
source
if FileStatus -> Bool
isDirectory FileStatus
fs then do
String -> IO ()
createDirectory String
dest
[String]
fps <- String -> IO [String]
getDirectoryContents String
source
let fps' :: [String]
fps' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [".", ".."]) [String]
fps
mk_source :: String -> String
mk_source fp :: String
fp = String
source String -> String -> String
</> String
fp
mk_dest :: String -> String
mk_dest fp :: String
fp = String
dest String -> String -> String
</> String
fp
(String -> String -> IO ()) -> [String] -> [String] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ String -> String -> IO ()
cloneSubTree ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mk_source [String]
fps') ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mk_dest [String]
fps')
else if FileStatus -> Bool
isRegularFile FileStatus
fs then
String -> String -> IO ()
cloneFile String
source String
dest
else String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("cloneSubTree: Bad source "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
source)
IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\e :: IOException
e -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOException -> Bool
isDoesNotExistError IOException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e)
cloneFile :: FilePath -> FilePath -> IO ()
cloneFile :: String -> String -> IO ()
cloneFile = String -> String -> IO ()
copyFile
backupByRenaming :: FilePath -> IO ()
backupByRenaming :: String -> IO ()
backupByRenaming = (String -> String -> IO ()) -> String -> IO ()
backupBy String -> String -> IO ()
rename
where rename :: String -> String -> IO ()
rename x :: String
x y :: String
y = do
Bool
isD <- String -> IO Bool
doesDirectoryExist String
x
if Bool
isD then String -> String -> IO ()
renameDirectory String
x String
y else String -> String -> IO ()
renameFile String
x String
y
backupByCopying :: FilePath -> IO ()
backupByCopying :: String -> IO ()
backupByCopying = (String -> String -> IO ()) -> String -> IO ()
backupBy String -> String -> IO ()
copy
where
copy :: String -> String -> IO ()
copy x :: String
x y :: String
y = do
Bool
isD <- String -> IO Bool
doesDirectoryExist String
x
if Bool
isD then do String -> IO ()
createDirectory String
y
String -> String -> IO ()
cloneTree (String -> String
normalise String
x) (String -> String
normalise String
y)
else String -> String -> IO ()
copyFile String
x String
y
backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()
backupBy :: (String -> String -> IO ()) -> String -> IO ()
backupBy backup :: String -> String -> IO ()
backup f :: String
f =
do Bool
hasBF <- String -> IO Bool
doesFileExist String
f
Bool
hasBD <- String -> IO Bool
doesDirectoryExist String
f
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasBF Bool -> Bool -> Bool
|| Bool
hasBD) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
helper 0
where
helper :: Int -> IO ()
helper :: Int -> IO ()
helper i :: Int
i = do Bool
existsF <- String -> IO Bool
doesFileExist String
next
Bool
existsD <- String -> IO Bool
doesDirectoryExist String
next
if Bool
existsF Bool -> Bool -> Bool
|| Bool
existsD
then Int -> IO ()
helper (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
else do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Backing up " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
String -> String -> IO ()
backup String
f String
next
where next :: String
next = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix
suffix :: String
suffix = ".~" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "~"
copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a
copyAndReadFile :: (String -> IO a) -> String -> Cachable -> IO a
copyAndReadFile readfn :: String -> IO a
readfn fou :: String
fou _ | String -> Bool
isValidLocalPath String
fou = String -> IO a
readfn String
fou
copyAndReadFile readfn :: String -> IO a
readfn fou :: String
fou cache :: Cachable
cache = (String -> IO a) -> IO a
forall a. (String -> IO a) -> IO a
withTemp ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \t :: String
t -> do
String -> String -> String -> Cachable -> IO ()
copyFileOrUrl String
defaultRemoteDarcsCmd String
fou String
t Cachable
cache
String -> IO a
readfn String
t
fetchFilePS :: String -> Cachable -> IO B.ByteString
fetchFilePS :: String -> Cachable -> IO ByteString
fetchFilePS = (String -> IO ByteString) -> String -> Cachable -> IO ByteString
forall a. (String -> IO a) -> String -> Cachable -> IO a
copyAndReadFile (String -> IO ByteString
B.readFile)
fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString
fetchFileLazyPS :: String -> Cachable -> IO ByteString
fetchFileLazyPS x :: String
x c :: Cachable
c = case String -> Maybe URI
parseURI String
x of
Just x' :: URI
x' | URI -> String
uriScheme URI
x' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "http:" -> do
Response ByteString
rsp <- ((URI, Response ByteString) -> Response ByteString)
-> IO (URI, Response ByteString) -> IO (Response ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (URI, Response ByteString) -> Response ByteString
forall a b. (a, b) -> b
snd (IO (URI, Response ByteString) -> IO (Response ByteString))
-> (BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
-> IO (URI, Response ByteString))
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
-> IO (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrowserAction (HandleStream ByteString) (URI, Response ByteString)
-> IO (URI, Response ByteString)
forall conn a. BrowserAction conn a -> IO a
browse (BrowserAction (HandleStream ByteString) (URI, Response ByteString)
-> IO (Response ByteString))
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
-> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ do
(String -> IO ()) -> BrowserAction (HandleStream ByteString) ()
forall t. (String -> IO ()) -> BrowserAction t ()
setErrHandler ((String -> IO ()) -> BrowserAction (HandleStream ByteString) ())
-> (IO () -> String -> IO ())
-> IO ()
-> BrowserAction (HandleStream ByteString) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> String -> IO ()
forall a b. a -> b -> a
const (IO () -> BrowserAction (HandleStream ByteString) ())
-> IO () -> BrowserAction (HandleStream ByteString) ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(String -> IO ()) -> BrowserAction (HandleStream ByteString) ()
forall t. (String -> IO ()) -> BrowserAction t ()
setOutHandler ((String -> IO ()) -> BrowserAction (HandleStream ByteString) ())
-> (IO () -> String -> IO ())
-> IO ()
-> BrowserAction (HandleStream ByteString) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> String -> IO ()
forall a b. a -> b -> a
const (IO () -> BrowserAction (HandleStream ByteString) ())
-> IO () -> BrowserAction (HandleStream ByteString) ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool -> BrowserAction (HandleStream ByteString) ()
forall t. Bool -> BrowserAction t ()
setAllowRedirects Bool
True
Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request (Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString))
-> Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
forall a b. (a -> b) -> a -> b
$ RequestMethod -> URI -> Request ByteString
forall ty. BufferType ty => RequestMethod -> URI -> Request ty
mkRequest RequestMethod
GET URI
x'
if Response ByteString -> ResponseCode
forall a. Response a -> ResponseCode
rspCode Response ByteString
rsp ResponseCode -> ResponseCode -> Bool
forall a. Eq a => a -> a -> Bool
/= (2, 0, 0)
then String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ "fetchFileLazyPS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Response ByteString -> String
forall a. Response a -> String
rspReason Response ByteString
rsp
else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall a. Response a -> a
rspBody Response ByteString
rsp
_ -> (String -> IO ByteString) -> String -> Cachable -> IO ByteString
forall a. (String -> IO a) -> String -> Cachable -> IO a
copyAndReadFile String -> IO ByteString
BL.readFile String
x Cachable
c
gzFetchFilePS :: String -> Cachable -> IO B.ByteString
gzFetchFilePS :: String -> Cachable -> IO ByteString
gzFetchFilePS = (String -> IO ByteString) -> String -> Cachable -> IO ByteString
forall a. (String -> IO a) -> String -> Cachable -> IO a
copyAndReadFile String -> IO ByteString
gzReadFilePS
copyRemote :: String -> FilePath -> Cachable -> IO ()
copyRemote :: String -> String -> Cachable -> IO ()
copyRemote u :: String
u v :: String
v cache :: Cachable
cache = String -> String -> Cachable -> IO ()
copyUrlFirst String
u String
v Cachable
cache IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
waitUrl String
u
speculateFileOrUrl :: String -> FilePath -> IO ()
speculateFileOrUrl :: String -> String -> IO ()
speculateFileOrUrl fou :: String
fou out :: String
out | String -> Bool
isHttpUrl String
fou = String -> String -> IO ()
speculateRemote String
fou String
out
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
speculateRemote :: String -> FilePath -> IO ()
speculateRemote :: String -> String -> IO ()
speculateRemote u :: String
u v :: String
v = String -> String -> Cachable -> IO ()
copyUrl String
u String
v Cachable
Cachable