4 files changed, 569 insertions, 0 deletions

diff --git a/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs b/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs
new file mode 100644
index 00000000..e6accdcc
--- /dev/null
+++ b/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs
@@ -0,0 +1,127 @@
+{-# 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
new file mode 100644
index 00000000..1caefae5
--- /dev/null
+++ b/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyPass.hs
@@ -0,0 +1,94 @@
+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 <http://git.zx2c4.com/password-store/about/>
+--
+
+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
new file mode 100644
index 00000000..c268f87d
--- /dev/null
+++ b/accounts/gkleen@sif/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/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs b/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs
new file mode 100644
index 00000000..c85d0f92
--- /dev/null
+++ b/accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs
@@ -0,0 +1,243 @@
+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
+  | null $ cCommand c = c { cCommand = "tmux new-session" }
+  | 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 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