diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/CopyFile.hs | 2 | ||||
| -rw-r--r-- | Utility/Ssh.hs | 61 | ||||
| -rw-r--r-- | Utility/StatFS.hsc | 125 | ||||
| -rw-r--r-- | Utility/Touch.hsc | 119 | ||||
| -rw-r--r-- | Utility/Url.hs | 70 |
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 () |