yeganesh-2.4: main.hs

-- boilerplate {{{
module Main where

import Catch (catch)
import Control.Arrow (second)
import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
import Control.Monad (filterM, forM)
import Data.Map (empty, intersection, union)
import Data.Time (getCurrentTime)
import Prelude hiding (catch)
import System.Directory (getDirectoryContents)
import System.Environment (getArgs, getEnv)
import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith)
import System.FilePath ((</>))
import System.IO (hClose, hGetContents, hPutStr, stderr, stdout)
import System.Posix.Files (fileAccess, getFileStatus, isDirectory)
import System.Process (runInteractiveProcess, waitForProcess)
import Version (CurrentFormat, versionYeganesh)
import Yeganesh (Commands, Options, addEntries, deprecate, dmenuOpts,
    executables, inFileName, outFileName, parseInput, parseOptions, parsePath,
    profile, prune, readPossiblyNonExistent, showPriority, stripNewline,
    updatePriority)
import qualified System.IO.Strict as Strict (getContents)
-- }}}
-- IO stuff {{{
catchList :: IO [a] -> IO [a]
catchList = flip catch (const . return $ [])
-- }}}
-- shell stuff {{{
dmenu :: [String] -> CurrentFormat -> IO (ExitCode, CurrentFormat)
dmenu opts cv@(_, cmds) = do
    (hIn, hOut, hErr, p) <- runInteractiveProcess "dmenu" opts Nothing Nothing
    hPutStr hIn (showPriority cmds)
    hClose hIn
    o <- hGetContents hOut
    e <- hGetContents hErr
    c <- waitForProcess p
    hPutStr stdout o
    hPutStr stderr e
    cv' <- updateState c o cv
    return (c, cv')

updateState :: ExitCode -> String -> CurrentFormat -> IO CurrentFormat
updateState (ExitFailure {})  _  (t, cmds) = return (t, cmds)
updateState  ExitSuccess     cmd (t, cmds) = do
    now <- getCurrentTime
    return (now, updatePriority (stripNewline cmd) t now cmds)

lsx :: Bool -> IO (IO [String])
lsx False = return (return [])
lsx True  = do
    mvar <- newEmptyMVar
    _    <- forkIO $ do
        path  <- catchList $ getEnv "PATH"
        execs <- catchList . forM (parsePath path) $ \s ->
            catchList (getDirectoryContents s) >>=
            filterM (\file -> do
                status <- getFileStatus (s </> file)
                case isDirectory status of
                    True  -> return False
                    False -> fileAccess (s </> file) True False True)
            -- TODO: do people prefer to see files which are executable by
            -- *someone*, even if not by the current user? ask brisbin on
            -- Freenode, who is to date the only person to request this feature
        putMVar mvar (concat execs)
    return (takeMVar mvar)

parseStdin :: Bool -> IO Commands
parseStdin False = fmap parseInput Strict.getContents
parseStdin True  = return empty

runWithOptions :: Options -> IO ()
runWithOptions opts = do
    future          <- lsx (executables opts)
    inFile          <- inFileName  (profile opts)
    outFile         <- outFileName (profile opts)
    cached          <- readPossiblyNonExistent inFile
    new             <- parseStdin  (executables opts)
    (code, updated) <- dmenu (dmenuOpts opts) (second (`combine` new) cached)
    execs           <- future
    writeFile outFile (show (addEntries execs updated))
    deprecate inFile (profile opts)
    exitWith code
    where
    combine = if prune opts
              then \old -> union old >>= intersection
              else union
-- }}}
introText :: String
introText = unlines $ [
    versionYeganesh,
    "Usage: yeganesh [OPTIONS] [-- DMENU_OPTIONS]",
    "OPTIONS are described below, and DMENU_OPTIONS are passed on verbatim to dmenu.",
    "Profiles are stored in the XDG data home for yeganesh."]

main :: IO ()
main = getArgs >>= either putStrLn runWithOptions . parseOptions introText versionYeganesh