summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
Diffstat (limited to 'Utility')
-rw-r--r--Utility/CoProcess.hs14
-rw-r--r--Utility/Daemon.hs61
-rw-r--r--Utility/DirWatcher.hs36
-rw-r--r--Utility/DiskFree.hs2
-rw-r--r--Utility/FreeDesktop.hs126
-rw-r--r--Utility/Gpg.hs38
-rw-r--r--Utility/INotify.hs7
-rw-r--r--Utility/Kqueue.hs68
-rw-r--r--Utility/Lsof.hs10
-rw-r--r--Utility/Misc.hs9
-rw-r--r--Utility/Mounts.hsc69
-rw-r--r--Utility/Network.hs22
-rw-r--r--Utility/NotificationBroadcaster.hs77
-rw-r--r--Utility/Parallel.hs35
-rw-r--r--Utility/Path.hs8
-rw-r--r--Utility/Process.hs214
-rw-r--r--Utility/RsyncFile.hs6
-rw-r--r--Utility/SafeCommand.hs45
-rw-r--r--Utility/TSet.hs39
-rw-r--r--Utility/TempFile.hs2
-rw-r--r--Utility/Tense.hs57
-rw-r--r--Utility/Types/DirWatcher.hs3
-rw-r--r--Utility/WebApp.hs179
-rw-r--r--Utility/Yesod.hs17
-rw-r--r--Utility/libmounts.c103
-rw-r--r--Utility/libmounts.h33
26 files changed, 1147 insertions, 133 deletions
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index 9fa8d864f..67f861bb3 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -13,23 +13,23 @@ module Utility.CoProcess (
query
) where
-import System.Cmd.Utils
-
import Common
-type CoProcessHandle = (PipeHandle, Handle, Handle)
+type CoProcessHandle = (ProcessHandle, Handle, Handle, CreateProcess)
start :: FilePath -> [String] -> IO CoProcessHandle
-start command params = hPipeBoth command params
+start command params = do
+ (from, to, _err, pid) <- runInteractiveProcess command params Nothing Nothing
+ return (pid, to, from, proc command params)
stop :: CoProcessHandle -> IO ()
-stop (pid, from, to) = do
+stop (pid, from, to, p) = do
hClose to
hClose from
- forceSuccess pid
+ forceSuccessProcess p pid
query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
-query (_, from, to) send receive = do
+query (_, from, to, _) send receive = do
_ <- send to
hFlush to
receive from
diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index f36a761d0..ba2b2c9c3 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -27,7 +27,7 @@ daemonize logfd pidfile changedirectory a = do
_ <- forkProcess child2
out
child2 = do
- maybe noop (lockPidFile alreadyrunning) pidfile
+ maybe noop lockPidFile pidfile
when changedirectory $
setCurrentDirectory "/"
nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
@@ -39,47 +39,56 @@ daemonize logfd pidfile changedirectory a = do
redir newh h = do
closeFd h
dupTo newh h
- alreadyrunning = error "Daemon is already running."
out = exitImmediately ExitSuccess
{- Locks the pid file, with an exclusive, non-blocking lock.
- - Runs an action on failure. On success, writes the pid to the file,
- - fully atomically. -}
-lockPidFile :: IO () -> FilePath -> IO ()
-lockPidFile onfailure file = do
+ - Writes the pid to the file, fully atomically.
+ - Fails if the pid file is already locked by another process. -}
+lockPidFile :: FilePath -> IO ()
+lockPidFile file = do
fd <- openFd file ReadWrite (Just stdFileMode) defaultFileFlags
locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags
{ trunc = True }
locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0)
case (locked, locked') of
- (Nothing, _) -> onfailure
- (_, Nothing) -> onfailure
+ (Nothing, _) -> alreadyrunning
+ (_, Nothing) -> alreadyrunning
_ -> do
_ <- fdWrite fd' =<< show <$> getProcessID
renameFile newfile file
closeFd fd
where
newfile = file ++ ".new"
+ alreadyrunning = error "Daemon is already running."
-{- Stops the daemon.
- -
- - The pid file is used to get the daemon's pid.
+{- Checks if the daemon is running, by checking that the pid file
+ - is locked by the same process that is listed in the pid file.
-
- - To guard against a stale pid, check the lock of the pid file,
- - and compare the process that has it locked with the file content.
- -}
-stopDaemon :: FilePath -> IO ()
-stopDaemon pidfile = do
- fd <- openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
- locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
- p <- readish <$> readFile pidfile
- case (locked, p) of
- (Nothing, _) -> noop
- (_, Nothing) -> noop
- (Just (pid, _), Just pid')
- | pid == pid' -> signalProcess sigTERM pid
- | otherwise -> error $
+ - If it's running, returns its pid. -}
+checkDaemon :: FilePath -> IO (Maybe ProcessID)
+checkDaemon pidfile = do
+ v <- catchMaybeIO $
+ openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
+ case v of
+ Just fd -> do
+ locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
+ 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 ++ " )"
+ "; 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
diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs
index 11ce7baef..213aeb50a 100644
--- a/Utility/DirWatcher.hs
+++ b/Utility/DirWatcher.hs
@@ -17,10 +17,10 @@ import Utility.Types.DirWatcher
#if WITH_INOTIFY
import qualified Utility.INotify as INotify
import qualified System.INotify as INotify
-import Utility.ThreadScheduler
#endif
#if WITH_KQUEUE
import qualified Utility.Kqueue as Kqueue
+import Control.Concurrent
#endif
type Pruner = FilePath -> Bool
@@ -72,19 +72,41 @@ closingTracked = undefined
#endif
#endif
+/* Starts a watcher thread. The runStartup action is passed a scanner action
+ * to run, that will return once the initial directory scan is complete.
+ * Once runStartup returns, the watcher thread continues running,
+ * and processing events. Returns a DirWatcherHandle that can be used
+ * to shutdown later. */
#if WITH_INOTIFY
-watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO ()
-watchDir dir prune hooks runstartup = INotify.withINotify $ \i -> do
+type DirWatcherHandle = INotify.INotify
+watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
+watchDir dir prune hooks runstartup = do
+ i <- INotify.initINotify
runstartup $ INotify.watchDir i dir prune hooks
- waitForTermination -- Let the inotify thread run.
+ return i
#else
#if WITH_KQUEUE
-watchDir :: FilePath -> Pruner -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO ()
+type DirWatcherHandle = ThreadId
+watchDir :: FilePath -> Pruner -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle
watchDir dir ignored hooks runstartup = do
kq <- runstartup $ Kqueue.initKqueue dir ignored
- Kqueue.runHooks kq hooks
+ forkIO $ Kqueue.runHooks kq hooks
#else
-watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO ()
+type DirWatcherHandle = ()
+watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
watchDir = undefined
#endif
#endif
+
+#if WITH_INOTIFY
+stopWatchDir :: DirWatcherHandle -> IO ()
+stopWatchDir = INotify.killINotify
+#else
+#if WITH_KQUEUE
+stopWatchDir :: DirWatcherHandle -> IO ()
+stopWatchDir = killThread
+#else
+stopWatchDir :: DirWatcherHandle -> IO ()
+stopWatchDir = undefined
+#endif
+#endif
diff --git a/Utility/DiskFree.hs b/Utility/DiskFree.hs
index ff7070562..18c7f2ee6 100644
--- a/Utility/DiskFree.hs
+++ b/Utility/DiskFree.hs
@@ -15,7 +15,7 @@ import Foreign.C.Types
import Foreign.C.String
import Foreign.C.Error
-foreign import ccall unsafe "libdiskfree.h diskfree" c_diskfree
+foreign import ccall safe "libdiskfree.h diskfree" c_diskfree
:: CString -> IO CULLong
getDiskFree :: FilePath -> IO (Maybe Integer)
diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs
new file mode 100644
index 000000000..a1109f729
--- /dev/null
+++ b/Utility/FreeDesktop.hs
@@ -0,0 +1,126 @@
+{- Freedesktop.org specifications
+ -
+ - http://standards.freedesktop.org/basedir-spec/latest/
+ - http://standards.freedesktop.org/desktop-entry-spec/latest/
+ - http://standards.freedesktop.org/menu-spec/latest/
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.FreeDesktop (
+ DesktopEntry,
+ genDesktopEntry,
+ buildDesktopMenuFile,
+ writeDesktopMenuFile,
+ desktopMenuFilePath,
+ autoStartPath,
+ systemDataDir,
+ systemConfigDir,
+ userDataDir,
+ userConfigDir,
+ userDesktopDir
+) where
+
+import Utility.Exception
+import Utility.Path
+import Utility.Process
+import Utility.PartialPrelude
+
+import System.Environment
+import System.Directory
+import System.FilePath
+import Data.List
+import Data.String.Utils
+import Control.Applicative
+
+type DesktopEntry = [(Key, Value)]
+
+type Key = String
+
+data Value = StringV String | BoolV Bool | NumericV Float | ListV [Value]
+
+toString :: Value -> String
+toString (StringV s) = s
+toString (BoolV b)
+ | b = "true"
+ | otherwise = "false"
+toString(NumericV f) = show f
+toString (ListV l)
+ | null l = ""
+ | otherwise = (intercalate ";" $ map (escapesemi . toString) l) ++ ";"
+ where
+ escapesemi = join "\\;" . split ";"
+
+genDesktopEntry :: String -> String -> Bool -> FilePath -> [String] -> DesktopEntry
+genDesktopEntry name comment terminal program categories =
+ [ item "Type" StringV "Application"
+ , item "Version" NumericV 1.0
+ , item "Name" StringV name
+ , item "Comment" StringV comment
+ , item "Terminal" BoolV terminal
+ , item "Exec" StringV program
+ , item "Categories" ListV (map StringV categories)
+ ]
+ 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
+
+writeDesktopMenuFile :: DesktopEntry -> String -> IO ()
+writeDesktopMenuFile d file = do
+ createDirectoryIfMissing True (parentDir file)
+ writeFile file $ buildDesktopMenuFile d
+
+{- Path to use for a desktop menu file, in either the systemDataDir or
+ - the userDataDir -}
+desktopMenuFilePath :: String -> FilePath -> FilePath
+desktopMenuFilePath basename datadir =
+ datadir </> "applications" </> desktopfile basename
+
+{- Path to use for a desktop autostart file, in either the systemDataDir
+ - or the userDataDir -}
+autoStartPath :: String -> FilePath -> FilePath
+autoStartPath basename configdir =
+ configdir </> "autostart" </> desktopfile basename
+
+desktopfile :: FilePath -> FilePath
+desktopfile f = f ++ ".desktop"
+
+{- Directory used for installation of system wide data files.. -}
+systemDataDir :: FilePath
+systemDataDir = "/usr/share"
+
+{- Directory used for installation of system wide config files. -}
+systemConfigDir :: FilePath
+systemConfigDir = "/etc/xdg"
+
+{- Directory for user data files. -}
+userDataDir :: IO FilePath
+userDataDir = xdgEnvHome "DATA_HOME" ".local/share"
+
+{- Directory for user config files. -}
+userConfigDir :: IO FilePath
+userConfigDir = xdgEnvHome "CONFIG_HOME" ".config"
+
+{- Directory for the user's Desktop, may be localized.
+ -
+ - This is not looked up very fast; the config file is in a shell format
+ - that is best parsed by shell, so xdg-user-dir is used, with a fallback
+ - 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"
+
+xdgEnvHome :: String -> String -> IO String
+xdgEnvHome envbase homedef = do
+ home <- myHomeDir
+ catchDefaultIO (getEnv $ "XDG_" ++ envbase) (home </> homedef)
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index e13afe5d4..eed77805c 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -11,8 +11,7 @@ import qualified Data.ByteString.Lazy as L
import System.Posix.Types
import Control.Applicative
import Control.Concurrent
-import Control.Exception (finally, bracket)
-import System.Exit
+import Control.Exception (bracket)
import System.Posix.Env (setEnv, unsetEnv, getEnv)
import Common
@@ -39,18 +38,21 @@ stdParams params = do
readStrict :: [CommandParam] -> IO String
readStrict params = do
params' <- stdParams params
- pOpen ReadFromPipe "gpg" params' hGetContentsStrict
+ withHandle StdoutHandle createProcessSuccess (proc "gpg" params') $ \h -> do
+ hSetBinaryMode h True
+ hGetContentsStrict h
{- Runs gpg, piping an input value to it, and returning its stdout,
- strictly. -}
pipeStrict :: [CommandParam] -> String -> IO String
pipeStrict params input = do
params' <- stdParams params
- (pid, fromh, toh) <- hPipeBoth "gpg" params'
- _ <- forkIO $ finally (hPutStr toh input) (hClose toh)
- output <- hGetContentsStrict fromh
- forceSuccess pid
- return output
+ withBothHandles createProcessSuccess (proc "gpg" params') $ \(to, from) -> do
+ hSetBinaryMode to True
+ hSetBinaryMode from True
+ hPutStr to input
+ hClose to
+ hGetContentsStrict from
{- Runs gpg with some parameters, first feeding it a passphrase via
- --passphrase-fd, then feeding it an input, and passing a handle
@@ -70,19 +72,13 @@ passphraseHandle params passphrase a b = do
let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]
params' <- stdParams $ passphrasefd ++ params
- (pid, fromh, toh) <- hPipeBoth "gpg" params'
- pid2 <- forkProcess $ do
- L.hPut toh =<< a
- hClose toh
- exitSuccess
- hClose toh
- ret <- b fromh
-
- -- cleanup
- forceSuccess pid
- _ <- getProcessStatus True False pid2
- closeFd frompipe
- return ret
+ closeFd frompipe `after`
+ withBothHandles createProcessSuccess (proc "gpg" params') go
+ where
+ go (to, from) = do
+ L.hPut to =<< a
+ hClose to
+ b from
{- Finds gpg public keys matching some string. (Could be an email address,
- a key id, or a name. -}
diff --git a/Utility/INotify.hs b/Utility/INotify.hs
index bf87f4e71..6af022819 100644
--- a/Utility/INotify.hs
+++ b/Utility/INotify.hs
@@ -160,12 +160,9 @@ tooManyWatches hook dir = do
querySysctl :: Read a => [CommandParam] -> IO (Maybe a)
querySysctl ps = do
- v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps
+ v <- catchMaybeIO $ readProcess "sysctl" (toCommand ps)
case v of
Nothing -> return Nothing
- Just (pid, h) -> do
- val <- parsesysctl <$> hGetContentsStrict h
- void $ getProcessStatus True False $ processID pid
- return val
+ Just s -> return $ parsesysctl s
where
parsesysctl s = readish =<< lastMaybe (words s)
diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs
index 7e7e653ec..f44893195 100644
--- a/Utility/Kqueue.hs
+++ b/Utility/Kqueue.hs
@@ -14,8 +14,6 @@ module Utility.Kqueue (
waitChange,
Change(..),
changedFile,
- isAdd,
- isDelete,
runHooks,
) where
@@ -34,19 +32,19 @@ import Control.Concurrent
data Change
= Deleted FilePath
+ | DeletedDir FilePath
| Added FilePath
deriving (Show)
isAdd :: Change -> Bool
isAdd (Added _) = True
isAdd (Deleted _) = False
-
-isDelete :: Change -> Bool
-isDelete = not . isAdd
+isAdd (DeletedDir _) = False
changedFile :: Change -> FilePath
changedFile (Added f) = f
changedFile (Deleted f) = f
+changedFile (DeletedDir f) = f
data Kqueue = Kqueue
{ kqueueFd :: Fd
@@ -59,27 +57,43 @@ type Pruner = FilePath -> Bool
type DirMap = M.Map Fd DirInfo
-{- A directory, and its last known contents (with filenames relative to it) -}
+{- Enough information to uniquely identify a file in a directory,
+ - but not too much. -}
+data DirEnt = DirEnt
+ { dirEnt :: FilePath -- relative to the parent directory
+ , _dirInode :: FileID -- included to notice file replacements
+ , isSubDir :: Bool
+ }
+ deriving (Eq, Ord, Show)
+
+{- A directory, and its last known contents. -}
data DirInfo = DirInfo
{ dirName :: FilePath
- , dirCache :: S.Set FilePath
+ , dirCache :: S.Set DirEnt
}
deriving (Show)
getDirInfo :: FilePath -> IO DirInfo
getDirInfo dir = do
- contents <- S.fromList . filter (not . dirCruft)
- <$> getDirectoryContents dir
+ 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)
{- Difference between the dirCaches of two DirInfos. -}
(//) :: DirInfo -> DirInfo -> [Change]
oldc // newc = deleted ++ added
where
- deleted = calc Deleted oldc newc
- added = calc Added newc oldc
- calc a x y = map a . map (dirName x </>) $
- S.toList $ S.difference (dirCache x) (dirCache y)
+ 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. -}
@@ -99,7 +113,7 @@ scanRecursive topdir prune = M.fromList <$> walk [] [topdir]
case mfd of
Nothing -> walk c rest
Just fd -> do
- let subdirs = map (dir </>) $
+ let subdirs = map (dir </>) . map dirEnt $
S.toList $ dirCache info
walk ((fd, info):c) (subdirs ++ rest)
@@ -123,15 +137,16 @@ removeSubDir dirmap dir = do
findDirContents :: DirMap -> FilePath -> [FilePath]
findDirContents dirmap dir = concatMap absolutecontents $ search
where
- absolutecontents i = map (dirName i </>) (S.toList $ dirCache i)
+ 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 unsafe "libkqueue.h init_kqueue" c_init_kqueue
+foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue
:: IO Fd
-foreign import ccall unsafe "libkqueue.h addfds_kqueue" c_addfds_kqueue
+foreign import ccall safe "libkqueue.h addfds_kqueue" c_addfds_kqueue
:: Fd -> CInt -> Ptr Fd -> IO ()
-foreign import ccall unsafe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue
+foreign import ccall safe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue
:: Fd -> IO Fd
{- Initializes a Kqueue to watch a directory, and all its subdirectories. -}
@@ -224,12 +239,14 @@ runHooks kq hooks = do
(q', changes) <- waitChange q
forM_ changes $ dispatch (kqueueMap q')
loop q'
- -- Kqueue returns changes for both whole directories
- -- being added and deleted, and individual files being
- -- added and deleted.
- dispatch dirmap change
- | isAdd change = withstatus change $ dispatchadd dirmap
- | otherwise = callhook delDirHook Nothing change
+
+ 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
@@ -237,12 +254,15 @@ runHooks kq hooks = do
| 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/Lsof.hs b/Utility/Lsof.hs
index 0061dfe57..ce6a16283 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -33,11 +33,11 @@ queryDir path = query ["+d", path]
- Note: If lsof is not available, this always returns [] !
-}
query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
-query opts = do
- (pid, s) <- pipeFrom "lsof" ("-F0can" : opts)
- let !r = parse s
- void $ getProcessStatus True False $ processID pid
- return r
+query opts =
+ withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do
+ parse <$> hGetContentsStrict h
+ where
+ p = proc "lsof" ("-F0can" : opts)
{- Parsing null-delimited output like:
-
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 3b359139b..77ebb4f3d 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -33,7 +33,7 @@ separate c l = unbreak $ break c l
| otherwise = (a, tail b)
{- Breaks out the first line. -}
-firstLine :: String-> String
+firstLine :: String -> String
firstLine = takeWhile (/= '\n')
{- Splits a list into segments that are delimited by items matching
@@ -45,3 +45,10 @@ segment p l = map reverse $ go [] [] l
go c r (i:is)
| p i = go [] (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. -}
+thenOrd :: Ordering -> Ordering -> Ordering
+thenOrd EQ x = x
+thenOrd x _ = x
+{-# INLINE thenOrd #-}
diff --git a/Utility/Mounts.hsc b/Utility/Mounts.hsc
new file mode 100644
index 000000000..0b1468521
--- /dev/null
+++ b/Utility/Mounts.hsc
@@ -0,0 +1,69 @@
+{- Interface to mtab (and fstab)
+ -
+ - Derived from hsshellscript, originally written by
+ - Volker Wysk <hsss@volker-wysk.de>
+ -
+ - Modified to support BSD and Mac OS X by
+ - Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU LGPL version 2.1 or higher.
+ -}
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Utility.Mounts (
+ Mntent(..),
+ getMounts
+) where
+
+import Control.Monad
+import Foreign
+import Foreign.C
+import GHC.IO hiding (finally, bracket)
+import Prelude hiding (catch)
+
+#include "libmounts.h"
+
+{- This is a stripped down mntent, containing only
+ - fields available everywhere. -}
+data Mntent = Mntent
+ { mnt_fsname :: String
+ , mnt_dir :: FilePath
+ , mnt_type :: String
+ } deriving (Read, Show, Eq, Ord)
+
+getMounts :: IO [Mntent]
+getMounts = do
+ h <- c_mounts_start
+ when (h == nullPtr) $
+ throwErrno "getMounts"
+ mntent <- getmntent h []
+ _ <- 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)
+
+{- Using unsafe imports because the C functions are belived to never block.
+ - Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking;
+ - while getmntent only accesses a file in /etc (or /proc) that should not
+ - block. -}
+foreign import ccall unsafe "libmounts.h mounts_start" c_mounts_start
+ :: IO (Ptr ())
+foreign import ccall unsafe "libmounts.h mounts_next" c_mounts_next
+ :: Ptr () -> IO (Ptr ())
+foreign import ccall unsafe "libmounts.h mounts_end" c_mounts_end
+ :: Ptr () -> IO CInt
diff --git a/Utility/Network.hs b/Utility/Network.hs
new file mode 100644
index 000000000..bedb37dc9
--- /dev/null
+++ b/Utility/Network.hs
@@ -0,0 +1,22 @@
+{- network functions
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Network where
+
+import Utility.Process
+import Utility.Exception
+
+import Control.Applicative
+
+{- Haskell lacks uname(2) bindings, except in the
+ - Bindings.Uname addon. Rather than depend on that,
+ - use uname -n when available. -}
+getHostname :: IO (Maybe String)
+getHostname = catchMaybeIO uname_node
+ where
+ uname_node = takeWhile (/= '\n') <$>
+ readProcess "uname" ["-n"]
diff --git a/Utility/NotificationBroadcaster.hs b/Utility/NotificationBroadcaster.hs
new file mode 100644
index 000000000..accc35fe1
--- /dev/null
+++ b/Utility/NotificationBroadcaster.hs
@@ -0,0 +1,77 @@
+{- notification broadcaster
+ -
+ - This is used to allow clients to block until there is a new notification
+ - that some thing occurred. It does not communicate what the change is,
+ - it only provides blocking reads to wait on notifications.
+ -
+ - Multiple clients are supported. Each has a unique id.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.NotificationBroadcaster (
+ NotificationBroadcaster,
+ NotificationHandle,
+ NotificationId,
+ newNotificationBroadcaster,
+ newNotificationHandle,
+ notificationHandleToId,
+ notificationHandleFromId,
+ sendNotification,
+ waitNotification,
+) where
+
+import Common
+
+import Control.Concurrent.STM
+import Control.Concurrent.SampleVar
+
+{- One SampleVar per client. The TMVar is never empty, so never blocks. -}
+type NotificationBroadcaster = TMVar [SampleVar ()]
+
+newtype NotificationId = NotificationId Int
+ deriving (Read, Show, Eq, Ord)
+
+{- Handle given out to an individual client. -}
+data NotificationHandle = NotificationHandle NotificationBroadcaster NotificationId
+
+newNotificationBroadcaster :: IO NotificationBroadcaster
+newNotificationBroadcaster = atomically $ newTMVar []
+
+{- Allocates a notification handle for a client to use. -}
+newNotificationHandle :: NotificationBroadcaster -> IO NotificationHandle
+newNotificationHandle b = NotificationHandle
+ <$> pure b
+ <*> addclient
+ where
+ addclient = do
+ s <- newEmptySampleVar
+ 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. -}
+notificationHandleToId :: NotificationHandle -> NotificationId
+notificationHandleToId (NotificationHandle _ i) = i
+
+notificationHandleFromId :: NotificationBroadcaster -> NotificationId -> NotificationHandle
+notificationHandleFromId = NotificationHandle
+
+{- Sends a notification to all clients. -}
+sendNotification :: NotificationBroadcaster -> IO ()
+sendNotification b = do
+ l <- atomically $ readTMVar b
+ mapM_ notify l
+ where
+ notify s = writeSampleVar s ()
+
+{- Used by a client to block until a new notification is available since
+ - the last time it tried. -}
+waitNotification :: NotificationHandle -> IO ()
+waitNotification (NotificationHandle b (NotificationId i)) = do
+ l <- atomically $ readTMVar b
+ readSampleVar (l !! i)
diff --git a/Utility/Parallel.hs b/Utility/Parallel.hs
new file mode 100644
index 000000000..373a0ece5
--- /dev/null
+++ b/Utility/Parallel.hs
@@ -0,0 +1,35 @@
+{- parallel processing via threads
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Parallel where
+
+import Common
+
+import Control.Concurrent
+import Control.Exception
+
+{- Runs an action in parallel with a set of values, in a set of threads.
+ - In order for the actions to truely run in parallel, requires GHC's
+ - threaded runtime,
+ -
+ - Returns the values partitioned into ones with which the action succeeded,
+ - and ones with which it failed. -}
+inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])
+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
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 76fbc6c4a..209ff1b0f 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -132,6 +132,14 @@ runPreserveOrder a files = preserveOrder files <$> a files
myHomeDir :: IO FilePath
myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID)
+{- Converts paths in the home directory to use ~/ -}
+relHome :: FilePath -> IO String
+relHome path = do
+ home <- myHomeDir
+ return $ if dirContains home path
+ then "~/" ++ relPathDirToFile home path
+ else path
+
{- Checks if a command is available in PATH. -}
inPath :: String -> IO Bool
inPath command = getSearchPath >>= anyM indir
diff --git a/Utility/Process.hs b/Utility/Process.hs
new file mode 100644
index 000000000..5c29bbdfb
--- /dev/null
+++ b/Utility/Process.hs
@@ -0,0 +1,214 @@
+{- System.Process enhancements, including additional ways of running
+ - processes, and logging.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE Rank2Types #-}
+
+module Utility.Process (
+ module X,
+ CreateProcess,
+ StdHandle(..),
+ readProcessEnv,
+ forceSuccessProcess,
+ checkSuccessProcess,
+ createProcessSuccess,
+ createProcessChecked,
+ createBackgroundProcess,
+ withHandle,
+ withBothHandles,
+ createProcess,
+ runInteractiveProcess,
+ writeReadProcess,
+ readProcess
+) where
+
+import qualified System.Process
+import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
+import System.Process hiding (createProcess, runInteractiveProcess, readProcess)
+import System.Exit
+import System.IO
+import System.Log.Logger
+
+import Utility.Misc
+
+type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
+
+data StdHandle = StdinHandle | StdoutHandle | StderrHandle
+ deriving (Eq)
+
+{- Like readProcess, but allows specifying the environment, and does
+ - not mess with stdin. -}
+readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
+readProcessEnv cmd args environ =
+ withHandle StdoutHandle createProcessSuccess p $ \h -> do
+ output <- hGetContentsStrict h
+ hClose h
+ return output
+ where
+ p = (proc cmd args)
+ { std_out = CreatePipe
+ , env = environ
+ }
+
+{- Waits for a ProcessHandle, and throws an exception if the process
+ - did not exit successfully. -}
+forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
+forceSuccessProcess p pid = do
+ code <- waitForProcess pid
+ case code of
+ ExitSuccess -> return ()
+ ExitFailure n -> error $ showCmd p ++ " exited " ++ show n
+
+{- Waits for a ProcessHandle and returns True if it exited successfully. -}
+checkSuccessProcess :: ProcessHandle -> IO Bool
+checkSuccessProcess pid = do
+ code <- waitForProcess pid
+ return $ code == ExitSuccess
+
+{- Runs createProcess, then an action on its handles, and then
+ - forceSuccessProcess. -}
+createProcessSuccess :: CreateProcessRunner
+createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
+
+{- Runs createProcess, then an action on its handles, and then
+ - an action on its exit code. -}
+createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
+createProcessChecked checker p a = do
+ t@(_, _, _, pid) <- createProcess p
+ r <- a t
+ _ <- checker pid
+ return r
+
+{- Leaves the process running, suitable for lazy streaming.
+ - Note: Zombies will result, and must be waited on. -}
+createBackgroundProcess :: CreateProcessRunner
+createBackgroundProcess p a = a =<< createProcess p
+
+{- Runs a CreateProcessRunner, on a CreateProcess structure, that
+ - is adjusted to pipe only from/to a single StdHandle, and passes
+ - the resulting Handle to an action. -}
+withHandle
+ :: StdHandle
+ -> CreateProcessRunner
+ -> CreateProcess
+ -> (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 })
+
+{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
+withBothHandles
+ :: CreateProcessRunner
+ -> CreateProcess
+ -> ((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
+ }
+
+{- Extract a desired handle from createProcess's tuple.
+ - These partial functions are safe as long as createProcess is run
+ - with appropriate parameters to set up the desired handle.
+ - Get it wrong and the runtime crash will always happen, so should be
+ - easily noticed. -}
+type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
+stdinHandle :: HandleExtractor
+stdinHandle (Just h, _, _, _) = h
+stdinHandle _ = error "expected stdinHandle"
+stdoutHandle :: HandleExtractor
+stdoutHandle (_, Just h, _, _) = h
+stdoutHandle _ = error "expected stdoutHandle"
+stderrHandle :: HandleExtractor
+stderrHandle (_, _, Just h, _) = h
+stderrHandle _ = error "expected stderrHandle"
+bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+bothHandles (Just hin, Just hout, _, _) = (hin, hout)
+bothHandles _ = error "expected bothHandles"
+
+{- Debugging trace for a CreateProcess. -}
+debugProcess :: CreateProcess -> IO ()
+debugProcess p = do
+ debugM "Utility.Process" $ unwords
+ [ action ++ ":"
+ , showCmd p
+ , maybe "" show (env 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
+
+{- 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
+
+{- Wrappers for System.Process functions that do debug logging.
+ -
+ - More could be added, but these are the only ones I usually need.
+ -}
+
+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+createProcess p = do
+ debugProcess p
+ System.Process.createProcess p
+
+runInteractiveProcess
+ :: FilePath
+ -> [String]
+ -> Maybe FilePath
+ -> Maybe [(String, String)]
+ -> IO (Handle, Handle, Handle, ProcessHandle)
+runInteractiveProcess f args c e = do
+ debugProcess $ (proc f args)
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ System.Process.runInteractiveProcess f args c e
+
+{- I think this is a more descriptive name than System.Process.readProcess. -}
+writeReadProcess
+ :: FilePath
+ -> [String]
+ -> String
+ -> IO String
+writeReadProcess f args input = do
+ debugProcess $ (proc f args) { std_out = CreatePipe, std_in = CreatePipe }
+ System.Process.readProcess f args input
+
+{- Normally, when reading from a process, it does not need to be fed any
+ - input. -}
+readProcess
+ :: FilePath
+ -> [String]
+ -> IO String
+readProcess f args = do
+ debugProcess $ (proc f args) { std_out = CreatePipe }
+ System.Process.readProcess f args []
diff --git a/Utility/RsyncFile.hs b/Utility/RsyncFile.hs
index 075e91d23..5a9a256a9 100644
--- a/Utility/RsyncFile.hs
+++ b/Utility/RsyncFile.hs
@@ -61,3 +61,9 @@ rsyncUrlIsShell s
| 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
+rsyncUrlIsPath s
+ | rsyncUrlIsShell s = False
+ | otherwise = ':' `notElem` s
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index aedf27137..19dd707b8 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -1,6 +1,6 @@
{- safely running shell commands
-
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -8,11 +8,9 @@
module Utility.SafeCommand where
import System.Exit
-import qualified System.Posix.Process
-import System.Posix.Process hiding (executeFile)
-import System.Posix.Signals
+import Utility.Process
+import System.Process (env)
import Data.String.Utils
-import System.Log.Logger
import Control.Applicative
{- A type for parameters passed to a shell command. A command can
@@ -42,7 +40,7 @@ boolSystem :: FilePath -> [CommandParam] -> IO Bool
boolSystem command params = boolSystemEnv command params Nothing
boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
-boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env
+boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
where
dispatch ExitSuccess = True
dispatch _ = False
@@ -51,36 +49,13 @@ boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
safeSystem command params = safeSystemEnv command params Nothing
-{- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. -}
+{- Unlike many implementations of system, SIGINT(ctrl-c) is allowed
+ - to propigate and will terminate the program. -}
safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
-safeSystemEnv command params env = do
- -- Going low-level because all the high-level system functions
- -- block SIGINT etc. We need to block SIGCHLD, but allow
- -- SIGINT to do its default program termination.
- let sigset = addSignal sigCHLD emptySignalSet
- oldint <- installHandler sigINT Default Nothing
- oldset <- getSignalMask
- blockSignals sigset
- childpid <- forkProcess $ childaction oldint oldset
- mps <- getProcessStatus True False childpid
- restoresignals oldint oldset
- case mps of
- Just (Exited code) -> return code
- _ -> error $ "unknown error running " ++ command
- where
- restoresignals oldint oldset = do
- _ <- installHandler sigINT oldint Nothing
- setSignalMask oldset
- childaction oldint oldset = do
- restoresignals oldint oldset
- executeFile command True (toCommand params) env
-
-{- executeFile with debug logging -}
-executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
-executeFile c path p e = do
- debugM "Utility.SafeCommand.executeFile" $
- "Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
- System.Posix.Process.executeFile c path p e
+safeSystemEnv command params environ = do
+ (_, _, _, pid) <- createProcess (proc command $ toCommand params)
+ { env = environ }
+ waitForProcess pid
{- Escapes a filename or other parameter to be safely able to be exposed to
- the shell. -}
diff --git a/Utility/TSet.hs b/Utility/TSet.hs
new file mode 100644
index 000000000..24d345477
--- /dev/null
+++ b/Utility/TSet.hs
@@ -0,0 +1,39 @@
+{- Transactional sets
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -}
+
+module Utility.TSet where
+
+import Common
+
+import Control.Concurrent.STM
+
+type TSet = TChan
+
+runTSet :: STM a -> IO a
+runTSet = atomically
+
+newTSet :: IO (TSet a)
+newTSet = atomically newTChan
+
+{- Gets the contents of the TSet. Blocks until at least one item is
+ - present. -}
+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)
+
+{- Puts items into a TSet. -}
+putTSet :: TSet a -> [a] -> IO ()
+putTSet tset vs = runTSet $ mapM_ (writeTChan tset) vs
+
+{- Put a single item into a TSet. -}
+putTSet1 :: TSet a -> a -> IO ()
+putTSet1 tset v = void $ runTSet $ writeTChan tset v
diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs
index 4dcbf1cca..62e0fc859 100644
--- a/Utility/TempFile.hs
+++ b/Utility/TempFile.hs
@@ -9,7 +9,7 @@ module Utility.TempFile where
import Control.Exception (bracket)
import System.IO
-import System.Posix.Process hiding (executeFile)
+import System.Posix.Process
import System.Directory
import Utility.Exception
diff --git a/Utility/Tense.hs b/Utility/Tense.hs
new file mode 100644
index 000000000..135a90af2
--- /dev/null
+++ b/Utility/Tense.hs
@@ -0,0 +1,57 @@
+{- Past and present tense text.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Utility.Tense where
+
+import qualified Data.Text as T
+import Data.Text (Text)
+import GHC.Exts( IsString(..) )
+
+data Tense = Present | Past
+ deriving (Eq)
+
+data TenseChunk = Tensed Text Text | UnTensed Text
+ deriving (Eq, Ord, Show)
+
+newtype TenseText = TenseText [TenseChunk]
+ deriving (Eq, Ord)
+
+{- Allows OverloadedStrings to be used, to build UnTensed chunks. -}
+instance IsString TenseChunk where
+ fromString = UnTensed . T.pack
+
+{- Allows OverloadedStrings to be used, to provide UnTensed TenseText. -}
+instance IsString TenseText where
+ fromString s = TenseText [fromString s]
+
+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
+
+{- Builds up a TenseText, separating chunks with spaces.
+ -
+ - However, rather than just intersperse new chunks for the spaces,
+ - the spaces are appended to the end of the 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 " "
+
+unTensed :: Text -> TenseText
+unTensed t = TenseText [UnTensed t]
diff --git a/Utility/Types/DirWatcher.hs b/Utility/Types/DirWatcher.hs
index c828a0593..ba7eae6a1 100644
--- a/Utility/Types/DirWatcher.hs
+++ b/Utility/Types/DirWatcher.hs
@@ -20,3 +20,6 @@ data WatchHooks = WatchHooks
, delDirHook :: Hook FilePath
, errHook :: Hook String -- error message
}
+
+mkWatchHooks :: WatchHooks
+mkWatchHooks = WatchHooks Nothing Nothing Nothing Nothing Nothing
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
new file mode 100644
index 000000000..be186baa2
--- /dev/null
+++ b/Utility/WebApp.hs
@@ -0,0 +1,179 @@
+{- Yesod webapp
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings, CPP, RankNTypes #-}
+
+module Utility.WebApp where
+
+import Common
+
+import Yesod
+import qualified Network.Wai as Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Logger
+import Control.Monad.IO.Class
+import Network.HTTP.Types
+import System.Log.Logger
+import Data.ByteString.Lazy.UTF8
+import qualified Data.CaseInsensitive as CI
+import Network.Socket
+import Control.Exception
+import Crypto.Random
+import Data.Digest.Pure.SHA
+import qualified Web.ClientSession as CS
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Blaze.ByteString.Builder.Char.Utf8 (fromText)
+import Blaze.ByteString.Builder (Builder)
+import Data.Monoid
+import Control.Arrow ((***))
+import Control.Concurrent
+
+localhost :: String
+localhost = "localhost"
+
+{- Runs a web browser on a given url.
+ -
+ - Note: The url *will* be visible to an attacker. -}
+runBrowser :: String -> IO Bool
+runBrowser url = boolSystem cmd [Param url]
+ where
+#if OSX
+ cmd = "open"
+#else
+ cmd = "xdg-open"
+#endif
+
+{- Binds to a socket on localhost, and runs a webapp on it.
+ -
+ - An IO action can also be run, to do something with the port number,
+ - such as start a web browser to view the webapp.
+ -}
+runWebApp :: Application -> (PortNumber -> IO ()) -> IO ()
+runWebApp app observer = do
+ sock <- localSocket
+ void $ forkIO $ runSettingsSocket defaultSettings sock app
+ observer =<< socketPort sock
+
+{- Binds to a local socket, selecting any free port.
+ -
+ - As a (very weak) form of security, only connections from
+ - localhost are accepted. -}
+localSocket :: IO Socket
+localSocket = do
+ addrs <- getAddrInfo (Just hints) (Just localhost) Nothing
+ case addrs of
+ [] -> error "unable to bind to a local socket"
+ (addr:_) -> go addr
+ where
+ hints = defaultHints
+ { addrFlags = [AI_ADDRCONFIG]
+ , addrSocketType = Stream
+ }
+ go addr = bracketOnError (open addr) close (use addr)
+ open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+ close = sClose
+ 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
+debugEnabled = do
+ l <- getRootLogger
+ return $ getLevel l <= Just DEBUG
+
+{- WAI middleware that logs using System.Log.Logger at debug level.
+ -
+ - Recommend only inserting this middleware when debugging is actually
+ - enabled, as it's not optimised at all.
+ -}
+httpDebugLogger :: Wai.Middleware
+httpDebugLogger waiApp req = do
+ logRequest req
+ waiApp req
+
+logRequest :: MonadIO m => Wai.Request -> m ()
+logRequest req = do
+ liftIO $ debugM "WebApp" $ unwords
+ [ showSockAddr $ Wai.remoteHost req
+ , frombs $ Wai.requestMethod req
+ , frombs $ Wai.rawPathInfo req
+ --, show $ Wai.httpVersion req
+ --, frombs $ lookupRequestField "referer" req
+ , frombs $ lookupRequestField "user-agent" req
+ ]
+ where
+ frombs v = toString $ L.fromChunks [v]
+
+lookupRequestField :: CI.CI Ascii -> Wai.Request -> Ascii
+lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
+
+{- Rather than storing a session key on disk, use a random key
+ - that will only be valid for this run of the webapp. -}
+webAppSessionBackend :: Yesod y => y -> IO (Maybe (SessionBackend y))
+webAppSessionBackend _ = do
+ g <- newGenIO :: IO SystemRandom
+ case genBytes 96 g of
+ Left e -> error $ "failed to generate random key: " ++ show e
+ Right (s, _) -> case CS.initKey s of
+ Left e -> error $ "failed to initialize key: " ++ show e
+ Right key -> return $ Just $
+ clientSessionBackend key 120
+
+{- Generates a random sha512 string, suitable to be used for an
+ - authentication secret. -}
+genRandomToken :: IO String
+genRandomToken = do
+ g <- newGenIO :: IO SystemRandom
+ return $
+ case genBytes 512 g of
+ Left e -> error $ "failed to generate secret token: " ++ show e
+ Right (s, _) -> showDigest $ sha512 $ L.fromChunks [s]
+
+{- A Yesod isAuthorized method, which checks the auth cgi parameter
+ - against a token extracted from the Yesod application.
+ -
+ - Note that the usual Yesod error page is bypassed on error, to avoid
+ - possibly leaking the auth token in urls on that page!
+ -}
+checkAuthToken :: forall t sub. (t -> T.Text) -> GHandler sub t AuthResult
+checkAuthToken extractToken = do
+ webapp <- getYesod
+ req <- getRequest
+ let params = reqGetParams req
+ if lookup "auth" params == Just (extractToken webapp)
+ then return Authorized
+ else sendResponseStatus unauthorized401 ()
+
+{- A Yesod joinPath method, which adds an auth cgi parameter to every
+ - url matching a predicate, containing a token extracted from the
+ - Yesod application.
+ -
+ - A typical predicate would exclude files under /static.
+ -}
+insertAuthToken :: forall y. (y -> T.Text)
+ -> ([T.Text] -> Bool)
+ -> y
+ -> T.Text
+ -> [T.Text]
+ -> [(T.Text, 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
diff --git a/Utility/Yesod.hs b/Utility/Yesod.hs
new file mode 100644
index 000000000..2d2c6c343
--- /dev/null
+++ b/Utility/Yesod.hs
@@ -0,0 +1,17 @@
+{- Yesod stuff, that's typically found in the scaffolded site.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Yesod where
+
+import Yesod.Default.Util
+import Language.Haskell.TH.Syntax
+
+widgetFile :: String -> Q Exp
+widgetFile = widgetFileNoReload
+
+hamletTemplate :: FilePath -> FilePath
+hamletTemplate f = globFile "hamlet" f
diff --git a/Utility/libmounts.c b/Utility/libmounts.c
new file mode 100644
index 000000000..8669f33ea
--- /dev/null
+++ b/Utility/libmounts.c
@@ -0,0 +1,103 @@
+/* mounted filesystems, C mini-library
+ *
+ * Copyright (c) 1980, 1989, 1993, 1994
+ * The Regents of the University of California. All rights reserved.
+ * Copyright (c) 2001
+ * David Rufino <daverufino@btinternet.com>
+ * Copyright 2012
+ * Joey Hess <joey@kitenet.net>
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#include "libmounts.h"
+
+#ifdef GETMNTENT
+/* direct passthrough the getmntent */
+FILE *mounts_start (void) {
+ return setmntent("/etc/mtab", "r");
+}
+int mounts_end (FILE *fp) {
+ return endmntent(fp);
+}
+struct mntent *mounts_next (FILE *fp) {
+ return getmntent(fp);
+}
+#endif
+
+#ifdef GETMNTINFO
+/* getmntent emulation using getmntinfo */
+FILE *mounts_start (void) {
+ return ((FILE *)0x1); /* dummy non-NULL FILE pointer, not used */
+}
+int mounts_end (FILE *fp) {
+ return 1;
+}
+
+static struct mntent _mntent;
+
+static struct mntent *statfs_to_mntent (struct statfs *mntbuf) {
+ _mntent.mnt_fsname = mntbuf->f_mntfromname;
+ _mntent.mnt_dir = mntbuf->f_mntonname;
+ _mntent.mnt_type = mntbuf->f_fstypename;
+
+ _mntent.mnt_opts = '\0';
+ _mntent.mnt_freq = 0;
+ _mntent.mnt_passno = 0;
+
+ return (&_mntent);
+}
+
+static int pos = -1;
+static int mntsize = -1;
+struct statfs *mntbuf = NULL;
+
+struct mntent *mounts_next (FILE *fp) {
+
+ if (pos == -1 || mntsize == -1)
+ mntsize = getmntinfo(&mntbuf, MNT_NOWAIT);
+ ++pos;
+ if (pos == mntsize) {
+ pos = mntsize = -1;
+ mntbuf = NULL;
+ return NULL;
+ }
+
+ return (statfs_to_mntent(&mntbuf[pos]));
+}
+#endif
+
+#ifdef UNKNOWN
+/* dummy, do-nothing version */
+FILE *mounts_start (void) {
+ return ((FILE *)0x1);
+}
+int mounts_end (FILE *fp) {
+ return 1;
+}
+struct mntent *mounts_next (FILE *fp) {
+ return NULL;
+}
+#endif
diff --git a/Utility/libmounts.h b/Utility/libmounts.h
new file mode 100644
index 000000000..b65978629
--- /dev/null
+++ b/Utility/libmounts.h
@@ -0,0 +1,33 @@
+/* Include appropriate headers for the OS, and define what will be used. */
+#if defined (__FreeBSD__) || defined (__APPLE__)
+# include <sys/param.h>
+# include <sys/ucred.h>
+# include <sys/mount.h>
+# define GETMNTINFO
+#else
+#if defined (__linux__) || defined (__FreeBSD_kernel__)
+/* Linux or Debian kFreeBSD */
+#include <mntent.h>
+# define GETMNTENT
+#else
+# warning mounts listing code not available for this OS
+# define UNKNOWN
+#endif
+#endif
+
+#include <stdio.h>
+
+#ifndef GETMNTENT
+struct mntent {
+ char *mnt_fsname;
+ char *mnt_dir;
+ char *mnt_type;
+ char *mnt_opts; /* not filled in */
+ int mnt_freq; /* not filled in */
+ int mnt_passno; /* not filled in */
+};
+#endif
+
+FILE *mounts_start (void);
+int mounts_end (FILE *fp);
+struct mntent *mounts_next (FILE *fp);
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 14:17:05 +0000