diff options
author | Joey Hess <joey@kitenet.net> | 2012-12-13 00:24:19 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-12-13 00:24:19 -0400 |
commit | 94554782894ec6c26da3b46312d5d1d16d596458 (patch) | |
tree | 78746106bfb153945ccbfd2bbae536081c005e91 /Utility | |
parent | 55bd61d8c42aaf36a3c57f8444c493f6b045f4cd (diff) |
finished where indentation changes
Diffstat (limited to 'Utility')
38 files changed, 895 insertions, 903 deletions
diff --git a/Utility/Base64.hs b/Utility/Base64.hs index dd739fd4f..ed803a00a 100644 --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -15,4 +15,4 @@ toB64 = encode . s2w8 fromB64 :: String -> String fromB64 s = maybe bad w82s $ decode s - where bad = error "bad base64 encoded data" + where bad = error "bad base64 encoded data" diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index 66b88e4f0..18290669d 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -17,9 +17,9 @@ copyFileExternal src dest = do whenM (doesFileExist dest) $ removeFile dest boolSystem "cp" $ params ++ [File src, File dest] - where - params = map snd $ filter fst - [ (SysConfig.cp_reflink_auto, Param "--reflink=auto") - , (SysConfig.cp_a, Param "-a") - , (SysConfig.cp_p && not SysConfig.cp_a, Param "-p") - ] + where + params = map snd $ filter fst + [ (SysConfig.cp_reflink_auto, Param "--reflink=auto") + , (SysConfig.cp_a, Param "-a") + , (SysConfig.cp_p && not SysConfig.cp_a, Param "-p") + ] diff --git a/Utility/DBus.hs b/Utility/DBus.hs index d31c20d54..3523a3aa3 100644 --- a/Utility/DBus.hs +++ b/Utility/DBus.hs @@ -57,10 +57,10 @@ runClient getaddr clientaction = do e <- takeMVar mv disconnect client throw e - where - threadrunner storeerr io = loop - where - loop = catchClientError (io >> loop) storeerr + where + threadrunner storeerr io = loop + where + loop = catchClientError (io >> loop) storeerr {- Connects to the bus, and runs the client action. - @@ -73,10 +73,10 @@ persistentClient getaddr v onretry clientaction = {- runClient can fail with not just ClientError, but also other - things, if dbus is not running. Let async exceptions through. -} runClient getaddr clientaction `catchNonAsync` retry - where - retry e = do - v' <- onretry e v - persistentClient getaddr v' onretry clientaction + where + retry e = do + v' <- onretry e v + persistentClient getaddr v' onretry clientaction {- Catches only ClientError -} catchClientError :: IO () -> (ClientError -> IO ()) -> IO () diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index 3417cb5c6..16245268e 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -22,27 +22,27 @@ daemonize logfd pidfile changedirectory a = do maybe noop checkalreadyrunning pidfile _ <- forkProcess child1 out - where - checkalreadyrunning f = maybe noop (const $ alreadyRunning) - =<< checkDaemon f - child1 = do - _ <- createSession - _ <- forkProcess child2 - out - child2 = do - maybe noop lockPidFile pidfile - when changedirectory $ - setCurrentDirectory "/" - nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags - _ <- redir nullfd stdInput - mapM_ (redir logfd) [stdOutput, stdError] - closeFd logfd - a - out - redir newh h = do - closeFd h - dupTo newh h - out = exitImmediately ExitSuccess + where + checkalreadyrunning f = maybe noop (const $ alreadyRunning) + =<< checkDaemon f + child1 = do + _ <- createSession + _ <- forkProcess child2 + out + child2 = do + maybe noop lockPidFile pidfile + when changedirectory $ + setCurrentDirectory "/" + nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags + _ <- redir nullfd stdInput + mapM_ (redir logfd) [stdOutput, stdError] + closeFd logfd + a + out + redir newh h = do + closeFd h + dupTo newh h + out = exitImmediately ExitSuccess {- Locks the pid file, with an exclusive, non-blocking lock. - Writes the pid to the file, fully atomically. @@ -62,8 +62,8 @@ lockPidFile file = do _ <- fdWrite fd' =<< show <$> getProcessID renameFile newfile file closeFd fd - where - newfile = file ++ ".new" + where + newfile = file ++ ".new" alreadyRunning :: IO () alreadyRunning = error "Daemon is already running." @@ -82,19 +82,19 @@ checkDaemon pidfile = do p <- readish <$> readFile pidfile return $ check locked p Nothing -> return Nothing - where - check Nothing _ = Nothing - check _ Nothing = Nothing - check (Just (pid, _)) (Just pid') - | pid == pid' = Just pid - | otherwise = error $ - "stale pid in " ++ pidfile ++ - " (got " ++ show pid' ++ - "; expected " ++ show pid ++ " )" + where + check Nothing _ = Nothing + check _ Nothing = Nothing + check (Just (pid, _)) (Just pid') + | pid == pid' = Just pid + | otherwise = error $ + "stale pid in " ++ pidfile ++ + " (got " ++ show pid' ++ + "; expected " ++ show pid ++ " )" {- Stops the daemon, safely. -} stopDaemon :: FilePath -> IO () stopDaemon pidfile = go =<< checkDaemon pidfile - where - go Nothing = noop - go (Just pid) = signalProcess sigTERM pid + where + go Nothing = noop + go (Just pid) = signalProcess sigTERM pid diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs index 101d64c5a..c6990fdfb 100644 --- a/Utility/DataUnits.hs +++ b/Utility/DataUnits.hs @@ -72,9 +72,9 @@ storageUnits = , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe , Unit (p 0) "B" "byte" ] - where - p :: Integer -> Integer - p n = 1000^n + where + p :: Integer -> Integer + p n = 1000^n {- Memory units are (stupidly named) powers of 2. -} memoryUnits :: [Unit] @@ -89,9 +89,9 @@ memoryUnits = , Unit (p 1) "KiB" "kibibyte" , Unit (p 0) "B" "byte" ] - where - p :: Integer -> Integer - p n = 2^(n*10) + where + p :: Integer -> Integer + p n = 2^(n*10) {- Bandwidth units are only measured in bits if you're some crazy telco. -} bandwidthUnits :: [Unit] @@ -100,32 +100,32 @@ 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 = zipWith (curry mingle) storageUnits memoryUnits - where - mingle (Unit _ a n, Unit s' _ _) = Unit s' a n + 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 + 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 + 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) + 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 + chop :: Integer -> Integer -> Integer + chop i' d = round $ (fromInteger i' :: Double) / fromInteger d - plural n u - | n == 1 = u - | otherwise = u ++ "s" + plural n u + | n == 1 = u + | otherwise = u ++ "s" {- displays comparison of two sizes -} compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String @@ -139,22 +139,22 @@ readSize :: [Unit] -> String -> Maybe ByteSize readSize units input | null parsednum || 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 + 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 + a ~~ b = map toLower a == map toLower b - plural n = n ++ "s" - byteabbrev a = a ++ "b" + plural n = n ++ "s" + byteabbrev a = a ++ "b" diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 5ca39b8b5..7cce4a68f 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -44,46 +44,46 @@ dirContentsRecursive' (dir:dirs) = unsafeInterleaveIO $ do (files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir) files' <- dirContentsRecursive' (dirs' ++ dirs) return (files ++ files') - where - collect files dirs' [] = return (reverse files, reverse dirs') - collect files dirs' (entry:entries) - | dirCruft entry = collect files dirs' entries - | otherwise = do - ifM (doesDirectoryExist entry) - ( collect files (entry:dirs') entries - , collect (entry:files) dirs' entries - ) + where + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) + | dirCruft entry = collect files dirs' entries + | otherwise = do + ifM (doesDirectoryExist entry) + ( collect files (entry:dirs') entries + , collect (entry:files) dirs' entries + ) {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} moveFile :: FilePath -> FilePath -> IO () moveFile src dest = tryIO (rename src dest) >>= onrename - where - onrename (Right _) = noop - onrename (Left e) - | isPermissionError e = rethrow - | isDoesNotExistError e = rethrow - | otherwise = do - -- copyFile is likely not as optimised as - -- the mv command, so we'll use the latter. - -- But, mv will move into a directory if - -- dest is one, which is not desired. - whenM (isdir dest) rethrow - viaTmp mv dest undefined - where - rethrow = throw e - mv tmp _ = do - ok <- boolSystem "mv" [Param "-f", - Param src, Param tmp] - unless ok $ do - -- delete any partial - _ <- tryIO $ removeFile tmp - rethrow - isdir f = do - r <- tryIO $ getFileStatus f - case r of - (Left _) -> return False - (Right s) -> return $ isDirectory s + where + onrename (Right _) = noop + onrename (Left e) + | isPermissionError e = rethrow + | isDoesNotExistError e = rethrow + | otherwise = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the latter. + -- But, mv will move into a directory if + -- dest is one, which is not desired. + whenM (isdir dest) rethrow + viaTmp mv dest undefined + where + rethrow = throw e + mv tmp _ = do + ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + unless ok $ do + -- delete any partial + _ <- tryIO $ removeFile tmp + rethrow + + isdir f = do + r <- tryIO $ getFileStatus f + case r of + (Left _) -> return False + (Right s) -> return $ isDirectory s {- Removes a file, which may or may not exist. - diff --git a/Utility/DiskFree.hs b/Utility/DiskFree.hs index 18c7f2ee6..453244175 100644 --- a/Utility/DiskFree.hs +++ b/Utility/DiskFree.hs @@ -25,5 +25,5 @@ getDiskFree path = withFilePath path $ \c_path -> do ( return $ Just $ toInteger free , return Nothing ) - where - safeErrno (Errno v) = v == 0 + where + safeErrno (Errno v) = v == 0 diff --git a/Utility/Dot.hs b/Utility/Dot.hs index 83f52a3cc..e57bf009f 100644 --- a/Utility/Dot.hs +++ b/Utility/Dot.hs @@ -10,9 +10,9 @@ 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= "}" + where + header = "digraph map {" + footer= "}" {- a node in the graph -} graphNode :: String -> String -> String @@ -21,8 +21,8 @@ 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 (`label` edge) desc - where - edge = quote fromid ++ " -> " ++ quote toid + where + edge = quote fromid ++ " -> " ++ quote toid {- adds a label to a node or edge -} label :: String -> String -> String @@ -46,18 +46,18 @@ subGraph subid l color s = 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" + 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 + where + s' = filter (/= '"') s diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 7109c1403..ddb89b2aa 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -37,10 +37,10 @@ removeModes ms m = m `intersectFileModes` complement (combineModes ms) {- Runs an action after changing a file's mode, then restores the old mode. -} withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a withModifiedFileMode file convert a = bracket setup cleanup go - where - setup = modifyFileMode' file convert - cleanup oldmode = modifyFileMode file (const oldmode) - go _ = a + where + setup = modifyFileMode' file convert + cleanup oldmode = modifyFileMode file (const oldmode) + go _ = a writeModes :: [FileMode] writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode] @@ -83,10 +83,10 @@ noUmask :: FileMode -> IO a -> IO a noUmask mode a | mode == stdFileMode = a | otherwise = bracket setup cleanup go - where - setup = setFileCreationMask nullFileMode - cleanup = setFileCreationMask - go _ = a + where + setup = setFileCreationMask nullFileMode + cleanup = setFileCreationMask + go _ = a combineModes :: [FileMode] -> FileMode combineModes [] = undefined diff --git a/Utility/Format.hs b/Utility/Format.hs index 1d96695ed..97a966ac1 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -43,19 +43,19 @@ type Variables = M.Map String String - This can be repeatedly called, efficiently. -} format :: Format -> Variables -> String format f vars = concatMap expand f - where - expand (Const s) = s - expand (Var name j) - | "escaped_" `isPrefixOf` name = - justify j $ encode_c_strict $ - getvar $ drop (length "escaped_") name - | otherwise = justify j $ getvar name - getvar name = fromMaybe "" $ M.lookup name vars - justify UnJustified s = s - justify (LeftJustified i) s = s ++ pad i s - justify (RightJustified i) s = pad i s ++ s - pad i s = take (i - length s) spaces - spaces = repeat ' ' + where + expand (Const s) = s + expand (Var name j) + | "escaped_" `isPrefixOf` name = + justify j $ encode_c_strict $ + getvar $ drop (length "escaped_") name + | otherwise = justify j $ getvar name + getvar name = fromMaybe "" $ M.lookup name vars + justify UnJustified s = s + justify (LeftJustified i) s = s ++ pad i s + justify (RightJustified i) s = pad i s ++ s + pad i s = take (i - length s) spaces + spaces = repeat ' ' {- Generates a Format that can be used to expand variables in a - format string, such as "${foo} ${bar;10} ${baz;-10}\n" @@ -64,37 +64,37 @@ format f vars = concatMap expand f -} gen :: FormatString -> Format gen = filter (not . empty) . fuse [] . scan [] . decode_c - where - -- The Format is built up in reverse, for efficiency, - -- and can have many adjacent Consts. Fusing it fixes both - -- problems. - fuse f [] = f - fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs - fuse f (v:vs) = fuse (v:f) vs - - scan f (a:b:cs) - | a == '$' && b == '{' = invar f [] cs - | otherwise = scan (Const [a] : f ) (b:cs) - scan f v = Const v : f - - invar f var [] = Const (novar var) : f - invar f var (c:cs) - | c == '}' = foundvar f var UnJustified cs - | isAlphaNum c || c == '_' = invar f (c:var) cs - | c == ';' = inpad "" f var cs - | otherwise = scan ((Const $ novar $ c:var):f) cs - - inpad p f var (c:cs) - | c == '}' = foundvar f var (readjustify $ reverse p) cs - | otherwise = inpad (c:p) f var cs - inpad p f var [] = Const (novar $ p++";"++var) : f - readjustify = getjustify . fromMaybe 0 . readish - getjustify i - | i == 0 = UnJustified - | i < 0 = LeftJustified (-1 * i) - | otherwise = RightJustified i - novar v = "${" ++ reverse v - foundvar f v p = scan (Var (reverse v) p : f) + where + -- The Format is built up in reverse, for efficiency, + -- and can have many adjacent Consts. Fusing it fixes both + -- problems. + fuse f [] = f + fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs + fuse f (v:vs) = fuse (v:f) vs + + scan f (a:b:cs) + | a == '$' && b == '{' = invar f [] cs + | otherwise = scan (Const [a] : f ) (b:cs) + scan f v = Const v : f + + invar f var [] = Const (novar var) : f + invar f var (c:cs) + | c == '}' = foundvar f var UnJustified cs + | isAlphaNum c || c == '_' = invar f (c:var) cs + | c == ';' = inpad "" f var cs + | otherwise = scan ((Const $ novar $ c:var):f) cs + + inpad p f var (c:cs) + | c == '}' = foundvar f var (readjustify $ reverse p) cs + | otherwise = inpad (c:p) f var cs + inpad p f var [] = Const (novar $ p++";"++var) : f + readjustify = getjustify . fromMaybe 0 . readish + getjustify i + | i == 0 = UnJustified + | i < 0 = LeftJustified (-1 * i) + | otherwise = RightJustified i + novar v = "${" ++ reverse v + foundvar f v p = scan (Var (reverse v) p : f) empty :: Frag -> Bool empty (Const "") = True @@ -106,36 +106,34 @@ empty _ = False decode_c :: FormatString -> FormatString decode_c [] = [] decode_c s = unescape ("", s) - where - e = '\\' - unescape (b, []) = b - -- look for escapes starting with '\' - unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair) - where - pair = span (/= e) v - isescape x = x == e - -- \NNN is an octal encoded character - handle (x:n1:n2:n3:rest) - | isescape x && alloctal = (fromoctal, rest) - where - alloctal = isOctDigit n1 && - isOctDigit n2 && - isOctDigit n3 - fromoctal = [chr $ readoctal [n1, n2, n3]] - readoctal o = Prelude.read $ "0o" ++ o :: Int - -- \C is used for a few special characters - handle (x:nc:rest) - | isescape x = ([echar nc], rest) - where - echar 'a' = '\a' - echar 'b' = '\b' - echar 'f' = '\f' - echar 'n' = '\n' - echar 'r' = '\r' - echar 't' = '\t' - echar 'v' = '\v' - echar a = a - handle n = ("", n) + where + e = '\\' + unescape (b, []) = b + -- look for escapes starting with '\' + unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair) + where + pair = span (/= e) v + isescape x = x == e + -- \NNN is an octal encoded character + handle (x:n1:n2:n3:rest) + | isescape x && alloctal = (fromoctal, rest) + where + alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3 + fromoctal = [chr $ readoctal [n1, n2, n3]] + readoctal o = Prelude.read $ "0o" ++ o :: Int + -- \C is used for a few special characters + handle (x:nc:rest) + | isescape x = ([echar nc], rest) + where + echar 'a' = '\a' + echar 'b' = '\b' + echar 'f' = '\f' + echar 'n' = '\n' + echar 'r' = '\r' + echar 't' = '\t' + echar 'v' = '\v' + echar a = a + handle n = ("", n) {- Inverse of decode_c. -} encode_c :: FormatString -> FormatString @@ -147,28 +145,28 @@ encode_c_strict = encode_c' isSpace encode_c' :: (Char -> Bool) -> FormatString -> FormatString encode_c' p = concatMap echar - where - e c = '\\' : [c] - echar '\a' = e 'a' - echar '\b' = e 'b' - echar '\f' = e 'f' - echar '\n' = e 'n' - echar '\r' = e 'r' - echar '\t' = e 't' - echar '\v' = e 'v' - echar '\\' = e '\\' - echar '"' = e '"' - echar c - | ord c < 0x20 = e_asc c -- low ascii - | ord c >= 256 = e_utf c -- unicode - | ord c > 0x7E = e_asc c -- high ascii - | p c = e_asc c -- unprintable ascii - | otherwise = [c] -- printable ascii - -- unicode character is decomposed to individual Word8s, - -- and each is shown in octal - e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) - e_asc c = showoctal $ ord c - showoctal i = '\\' : printf "%03o" i + where + e c = '\\' : [c] + echar '\a' = e 'a' + echar '\b' = e 'b' + echar '\f' = e 'f' + echar '\n' = e 'n' + echar '\r' = e 'r' + echar '\t' = e 't' + echar '\v' = e 'v' + echar '\\' = e '\\' + echar '"' = e '"' + echar c + | ord c < 0x20 = e_asc c -- low ascii + | ord c >= 256 = e_utf c -- unicode + | ord c > 0x7E = e_asc c -- high ascii + | p c = e_asc c -- unprintable ascii + | otherwise = [c] -- printable ascii + -- unicode character is decomposed to individual Word8s, + -- and each is shown in octal + e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) + e_asc c = showoctal $ ord c + showoctal i = '\\' : printf "%03o" i {- for quickcheck -} prop_idempotent_deencode :: String -> Bool diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs index 7aba1f272..e3ced6d74 100644 --- a/Utility/FreeDesktop.hs +++ b/Utility/FreeDesktop.hs @@ -51,8 +51,8 @@ toString(NumericV f) = show f toString (ListV l) | null l = "" | otherwise = (intercalate ";" $ map (escapesemi . toString) l) ++ ";" - where - escapesemi = join "\\;" . split ";" + where + escapesemi = join "\\;" . split ";" genDesktopEntry :: String -> String -> Bool -> FilePath -> [String] -> DesktopEntry genDesktopEntry name comment terminal program categories = @@ -64,13 +64,13 @@ genDesktopEntry name comment terminal program categories = , item "Exec" StringV program , item "Categories" ListV (map StringV categories) ] - where - item x c y = (x, c y) + where + item x c y = (x, c y) buildDesktopMenuFile :: DesktopEntry -> String buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n" - where - keyvalue (k, v) = k ++ "=" ++ toString v + where + keyvalue (k, v) = k ++ "=" ++ toString v writeDesktopMenuFile :: DesktopEntry -> String -> IO () writeDesktopMenuFile d file = do @@ -115,11 +115,10 @@ userConfigDir = xdgEnvHome "CONFIG_HOME" ".config" - to ~/Desktop. -} userDesktopDir :: IO FilePath userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir) - where - parse = maybe Nothing (headMaybe . lines) - xdg_user_dir = catchMaybeIO $ - readProcess "xdg-user-dir" ["DESKTOP"] - fallback = xdgEnvHome "DESKTOP_DIR" "Desktop" + where + parse = maybe Nothing (headMaybe . lines) + xdg_user_dir = catchMaybeIO $ readProcess "xdg-user-dir" ["DESKTOP"] + fallback = xdgEnvHome "DESKTOP_DIR" "Desktop" xdgEnvHome :: String -> String -> IO String xdgEnvHome envbase homedef = do diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 054e6ca17..8c7a3ac38 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -29,9 +29,9 @@ stdParams params = do then [] else ["--batch", "--no-tty", "--use-agent"] return $ batch ++ defaults ++ toCommand params - where - -- be quiet, even about checking the trustdb - defaults = ["--quiet", "--trust-model", "always"] + where + -- be quiet, even about checking the trustdb + defaults = ["--quiet", "--trust-model", "always"] {- Runs gpg with some params and returns its stdout, strictly. -} readStrict :: [CommandParam] -> IO String @@ -74,22 +74,22 @@ feedRead params passphrase feeder reader = do params' <- stdParams $ passphrasefd ++ params closeFd frompipe `after` withBothHandles createProcessSuccess (proc "gpg" params') go - where - go (to, from) = do - void $ forkIO $ do - feeder to - hClose to - reader from + where + go (to, from) = do + void $ forkIO $ do + feeder to + hClose to + reader from {- Finds gpg public keys matching some string. (Could be an email address, - a key id, or a name. -} findPubKeys :: String -> IO KeyIds findPubKeys for = KeyIds . parse <$> readStrict params - where - params = [Params "--with-colons --list-public-keys", Param for] - parse = catMaybes . map (keyIdField . split ":") . lines - keyIdField ("pub":_:_:_:f:_) = Just f - keyIdField _ = Nothing + where + params = [Params "--with-colons --list-public-keys", Param for] + parse = catMaybes . map (keyIdField . split ":") . lines + keyIdField ("pub":_:_:_:f:_) = Just f + keyIdField _ = Nothing {- Creates a block of high-quality random data suitable to use as a cipher. - It is armored, to avoid newlines, since gpg only reads ciphers up to the @@ -100,9 +100,9 @@ genRandom size = readStrict , Param $ show randomquality , Param $ show size ] - where - -- 1 is /dev/urandom; 2 is /dev/random - randomquality = 1 :: Int + where + -- 1 is /dev/urandom; 2 is /dev/random + randomquality = 1 :: Int {- A test key. This is provided pre-generated since generating a new gpg - key is too much work (requires too much entropy) for a test suite to @@ -173,10 +173,10 @@ keyBlock public ls = unlines , unlines ls , "-----END PGP "++t++" KEY BLOCK-----" ] - where - t - | public = "PUBLIC" - | otherwise = "PRIVATE" + where + t + | public = "PUBLIC" + | otherwise = "PRIVATE" {- Runs an action using gpg in a test harness, in which gpg does - not use ~/.gpg/, but a directory with the test key set up to be used. -} @@ -184,20 +184,20 @@ testHarness :: IO a -> IO a testHarness a = do orig <- getEnv var bracket setup (cleanup orig) (const a) - where - var = "GNUPGHOME" + where + var = "GNUPGHOME" - setup = do - base <- getTemporaryDirectory - dir <- mktmpdir $ base </> "gpgtmpXXXXXX" - setEnv var dir True - _ <- pipeStrict [Params "--import -q"] $ unlines - [testSecretKey, testKey] - return dir + setup = do + base <- getTemporaryDirectory + dir <- mktmpdir $ base </> "gpgtmpXXXXXX" + setEnv var dir True + _ <- pipeStrict [Params "--import -q"] $ unlines + [testSecretKey, testKey] + return dir - cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig - reset (Just v) = setEnv var v True - reset _ = unsetEnv var + cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig + reset (Just v) = setEnv var v True + reset _ = unsetEnv var {- Tests the test harness. -} testTestHarness :: IO Bool diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index ca631dbb1..038d1228e 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -17,10 +17,10 @@ parseDuration s = do num <- readish s :: Maybe Integer units <- findUnits =<< lastMaybe s return $ fromIntegral num * units - where - findUnits 's' = Just 1 - findUnits 'm' = Just 60 - findUnits 'h' = Just $ 60 * 60 - findUnits 'd' = Just $ 60 * 60 * 24 - findUnits 'y' = Just $ 60 * 60 * 24 * 365 - findUnits _ = Nothing + where + findUnits 's' = Just 1 + findUnits 'm' = Just 60 + findUnits 'h' = Just $ 60 * 60 + findUnits 'd' = Just $ 60 * 60 * 24 + findUnits 'y' = Just $ 60 * 60 * 24 * 365 + findUnits _ = Nothing diff --git a/Utility/INotify.hs b/Utility/INotify.hs index b55fbc953..2b5789479 100644 --- a/Utility/INotify.hs +++ b/Utility/INotify.hs @@ -59,116 +59,116 @@ watchDir i dir ignored hooks withLock lock $ mapM_ scan =<< filter (not . dirCruft) <$> getDirectoryContents dir - where - recurse d = watchDir i d ignored hooks + where + recurse d = watchDir i d ignored hooks - -- Select only inotify events required by the enabled - -- hooks, but always include Create so new directories can - -- be scanned. - watchevents = Create : addevents ++ delevents ++ modifyevents - addevents - | hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite] - | otherwise = [] - delevents - | hashook delHook || hashook delDirHook = [MoveOut, Delete] - | otherwise = [] - modifyevents - | hashook modifyHook = [Modify] - | otherwise = [] + -- Select only inotify events required by the enabled + -- hooks, but always include Create so new directories can + -- be scanned. + watchevents = Create : addevents ++ delevents ++ modifyevents + addevents + | hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite] + | otherwise = [] + delevents + | hashook delHook || hashook delDirHook = [MoveOut, Delete] + | otherwise = [] + modifyevents + | hashook modifyHook = [Modify] + | otherwise = [] - scan f = unless (ignored f) $ do - ms <- getstatus f - case ms of - Nothing -> return () - Just s - | Files.isDirectory s -> - recurse $ indir f - | Files.isSymbolicLink s -> - runhook addSymlinkHook f ms - | Files.isRegularFile s -> - runhook addHook f ms - | otherwise -> - noop + scan f = unless (ignored f) $ do + ms <- getstatus f + case ms of + Nothing -> return () + Just s + | Files.isDirectory s -> + recurse $ indir f + | Files.isSymbolicLink s -> + runhook addSymlinkHook f ms + | Files.isRegularFile s -> + runhook addHook f ms + | otherwise -> + noop - -- Ignore creation events for regular files, which won't be - -- done being written when initially created, but handle for - -- directories and symlinks. - go (Created { isDirectory = isd, filePath = f }) - | isd = recurse $ indir f - | hashook addSymlinkHook = - checkfiletype Files.isSymbolicLink addSymlinkHook f - | otherwise = noop - -- Closing a file is assumed to mean it's done being written. - go (Closed { isDirectory = False, maybeFilePath = Just f }) = - checkfiletype Files.isRegularFile addHook f - -- When a file or directory is moved in, scan it to add new - -- stuff. - go (MovedIn { filePath = f }) = scan f - go (MovedOut { isDirectory = isd, filePath = f }) - | isd = runhook delDirHook f Nothing - | otherwise = runhook delHook f Nothing - -- Verify that the deleted item really doesn't exist, - -- since there can be spurious deletion events for items - -- in a directory that has been moved out, but is still - -- being watched. - go (Deleted { isDirectory = isd, filePath = f }) - | isd = guarded $ runhook delDirHook f Nothing - | otherwise = guarded $ runhook delHook f Nothing - where - guarded = unlessM (filetype (const True) f) - go (Modified { isDirectory = isd, maybeFilePath = Just f }) - | isd = noop - | otherwise = runhook modifyHook f Nothing - go _ = noop + -- Ignore creation events for regular files, which won't be + -- done being written when initially created, but handle for + -- directories and symlinks. + go (Created { isDirectory = isd, filePath = f }) + | isd = recurse $ indir f + | hashook addSymlinkHook = + checkfiletype Files.isSymbolicLink addSymlinkHook f + | otherwise = noop + -- Closing a file is assumed to mean it's done being written. + go (Closed { isDirectory = False, maybeFilePath = Just f }) = + checkfiletype Files.isRegularFile addHook f + -- When a file or directory is moved in, scan it to add new + -- stuff. + go (MovedIn { filePath = f }) = scan f + go (MovedOut { isDirectory = isd, filePath = f }) + | isd = runhook delDirHook f Nothing + | otherwise = runhook delHook f Nothing + -- Verify that the deleted item really doesn't exist, + -- since there can be spurious deletion events for items + -- in a directory that has been moved out, but is still + -- being watched. + go (Deleted { isDirectory = isd, filePath = f }) + | isd = guarded $ runhook delDirHook f Nothing + | otherwise = guarded $ runhook delHook f Nothing + where + guarded = unlessM (filetype (const True) f) + go (Modified { isDirectory = isd, maybeFilePath = Just f }) + | isd = noop + | otherwise = runhook modifyHook f Nothing + go _ = noop - hashook h = isJust $ h hooks + hashook h = isJust $ h hooks - runhook h f s - | ignored f = noop - | otherwise = maybe noop (\a -> a (indir f) s) (h hooks) + runhook h f s + | ignored f = noop + | otherwise = maybe noop (\a -> a (indir f) s) (h hooks) - indir f = dir </> f + indir f = dir </> f - getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f - checkfiletype check h f = do - ms <- getstatus f - case ms of - Just s - | check s -> runhook h f ms - _ -> noop - filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) + getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f + checkfiletype check h f = do + ms <- getstatus f + case ms of + Just s + | check s -> runhook h f ms + _ -> noop + filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) - -- Inotify fails when there are too many watches with a - -- disk full error. - failedaddwatch e - | isFullError e = - case errHook hooks of - Nothing -> throw e - Just hook -> tooManyWatches hook dir - | otherwise = throw e + -- Inotify fails when there are too many watches with a + -- disk full error. + failedaddwatch e + | isFullError e = + case errHook hooks of + Nothing -> throw e + Just hook -> tooManyWatches hook dir + | otherwise = throw e tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO () tooManyWatches hook dir = do sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer) hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing - where - maxwatches = "fs.inotify.max_user_watches" - basewarning = "Too many directories to watch! (Not watching " ++ dir ++")" - withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"] - withsysctl n = let new = n * 10 in - [ "Increase the limit permanently by running:" - , " echo " ++ maxwatches ++ "=" ++ show new ++ - " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p" - , "Or temporarily by running:" - , " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new - ] + where + maxwatches = "fs.inotify.max_user_watches" + basewarning = "Too many directories to watch! (Not watching " ++ dir ++")" + withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"] + withsysctl n = let new = n * 10 in + [ "Increase the limit permanently by running:" + , " echo " ++ maxwatches ++ "=" ++ show new ++ + " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p" + , "Or temporarily by running:" + , " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new + ] querySysctl :: Read a => [CommandParam] -> IO (Maybe a) querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"] - where - go p = do - v <- catchMaybeIO $ readProcess p (toCommand ps) - case v of - Nothing -> return Nothing - Just s -> return $ parsesysctl s - parsesysctl s = readish =<< lastMaybe (words s) + where + go p = do + v <- catchMaybeIO $ readProcess p (toCommand ps) + case v of + Nothing -> return Nothing + Just s -> return $ parsesysctl s + parsesysctl s = readish =<< lastMaybe (words s) diff --git a/Utility/JSONStream.hs b/Utility/JSONStream.hs index 7910c1194..aaa332bca 100644 --- a/Utility/JSONStream.hs +++ b/Utility/JSONStream.hs @@ -21,15 +21,15 @@ start :: JSON a => [(String, a)] -> String start l | last s == endchar = init s | otherwise = bad s - where - s = encodeStrict $ toJSObject l + where + s = encodeStrict $ toJSObject l add :: JSON a => [(String, a)] -> String add l | head s == startchar = ',' : drop 1 s | otherwise = bad s - where - s = start l + where + s = start l end :: String end = [endchar, '\n'] diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs index 4b72961b2..f9f965f6f 100644 --- a/Utility/Kqueue.hs +++ b/Utility/Kqueue.hs @@ -78,44 +78,44 @@ getDirInfo dir = do l <- filter (not . dirCruft) <$> getDirectoryContents dir contents <- S.fromList . catMaybes <$> mapM getDirEnt l return $ DirInfo dir contents - where - getDirEnt f = catchMaybeIO $ do - s <- getFileStatus (dir </> f) - return $ DirEnt f (fileID s) (isDirectory s) + where + getDirEnt f = catchMaybeIO $ do + s <- getFileStatus (dir </> f) + return $ DirEnt f (fileID s) (isDirectory s) {- Difference between the dirCaches of two DirInfos. -} (//) :: DirInfo -> DirInfo -> [Change] oldc // newc = deleted ++ added - where - deleted = calc gendel oldc newc - added = calc genadd newc oldc - gendel x = (if isSubDir x then DeletedDir else Deleted) $ - dirName oldc </> dirEnt x - genadd x = Added $ dirName newc </> dirEnt x - calc a x y = map a $ S.toList $ - S.difference (dirCache x) (dirCache y) + where + deleted = calc gendel oldc newc + added = calc genadd newc oldc + gendel x = (if isSubDir x then DeletedDir else Deleted) $ + dirName oldc </> dirEnt x + genadd x = Added $ dirName newc </> dirEnt x + calc a x y = map a $ S.toList $ + S.difference (dirCache x) (dirCache y) {- Builds a map of directories in a tree, possibly pruning some. - Opens each directory in the tree, and records its current contents. -} scanRecursive :: FilePath -> Pruner -> IO DirMap scanRecursive topdir prune = M.fromList <$> walk [] [topdir] - where - walk c [] = return c - walk c (dir:rest) - | prune dir = walk c rest - | otherwise = do - minfo <- catchMaybeIO $ getDirInfo dir - case minfo of - Nothing -> walk c rest - Just info -> do - mfd <- catchMaybeIO $ - openFd dir ReadOnly Nothing defaultFileFlags - case mfd of - Nothing -> walk c rest - Just fd -> do - let subdirs = map (dir </>) . map dirEnt $ - S.toList $ dirCache info - walk ((fd, info):c) (subdirs ++ rest) + where + walk c [] = return c + walk c (dir:rest) + | prune dir = walk c rest + | otherwise = do + minfo <- catchMaybeIO $ getDirInfo dir + case minfo of + Nothing -> walk c rest + Just info -> do + mfd <- catchMaybeIO $ + openFd dir ReadOnly Nothing defaultFileFlags + case mfd of + Nothing -> walk c rest + Just fd -> do + let subdirs = map (dir </>) . map dirEnt $ + S.toList $ dirCache info + walk ((fd, info):c) (subdirs ++ rest) {- Adds a list of subdirectories (and all their children), unless pruned to a - directory map. Adding a subdirectory that's already in the map will @@ -131,16 +131,16 @@ removeSubDir :: DirMap -> FilePath -> IO DirMap removeSubDir dirmap dir = do mapM_ closeFd $ M.keys toremove return rest - where - (toremove, rest) = M.partition (dirContains dir . dirName) dirmap + where + (toremove, rest) = M.partition (dirContains dir . dirName) dirmap findDirContents :: DirMap -> FilePath -> [FilePath] findDirContents dirmap dir = concatMap absolutecontents $ search - where - absolutecontents i = map (dirName i </>) - (map dirEnt $ S.toList $ dirCache i) - search = map snd $ M.toList $ - M.filter (\i -> dirName i == dir) dirmap + where + absolutecontents i = map (dirName i </>) + (map dirEnt $ S.toList $ dirCache i) + search = map snd $ M.toList $ + M.filter (\i -> dirName i == dir) dirmap foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue :: IO Fd @@ -181,8 +181,8 @@ waitChange kq@(Kqueue h _ dirmap _) = do else case M.lookup changedfd dirmap of Nothing -> nochange Just info -> handleChange kq changedfd info - where - nochange = return (kq, []) + where + nochange = return (kq, []) {- The kqueue interface does not tell what type of change took place in - the directory; it could be an added file, a deleted file, a renamed @@ -196,36 +196,36 @@ waitChange kq@(Kqueue h _ dirmap _) = do handleChange :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change]) handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo = go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo) - where - go (Just newdirinfo) = do - let changes = filter (not . pruner . changedFile) $ - olddirinfo // newdirinfo - let (added, deleted) = partition isAdd changes - - -- Scan newly added directories to add to the map. - -- (Newly added files will fail getDirInfo.) - newdirinfos <- catMaybes <$> - mapM (catchMaybeIO . getDirInfo . changedFile) added - newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos - - -- Remove deleted directories from the map. - newmap' <- foldM removeSubDir newmap (map changedFile deleted) - - -- Update the cached dirinfo just looked up. - let newmap'' = M.insertWith' const fd newdirinfo newmap' - - -- When new directories were added, need to update - -- the kqueue to watch them. - let kq' = kq { kqueueMap = newmap'' } - unless (null newdirinfos) $ - updateKqueue kq' - - return (kq', changes) - go Nothing = do - -- The directory has been moved or deleted, so - -- remove it from our map. - newmap <- removeSubDir dirmap (dirName olddirinfo) - return (kq { kqueueMap = newmap }, []) + where + go (Just newdirinfo) = do + let changes = filter (not . pruner . changedFile) $ + olddirinfo // newdirinfo + let (added, deleted) = partition isAdd changes + + -- Scan newly added directories to add to the map. + -- (Newly added files will fail getDirInfo.) + newdirinfos <- catMaybes <$> + mapM (catchMaybeIO . getDirInfo . changedFile) added + newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos + + -- Remove deleted directories from the map. + newmap' <- foldM removeSubDir newmap (map changedFile deleted) + + -- Update the cached dirinfo just looked up. + let newmap'' = M.insertWith' const fd newdirinfo newmap' + + -- When new directories were added, need to update + -- the kqueue to watch them. + let kq' = kq { kqueueMap = newmap'' } + unless (null newdirinfos) $ + updateKqueue kq' + + return (kq', changes) + go Nothing = do + -- The directory has been moved or deleted, so + -- remove it from our map. + newmap <- removeSubDir dirmap (dirName olddirinfo) + return (kq { kqueueMap = newmap }, []) {- Processes changes on the Kqueue, calling the hooks as appropriate. - Never returns. -} @@ -235,35 +235,33 @@ runHooks kq hooks = do -- to catch any files created beforehand. recursiveadd (kqueueMap kq) (Added $ kqueueTop kq) loop kq - where - loop q = do - (q', changes) <- waitChange q - forM_ changes $ dispatch (kqueueMap q') - loop q' - - dispatch _ change@(Deleted _) = - callhook delHook Nothing change - dispatch _ change@(DeletedDir _) = - callhook delDirHook Nothing change - dispatch dirmap change@(Added _) = - withstatus change $ dispatchadd dirmap + where + loop q = do + (q', changes) <- waitChange q + forM_ changes $ dispatch (kqueueMap q') + loop q' + + dispatch _ change@(Deleted _) = + callhook delHook Nothing change + dispatch _ change@(DeletedDir _) = + callhook delDirHook Nothing change + dispatch dirmap change@(Added _) = + withstatus change $ dispatchadd dirmap - dispatchadd dirmap change s - | Files.isSymbolicLink s = - callhook addSymlinkHook (Just s) change - | Files.isDirectory s = recursiveadd dirmap change - | Files.isRegularFile s = - callhook addHook (Just s) change - | otherwise = noop - - recursiveadd dirmap change = do - let contents = findDirContents dirmap $ changedFile change - forM_ contents $ \f -> - withstatus (Added f) $ dispatchadd dirmap - - callhook h s change = case h hooks of - Nothing -> noop - Just a -> a (changedFile change) s - - withstatus change a = maybe noop (a change) =<< - (catchMaybeIO (getSymbolicLinkStatus (changedFile change))) + dispatchadd dirmap change s + | Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change + | Files.isDirectory s = recursiveadd dirmap change + | Files.isRegularFile s = callhook addHook (Just s) change + | otherwise = noop + + recursiveadd dirmap change = do + let contents = findDirContents dirmap $ changedFile change + forM_ contents $ \f -> + withstatus (Added f) $ dispatchadd dirmap + + callhook h s change = case h hooks of + Nothing -> noop + Just a -> a (changedFile change) s + + withstatus change a = maybe noop (a change) =<< + (catchMaybeIO (getSymbolicLinkStatus (changedFile change))) diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs index 7ffb63f52..c45a1d405 100644 --- a/Utility/LogFile.hs +++ b/Utility/LogFile.hs @@ -23,9 +23,9 @@ rotateLog logfile num | otherwise = whenM (doesFileExist currfile) $ do rotateLog logfile (num + 1) renameFile currfile nextfile - where - currfile = filename num - nextfile = filename (num + 1) - filename n - | n == 0 = logfile - | otherwise = logfile ++ "." ++ show n + where + currfile = filename num + nextfile = filename (num + 1) + filename n + | n == 0 = logfile + | otherwise = logfile ++ "." ++ show n diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index ce6a16283..72f3e5815 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -36,8 +36,8 @@ query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)] query opts = withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do parse <$> hGetContentsStrict h - where - p = proc "lsof" ("-F0can" : opts) + where + p = proc "lsof" ("-F0can" : opts) {- Parsing null-delimited output like: - @@ -51,38 +51,36 @@ query opts = -} parse :: String -> [(FilePath, LsofOpenMode, ProcessInfo)] parse s = bundle $ go [] $ lines s - where - bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs) - - go c [] = c - go c ((t:r):ls) - | t == 'p' = - let (fs, ls') = parsefiles [] ls - in go ((fs, parseprocess r):c) ls' - | otherwise = parsefail - go _ _ = parsefail - - parseprocess l = - case splitnull l of - [pid, 'c':cmdline, ""] -> - case readish pid of - (Just n) -> ProcessInfo n cmdline - Nothing -> parsefail - _ -> parsefail - - parsefiles c [] = (c, []) - parsefiles c (l:ls) = - case splitnull l of - ['a':mode, 'n':file, ""] -> - parsefiles ((file, parsemode mode):c) ls - (('p':_):_) -> (c, l:ls) - _ -> parsefail - - parsemode ('r':_) = OpenReadOnly - parsemode ('w':_) = OpenWriteOnly - parsemode ('u':_) = OpenReadWrite - parsemode _ = OpenUnknown - - splitnull = split "\0" - - parsefail = error $ "failed to parse lsof output: " ++ show s + where + bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs) + + go c [] = c + go c ((t:r):ls) + | t == 'p' = + let (fs, ls') = parsefiles [] ls + in go ((fs, parseprocess r):c) ls' + | otherwise = parsefail + go _ _ = parsefail + + parseprocess l = case splitnull l of + [pid, 'c':cmdline, ""] -> + case readish pid of + (Just n) -> ProcessInfo n cmdline + Nothing -> parsefail + _ -> parsefail + + parsefiles c [] = (c, []) + parsefiles c (l:ls) = case splitnull l of + ['a':mode, 'n':file, ""] -> + parsefiles ((file, parsemode mode):c) ls + (('p':_):_) -> (c, l:ls) + _ -> parsefail + + parsemode ('r':_) = OpenReadOnly + parsemode ('w':_) = OpenWriteOnly + parsemode ('u':_) = OpenReadWrite + parsemode _ = OpenUnknown + + splitnull = split "\0" + + parsefail = error $ "failed to parse lsof output: " ++ show s diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs index 3d525e2af..89a4e7d0c 100644 --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -58,36 +58,36 @@ tokens = words "and or not ( )" {- Converts a list of Tokens into a Matcher. -} generate :: [Token op] -> Matcher op generate = go MAny - where - go m [] = m - go m ts = uncurry go $ consume m ts + where + go m [] = m + go m ts = uncurry go $ consume m ts {- Consumes one or more Tokens, constructs a new Matcher, - and returns unconsumed Tokens. -} consume :: Matcher op -> [Token op] -> (Matcher op, [Token op]) consume m [] = (m, []) consume m (t:ts) = go t - where - go And = cont $ m `MAnd` next - go Or = cont $ m `MOr` next - go Not = cont $ m `MAnd` MNot next - go Open = let (n, r) = consume next rest in (m `MAnd` n, r) - go Close = (m, ts) - go (Operation o) = (m `MAnd` MOp o, ts) + where + go And = cont $ m `MAnd` next + go Or = cont $ m `MOr` next + go Not = cont $ m `MAnd` MNot next + go Open = let (n, r) = consume next rest in (m `MAnd` n, r) + go Close = (m, ts) + go (Operation o) = (m `MAnd` MOp o, ts) - (next, rest) = consume MAny ts - cont v = (v, rest) + (next, rest) = consume MAny ts + cont v = (v, rest) {- Checks if a Matcher matches, using a supplied function to check - the value of Operations. -} match :: (op -> v -> Bool) -> Matcher op -> v -> Bool match a m v = go m - where - go MAny = True - go (MAnd m1 m2) = go m1 && go m2 - go (MOr m1 m2) = go m1 || go m2 - go (MNot m1) = not $ go m1 - go (MOp o) = a o v + where + go MAny = True + go (MAnd m1 m2) = go m1 && go m2 + go (MOr m1 m2) = go m1 || go m2 + go (MNot m1) = not $ go m1 + go (MOp o) = a o v {- Runs a monadic Matcher, where Operations are actions in the monad. -} matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool @@ -98,12 +98,12 @@ matchM m v = matchMrun m $ \o -> o v - parameter. -} matchMrun :: forall o (m :: * -> *). Monad m => Matcher o -> (o -> m Bool) -> m Bool matchMrun m run = go m - where - go MAny = return True - go (MAnd m1 m2) = go m1 <&&> go m2 - go (MOr m1 m2) = go m1 <||> go m2 - go (MNot m1) = liftM not (go m1) - go (MOp o) = run o + where + go MAny = return True + go (MAnd m1 m2) = go m1 <&&> go m2 + go (MOr m1 m2) = go m1 <||> go m2 + go (MNot m1) = liftM not (go m1) + go (MOp o) = run o {- Checks if a matcher contains no limits. -} isEmpty :: Matcher a -> Bool diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 7c81f56fd..c04409563 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -33,10 +33,10 @@ readFileStrict = readFile >=> \s -> length s `seq` return s -} separate :: (a -> Bool) -> [a] -> ([a], [a]) separate c l = unbreak $ break c l - where - unbreak r@(a, b) - | null b = r - | otherwise = (a, tail b) + where + unbreak r@(a, b) + | null b = r + | otherwise = (a, tail b) {- Breaks out the first line. -} firstLine :: String -> String @@ -47,11 +47,11 @@ firstLine = takeWhile (/= '\n') - Segments may be empty. -} segment :: (a -> Bool) -> [a] -> [[a]] segment p l = map reverse $ go [] [] l - where - go c r [] = reverse $ c:r - go c r (i:is) - | p i = go [] (c:r) is - | otherwise = go (i:c) r is + where + go c r [] = reverse $ c:r + go c r (i:is) + | p i = go [] (c:r) is + | otherwise = go (i:c) r is prop_segment_regressionTest :: Bool prop_segment_regressionTest = all id @@ -64,11 +64,11 @@ prop_segment_regressionTest = all id {- Includes the delimiters as segments of their own. -} segmentDelim :: (a -> Bool) -> [a] -> [[a]] segmentDelim p l = map reverse $ go [] [] l - where - go c r [] = reverse $ c:r - go c r (i:is) - | p i = go [] ([i]:c:r) is - | otherwise = go (i:c) r is + where + go c r [] = reverse $ c:r + go c r (i:is) + | p i = go [] ([i]:c:r) is + | otherwise = go (i:c) r is {- Given two orderings, returns the second if the first is EQ and returns - the first otherwise. @@ -96,9 +96,9 @@ hGetSomeString h sz = do fp <- mallocForeignPtrBytes sz len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len) - where - peekbytes :: Int -> Ptr Word8 -> IO [Word8] - peekbytes len buf = mapM (peekElemOff buf) [0..pred len] + where + peekbytes :: Int -> Ptr Word8 -> IO [Word8] + peekbytes len buf = mapM (peekElemOff buf) [0..pred len] {- Reaps any zombie git processes. - diff --git a/Utility/Mounts.hsc b/Utility/Mounts.hsc index 0b1468521..c21a68032 100644 --- a/Utility/Mounts.hsc +++ b/Utility/Mounts.hsc @@ -41,21 +41,21 @@ getMounts = do _ <- c_mounts_end h return mntent - where - getmntent h c = do - ptr <- c_mounts_next h - if (ptr == nullPtr) - then return $ reverse c - else do - mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString - mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString - mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString - let ent = Mntent - { mnt_fsname = mnt_fsname_str - , mnt_dir = mnt_dir_str - , mnt_type = mnt_type_str - } - getmntent h (ent:c) + where + getmntent h c = do + ptr <- c_mounts_next h + if (ptr == nullPtr) + then return $ reverse c + else do + mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString + mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString + mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString + let ent = Mntent + { mnt_fsname = mnt_fsname_str + , mnt_dir = mnt_dir_str + , mnt_type = mnt_type_str + } + getmntent h (ent:c) {- Using unsafe imports because the C functions are belived to never block. - Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking; diff --git a/Utility/Network.hs b/Utility/Network.hs index bedb37dc9..62523c9e9 100644 --- a/Utility/Network.hs +++ b/Utility/Network.hs @@ -17,6 +17,5 @@ import Control.Applicative - use uname -n when available. -} getHostname :: IO (Maybe String) getHostname = catchMaybeIO uname_node - where - uname_node = takeWhile (/= '\n') <$> - readProcess "uname" ["-n"] + where + uname_node = takeWhile (/= '\n') <$> readProcess "uname" ["-n"] diff --git a/Utility/NotificationBroadcaster.hs b/Utility/NotificationBroadcaster.hs index 4bbbc544a..413ec2d75 100644 --- a/Utility/NotificationBroadcaster.hs +++ b/Utility/NotificationBroadcaster.hs @@ -45,13 +45,13 @@ newNotificationHandle :: NotificationBroadcaster -> IO NotificationHandle newNotificationHandle b = NotificationHandle <$> pure b <*> addclient - where - addclient = do - s <- newEmptySV - atomically $ do - l <- takeTMVar b - putTMVar b $ l ++ [s] - return $ NotificationId $ length l + where + addclient = do + s <- newEmptySV + atomically $ do + l <- takeTMVar b + putTMVar b $ l ++ [s] + return $ NotificationId $ length l {- Extracts the identifier from a notification handle. - This can be used to eg, pass the identifier through to a WebApp. -} @@ -66,8 +66,8 @@ sendNotification :: NotificationBroadcaster -> IO () sendNotification b = do l <- atomically $ readTMVar b mapM_ notify l - where - notify s = writeSV s () + where + notify s = writeSV s () {- Used by a client to block until a new notification is available since - the last time it tried. -} diff --git a/Utility/Parallel.hs b/Utility/Parallel.hs index 373a0ece5..b39880355 100644 --- a/Utility/Parallel.hs +++ b/Utility/Parallel.hs @@ -23,13 +23,13 @@ inParallel a l = do mvars <- mapM thread l statuses <- mapM takeMVar mvars return $ reduce $ partition snd $ zip l statuses - where - reduce (x,y) = (map fst x, map fst y) - thread v = do - mvar <- newEmptyMVar - _ <- forkIO $ do - r <- try (a v) :: IO (Either SomeException Bool) - case r of - Left _ -> putMVar mvar False - Right b -> putMVar mvar b - return mvar + where + reduce (x,y) = (map fst x, map fst y) + thread v = do + mvar <- newEmptyMVar + _ <- forkIO $ do + r <- try (a v) :: IO (Either SomeException Bool) + case r of + Left _ -> putMVar mvar False + Right b -> putMVar mvar b + return mvar diff --git a/Utility/Path.hs b/Utility/Path.hs index 272d2e85b..4bab297da 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -23,18 +23,18 @@ parentDir :: FilePath -> FilePath parentDir dir | not $ null dirs = slash ++ join s (init dirs) | otherwise = "" - where - dirs = filter (not . null) $ split s dir - slash = if isAbsolute dir then s else "" - s = [pathSeparator] + where + dirs = filter (not . null) $ split s dir + slash = if isAbsolute dir then s else "" + s = [pathSeparator] prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics dir | null dir = True | dir == "/" = parentDir dir == "" | otherwise = p /= dir - where - p = parentDir dir + where + p = parentDir dir {- Checks if the first FilePath is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc @@ -42,10 +42,10 @@ prop_parentDir_basics dir -} dirContains :: FilePath -> FilePath -> Bool dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b' - where - norm p = fromMaybe "" $ absNormPath p "." - a' = norm a - b' = norm b + where + norm p = fromMaybe "" $ absNormPath p "." + a' = norm a + b' = norm b {- Converts a filename into a normalized, absolute path. - @@ -60,8 +60,8 @@ absPath file = do - from the specified cwd. -} absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file - where - bad = error $ "unable to normalize " ++ file + where + bad = error $ "unable to normalize " ++ file {- Constructs a relative path from the CWD to a file. - @@ -78,31 +78,31 @@ relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f -} relPathDirToFile :: FilePath -> FilePath -> FilePath relPathDirToFile from to = join s $ dotdots ++ uncommon - where - s = [pathSeparator] - pfrom = split s from - pto = split s to - common = map fst $ takeWhile same $ zip pfrom pto - same (c,d) = c == d - uncommon = drop numcommon pto - dotdots = replicate (length pfrom - numcommon) ".." - numcommon = length common + where + s = [pathSeparator] + pfrom = split s from + pto = split s to + common = map fst $ takeWhile same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = replicate (length pfrom - numcommon) ".." + numcommon = length common prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to | from == to = null r | otherwise = not (null r) - where - r = relPathDirToFile from to + where + r = relPathDirToFile from to prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - where - {- Two paths have the same directory component at the same - - location, but it's not really the same directory. - - Code used to get this wrong. -} - same_dir_shortcurcuits_at_difference = - relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" + where + {- Two paths have the same directory component at the same + - location, but it's not really the same directory. + - Code used to get this wrong. -} + same_dir_shortcurcuits_at_difference = + relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" {- Given an original list of paths, and an expanded list derived from it, - generates a list of lists, where each sublist corresponds to one of the @@ -114,8 +114,8 @@ segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest - where - (found, rest)=partition (l `dirContains`) new + where + (found, rest)=partition (l `dirContains`) new {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In @@ -135,8 +135,8 @@ relHome path = do {- Checks if a command is available in PATH. -} inPath :: String -> IO Bool inPath command = getSearchPath >>= anyM indir - where - indir d = doesFileExist $ d </> command + where + indir d = doesFileExist $ d </> command {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} @@ -146,5 +146,5 @@ dotfile file | f == ".." = False | f == "" = False | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) - where - f = takeFileName file + where + f = takeFileName file diff --git a/Utility/Percentage.hs b/Utility/Percentage.hs index 309e00181..1c6b50062 100644 --- a/Utility/Percentage.hs +++ b/Utility/Percentage.hs @@ -28,11 +28,11 @@ showPercentage :: Int -> Percentage -> String showPercentage precision (Percentage p) | precision == 0 || remainder == 0 = go $ show int | otherwise = go $ show int ++ "." ++ strip0s (show remainder) - where - go v = v ++ "%" - int :: Integer - (int, frac) = properFraction (fromRational p) - remainder = floor (frac * multiplier) :: Integer - strip0s = reverse . dropWhile (== '0') . reverse - multiplier :: Float - multiplier = 10 ** (fromIntegral precision) + where + go v = v ++ "%" + int :: Integer + (int, frac) = properFraction (fromRational p) + remainder = floor (frac * multiplier) :: Integer + strip0s = reverse . dropWhile (== '0') . reverse + multiplier :: Float + multiplier = 10 ** (fromIntegral precision) diff --git a/Utility/Process.hs b/Utility/Process.hs index 14d40f0c4..11a9a4f38 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -59,11 +59,11 @@ readProcessEnv cmd args environ = output <- hGetContentsStrict h hClose h return output - where - p = (proc cmd args) - { std_out = CreatePipe - , env = environ - } + where + p = (proc cmd args) + { std_out = CreatePipe + , env = environ + } {- Writes a string to a process on its stdin, - returns its output, and also allows specifying the environment. @@ -99,13 +99,13 @@ writeReadProcessEnv cmd args environ input adjusthandle = do return output - where - p = (proc cmd args) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = Inherit - , env = environ - } + where + p = (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + , env = environ + } {- Waits for a ProcessHandle, and throws an IOError if the process - did not exit successfully. -} @@ -156,19 +156,19 @@ withHandle -> (Handle -> IO a) -> IO a withHandle h creator p a = creator p' $ a . select - where - base = p - { std_in = Inherit - , std_out = Inherit - , std_err = Inherit - } - (select, p') - | h == StdinHandle = - (stdinHandle, base { std_in = CreatePipe }) - | h == StdoutHandle = - (stdoutHandle, base { std_out = CreatePipe }) - | h == StderrHandle = - (stderrHandle, base { std_err = CreatePipe }) + where + base = p + { std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + (select, p') + | h == StdinHandle = + (stdinHandle, base { std_in = CreatePipe }) + | h == StdoutHandle = + (stdoutHandle, base { std_out = CreatePipe }) + | h == StderrHandle = + (stderrHandle, base { std_err = CreatePipe }) {- Like withHandle, but passes (stdin, stdout) handles to the action. -} withBothHandles @@ -177,12 +177,12 @@ withBothHandles -> ((Handle, Handle) -> IO a) -> IO a withBothHandles creator p a = creator p' $ a . bothHandles - where - p' = p - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = Inherit - } + where + p' = p + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + } {- Forces the CreateProcessRunner to run quietly; - both stdout and stderr are discarded. -} @@ -223,21 +223,21 @@ debugProcess p = do [ action ++ ":" , showCmd p ] - where - action - | piped (std_in p) && piped (std_out p) = "chat" - | piped (std_in p) = "feed" - | piped (std_out p) = "read" - | otherwise = "call" - piped Inherit = False - piped _ = True + where + action + | piped (std_in p) && piped (std_out p) = "chat" + | piped (std_in p) = "feed" + | piped (std_out p) = "read" + | otherwise = "call" + piped Inherit = False + piped _ = True {- Shows the command that a CreateProcess will run. -} showCmd :: CreateProcess -> String showCmd = go . cmdspec - where - go (ShellCommand s) = s - go (RawCommand c ps) = c ++ " " ++ show ps + where + go (ShellCommand s) = s + go (RawCommand c ps) = c ++ " " ++ show ps {- Wrappers for System.Process functions that do debug logging. - diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 68d27550c..09e7d8282 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -15,11 +15,11 @@ import Data.Char - shell. -} rsyncShell :: [CommandParam] -> [CommandParam] rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)] - where - {- rsync requires some weird, non-shell like quoting in - - here. A doubled single quote inside the single quoted - - string is a single quote. -} - escape s = "'" ++ join "''" (split "'" s) ++ "'" + where + {- rsync requires some weird, non-shell like quoting in + - here. A doubled single quote inside the single quoted + - string is a single quote. -} + escape s = "'" ++ join "''" (split "'" s) ++ "'" {- Runs rsync in server mode to send a file. -} rsyncServerSend :: FilePath -> IO Bool @@ -60,22 +60,22 @@ rsyncProgress callback params = do - on. Reap the resulting zombie. -} reapZombies return r - where - p = proc "rsync" (toCommand params) - feedprogress prev buf h = do - s <- hGetSomeString h 80 - if null s - then return True - else do - putStr s - hFlush stdout - let (mbytes, buf') = parseRsyncProgress (buf++s) - case mbytes of - Nothing -> feedprogress prev buf' h - (Just bytes) -> do - when (bytes /= prev) $ - callback bytes - feedprogress bytes buf' h + where + p = proc "rsync" (toCommand params) + feedprogress prev buf h = do + s <- hGetSomeString h 80 + if null s + then return True + else do + putStr s + hFlush stdout + let (mbytes, buf') = parseRsyncProgress (buf++s) + case mbytes of + Nothing -> feedprogress prev buf' h + (Just bytes) -> do + when (bytes /= prev) $ + callback bytes + feedprogress bytes buf' h {- Checks if an rsync url involves the remote shell (ssh or rsh). - Use of such urls with rsync requires additional shell @@ -84,13 +84,13 @@ rsyncUrlIsShell :: String -> Bool rsyncUrlIsShell s | "rsync://" `isPrefixOf` s = False | otherwise = go s - where - -- host::dir is rsync protocol, while host:dir is ssh/rsh - go [] = False - go (c:cs) - | c == '/' = False -- got to directory with no colon - | c == ':' = not $ ":" `isPrefixOf` cs - | otherwise = go cs + where + -- host::dir is rsync protocol, while host:dir is ssh/rsh + go [] = False + go (c:cs) + | c == '/' = False -- got to directory with no colon + | c == ':' = not $ ":" `isPrefixOf` cs + | otherwise = go cs {- Checks if a rsync url is really just a local path. -} rsyncUrlIsPath :: String -> Bool @@ -113,19 +113,19 @@ rsyncUrlIsPath s -} parseRsyncProgress :: String -> (Maybe Integer, String) parseRsyncProgress = go [] . reverse . progresschunks - where - go remainder [] = (Nothing, remainder) - go remainder (x:xs) = case parsebytes (findbytesstart x) of - Nothing -> go (delim:x++remainder) xs - Just b -> (Just b, remainder) + where + go remainder [] = (Nothing, remainder) + go remainder (x:xs) = case parsebytes (findbytesstart x) of + Nothing -> go (delim:x++remainder) xs + Just b -> (Just b, remainder) - delim = '\r' - {- Find chunks that each start with delim. - - The first chunk doesn't start with it - - (it's empty when delim is at the start of the string). -} - progresschunks = drop 1 . split [delim] - findbytesstart s = dropWhile isSpace s - parsebytes s = case break isSpace s of - ([], _) -> Nothing - (_, []) -> Nothing - (b, _) -> readish b + delim = '\r' + {- Find chunks that each start with delim. + - The first chunk doesn't start with it + - (it's empty when delim is at the start of the string). -} + progresschunks = drop 1 . split [delim] + findbytesstart s = dropWhile isSpace s + parsebytes s = case break isSpace s of + ([], _) -> Nothing + (_, []) -> Nothing + (b, _) -> readish b diff --git a/Utility/SRV.hs b/Utility/SRV.hs index bbfc7276d..9a099089e 100644 --- a/Utility/SRV.hs +++ b/Utility/SRV.hs @@ -74,11 +74,11 @@ lookupSRV (SRV srv) = do r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv print r return $ maybe [] (orderHosts . map tohosts) r - where - tohosts (priority, weight, port, hostname) = - ( (priority, weight) - , (B8.toString hostname, PortNumber $ fromIntegral port) - ) + where + tohosts (priority, weight, port, hostname) = + ( (priority, weight) + , (B8.toString hostname, PortNumber $ fromIntegral port) + ) #else lookupSRV = lookupSRVHost #endif @@ -93,21 +93,21 @@ lookupSRVHost (SRV srv) = catchDefaultIO [] $ parseSrvHost :: String -> [HostPort] parseSrvHost = orderHosts . catMaybes . map parse . lines - where - parse l = case words l of - [_, _, _, _, spriority, sweight, sport, hostname] -> do - let v = - ( readish sport :: Maybe Int - , readish spriority :: Maybe Int - , readish sweight :: Maybe Int + where + parse l = case words l of + [_, _, _, _, spriority, sweight, sport, hostname] -> do + let v = + ( readish sport :: Maybe Int + , readish spriority :: Maybe Int + , readish sweight :: Maybe Int + ) + case v of + (Just port, Just priority, Just weight) -> Just + ( (priority, weight) + , (hostname, PortNumber $ fromIntegral port) ) - case v of - (Just port, Just priority, Just weight) -> Just - ( (priority, weight) - , (hostname, PortNumber $ fromIntegral port) - ) - _ -> Nothing - _ -> Nothing + _ -> Nothing + _ -> Nothing orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort] orderHosts = map snd . sortBy (compare `on` fst) diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index fbea7b6b2..026456327 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -25,13 +25,13 @@ data CommandParam = Params String | Param String | File FilePath - a command and expects Strings. -} toCommand :: [CommandParam] -> [String] toCommand = (>>= unwrap) - where - unwrap (Param s) = [s] - unwrap (Params s) = filter (not . null) (split " " s) - -- Files that start with a dash are modified to avoid - -- the command interpreting them as options. - unwrap (File s@('-':_)) = ["./" ++ s] - unwrap (File s) = [s] + where + unwrap (Param s) = [s] + unwrap (Params s) = filter (not . null) (split " " s) + -- Files that start with a dash are modified to avoid + -- the command interpreting them as options. + unwrap (File s@('-':_)) = ["./" ++ s] + unwrap (File s) = [s] {- Run a system command, and returns True or False - if it succeeded or failed. @@ -41,9 +41,9 @@ boolSystem command params = boolSystemEnv command params Nothing boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ - where - dispatch ExitSuccess = True - dispatch _ = False + where + dispatch ExitSuccess = True + dispatch _ = False {- Runs a system command, returning the exit status. -} safeSystem :: FilePath -> [CommandParam] -> IO ExitCode @@ -59,26 +59,26 @@ safeSystemEnv command params environ = do - the shell. -} shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" - where - -- replace ' with '"'"' - escaped = join "'\"'\"'" $ split "'" f + where + -- replace ' with '"'"' + escaped = join "'\"'\"'" $ split "'" f {- Unescapes a set of shellEscaped words or filenames. -} shellUnEscape :: String -> [String] shellUnEscape [] = [] shellUnEscape s = word : shellUnEscape rest - where - (word, rest) = findword "" s - findword w [] = (w, "") - findword w (c:cs) - | c == ' ' = (w, cs) - | c == '\'' = inquote c w cs - | c == '"' = inquote c w cs - | otherwise = findword (w++[c]) cs - inquote _ w [] = (w, "") - inquote q w (c:cs) - | c == q = findword w cs - | otherwise = inquote q (w++[c]) cs + where + (word, rest) = findword "" s + findword w [] = (w, "") + findword w (c:cs) + | c == ' ' = (w, cs) + | c == '\'' = inquote c w cs + | c == '"' = inquote c w cs + | otherwise = findword (w++[c]) cs + inquote _ w [] = (w, "") + inquote q w (c:cs) + | c == q = findword w cs + | otherwise = inquote q (w++[c]) cs {- For quickcheck. -} prop_idempotent_shellEscape :: String -> Bool diff --git a/Utility/TSet.hs b/Utility/TSet.hs index 24d345477..bb711a4fb 100644 --- a/Utility/TSet.hs +++ b/Utility/TSet.hs @@ -23,12 +23,12 @@ getTSet :: TSet a -> IO [a] getTSet tset = runTSet $ do c <- readTChan tset go [c] - where - go l = do - v <- tryReadTChan tset - case v of - Nothing -> return l - Just c -> go (c:l) + where + go l = do + v <- tryReadTChan tset + case v of + Nothing -> return l + Just c -> go (c:l) {- Puts items into a TSet. -} putTSet :: TSet a -> [a] -> IO () diff --git a/Utility/Tense.hs b/Utility/Tense.hs index 135a90af2..60b3fa513 100644 --- a/Utility/Tense.hs +++ b/Utility/Tense.hs @@ -32,11 +32,11 @@ instance IsString TenseText where renderTense :: Tense -> TenseText -> Text renderTense tense (TenseText chunks) = T.concat $ map render chunks - where - render (Tensed present past) - | tense == Present = present - | otherwise = past - render (UnTensed s) = s + where + render (Tensed present past) + | tense == Present = present + | otherwise = past + render (UnTensed s) = s {- Builds up a TenseText, separating chunks with spaces. - @@ -45,13 +45,13 @@ renderTense tense (TenseText chunks) = T.concat $ map render chunks -} tenseWords :: [TenseChunk] -> TenseText tenseWords = TenseText . go [] - where - go c [] = reverse c - go c (w:[]) = reverse (w:c) - go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws - go c ((Tensed w1 w2):ws) = - go (Tensed (addspace w1) (addspace w2) : c) ws - addspace w = T.append w " " + where + go c [] = reverse c + go c (w:[]) = reverse (w:c) + go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws + go c ((Tensed w1 w2):ws) = + go (Tensed (addspace w1) (addspace w2) : c) ws + addspace w = T.append w " " unTensed :: Text -> TenseText unTensed t = TenseText [UnTensed t] diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index 6557398fd..96bccbe70 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -26,8 +26,8 @@ runEvery n a = forever $ do threadDelaySeconds :: Seconds -> IO () threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond) - where - oneSecond = 1000000 -- microseconds + where + oneSecond = 1000000 -- microseconds {- Like threadDelay, but not bounded by an Int. - @@ -52,6 +52,6 @@ waitForTermination = do whenM (queryTerminal stdInput) $ check keyboardSignal lock takeMVar lock - where - check sig lock = void $ - installHandler sig (CatchOnce $ putMVar lock ()) Nothing + where + check sig lock = void $ + installHandler sig (CatchOnce $ putMVar lock ()) Nothing diff --git a/Utility/Touch.hsc b/Utility/Touch.hsc index 0b1ca3d9b..53dd719fb 100644 --- a/Utility/Touch.hsc +++ b/Utility/Touch.hsc @@ -48,9 +48,9 @@ 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) + 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 @@ -70,10 +70,10 @@ touchBoth file atime mtime follow = 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 + where + flags + | follow = 0 + | otherwise = at_symlink_nofollow #else #if 0 @@ -108,10 +108,10 @@ touchBoth file atime mtime follow = r <- syscall f ptr when (r /= 0) $ throwErrno "touchBoth" - where - syscall = if follow - then c_lutimes - else c_utimes + where + syscall + | follow = c_lutimes + | otherwise = c_utimes #else #warning "utimensat and lutimes not available; building without symlink timestamp preservation support" diff --git a/Utility/Url.hs b/Utility/Url.hs index e47cb9dee..67efdb558 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -29,10 +29,10 @@ type Headers = [String] - also checking that its size, if available, matches a specified size. -} check :: URLString -> Headers -> Maybe Integer -> IO Bool check url headers expected_size = handle <$> exists url headers - where - handle (False, _) = False - handle (True, Nothing) = True - handle (True, s) = expected_size == s + where + handle (False, _) = False + handle (True, Nothing) = True + handle (True, s) = expected_size == s {- Checks that an url exists and could be successfully downloaded, - also returning its size if available. -} @@ -50,8 +50,8 @@ exists url headers = case parseURI url of case rspCode r of (2,_,_) -> return (True, size r) _ -> return (False, Nothing) - where - size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders + where + size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders {- Used to download large files, such as the contents of keys. - @@ -66,17 +66,17 @@ download :: URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool download url headers options file | "file://" `isPrefixOf` url = curl | otherwise = ifM (inPath "wget") (wget , curl) - where - headerparams = map (\h -> Param $ "--header=" ++ h) headers - wget = go "wget" $ headerparams ++ [Params "-c -O"] - {- 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. -} - curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"] - go cmd opts = boolSystem cmd $ - options++opts++[File file, File url] + where + headerparams = map (\h -> Param $ "--header=" ++ h) headers + wget = go "wget" $ headerparams ++ [Params "-c -O"] + {- 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. -} + curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"] + go cmd opts = boolSystem cmd $ + options++opts++[File file, File url] {- Downloads a small file. -} get :: URLString -> Headers -> IO String @@ -98,36 +98,36 @@ get url headers = -} request :: URI -> Headers -> RequestMethod -> IO (Response String) request url headers requesttype = go 5 url - where - go :: Int -> URI -> IO (Response String) - go 0 _ = error "Too many redirects " - go n u = do - rsp <- Browser.browse $ do - Browser.setErrHandler ignore - Browser.setOutHandler ignore - Browser.setAllowRedirects False - let req = mkRequest requesttype u :: Request_String - snd <$> Browser.request (addheaders req) - case rspCode rsp of - (3,0,x) | x /= 5 -> redir (n - 1) u rsp - _ -> return rsp - ignore = const noop - redir n u rsp = case retrieveHeaders HdrLocation rsp of - [] -> return rsp - (Header _ newu:_) -> - case parseURIReference newu of - Nothing -> return rsp - Just newURI -> go n newURI_abs - where + where + go :: Int -> URI -> IO (Response String) + go 0 _ = error "Too many redirects " + go n u = do + rsp <- Browser.browse $ do + Browser.setErrHandler ignore + Browser.setOutHandler ignore + Browser.setAllowRedirects False + let req = mkRequest requesttype u :: Request_String + snd <$> Browser.request (addheaders req) + case rspCode rsp of + (3,0,x) | x /= 5 -> redir (n - 1) u rsp + _ -> return rsp + ignore = const noop + redir n u rsp = case retrieveHeaders HdrLocation rsp of + [] -> return rsp + (Header _ newu:_) -> + case parseURIReference newu of + Nothing -> return rsp + Just newURI -> go n newURI_abs + where #if defined VERSION_network #if ! MIN_VERSION_network(2,4,0) #define WITH_OLD_URI #endif #endif #ifdef WITH_OLD_URI - newURI_abs = fromMaybe newURI (newURI `relativeTo` u) + newURI_abs = fromMaybe newURI (newURI `relativeTo` u) #else - newURI_abs = newURI `relativeTo` u + newURI_abs = newURI `relativeTo` u #endif - addheaders req = setHeaders req (rqHeaders req ++ userheaders) - userheaders = rights $ map parseHeader headers + addheaders req = setHeaders req (rqHeaders req ++ userheaders) + userheaders = rights $ map parseHeader headers diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index 6e757548a..bdddf4f8e 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -26,7 +26,7 @@ myUserName = myVal ["USER", "LOGNAME"] userName myVal :: [String] -> (UserEntry -> String) -> IO String myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars - where - check [] = return Nothing - check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v - getpwent = getUserEntryForID =<< getEffectiveUserID + where + check [] = return Nothing + check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v + getpwent = getUserEntryForID =<< getEffectiveUserID diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs index d586d7453..4f88cb9f2 100644 --- a/Utility/Verifiable.hs +++ b/Utility/Verifiable.hs @@ -33,5 +33,5 @@ calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v {- for quickcheck -} prop_verifiable_sane :: String -> String -> Bool prop_verifiable_sane a s = verify (mkVerifiable a secret) secret - where - secret = fromString s + where + secret = fromString s diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 0c3f6040d..6f64b2bdf 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -43,11 +43,11 @@ localhost = "localhost" - Note: The url *will* be visible to an attacker. -} runBrowser :: String -> (Maybe [(String, String)]) -> IO Bool runBrowser url env = boolSystemEnv cmd [Param url] env - where + where #ifdef darwin_HOST_OS - cmd = "open" + cmd = "open" #else - cmd = "xdg-open" + cmd = "xdg-open" #endif {- Binds to a socket on localhost, and runs a webapp on it. @@ -75,25 +75,25 @@ localSocket = do (v4addr:_, _) -> go v4addr (_, v6addr:_) -> go v6addr _ -> error "unable to bind to a local socket" - where - hints = defaultHints - { addrFlags = [AI_ADDRCONFIG] - , addrSocketType = Stream - } - {- Repeated attempts because bind sometimes fails for an - - unknown reason on OSX. -} - go addr = go' 100 addr - go' :: Int -> AddrInfo -> IO Socket - go' 0 _ = error "unable to bind to local socket" - go' n addr = do - r <- tryIO $ bracketOnError (open addr) sClose (use addr) - either (const $ go' (pred n) addr) return r - open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - use addr sock = do - setSocketOption sock ReuseAddr 1 - bindSocket sock (addrAddress addr) - listen sock maxListenQueue - return sock + where + hints = defaultHints + { addrFlags = [AI_ADDRCONFIG] + , addrSocketType = Stream + } + {- Repeated attempts because bind sometimes fails for an + - unknown reason on OSX. -} + go addr = go' 100 addr + go' :: Int -> AddrInfo -> IO Socket + go' 0 _ = error "unable to bind to local socket" + go' n addr = do + r <- tryIO $ bracketOnError (open addr) sClose (use addr) + either (const $ go' (pred n) addr) return r + open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + use addr sock = do + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress addr) + listen sock maxListenQueue + return sock {- Checks if debugging is actually enabled. -} debugEnabled :: IO Bool @@ -121,8 +121,8 @@ logRequest req = do --, frombs $ lookupRequestField "referer" req , frombs $ lookupRequestField "user-agent" req ] - where - frombs v = toString $ L.fromChunks [v] + where + frombs v = toString $ L.fromChunks [v] lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req @@ -179,12 +179,12 @@ insertAuthToken :: forall y. (y -> T.Text) -> Builder insertAuthToken extractToken predicate webapp root pathbits params = fromText root `mappend` encodePath pathbits' encodedparams - where - pathbits' = if null pathbits then [T.empty] else pathbits - encodedparams = map (TE.encodeUtf8 *** go) params' - go "" = Nothing - go x = Just $ TE.encodeUtf8 x - authparam = (T.pack "auth", extractToken webapp) - params' - | predicate pathbits = authparam:params - | otherwise = params + where + pathbits' = if null pathbits then [T.empty] else pathbits + encodedparams = map (TE.encodeUtf8 *** go) params' + go "" = Nothing + go x = Just $ TE.encodeUtf8 x + authparam = (T.pack "auth", extractToken webapp) + params' + | predicate pathbits = authparam:params + | otherwise = params |