moved files around

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. -}

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

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

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

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 ()