summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-12-13 00:24:19 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-12-13 00:24:19 -0400
commit94554782894ec6c26da3b46312d5d1d16d596458 (patch)
tree78746106bfb153945ccbfd2bbae536081c005e91 /Utility
parent55bd61d8c42aaf36a3c57f8444c493f6b045f4cd (diff)
finished where indentation changes
Diffstat (limited to 'Utility')
-rw-r--r--Utility/Base64.hs2
-rw-r--r--Utility/CopyFile.hs12
-rw-r--r--Utility/DBus.hs16
-rw-r--r--Utility/Daemon.hs70
-rw-r--r--Utility/DataUnits.hs78
-rw-r--r--Utility/Directory.hs70
-rw-r--r--Utility/DiskFree.hs4
-rw-r--r--Utility/Dot.hs28
-rw-r--r--Utility/FileMode.hs16
-rw-r--r--Utility/Format.hs190
-rw-r--r--Utility/FreeDesktop.hs21
-rw-r--r--Utility/Gpg.hs66
-rw-r--r--Utility/HumanTime.hs14
-rw-r--r--Utility/INotify.hs194
-rw-r--r--Utility/JSONStream.hs8
-rw-r--r--Utility/Kqueue.hs196
-rw-r--r--Utility/LogFile.hs12
-rw-r--r--Utility/Lsof.hs72
-rw-r--r--Utility/Matcher.hs48
-rw-r--r--Utility/Misc.hs34
-rw-r--r--Utility/Mounts.hsc30
-rw-r--r--Utility/Network.hs5
-rw-r--r--Utility/NotificationBroadcaster.hs18
-rw-r--r--Utility/Parallel.hs20
-rw-r--r--Utility/Path.hs70
-rw-r--r--Utility/Percentage.hs16
-rw-r--r--Utility/Process.hs84
-rw-r--r--Utility/Rsync.hs86
-rw-r--r--Utility/SRV.hs38
-rw-r--r--Utility/SafeCommand.hs50
-rw-r--r--Utility/TSet.hs12
-rw-r--r--Utility/Tense.hs24
-rw-r--r--Utility/ThreadScheduler.hs10
-rw-r--r--Utility/Touch.hsc22
-rw-r--r--Utility/Url.hs84
-rw-r--r--Utility/UserInfo.hs8
-rw-r--r--Utility/Verifiable.hs4
-rw-r--r--Utility/WebApp.hs66
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