summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
Diffstat (limited to 'Utility')
-rw-r--r--Utility/CopyFile.hs2
-rw-r--r--Utility/Ssh.hs61
-rw-r--r--Utility/StatFS.hsc125
-rw-r--r--Utility/Touch.hsc119
-rw-r--r--Utility/Url.hs70
5 files changed, 376 insertions, 1 deletions
diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs
index 2e06dd92b..befb00f8f 100644
--- a/Utility/CopyFile.hs
+++ b/Utility/CopyFile.hs
@@ -10,7 +10,7 @@ module Utility.CopyFile (copyFile) where
import System.Directory (doesFileExist, removeFile)
import Utility
-import qualified SysConfig
+import qualified Build.SysConfig as SysConfig
{- The cp command is used, because I hate reinventing the wheel,
- and because this allows easy access to features like cp --reflink. -}
diff --git a/Utility/Ssh.hs b/Utility/Ssh.hs
new file mode 100644
index 000000000..6cbc362a0
--- /dev/null
+++ b/Utility/Ssh.hs
@@ -0,0 +1,61 @@
+{- git-annex remote access with ssh
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Ssh where
+
+import Control.Monad.State (liftIO)
+
+import qualified Git
+import Utility
+import Types
+import Config
+
+{- Generates parameters to ssh to a repository's host and run a command.
+ - Caller is responsible for doing any neccessary shellEscaping of the
+ - passed command. -}
+sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
+sshToRepo repo sshcmd = do
+ s <- getConfig repo "ssh-options" ""
+ let sshoptions = map Param (words s)
+ let sshport = case Git.urlPort repo of
+ Nothing -> []
+ Just p -> [Param "-p", Param (show p)]
+ let sshhost = Param $ Git.urlHostUser repo
+ return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd
+
+{- Generates parameters to run a git-annex-shell command on a remote
+ - repository. -}
+git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam]))
+git_annex_shell r command params
+ | not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
+ | Git.repoIsSsh r = do
+ sshparams <- sshToRepo r [Param sshcmd]
+ return $ Just ("ssh", sshparams)
+ | otherwise = return Nothing
+ where
+ dir = Git.workTree r
+ shellcmd = "git-annex-shell"
+ shellopts = Param command : File dir : params
+ sshcmd = shellcmd ++ " " ++
+ unwords (map shellEscape $ toCommand shellopts)
+
+{- Uses a supplied function (such as boolSystem) to run a git-annex-shell
+ - command on a remote.
+ -
+ - Or, if the remote does not support running remote commands, returns
+ - a specified error value. -}
+onRemote
+ :: Git.Repo
+ -> (FilePath -> [CommandParam] -> IO a, a)
+ -> String
+ -> [CommandParam]
+ -> Annex a
+onRemote r (with, errorval) command params = do
+ s <- git_annex_shell r command params
+ case s of
+ Just (c, ps) -> liftIO $ with c ps
+ Nothing -> return errorval
diff --git a/Utility/StatFS.hsc b/Utility/StatFS.hsc
new file mode 100644
index 000000000..d3e4a507e
--- /dev/null
+++ b/Utility/StatFS.hsc
@@ -0,0 +1,125 @@
+-----------------------------------------------------------------------------
+-- |
+--
+-- (This code originally comes from xmobar)
+--
+-- Module : StatFS
+-- Copyright : (c) Jose A Ortega Ruiz
+-- License : BSD-3-clause
+--
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions
+-- are met:
+--
+-- 1. Redistributions of source code must retain the above copyright
+-- notice, this list of conditions and the following disclaimer.
+-- 2. Redistributions in binary form must reproduce the above copyright
+-- notice, this list of conditions and the following disclaimer in the
+-- documentation and/or other materials provided with the distribution.
+-- 3. Neither the name of the author nor the names of his contributors
+-- may be used to endorse or promote products derived from this software
+-- without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+-- ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+-- SUCH DAMAGE.
+--
+-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A binding to C's statvfs(2)
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}
+
+
+module Utility.StatFS ( FileSystemStats(..), getFileSystemStats ) where
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Data.ByteString (useAsCString)
+import Data.ByteString.Char8 (pack)
+
+#if defined (__FreeBSD__) || defined (__FreeBSD_kernel__) || defined (__APPLE__)
+# include <sys/param.h>
+# include <sys/mount.h>
+#else
+#if defined (__linux__)
+#include <sys/vfs.h>
+#else
+#define UNKNOWN
+#endif
+#endif
+
+data FileSystemStats = FileSystemStats {
+ fsStatBlockSize :: Integer
+ -- ^ Optimal transfer block size.
+ , fsStatBlockCount :: Integer
+ -- ^ Total data blocks in file system.
+ , fsStatByteCount :: Integer
+ -- ^ Total bytes in file system.
+ , fsStatBytesFree :: Integer
+ -- ^ Free bytes in file system.
+ , fsStatBytesAvailable :: Integer
+ -- ^ Free bytes available to non-superusers.
+ , fsStatBytesUsed :: Integer
+ -- ^ Bytes used.
+ } deriving (Show, Eq)
+
+data CStatfs
+
+#ifdef UNKNOWN
+#warning free space checking code not available for this OS
+#else
+#if defined(__APPLE__)
+foreign import ccall unsafe "sys/mount.h statfs64"
+#else
+#if defined(__FreeBSD__) || defined (__FreeBSD_kernel__)
+foreign import ccall unsafe "sys/mount.h statfs"
+#else
+foreign import ccall unsafe "sys/vfs.h statfs64"
+#endif
+#endif
+ c_statfs :: CString -> Ptr CStatfs -> IO CInt
+#endif
+
+toI :: CULong -> Integer
+toI = toInteger
+
+getFileSystemStats :: String -> IO (Maybe FileSystemStats)
+getFileSystemStats path =
+#ifdef UNKNOWN
+ return Nothing
+#else
+ allocaBytes (#size struct statfs) $ \vfs ->
+ useAsCString (pack path) $ \cpath -> do
+ res <- c_statfs cpath vfs
+ if res == -1 then return Nothing
+ else do
+ bsize <- (#peek struct statfs, f_bsize) vfs
+ bcount <- (#peek struct statfs, f_blocks) vfs
+ bfree <- (#peek struct statfs, f_bfree) vfs
+ bavail <- (#peek struct statfs, f_bavail) vfs
+ let bpb = toI bsize
+ return $ Just FileSystemStats
+ { fsStatBlockSize = bpb
+ , fsStatBlockCount = toI bcount
+ , fsStatByteCount = toI bcount * bpb
+ , fsStatBytesFree = toI bfree * bpb
+ , fsStatBytesAvailable = toI bavail * bpb
+ , fsStatBytesUsed = toI (bcount - bfree) * bpb
+ }
+#endif
diff --git a/Utility/Touch.hsc b/Utility/Touch.hsc
new file mode 100644
index 000000000..f27ac3136
--- /dev/null
+++ b/Utility/Touch.hsc
@@ -0,0 +1,119 @@
+{- More control over touching a file.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Utility.Touch (
+ TimeSpec(..),
+ touchBoth,
+ touch
+) where
+
+import Foreign
+import Foreign.C
+import Control.Monad (when)
+
+newtype TimeSpec = TimeSpec CTime
+
+{- Changes the access and modification times of an existing file.
+ Can follow symlinks, or not. Throws IO error on failure. -}
+touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()
+
+touch :: FilePath -> TimeSpec -> Bool -> IO ()
+touch file mtime follow = touchBoth file mtime mtime follow
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <sys/time.h>
+
+#ifndef _BSD_SOURCE
+#define _BSD_SOURCE
+#endif
+
+#if (defined UTIME_OMIT && defined UTIME_NOW && defined AT_FDCWD && defined AT_SYMLINK_NOFOLLOW)
+
+at_fdcwd :: CInt
+at_fdcwd = #const AT_FDCWD
+
+at_symlink_nofollow :: CInt
+at_symlink_nofollow = #const AT_SYMLINK_NOFOLLOW
+
+instance Storable TimeSpec where
+ -- use the larger alignment of the two types in the struct
+ alignment _ = max sec_alignment nsec_alignment
+ where
+ sec_alignment = alignment (undefined::CTime)
+ nsec_alignment = alignment (undefined::CLong)
+ sizeOf _ = #{size struct timespec}
+ peek ptr = do
+ sec <- #{peek struct timespec, tv_sec} ptr
+ return $ TimeSpec sec
+ poke ptr (TimeSpec sec) = do
+ #{poke struct timespec, tv_sec} ptr sec
+ #{poke struct timespec, tv_nsec} ptr (0 :: CLong)
+
+{- While its interface is beastly, utimensat is in recent
+ POSIX standards, unlike lutimes. -}
+foreign import ccall "utimensat"
+ c_utimensat :: CInt -> CString -> Ptr TimeSpec -> CInt -> IO CInt
+
+touchBoth file atime mtime follow =
+ allocaArray 2 $ \ptr ->
+ withCString file $ \f -> do
+ pokeArray ptr [atime, mtime]
+ r <- c_utimensat at_fdcwd f ptr flags
+ when (r /= 0) $ throwErrno "touchBoth"
+ where
+ flags = if follow
+ then 0
+ else at_symlink_nofollow
+
+#else
+#if 0
+{- Using lutimes is needed for BSD.
+ -
+ - TODO: test if lutimes is available. May have to do it in configure.
+ - TODO: TimeSpec uses a CTime, while tv_sec is a CLong. It is implementation
+ - dependent whether these are the same; need to find a cast that works.
+ - (Without the cast it works on linux i386, but
+ - maybe not elsewhere.)
+ -}
+
+instance Storable TimeSpec where
+ alignment _ = alignment (undefined::CLong)
+ sizeOf _ = #{size struct timeval}
+ peek ptr = do
+ sec <- #{peek struct timeval, tv_sec} ptr
+ return $ TimeSpec sec
+ poke ptr (TimeSpec sec) = do
+ #{poke struct timeval, tv_sec} ptr sec
+ #{poke struct timeval, tv_usec} ptr (0 :: CLong)
+
+foreign import ccall "utimes"
+ c_utimes :: CString -> Ptr TimeSpec -> IO CInt
+foreign import ccall "lutimes"
+ c_lutimes :: CString -> Ptr TimeSpec -> IO CInt
+
+touchBoth file atime mtime follow =
+ allocaArray 2 $ \ptr ->
+ withCString file $ \f -> do
+ pokeArray ptr [atime, mtime]
+ r <- syscall f ptr
+ if (r /= 0)
+ then throwErrno "touchBoth"
+ else return ()
+ where
+ syscall = if follow
+ then c_lutimes
+ else c_utimes
+
+#else
+#warning "utimensat and lutimes not available; building without symlink timestamp preservation support"
+touchBoth _ _ _ _ = return ()
+#endif
+#endif
diff --git a/Utility/Url.hs b/Utility/Url.hs
new file mode 100644
index 000000000..5954e0ff7
--- /dev/null
+++ b/Utility/Url.hs
@@ -0,0 +1,70 @@
+{- Url downloading.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Url (
+ exists,
+ download,
+ get
+) where
+
+import Control.Monad (liftM)
+import Control.Monad.State (liftIO)
+import qualified Network.Browser as Browser
+import Network.HTTP
+import Network.URI
+
+import Types
+import Messages
+import Utility
+
+type URLString = String
+
+{- Checks that an url exists and could be successfully downloaded. -}
+exists :: URLString -> IO Bool
+exists url =
+ case parseURI url of
+ Nothing -> return False
+ Just u -> do
+ r <- request u HEAD
+ case rspCode r of
+ (2,_,_) -> return True
+ _ -> return False
+
+{- Used to download large files, such as the contents of keys.
+ - Uses curl program for its progress bar. -}
+download :: URLString -> FilePath -> Annex Bool
+download url file = do
+ showOutput -- make way for curl progress bar
+ -- Uses the -# progress display, because the normal one is very
+ -- confusing when resuming, showing the remainder to download
+ -- as the whole file, and not indicating how much percent was
+ -- downloaded before the resume.
+ liftIO $ boolSystem "curl" [Params "-L -C - -# -o", File file, File url]
+
+{- Downloads a small file. -}
+get :: URLString -> IO String
+get url =
+ case parseURI url of
+ Nothing -> error "url parse error"
+ Just u -> do
+ r <- request u GET
+ case rspCode r of
+ (2,_,_) -> return $ rspBody r
+ _ -> error $ rspReason r
+
+{- Makes a http request of an url. For example, HEAD can be used to
+ - check if the url exists, or GET used to get the url content (best for
+ - small urls). -}
+request :: URI -> RequestMethod -> IO (Response String)
+request url requesttype = Browser.browse $ do
+ Browser.setErrHandler ignore
+ Browser.setOutHandler ignore
+ Browser.setAllowRedirects True
+ liftM snd $ Browser.request
+ (mkRequest requesttype url :: Request_String)
+ where
+ ignore = const $ return ()