From cab4ac247ca990a03537f7611b299efca8edaffe Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 5 Jul 2011 20:36:43 -0400 Subject: rename --- Command/Fsck.hs | 2 +- Command/Map.hs | 4 +- Command/Status.hs | 2 +- Content.hs | 2 +- DataUnits.hs | 161 --------------------------------------------------- Dot.hs | 63 -------------------- Remote/Bup.hs | 2 +- Remote/Git.hs | 2 +- Remote/Ssh.hs | 61 +++++++++++++++++++ Ssh.hs | 61 ------------------- Utility/DataUnits.hs | 161 +++++++++++++++++++++++++++++++++++++++++++++++++++ Utility/Dot.hs | 63 ++++++++++++++++++++ 12 files changed, 292 insertions(+), 292 deletions(-) delete mode 100644 DataUnits.hs delete mode 100644 Dot.hs create mode 100644 Remote/Ssh.hs delete mode 100644 Ssh.hs create mode 100644 Utility/DataUnits.hs create mode 100644 Utility/Dot.hs diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 446d25a44..ec3f1d8e7 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -26,7 +26,7 @@ import Content import LocationLog import Locations import Trust -import DataUnits +import Utility.DataUnits import Config command :: [Command] diff --git a/Command/Map.hs b/Command/Map.hs index 940db54c8..0391ab8e8 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -21,8 +21,8 @@ import Types import Utility import UUID import Trust -import Ssh -import qualified Dot +import Remote.Ssh +import qualified Utility.Dot as Dot -- a link from the first repository to the second (its remote) data Link = Link Git.Repo Git.Repo diff --git a/Command/Status.hs b/Command/Status.hs index 2448f65a4..1ec478236 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -21,7 +21,7 @@ import qualified Command.Unused import qualified Git import Command import Types -import DataUnits +import Utility.DataUnits import Content import Types.Key import Locations diff --git a/Content.hs b/Content.hs index a2f38ddc9..94f8b8c2a 100644 --- a/Content.hs +++ b/Content.hs @@ -43,7 +43,7 @@ import qualified Branch import Utility import StatFS import Types.Key -import DataUnits +import Utility.DataUnits import Config {- Checks if a given key is currently present in the gitAnnexLocation. -} diff --git a/DataUnits.hs b/DataUnits.hs deleted file mode 100644 index c81c6e42e..000000000 --- a/DataUnits.hs +++ /dev/null @@ -1,161 +0,0 @@ -{- data size display and parsing - - - - Copyright 2011 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module DataUnits ( - dataUnits, - storageUnits, - memoryUnits, - bandwidthUnits, - oldSchoolUnits, - - roughSize, - compareSizes, - readSize -) where - -import Data.List -import Data.Char - -type ByteSize = Integer -type Name = String -type Abbrev = String -data Unit = Unit ByteSize Abbrev Name - deriving (Ord, Show, Eq) - -{- And now a rant: - - - - In the beginning, we had powers of two, and they were good. - - - - Disk drive manufacturers noticed that some powers of two were - - sorta close to some powers of ten, and that rounding down to the nearest - - power of ten allowed them to advertise their drives were bigger. This - - was sorta annoying. - - - - Then drives got big. Really, really big. This was good. - - - - Except that the small rounding error perpretrated by the drive - - manufacturers suffered the fate of a small error, and became a large - - error. This was bad. - - - - So, a committee was formed. And it arrived at a committee-like decision, - - which satisfied noone, confused everyone, and made the world an uglier - - place. As with all committees, this was meh. - - - - And the drive manufacturers happily continued selling drives that are - - increasingly smaller than you'd expect, if you don't count on your - - fingers. But that are increasingly too big for anyone to much notice. - - This caused me to need git-annex. - - - - Thus, I use units here that I loathe. Because if I didn't, people would - - be confused that their drives seem the wrong size, and other people would - - complain at me for not being standards compliant. And we call this - - progress? - -} - -dataUnits :: [Unit] -dataUnits = storageUnits ++ memoryUnits - -{- Storage units are (stupidly) powers of ten. -} -storageUnits :: [Unit] -storageUnits = - [ Unit (p 8) "YB" "yottabyte" - , Unit (p 7) "ZB" "zettabyte" - , Unit (p 6) "EB" "exabyte" - , Unit (p 5) "PB" "petabyte" - , Unit (p 4) "TB" "terabyte" - , Unit (p 3) "GB" "gigabyte" - , Unit (p 2) "MB" "megabyte" - , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe - , Unit (p 0) "B" "byte" - ] - where - p :: Integer -> Integer - p n = 1000^n - -{- Memory units are (stupidly named) powers of 2. -} -memoryUnits :: [Unit] -memoryUnits = - [ Unit (p 8) "YiB" "yobibyte" - , Unit (p 7) "ZiB" "zebibyte" - , Unit (p 6) "EiB" "exbibyte" - , Unit (p 5) "PiB" "pebibyte" - , Unit (p 4) "TiB" "tebibyte" - , Unit (p 3) "GiB" "gigabyte" - , Unit (p 2) "MiB" "mebibyte" - , Unit (p 1) "KiB" "kibibyte" - , Unit (p 0) "B" "byte" - ] - where - p :: Integer -> Integer - p n = 2^(n*10) - -{- Bandwidth units are only measured in bits if you're some crazy telco. -} -bandwidthUnits :: [Unit] -bandwidthUnits = error "stop trying to rip people off" - -{- Do you yearn for the days when men were men and megabytes were megabytes? -} -oldSchoolUnits :: [Unit] -oldSchoolUnits = map mingle $ zip storageUnits memoryUnits - where - mingle (Unit _ a n, Unit s' _ _) = Unit s' a n - -{- approximate display of a particular number of bytes -} -roughSize :: [Unit] -> Bool -> ByteSize -> String -roughSize units abbrev i - | i < 0 = "-" ++ findUnit units' (negate i) - | otherwise = findUnit units' i - where - units' = reverse $ sort units -- largest first - - findUnit (u@(Unit s _ _):us) i' - | i' >= s = showUnit i' u - | otherwise = findUnit us i' - findUnit [] i' = showUnit i' (last units') -- bytes - - showUnit i' (Unit s a n) = let num = chop i' s in - show num ++ " " ++ - (if abbrev then a else plural num n) - - chop :: Integer -> Integer -> Integer - chop i' d = round $ (fromInteger i' :: Double) / fromInteger d - - plural n u - | n == 1 = u - | otherwise = u ++ "s" - -{- displays comparison of two sizes -} -compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String -compareSizes units abbrev old new - | old > new = roughSize units abbrev (old - new) ++ " smaller" - | old < new = roughSize units abbrev (new - old) ++ " larger" - | otherwise = "same" - -{- Parses strings like "10 kilobytes" or "0.5tb". -} -readSize :: [Unit] -> String -> Maybe ByteSize -readSize units input - | null parsednum = Nothing - | null parsedunit = Nothing - | otherwise = Just $ round $ number * (fromIntegral multiplier) - where - (number, rest) = head parsednum - multiplier = head $ parsedunit - unitname = takeWhile isAlpha $ dropWhile isSpace rest - - parsednum = reads input :: [(Double, String)] - parsedunit = lookupUnit units unitname - - lookupUnit _ [] = [1] -- no unit given, assume bytes - lookupUnit [] _ = [] - lookupUnit (Unit s a n:us) v - | a ~~ v || n ~~ v = [s] - | plural n ~~ v || a ~~ byteabbrev v = [s] - | otherwise = lookupUnit us v - - a ~~ b = map toLower a == map toLower b - - plural n = n ++ "s" - byteabbrev a = a ++ "b" diff --git a/Dot.hs b/Dot.hs deleted file mode 100644 index deba10201..000000000 --- a/Dot.hs +++ /dev/null @@ -1,63 +0,0 @@ -{- a simple graphviz / dot(1) digraph description generator library - - - - Copyright 2010 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Dot where -- import qualified - -{- generates a graph description from a list of lines -} -graph :: [String] -> String -graph s = unlines $ [header] ++ map indent s ++ [footer] - where - header = "digraph map {" - footer= "}" - -{- a node in the graph -} -graphNode :: String -> String -> String -graphNode nodeid desc = label desc $ quote nodeid - -{- an edge between two nodes -} -graphEdge :: String -> String -> Maybe String -> String -graphEdge fromid toid desc = indent $ maybe edge (\d -> label d edge) desc - where - edge = quote fromid ++ " -> " ++ quote toid - -{- adds a label to a node or edge -} -label :: String -> String -> String -label l s = attr "label" l s - -{- adds an attribute to a node or edge - - (can be called multiple times for multiple attributes) -} -attr :: String -> String -> String -> String -attr a v s = s ++ " [ " ++ a ++ "=" ++ quote v ++ " ]" - -{- fills a node with a color -} -fillColor :: String -> String -> String -fillColor color s = attr "fillcolor" color $ attr "style" "filled" $ s - -{- apply to graphNode to put the node in a labeled box -} -subGraph :: String -> String -> String -> String -> String -subGraph subid l color s = - "subgraph " ++ name ++ " {\n" ++ - ii setlabel ++ - ii setfilled ++ - ii setcolor ++ - ii s ++ - indent "}" - where - -- the "cluster_" makes dot draw a box - name = quote ("cluster_" ++ subid) - setlabel = "label=" ++ quote l - setfilled = "style=" ++ quote "filled" - setcolor = "fillcolor=" ++ quote color - ii x = (indent $ indent x) ++ "\n" - -indent ::String -> String -indent s = "\t" ++ s - -quote :: String -> String -quote s = "\"" ++ s' ++ "\"" - where - s' = filter (/= '"') s diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 11c0ec4da..5a44397f0 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -28,7 +28,7 @@ import Locations import Config import Utility import Messages -import Ssh +import Remote.Ssh import Remote.Special import Remote.Encryptable import Crypto diff --git a/Remote/Git.hs b/Remote/Git.hs index 4a8f8ee92..fb8512382 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -24,7 +24,7 @@ import qualified Content import Messages import Utility.CopyFile import Utility.RsyncFile -import Ssh +import Remote.Ssh import Config remote :: RemoteType Annex diff --git a/Remote/Ssh.hs b/Remote/Ssh.hs new file mode 100644 index 000000000..0d4842a1a --- /dev/null +++ b/Remote/Ssh.hs @@ -0,0 +1,61 @@ +{- git-annex remote access with ssh + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Remote.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/Ssh.hs b/Ssh.hs deleted file mode 100644 index 21e72c083..000000000 --- a/Ssh.hs +++ /dev/null @@ -1,61 +0,0 @@ -{- git-annex repository access with ssh - - - - Copyright 2011 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module 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/DataUnits.hs b/Utility/DataUnits.hs new file mode 100644 index 000000000..7af2eadaf --- /dev/null +++ b/Utility/DataUnits.hs @@ -0,0 +1,161 @@ +{- data size display and parsing + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.DataUnits ( + dataUnits, + storageUnits, + memoryUnits, + bandwidthUnits, + oldSchoolUnits, + + roughSize, + compareSizes, + readSize +) where + +import Data.List +import Data.Char + +type ByteSize = Integer +type Name = String +type Abbrev = String +data Unit = Unit ByteSize Abbrev Name + deriving (Ord, Show, Eq) + +{- And now a rant: + - + - In the beginning, we had powers of two, and they were good. + - + - Disk drive manufacturers noticed that some powers of two were + - sorta close to some powers of ten, and that rounding down to the nearest + - power of ten allowed them to advertise their drives were bigger. This + - was sorta annoying. + - + - Then drives got big. Really, really big. This was good. + - + - Except that the small rounding error perpretrated by the drive + - manufacturers suffered the fate of a small error, and became a large + - error. This was bad. + - + - So, a committee was formed. And it arrived at a committee-like decision, + - which satisfied noone, confused everyone, and made the world an uglier + - place. As with all committees, this was meh. + - + - And the drive manufacturers happily continued selling drives that are + - increasingly smaller than you'd expect, if you don't count on your + - fingers. But that are increasingly too big for anyone to much notice. + - This caused me to need git-annex. + - + - Thus, I use units here that I loathe. Because if I didn't, people would + - be confused that their drives seem the wrong size, and other people would + - complain at me for not being standards compliant. And we call this + - progress? + -} + +dataUnits :: [Unit] +dataUnits = storageUnits ++ memoryUnits + +{- Storage units are (stupidly) powers of ten. -} +storageUnits :: [Unit] +storageUnits = + [ Unit (p 8) "YB" "yottabyte" + , Unit (p 7) "ZB" "zettabyte" + , Unit (p 6) "EB" "exabyte" + , Unit (p 5) "PB" "petabyte" + , Unit (p 4) "TB" "terabyte" + , Unit (p 3) "GB" "gigabyte" + , Unit (p 2) "MB" "megabyte" + , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 1000^n + +{- Memory units are (stupidly named) powers of 2. -} +memoryUnits :: [Unit] +memoryUnits = + [ Unit (p 8) "YiB" "yobibyte" + , Unit (p 7) "ZiB" "zebibyte" + , Unit (p 6) "EiB" "exbibyte" + , Unit (p 5) "PiB" "pebibyte" + , Unit (p 4) "TiB" "tebibyte" + , Unit (p 3) "GiB" "gigabyte" + , Unit (p 2) "MiB" "mebibyte" + , Unit (p 1) "KiB" "kibibyte" + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 2^(n*10) + +{- Bandwidth units are only measured in bits if you're some crazy telco. -} +bandwidthUnits :: [Unit] +bandwidthUnits = error "stop trying to rip people off" + +{- Do you yearn for the days when men were men and megabytes were megabytes? -} +oldSchoolUnits :: [Unit] +oldSchoolUnits = map mingle $ zip storageUnits memoryUnits + where + mingle (Unit _ a n, Unit s' _ _) = Unit s' a n + +{- approximate display of a particular number of bytes -} +roughSize :: [Unit] -> Bool -> ByteSize -> String +roughSize units abbrev i + | i < 0 = "-" ++ findUnit units' (negate i) + | otherwise = findUnit units' i + where + units' = reverse $ sort units -- largest first + + findUnit (u@(Unit s _ _):us) i' + | i' >= s = showUnit i' u + | otherwise = findUnit us i' + findUnit [] i' = showUnit i' (last units') -- bytes + + showUnit i' (Unit s a n) = let num = chop i' s in + show num ++ " " ++ + (if abbrev then a else plural num n) + + chop :: Integer -> Integer -> Integer + chop i' d = round $ (fromInteger i' :: Double) / fromInteger d + + plural n u + | n == 1 = u + | otherwise = u ++ "s" + +{- displays comparison of two sizes -} +compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String +compareSizes units abbrev old new + | old > new = roughSize units abbrev (old - new) ++ " smaller" + | old < new = roughSize units abbrev (new - old) ++ " larger" + | otherwise = "same" + +{- Parses strings like "10 kilobytes" or "0.5tb". -} +readSize :: [Unit] -> String -> Maybe ByteSize +readSize units input + | null parsednum = Nothing + | null parsedunit = Nothing + | otherwise = Just $ round $ number * (fromIntegral multiplier) + where + (number, rest) = head parsednum + multiplier = head $ parsedunit + unitname = takeWhile isAlpha $ dropWhile isSpace rest + + parsednum = reads input :: [(Double, String)] + parsedunit = lookupUnit units unitname + + lookupUnit _ [] = [1] -- no unit given, assume bytes + lookupUnit [] _ = [] + lookupUnit (Unit s a n:us) v + | a ~~ v || n ~~ v = [s] + | plural n ~~ v || a ~~ byteabbrev v = [s] + | otherwise = lookupUnit us v + + a ~~ b = map toLower a == map toLower b + + plural n = n ++ "s" + byteabbrev a = a ++ "b" diff --git a/Utility/Dot.hs b/Utility/Dot.hs new file mode 100644 index 000000000..869684996 --- /dev/null +++ b/Utility/Dot.hs @@ -0,0 +1,63 @@ +{- a simple graphviz / dot(1) digraph description generator library + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Dot where -- import qualified + +{- generates a graph description from a list of lines -} +graph :: [String] -> String +graph s = unlines $ [header] ++ map indent s ++ [footer] + where + header = "digraph map {" + footer= "}" + +{- a node in the graph -} +graphNode :: String -> String -> String +graphNode nodeid desc = label desc $ quote nodeid + +{- an edge between two nodes -} +graphEdge :: String -> String -> Maybe String -> String +graphEdge fromid toid desc = indent $ maybe edge (\d -> label d edge) desc + where + edge = quote fromid ++ " -> " ++ quote toid + +{- adds a label to a node or edge -} +label :: String -> String -> String +label l s = attr "label" l s + +{- adds an attribute to a node or edge + - (can be called multiple times for multiple attributes) -} +attr :: String -> String -> String -> String +attr a v s = s ++ " [ " ++ a ++ "=" ++ quote v ++ " ]" + +{- fills a node with a color -} +fillColor :: String -> String -> String +fillColor color s = attr "fillcolor" color $ attr "style" "filled" $ s + +{- apply to graphNode to put the node in a labeled box -} +subGraph :: String -> String -> String -> String -> String +subGraph subid l color s = + "subgraph " ++ name ++ " {\n" ++ + ii setlabel ++ + ii setfilled ++ + ii setcolor ++ + ii s ++ + indent "}" + where + -- the "cluster_" makes dot draw a box + name = quote ("cluster_" ++ subid) + setlabel = "label=" ++ quote l + setfilled = "style=" ++ quote "filled" + setcolor = "fillcolor=" ++ quote color + ii x = (indent $ indent x) ++ "\n" + +indent ::String -> String +indent s = "\t" ++ s + +quote :: String -> String +quote s = "\"" ++ s' ++ "\"" + where + s' = filter (/= '"') s -- cgit v1.2.3