From 37e55957fbf411b928184465acb2b1ecd5ca6852 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 17 Jan 2025 22:20:56 +0100 Subject: mako --- accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs | 127 ----------- .../gkleen@sif/xmonad/lib/XMonad/Prompt/MyPass.hs | 94 -------- .../gkleen@sif/xmonad/lib/XMonad/Prompt/MyShell.hs | 105 --------- .../gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs | 246 --------------------- 4 files changed, 572 deletions(-) delete mode 100644 accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs delete mode 100644 accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyPass.hs delete mode 100644 accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyShell.hs delete mode 100644 accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs (limited to 'accounts/gkleen@sif/xmonad/lib') diff --git a/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs b/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs deleted file mode 100644 index e6accdcc..00000000 --- a/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE DeriveGeneric, OverloadedLists, OverloadedStrings, ViewPatterns, ExistentialQuantification, MultiWayIf #-} - -module XMonad.Mpv - ( MpvCommand(..), MpvResponse(..), MpvException(..) - , mpv - , mpvDir - , mpvAll, mpvOne - , mpvResponse - ) where - -import Data.Aeson - -import Data.Monoid - -import Network.Socket hiding (recv) -import Network.Socket.ByteString - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as CBS -import qualified Data.ByteString.Lazy as LBS - -import GHC.Generics (Generic) -import Data.Typeable (Typeable) -import Data.String (IsString(..)) - -import Control.Exception - -import System.IO.Temp (getCanonicalTemporaryDirectory) - -import Control.Monad -import Control.Exception (bracket) -import Control.Monad.IO.Class (MonadIO(..)) - -import System.FilePath -import System.Directory (getDirectoryContents) - -import Data.List -import Data.Either -import Data.Maybe - -import Debug.Trace - - -data MpvCommand - = forall a. ToJSON a => MpvSetProperty String a - | MpvGetProperty String -data MpvResponse - = MpvError String - | MpvSuccess (Maybe Value) - deriving (Read, Show, Generic, Eq) -data MpvException = MpvException String - | MpvNoValue - | MpvNoParse String - deriving (Generic, Typeable, Read, Show) -instance Exception MpvException - - -instance ToJSON MpvCommand where - toJSON (MpvSetProperty name val) = Array ["set_property", fromString name, toJSON val] - toJSON (MpvGetProperty name) = Array ["get_property", fromString name] - -instance FromJSON MpvResponse where - parseJSON = withObject "response object" $ \obj -> do - mval <- obj .:? "data" - err <- obj .: "error" - - let ret - | err == "success" = MpvSuccess mval - | otherwise = MpvError err - - return ret - -mpvSocket :: FilePath -> (Socket -> IO a) -> IO a -mpvSocket sockPath = withSocketsDo . bracket mkSock close - where - mkSock = do - sock <- socket AF_UNIX Stream defaultProtocol - connect sock $ SockAddrUnix (traceId sockPath) - return sock - -mpvResponse :: FromJSON v => MpvResponse -> IO v -mpvResponse (MpvError str) = throwIO $ MpvException str -mpvResponse (MpvSuccess Nothing) = throwIO MpvNoValue -mpvResponse (MpvSuccess (Just v)) = case fromJSON v of - Success v' -> return v' - Error str -> throwIO $ MpvNoParse str - -mpv :: FilePath -> MpvCommand -> IO MpvResponse -mpv sockPath cmd = mpvSocket sockPath $ \sock -> do - let message = (`BS.append` "\n") . LBS.toStrict . encode $ Object [("command", toJSON cmd)] - traceIO $ show message - sendAll sock message - let recvAll = do - prefix <- recv sock 4096 - if - | (prefix', rest) <- CBS.break (== '\n') prefix - , not (BS.null rest) -> return prefix' - | BS.null prefix -> return prefix - | otherwise -> BS.append prefix <$> recvAll - response <- recvAll - traceIO $ show response - either (ioError . userError) return . traceShowId $ eitherDecodeStrict' response - -mpvDir :: Exception e => FilePath -> (FilePath -> [(FilePath, Either e MpvResponse)] -> Maybe MpvCommand) -> IO [(FilePath, Either e MpvResponse)] -mpvDir dir step = do - socks <- filter (".sock" `isSuffixOf`) <$> getDirectoryContents dir - go [] socks - where - go acc [] = return acc - go acc (sock:socks) - | Just cmd <- step sock acc = do - res <- try $ mpv (dir sock) cmd - go ((sock, res) : acc) socks - | otherwise = - go acc socks - -mpvAll :: FilePath -> MpvCommand -> IO [MpvResponse] -mpvAll dir cmd = do - results <- map snd <$> (mpvDir dir (\_ _ -> Just cmd) :: IO [(FilePath, Either SomeException MpvResponse)]) - mapM (either throwIO return) results - -mpvOne :: FilePath -> MpvCommand -> IO (Maybe MpvResponse) -mpvOne dir cmd = listToMaybe . snd . partitionEithers . map snd <$> (mpvDir dir step :: IO [(FilePath, Either SomeException MpvResponse)]) - where - step _ results - | any (isRight . snd) results = Nothing - | otherwise = Just cmd diff --git a/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyPass.hs b/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyPass.hs deleted file mode 100644 index 1caefae5..00000000 --- a/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyPass.hs +++ /dev/null @@ -1,94 +0,0 @@ -module XMonad.Prompt.MyPass - ( - -- * Usages - -- $usages - mkPassPrompt - ) where - -import Control.Monad (liftM) -import XMonad.Core -import XMonad.Prompt ( XPrompt - , showXPrompt - , commandToComplete - , nextCompletion - , getNextCompletion - , XPConfig - , mkXPrompt - , searchPredicate) -import System.Directory (getHomeDirectory) -import System.FilePath (takeExtension, dropExtension, combine) -import System.Posix.Env (getEnv) -import XMonad.Util.Run (runProcessWithInput) - --- $usages --- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: --- --- > import XMonad.Prompt.Pass --- --- Then add a keybinding for 'passPrompt', 'passGeneratePrompt' or 'passRemovePrompt': --- --- > , ((modMask x , xK_p) , passPrompt xpconfig) --- > , ((modMask x .|. controlMask, xK_p) , passGeneratePrompt xpconfig) --- > , ((modMask x .|. controlMask .|. shiftMask, xK_p), passRemovePrompt xpconfig) --- --- For detailed instructions on: --- --- - editing your key bindings, see "XMonad.Doc.Extending#Editing_key_bindings". --- --- - how to setup the password storage, see --- - -type Predicate = String -> String -> Bool - -getPassCompl :: [String] -> Predicate -> String -> IO [String] -getPassCompl compls p s - | length s <= minL - , all ((> minL) . length) compls = return [] - | otherwise = do return $ filter (p s) compls - where - minL = 3 - -type PromptLabel = String - -data Pass = Pass PromptLabel - -instance XPrompt Pass where - showXPrompt (Pass prompt) = prompt ++ ": " - commandToComplete _ c = c - nextCompletion _ = getNextCompletion - --- | Default password store folder in $HOME/.password-store --- -passwordStoreFolderDefault :: String -> String -passwordStoreFolderDefault home = combine home ".password-store" - --- | Compute the password store's location. --- Use the PASSWORD_STORE_DIR environment variable to set the password store. --- If empty, return the password store located in user's home. --- -passwordStoreFolder :: IO String -passwordStoreFolder = - getEnv "PASSWORD_STORE_DIR" >>= computePasswordStoreDir - where computePasswordStoreDir Nothing = liftM passwordStoreFolderDefault getHomeDirectory - computePasswordStoreDir (Just storeDir) = return storeDir - --- | A pass prompt factory --- -mkPassPrompt :: PromptLabel -> (String -> X ()) -> XPConfig -> X () -mkPassPrompt promptLabel passwordFunction xpconfig = do - passwords <- io (passwordStoreFolder >>= getPasswords) - mkXPrompt (Pass promptLabel) xpconfig (getPassCompl passwords $ searchPredicate xpconfig) passwordFunction - --- | Retrieve the list of passwords from the password storage 'passwordStoreDir -getPasswords :: FilePath -> IO [String] -getPasswords passwordStoreDir = do - files <- runProcessWithInput "find" [ - passwordStoreDir, - "-type", "f", - "-name", "*.gpg", - "-printf", "%P\n"] [] - return $ map removeGpgExtension $ lines files - -removeGpgExtension :: String -> String -removeGpgExtension file | takeExtension file == ".gpg" = dropExtension file - | otherwise = file diff --git a/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyShell.hs b/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyShell.hs deleted file mode 100644 index c268f87d..00000000 --- a/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyShell.hs +++ /dev/null @@ -1,105 +0,0 @@ -module XMonad.Prompt.MyShell - ( Shell (..) - , shellPrompt - , prompt - , safePrompt - , unsafePrompt - , getCommands - , getShellCompl - , split - ) where - -import Codec.Binary.UTF8.String (encodeString) -import Control.Exception as E -import Control.Monad (forM) -import Data.List (isPrefixOf) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.Environment (getEnv) -import System.Posix.Files (getFileStatus, isDirectory) - -import XMonad hiding (config) -import XMonad.Prompt -import XMonad.Util.Run - -econst :: Monad m => a -> IOException -> m a -econst = const . return - -data Shell = Shell String - -instance XPrompt Shell where - showXPrompt (Shell q) = q - completionToCommand _ = escape - -shellPrompt :: String -> XPConfig -> X () -shellPrompt q c = do - cmds <- io getCommands - mkXPrompt (Shell q) c (getShellCompl cmds) spawn - -{- $spawns - See safe and unsafeSpawn in "XMonad.Util.Run". - prompt is an alias for safePrompt; - safePrompt and unsafePrompt work on the same principles, but will use - XPrompt to interactively query the user for input; the appearance is - set by passing an XPConfig as the second argument. The first argument - is the program to be run with the interactive input. - You would use these like this: - - > , ((modm, xK_b), safePrompt "firefox" greenXPConfig) - > , ((modm .|. shiftMask, xK_c), prompt ("xterm" ++ " -e") greenXPConfig) - - Note that you want to use safePrompt for Firefox input, as Firefox - wants URLs, and unsafePrompt for the XTerm example because this allows - you to easily start a terminal executing an arbitrary command, like - 'top'. -} - -prompt, unsafePrompt, safePrompt :: String -> FilePath -> XPConfig -> X () -prompt = unsafePrompt -safePrompt q c config = mkXPrompt (Shell q) config (getShellCompl [c]) run - where run = safeSpawn c . return -unsafePrompt q c config = mkXPrompt (Shell q) config (getShellCompl [c]) run - where run a = unsafeSpawn $ c ++ " " ++ a - -getShellCompl :: [String] -> String -> IO [String] -getShellCompl cmds s | s == "" || last s == ' ' = return [] - | otherwise = do - f <- fmap lines $ runProcessWithInput "bash" [] ("compgen -A file -- " - ++ s ++ "\n") - files <- case f of - [x] -> do fs <- getFileStatus (encodeString x) - if isDirectory fs then return [x ++ "/"] - else return [x] - _ -> return f - return . uniqSort $ files ++ commandCompletionFunction cmds s - -commandCompletionFunction :: [String] -> String -> [String] -commandCompletionFunction cmds str | '/' `elem` str = [] - | otherwise = filter (isPrefixOf str) cmds - -getCommands :: IO [String] -getCommands = do - p <- getEnv "PATH" `E.catch` econst [] - let ds = filter (/= "") $ split ':' p - es <- forM ds $ \d -> do - exists <- doesDirectoryExist d - if exists - then getDirectoryContents d - else return [] - return . uniqSort . filter ((/= '.') . head) . concat $ es - -split :: Eq a => a -> [a] -> [[a]] -split _ [] = [] -split e l = - f : split e (rest ls) - where - (f,ls) = span (/=e) l - rest s | s == [] = [] - | otherwise = tail s - -escape :: String -> String -escape [] = "" -escape (x:xs) - | isSpecialChar x = '\\' : x : escape xs - | otherwise = x : escape xs - -isSpecialChar :: Char -> Bool -isSpecialChar = flip elem " &\\@\"'#?$*()[]{};" diff --git a/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs b/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs deleted file mode 100644 index 998c533e..00000000 --- a/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs +++ /dev/null @@ -1,246 +0,0 @@ -module XMonad.Prompt.MySsh - ( -- * Usage - -- $usage - sshPrompt, - Ssh, - Override (..), - mkOverride, - Conn (..), - moshCmd, - moshCmd', - sshCmd, - inTmux, - withEnv - ) where - -import XMonad -import XMonad.Util.Run -import XMonad.Prompt - -import System.Directory -import System.Environment -import qualified Control.Exception as E - -import Control.Monad -import Data.Maybe - -import Text.Parsec.String -import Text.Parsec -import Data.Char (isSpace) - -econst :: Monad m => a -> E.IOException -> m a -econst = const . return - --- $usage --- 1. In your @~\/.xmonad\/xmonad.hs@: --- --- > import XMonad.Prompt --- > import XMonad.Prompt.Ssh --- --- 2. In your keybindings add something like: --- --- > , ((modm .|. controlMask, xK_s), sshPrompt defaultXPConfig) --- --- Keep in mind, that if you want to use the completion you have to --- disable the "HashKnownHosts" option in your ssh_config --- --- For detailed instruction on editing the key binding see --- "XMonad.Doc.Extending#Editing_key_bindings". - -data Override = Override - { oUser :: Maybe String - , oHost :: String - , oPort :: Maybe Int - , oCommand :: Conn -> String - } - -mkOverride = Override { oUser = Nothing, oHost = "", oPort = Nothing, oCommand = sshCmd } -sshCmd c = concat - [ "ssh -t " - , if isJust $ cUser c then (fromJust $ cUser c) ++ "@" else "" - , cHost c - , if isJust $ cPort c then " -p " ++ (show $ fromJust $ cPort c) else "" - , " -- " - , cCommand c - ] -moshCmd c = concat - [ "mosh " - , if isJust $ cUser c then (fromJust $ cUser c) ++ "@" else "" - , cHost c - , if isJust $ cPort c then " --ssh=\"ssh -p " ++ (show $ fromJust $ cPort c) ++ "\"" else "" - , " -- " - , cCommand c - ] -moshCmd' p c = concat - [ "mosh " - , "--server=" ++ p ++ " " - , if isJust $ cUser c then (fromJust $ cUser c) ++ "@" else "" - , cHost c - , if isJust $ cPort c then " --ssh=\"ssh -p " ++ (show $ fromJust $ cPort c) ++ "\"" else "" - , " -- " - , cCommand c - ] -inTmux Nothing c - | null $ cCommand c = c { cCommand = "tmux new-session" } - | otherwise = c { cCommand = "tmux new-session \"" ++ (cCommand c) ++ "\"" } -inTmux (Just h) c - | null $ cCommand c = c { cCommand = "tmux new-session -As " <> h } - | otherwise = c { cCommand = "tmux new-session \"" ++ (cCommand c) ++ "\"" } -withEnv :: [(String, String)] -> Conn -> Conn -withEnv envs c = c { cCommand = "env" ++ (concat $ map (\(n, v) -> ' ' : (n ++ "=" ++ v)) envs) ++ " " ++ (cCommand c) } - -data Conn = Conn - { cUser :: Maybe String - , cHost :: String - , cPort :: Maybe Int - , cCommand :: String - } deriving (Eq, Show, Read) - -data Ssh = Ssh - -instance XPrompt Ssh where - showXPrompt Ssh = "SSH to: " - commandToComplete _ c = c - nextCompletion _ = getNextCompletion - -toConn :: String -> Maybe Conn -toConn = toConn' . parse connParser "(unknown)" -toConn' :: Either ParseError Conn -> Maybe Conn -toConn' (Left _) = Nothing -toConn' (Right a) = Just a - -connParser :: Parser Conn -connParser = do - spaces - user' <- optionMaybe $ try $ do - str <- many1 $ satisfy (\c -> (not $ isSpace c) && (c /= '@')) - char '@' - return str - host' <- many1 $ satisfy (not . isSpace) - port' <- optionMaybe $ try $ do - space - string "-p" - spaces - int <- many1 digit - (space >> return ()) <|> eof - return $ (read int :: Int) - spaces - command' <- many anyChar - eof - return $ Conn - { cHost = host' - , cUser = user' - , cPort = port' - , cCommand = command' - } - -sshPrompt :: [Override] -> XPConfig -> X () -sshPrompt o c = do - sc <- io sshComplList - mkXPrompt Ssh c (mkComplFunFromList c sc) $ ssh o - -ssh :: [Override] -> String -> X () -ssh overrides str = do - let cmd = applyOverrides overrides str - liftIO $ putStr "SSH Command: " - liftIO $ putStrLn cmd - runInTerm "" cmd - -applyOverrides :: [Override] -> String -> String -applyOverrides [] str = "ssh " ++ str -applyOverrides (o:os) str = case (applyOverride o str) of - Just str -> str - Nothing -> applyOverrides os str - -applyOverride :: Override -> String -> Maybe String -applyOverride o str = let - conn = toConn str - in - if isNothing conn then Nothing else - case (fromJust conn) `matches` o of - True -> Just $ (oCommand o) (fromJust conn) - False -> Nothing - -matches :: Conn -> Override -> Bool -a `matches` b = and - [ justBool (cUser a) (oUser b) (==) - , (cHost a) == (oHost b) - , justBool (cPort a) (oPort b) (==) - ] - -justBool :: Eq a => Maybe a -> Maybe a -> (a -> a -> Bool) -> Bool -justBool Nothing _ _ = True -justBool _ Nothing _ = True -justBool (Just a) (Just b) match = a `match` b - -sshComplList :: IO [String] -sshComplList = uniqSort `fmap` liftM2 (++) sshComplListLocal sshComplListGlobal - -sshComplListLocal :: IO [String] -sshComplListLocal = do - h <- getEnv "HOME" - s1 <- sshComplListFile $ h ++ "/.ssh/known_hosts" - s2 <- sshComplListConf $ h ++ "/.ssh/config" - return $ s1 ++ s2 - -sshComplListGlobal :: IO [String] -sshComplListGlobal = do - env <- getEnv "SSH_KNOWN_HOSTS" `E.catch` econst "/nonexistent" - fs <- mapM fileExists [ env - , "/usr/local/etc/ssh/ssh_known_hosts" - , "/usr/local/etc/ssh_known_hosts" - , "/etc/ssh/ssh_known_hosts" - , "/etc/ssh_known_hosts" - ] - case catMaybes fs of - [] -> return [] - (f:_) -> sshComplListFile' f - -sshComplListFile :: String -> IO [String] -sshComplListFile kh = do - f <- doesFileExist kh - if f then sshComplListFile' kh - else return [] - -sshComplListFile' :: String -> IO [String] -sshComplListFile' kh = do - l <- readFile kh - return $ map (getWithPort . takeWhile (/= ',') . concat . take 1 . words) - $ filter nonComment - $ lines l - -sshComplListConf :: String -> IO [String] -sshComplListConf kh = do - f <- doesFileExist kh - if f then sshComplListConf' kh - else return [] - -sshComplListConf' :: String -> IO [String] -sshComplListConf' kh = do - l <- readFile kh - return $ map (!!1) - $ filter isHost - $ map words - $ lines l - where - isHost ws = take 1 ws == ["Host"] && length ws > 1 - -fileExists :: String -> IO (Maybe String) -fileExists kh = do - f <- doesFileExist kh - if f then return $ Just kh - else return Nothing - -nonComment :: String -> Bool -nonComment [] = False -nonComment ('#':_) = False -nonComment ('|':_) = False -- hashed, undecodeable -nonComment _ = True - -getWithPort :: String -> String -getWithPort ('[':str) = host ++ " -p " ++ port - where (host,p) = break (==']') str - port = case p of - ']':':':x -> x - _ -> "22" -getWithPort str = str -- cgit v1.2.3