more Wall cleaning
This commit is contained in:
parent
b2c28c1ac0
commit
cf4c926f2e
8 changed files with 23 additions and 32 deletions
|
@ -15,25 +15,18 @@
|
||||||
module Backend.File (backend) where
|
module Backend.File (backend) where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import System.IO
|
|
||||||
import System.Cmd
|
|
||||||
import System.Cmd.Utils
|
|
||||||
import Control.Exception
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import List
|
|
||||||
import Maybe
|
|
||||||
|
|
||||||
import TypeInternals
|
import TypeInternals
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import Locations
|
import Locations
|
||||||
import qualified Remotes
|
import qualified Remotes
|
||||||
import qualified GitRepo as Git
|
import qualified GitRepo as Git
|
||||||
import Utility
|
|
||||||
import Core
|
import Core
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import UUID
|
import UUID
|
||||||
import qualified Backend
|
|
||||||
|
|
||||||
|
backend :: Backend
|
||||||
backend = Backend {
|
backend = Backend {
|
||||||
name = mustProvide,
|
name = mustProvide,
|
||||||
getKey = mustProvide,
|
getKey = mustProvide,
|
||||||
|
@ -43,11 +36,12 @@ backend = Backend {
|
||||||
hasKey = checkKeyFile
|
hasKey = checkKeyFile
|
||||||
}
|
}
|
||||||
|
|
||||||
|
mustProvide :: a
|
||||||
mustProvide = error "must provide this field"
|
mustProvide = error "must provide this field"
|
||||||
|
|
||||||
{- Storing a key is a no-op. -}
|
{- Storing a key is a no-op. -}
|
||||||
dummyStore :: FilePath -> Key -> Annex (Bool)
|
dummyStore :: FilePath -> Key -> Annex (Bool)
|
||||||
dummyStore file key = return True
|
dummyStore _ _ = return True
|
||||||
|
|
||||||
{- Just check if the .git/annex/ file for the key exists. -}
|
{- Just check if the .git/annex/ file for the key exists. -}
|
||||||
checkKeyFile :: Key -> Annex Bool
|
checkKeyFile :: Key -> Annex Bool
|
||||||
|
@ -147,6 +141,7 @@ showLocations key = do
|
||||||
then showLongNote $ "No other repository is known to contain the file."
|
then showLongNote $ "No other repository is known to contain the file."
|
||||||
else showLongNote $ "Try making some of these repositories available:\n" ++ ppuuids
|
else showLongNote $ "Try making some of these repositories available:\n" ++ ppuuids
|
||||||
|
|
||||||
|
showTriedRemotes :: [Git.Repo] -> Annex ()
|
||||||
showTriedRemotes [] = return ()
|
showTriedRemotes [] = return ()
|
||||||
showTriedRemotes remotes =
|
showTriedRemotes remotes =
|
||||||
showLongNote $ "I was unable to access these remotes: " ++
|
showLongNote $ "I was unable to access these remotes: " ++
|
||||||
|
|
|
@ -15,6 +15,7 @@ import System.IO
|
||||||
import qualified Backend.File
|
import qualified Backend.File
|
||||||
import TypeInternals
|
import TypeInternals
|
||||||
|
|
||||||
|
backend :: Backend
|
||||||
backend = Backend.File.backend {
|
backend = Backend.File.backend {
|
||||||
name = "SHA1",
|
name = "SHA1",
|
||||||
getKey = keyValue
|
getKey = keyValue
|
||||||
|
|
|
@ -9,14 +9,12 @@ module Backend.URL (backend) where
|
||||||
|
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
import Data.String.Utils
|
import Data.String.Utils
|
||||||
import System.Cmd
|
|
||||||
import System.Cmd.Utils
|
|
||||||
import System.Exit
|
|
||||||
|
|
||||||
import TypeInternals
|
import TypeInternals
|
||||||
import Core
|
import Core
|
||||||
import Utility
|
import Utility
|
||||||
|
|
||||||
|
backend :: Backend
|
||||||
backend = Backend {
|
backend = Backend {
|
||||||
name = "URL",
|
name = "URL",
|
||||||
getKey = keyValue,
|
getKey = keyValue,
|
||||||
|
@ -28,15 +26,15 @@ backend = Backend {
|
||||||
|
|
||||||
-- cannot generate url from filename
|
-- cannot generate url from filename
|
||||||
keyValue :: FilePath -> Annex (Maybe Key)
|
keyValue :: FilePath -> Annex (Maybe Key)
|
||||||
keyValue file = return Nothing
|
keyValue _ = return Nothing
|
||||||
|
|
||||||
-- cannot change url contents
|
-- cannot change url contents
|
||||||
dummyStore :: FilePath -> Key -> Annex Bool
|
dummyStore :: FilePath -> Key -> Annex Bool
|
||||||
dummyStore file url = return False
|
dummyStore _ _ = return False
|
||||||
|
|
||||||
-- allow keys to be removed; presumably they can always be downloaded again
|
-- allow keys to be removed; presumably they can always be downloaded again
|
||||||
dummyOk :: Key -> Annex Bool
|
dummyOk :: Key -> Annex Bool
|
||||||
dummyOk url = return True
|
dummyOk _ = return True
|
||||||
|
|
||||||
downloadUrl :: Key -> FilePath -> Annex Bool
|
downloadUrl :: Key -> FilePath -> Annex Bool
|
||||||
downloadUrl key file = do
|
downloadUrl key file = do
|
||||||
|
|
|
@ -10,12 +10,11 @@ module Backend.WORM (backend) where
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import qualified Data.ByteString.Lazy.Char8 as B
|
|
||||||
|
|
||||||
import qualified Backend.File
|
import qualified Backend.File
|
||||||
import TypeInternals
|
import TypeInternals
|
||||||
import Utility
|
|
||||||
|
|
||||||
|
backend :: Backend
|
||||||
backend = Backend.File.backend {
|
backend = Backend.File.backend {
|
||||||
name = "WORM",
|
name = "WORM",
|
||||||
getKey = keyValue
|
getKey = keyValue
|
||||||
|
|
2
Core.hs
2
Core.hs
|
@ -109,7 +109,7 @@ calcGitLink file key = do
|
||||||
Just f -> f
|
Just f -> f
|
||||||
Nothing -> error $ "unable to normalize " ++ file
|
Nothing -> error $ "unable to normalize " ++ file
|
||||||
return $ (relPathDirToDir (parentDir absfile) (Git.workTree g)) ++
|
return $ (relPathDirToDir (parentDir absfile) (Git.workTree g)) ++
|
||||||
annexLocationRelative g key
|
annexLocationRelative key
|
||||||
|
|
||||||
{- Updates the LocationLog when a key's presence changes. -}
|
{- Updates the LocationLog when a key's presence changes. -}
|
||||||
logStatus :: Key -> LogStatus -> Annex ()
|
logStatus :: Key -> LogStatus -> Annex ()
|
||||||
|
|
|
@ -18,11 +18,11 @@ module Locations (
|
||||||
import Data.String.Utils
|
import Data.String.Utils
|
||||||
|
|
||||||
import Types
|
import Types
|
||||||
import qualified TypeInternals as Internals
|
|
||||||
import qualified GitRepo as Git
|
import qualified GitRepo as Git
|
||||||
|
|
||||||
{- Long-term, cross-repo state is stored in files inside the .git-annex
|
{- Long-term, cross-repo state is stored in files inside the .git-annex
|
||||||
- directory, in the git repository's working tree. -}
|
- directory, in the git repository's working tree. -}
|
||||||
|
stateLoc :: String
|
||||||
stateLoc = ".git-annex/"
|
stateLoc = ".git-annex/"
|
||||||
gitStateDir :: Git.Repo -> FilePath
|
gitStateDir :: Git.Repo -> FilePath
|
||||||
gitStateDir repo = (Git.workTree repo) ++ "/" ++ stateLoc
|
gitStateDir repo = (Git.workTree repo) ++ "/" ++ stateLoc
|
||||||
|
@ -35,13 +35,13 @@ gitStateDir repo = (Git.workTree repo) ++ "/" ++ stateLoc
|
||||||
-}
|
-}
|
||||||
annexLocation :: Git.Repo -> Key -> FilePath
|
annexLocation :: Git.Repo -> Key -> FilePath
|
||||||
annexLocation r key =
|
annexLocation r key =
|
||||||
(Git.workTree r) ++ "/" ++ (annexLocationRelative r key)
|
(Git.workTree r) ++ "/" ++ (annexLocationRelative key)
|
||||||
|
|
||||||
{- Annexed file's location relative to git's working tree.
|
{- Annexed file's location relative to git's working tree.
|
||||||
-
|
-
|
||||||
- Note: Assumes repo is NOT bare.-}
|
- Note: Assumes repo is NOT bare.-}
|
||||||
annexLocationRelative :: Git.Repo -> Key -> FilePath
|
annexLocationRelative :: Key -> FilePath
|
||||||
annexLocationRelative r key = ".git/annex/" ++ (keyFile key)
|
annexLocationRelative key = ".git/annex/" ++ (keyFile key)
|
||||||
|
|
||||||
{- .git-annex/tmp is used for temp files
|
{- .git-annex/tmp is used for temp files
|
||||||
-
|
-
|
||||||
|
|
|
@ -58,9 +58,9 @@ instance Read Key where
|
||||||
k = join ":" $ drop 1 l
|
k = join ":" $ drop 1 l
|
||||||
|
|
||||||
backendName :: Key -> BackendName
|
backendName :: Key -> BackendName
|
||||||
backendName (Key (b,k)) = b
|
backendName (Key (b,_)) = b
|
||||||
keyName :: Key -> KeyName
|
keyName :: Key -> KeyName
|
||||||
keyName (Key (b,k)) = k
|
keyName (Key (_,k)) = k
|
||||||
|
|
||||||
-- this structure represents a key-value backend
|
-- this structure represents a key-value backend
|
||||||
data Backend = Backend {
|
data Backend = Backend {
|
||||||
|
|
12
Utility.hs
12
Utility.hs
|
@ -15,20 +15,17 @@ module Utility (
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import System.IO
|
import System.IO
|
||||||
import System.Cmd.Utils
|
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.Posix.Process
|
import System.Posix.Process
|
||||||
import System.Posix.Process.Internals
|
|
||||||
import System.Posix.Signals
|
import System.Posix.Signals
|
||||||
import System.Posix.IO
|
|
||||||
import Data.String.Utils
|
import Data.String.Utils
|
||||||
import System.Path
|
import System.Path
|
||||||
import System.IO.HVFS
|
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
|
||||||
{- A version of hgetContents that is not lazy. Ensures file is
|
{- A version of hgetContents that is not lazy. Ensures file is
|
||||||
- all read before it gets closed. -}
|
- all read before it gets closed. -}
|
||||||
|
hGetContentsStrict :: Handle -> IO String
|
||||||
hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s
|
hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s
|
||||||
|
|
||||||
{- Returns the parent directory of a path. Parent of / is "" -}
|
{- Returns the parent directory of a path. Parent of / is "" -}
|
||||||
|
@ -53,11 +50,11 @@ parentDir dir =
|
||||||
relPathCwdToDir :: FilePath -> IO FilePath
|
relPathCwdToDir :: FilePath -> IO FilePath
|
||||||
relPathCwdToDir dir = do
|
relPathCwdToDir dir = do
|
||||||
cwd <- getCurrentDirectory
|
cwd <- getCurrentDirectory
|
||||||
let absdir = abs cwd dir
|
let absdir = absnorm cwd
|
||||||
return $ relPathDirToDir cwd absdir
|
return $ relPathDirToDir cwd absdir
|
||||||
where
|
where
|
||||||
-- absolute, normalized form of the directory
|
-- absolute, normalized form of the directory
|
||||||
abs cwd dir =
|
absnorm cwd =
|
||||||
case (absNormPath cwd dir) of
|
case (absNormPath cwd dir) of
|
||||||
Just d -> d
|
Just d -> d
|
||||||
Nothing -> error $ "unable to normalize " ++ dir
|
Nothing -> error $ "unable to normalize " ++ dir
|
||||||
|
@ -106,13 +103,14 @@ boolSystem command params = do
|
||||||
_ -> return False
|
_ -> return False
|
||||||
where
|
where
|
||||||
restoresignals oldint oldset = do
|
restoresignals oldint oldset = do
|
||||||
installHandler sigINT oldint Nothing
|
_ <- installHandler sigINT oldint Nothing
|
||||||
setSignalMask oldset
|
setSignalMask oldset
|
||||||
childaction oldint oldset = do
|
childaction oldint oldset = do
|
||||||
restoresignals oldint oldset
|
restoresignals oldint oldset
|
||||||
executeFile command True params Nothing
|
executeFile command True params Nothing
|
||||||
|
|
||||||
{- Escapes a filename to be safely able to be exposed to the shell. -}
|
{- Escapes a filename to be safely able to be exposed to the shell. -}
|
||||||
|
shellEscape :: FilePath -> FilePath
|
||||||
shellEscape f = "'" ++ quote ++ "'"
|
shellEscape f = "'" ++ quote ++ "'"
|
||||||
where
|
where
|
||||||
-- replace ' with '"'"'
|
-- replace ' with '"'"'
|
||||||
|
|
Loading…
Reference in a new issue