Additional xmonad libs

2 files changed, 346 insertions, 0 deletions

diff --git a/.xmonad/lib/XMonad/Prompt/MyShell.hs b/.xmonad/lib/XMonad/Prompt/MyShell.hs
new file mode 100644
index 0000000..c268f87
--- /dev/null
+++ b/.xmonad/lib/XMonad/Prompt/MyShell.hs
@@ -0,0 +1,105 @@
+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/.xmonad/lib/XMonad/Prompt/MySsh.hs b/.xmonad/lib/XMonad/Prompt/MySsh.hs
new file mode 100644
index 0000000..e6ea042
--- /dev/null
+++ b/.xmonad/lib/XMonad/Prompt/MySsh.hs
@@ -0,0 +1,241 @@
+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 c = 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 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