From 4a3d2a8ddaf4e546df360656bc54b2947bdb890b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 3 Jan 2021 00:55:29 +0100 Subject: gkleen@sif: import --- accounts/gkleen@sif/xmonad/.gitignore | 4 + accounts/gkleen@sif/xmonad/default.nix | 7 + 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 | 243 ++++++ accounts/gkleen@sif/xmonad/package.yaml | 30 + accounts/gkleen@sif/xmonad/stack.nix | 17 + accounts/gkleen@sif/xmonad/stack.yaml | 10 + accounts/gkleen@sif/xmonad/xmonad-yggdrasil.nix | 21 + accounts/gkleen@sif/xmonad/xmonad.hs | 898 +++++++++++++++++++++ 11 files changed, 1556 insertions(+) create mode 100644 accounts/gkleen@sif/xmonad/.gitignore create mode 100644 accounts/gkleen@sif/xmonad/default.nix create mode 100644 accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs create mode 100644 accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyPass.hs create mode 100644 accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MyShell.hs create mode 100644 accounts/gkleen@sif/xmonad/lib/XMonad/Prompt/MySsh.hs create mode 100644 accounts/gkleen@sif/xmonad/package.yaml create mode 100644 accounts/gkleen@sif/xmonad/stack.nix create mode 100644 accounts/gkleen@sif/xmonad/stack.yaml create mode 100644 accounts/gkleen@sif/xmonad/xmonad-yggdrasil.nix create mode 100644 accounts/gkleen@sif/xmonad/xmonad.hs (limited to 'accounts/gkleen@sif/xmonad') diff --git a/accounts/gkleen@sif/xmonad/.gitignore b/accounts/gkleen@sif/xmonad/.gitignore new file mode 100644 index 00000000..c11891cd --- /dev/null +++ b/accounts/gkleen@sif/xmonad/.gitignore @@ -0,0 +1,4 @@ +**/#*# +**/.stack-work/ +/stack.yaml.lock +/*.cabal diff --git a/accounts/gkleen@sif/xmonad/default.nix b/accounts/gkleen@sif/xmonad/default.nix new file mode 100644 index 00000000..8790c12f --- /dev/null +++ b/accounts/gkleen@sif/xmonad/default.nix @@ -0,0 +1,7 @@ +argumentPackages@{ ... }: + +let + # defaultPackages = (import ./stackage.nix {}); + # haskellPackages = defaultPackages // argumentPackages; + haskellPackages = argumentPackages; +in haskellPackages.callPackage ./xmonad-yggdrasil.nix {} 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 +-- + +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 diff --git a/accounts/gkleen@sif/xmonad/package.yaml b/accounts/gkleen@sif/xmonad/package.yaml new file mode 100644 index 00000000..48de1a53 --- /dev/null +++ b/accounts/gkleen@sif/xmonad/package.yaml @@ -0,0 +1,30 @@ +name: xmonad-yggdrasil + +executables: + xmonad: + dependencies: + - base + - xmonad + - xmonad-contrib + - aeson + - bytestring + - text + - temporary + - filepath + - directory + - network + - unix + - utf8-string + - parsec + - process + - mtl + - X11 + - transformers + - containers + - hostname + - libnotify + + main: xmonad.hs + source-dirs: + - . + - lib diff --git a/accounts/gkleen@sif/xmonad/stack.nix b/accounts/gkleen@sif/xmonad/stack.nix new file mode 100644 index 00000000..17a49e04 --- /dev/null +++ b/accounts/gkleen@sif/xmonad/stack.nix @@ -0,0 +1,17 @@ +{ ghc, nixpkgs ? import ./nixpkgs.nix {} }: + +let + haskellPackages = import ./stackage.nix { inherit nixpkgs; }; + inherit (nixpkgs {}) pkgs; +in pkgs.haskell.lib.buildStackProject { + inherit ghc; + inherit (haskellPackages) stack; + name = "stackenv"; + buildInputs = (with pkgs; + [ xorg.libX11 xorg.libXrandr xorg.libXinerama xorg.libXScrnSaver xorg.libXext xorg.libXft + cairo + glib + ]) ++ (with haskellPackages; + [ + ]); +} diff --git a/accounts/gkleen@sif/xmonad/stack.yaml b/accounts/gkleen@sif/xmonad/stack.yaml new file mode 100644 index 00000000..b8ed1147 --- /dev/null +++ b/accounts/gkleen@sif/xmonad/stack.yaml @@ -0,0 +1,10 @@ +nix: + enable: true + shell-file: stack.nix + +resolver: lts-13.21 + +packages: + - . + +extra-deps: [] diff --git a/accounts/gkleen@sif/xmonad/xmonad-yggdrasil.nix b/accounts/gkleen@sif/xmonad/xmonad-yggdrasil.nix new file mode 100644 index 00000000..e8786d35 --- /dev/null +++ b/accounts/gkleen@sif/xmonad/xmonad-yggdrasil.nix @@ -0,0 +1,21 @@ +{ mkDerivation, aeson, base, bytestring, containers, directory +, filepath, hostname, hpack, mtl, network, parsec, process, stdenv +, temporary, transformers, unix, utf8-string, X11, xmonad +, xmonad-contrib, libnotify +}: +mkDerivation { + pname = "xmonad-yggdrasil"; + version = "0.0.0"; + src = ./.; + isLibrary = false; + isExecutable = true; + libraryToolDepends = [ hpack ]; + executableHaskellDepends = [ + aeson base bytestring containers directory filepath hostname mtl + network parsec process temporary transformers unix utf8-string X11 + xmonad xmonad-contrib libnotify + ]; + preConfigure = "hpack"; + license = "unknown"; + hydraPlatforms = stdenv.lib.platforms.none; +} diff --git a/accounts/gkleen@sif/xmonad/xmonad.hs b/accounts/gkleen@sif/xmonad/xmonad.hs new file mode 100644 index 00000000..f3a59f34 --- /dev/null +++ b/accounts/gkleen@sif/xmonad/xmonad.hs @@ -0,0 +1,898 @@ +{-# LANGUAGE TupleSections, ViewPatterns, OverloadedStrings, FlexibleInstances, UndecidableInstances, MultiWayIf #-} + +import XMonad +import XMonad.Hooks.DynamicLog +import XMonad.Hooks.ManageDocks +import XMonad.Util.Run +import XMonad.Util.Loggers +import XMonad.Util.EZConfig(additionalKeys) +import System.IO +import System.IO.Error +import System.Environment +import Data.Map (Map) +import qualified Data.Map as Map +import qualified XMonad.StackSet as W +import System.Exit +import Control.Monad.State (get) +-- import XMonad.Layout.Spiral +import Data.Ratio +import Data.List +import Data.Char +import Data.Maybe (fromMaybe, listToMaybe, maybeToList, catMaybes, isJust) +import XMonad.Layout.Tabbed +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Util.Scratchpad +import XMonad.Util.NamedScratchpad +import Control.Monad (sequence, liftM, liftM2, join, void) +import XMonad.Util.WorkspaceCompare +import XMonad.Layout.NoBorders +import XMonad.Layout.PerWorkspace +import XMonad.Layout.SimplestFloat +import XMonad.Layout.Renamed +import XMonad.Layout.Reflect +import XMonad.Layout.OnHost +import XMonad.Layout.Combo +import XMonad.Layout.ComboP +import XMonad.Layout.Column +import XMonad.Layout.TwoPane +import XMonad.Layout.IfMax +import XMonad.Layout.LayoutBuilder +import XMonad.Layout.WindowNavigation +import XMonad.Layout.Dwindle +import XMonad.Layout.TrackFloating +import System.Process +import System.Directory (removeFile) +import System.Posix.Files +import System.FilePath (()) +import Control.Concurrent +import System.Posix.Process (getProcessID) +import System.IO.Error +import System.IO +import XMonad.Hooks.ManageHelpers hiding (CW) +import XMonad.Hooks.UrgencyHook as U +import XMonad.Hooks.EwmhDesktops +import XMonad.StackSet (RationalRect (..)) +import Control.Monad (when, filterM, (<=<)) +import Graphics.X11.ExtraTypes.XF86 +import XMonad.Util.Cursor +import XMonad.Actions.Warp +import XMonad.Actions.FloatKeys +import XMonad.Util.SpawnOnce +import System.Directory +import System.FilePath +import XMonad.Actions.CopyWindow +import XMonad.Hooks.ServerMode +import XMonad.Actions.Commands +import XMonad.Actions.CycleWS +import XMonad.Actions.RotSlaves +import XMonad.Actions.UpdatePointer +import XMonad.Prompt.Window +import Data.IORef +import Data.Monoid +import Data.String +import qualified XMonad.Actions.PhysicalScreens as P + +import XMonad.Layout.IM + +import XMonad.Prompt.MyShell +import XMonad.Prompt.MyPass +import XMonad.Prompt.MySsh + +import XMonad.Mpv + +import Network.HostName + +import Control.Applicative ((<$>)) + +import Libnotify as Notify hiding (appName) +import qualified Libnotify as Notify (appName) +import Libnotify (Notification) +-- import System.Information.Battery + +import Data.Int (Int32) + +import System.Posix.Process +import System.Posix.Signals +import System.Posix.IO as Posix +import Control.Exception + +import System.IO.Unsafe + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe + +import Data.Fixed (Micro) + +import qualified Data.Text as Text +import Data.Ord (comparing) +import Debug.Trace + +instance MonadIO m => IsString (m ()) where + fromString = spawn + +type KeyMap = Map (ButtonMask, KeySym) (X ()) + +data Host = Host + { hName :: HostName + , hManageHook :: ManageHook + , hWsp :: Integer -> WorkspaceId + , hCoWsp :: String -> Maybe WorkspaceId + , hKeysMod :: XConfig Layout -> (KeyMap -> KeyMap) + , hScreens :: [P.PhysicalScreen] + , hKbLayouts :: [(String, Maybe String)] + , hCmds :: X [(String, X ())] + , hKeyUpKeys :: XConfig Layout -> KeyMap + } + +defaultHost = Host { hName = "unkown" + , hManageHook = composeOne [manageScratchTerm] + , hWsp = show + , hCoWsp = const Nothing + , hKeysMod = const id + , hScreens = [0,1..] + , hKbLayouts = [ ("us", Just "dvp") + , ("us", Nothing) + , ("de", Nothing) + ] + , hCmds = return [] + , hKeyUpKeys = const Map.empty + } + +browser :: String +browser = "env MOZ_USE_XINPUT2=1 firefox" + +hostFromName :: HostName -> Host +hostFromName h@("vali") = defaultHost { hName = h + , hManageHook = composeOne $ catMaybes [ Just manageScratchTerm + , assign "web" $ className =? ".dwb-wrapped" + , assign "web" $ className =? "Chromium" + , assign "work" $ className =? "Emacs" + , assign "media" $ className =? "mpv" + ] + , hWsp = hWsp + , hCoWsp = hCoWsp + , hKeysMod = \conf -> Map.union $ (Map.fromList $ join $ map (spawnBindings conf) [ (xK_d, ["chromium", "chromium $(xclip -o)"]) + , (xK_e, ["emacsclient -c"]) + ]) + `Map.union` + ( Map.fromList [ ((XMonad.modMask conf .|. controlMask, xK_Return), scratchpadSpawnActionCustom $ (XMonad.terminal conf) ++ " -name scratchpad -title scratchpad -e tmux new-session -D -s scratch") + ] ) + , hScreens = hScreens defaultHost + } + where + workspaceNames = Map.fromList [ (2, "web") + , (3, "work") + , (10, "media") + ] + hWsp = wspFromMap workspaceNames + hCoWsp = coWspFromMap workspaceNames + assign wsp test = (\wsp -> test -?> doShift wsp) <$> hCoWsp wsp +hostFromName h + | h `elem` ["hel", "sif"] = defaultHost { hName = h + , hManageHook = namedScratchpadManageHook scratchpads <+> composeOne (catMaybes + [ assign "mpv" $ className =? "mpv" + , assign "mpv" $ (className =? "URxvt" <&&> title =? "irssi") + , assign "mpv" $ (className =? "URxvt" <&&> resource =? "presentation") + , assign "mpv" $ stringProperty "WM_WINDOW_ROLE" =? "presentation" + , assign "read" $ stringProperty "WM_WINDOW_ROLE" =? "presenter" + , assign "mpv" $ className =? "factorio" + , assign "web" $ className =? "chromium-browser" + , assign "web" $ className =? "Google-chrome" + , assign "work" $ (appName =? "Devtools" <&&> className =? "Firefox") + , assign "work" $ className =? "Postman" + , assign "web" $ className =? "Firefox" + , assign "comm" $ (className =? "URxvt" <&&> resource =? "comm") + , assign "comm" $ (className =? "Emacs" <&&> title =? "Mail") + , assign "comm" $ className =? "Zulip" + , assign "comm" $ className =? "Discord" + , assign "media" $ (className =? "URxvt" <&&> resource =? "media") + , assign "media" $ (className =? "URxvt" <&&> title =? "streamlink") + , assign "media" $ (className =? "URxvt" <&&> title =? "mpv") + , assign "monitor" $ (className =? "URxvt" <&&> fmap ("monitor" `isInfixOf`) title) + , assign "monitor" $ className =? "Grafana" + , Just $ (className =? "URxvt" <&&> resource =? "htop") -?> centerFloat + , Just $ (className =? "Scp-dbus-service.py") -?> centerFloat + , Just $ (className =? "URxvt" <&&> resource =? "log") -?> centerFloat + , assign "work" $ className =? "URxvt" + , assign' ["work", "uni"] $ (className =? "Emacs" <&&> appName /=? "Edit_with_Emacs_FRAME") + , assign' ["work", "uni"] $ className =? "jetbrains-idea-ce" + , assign "read" $ className =? "llpp" + , assign "read" $ className =? "Evince" + , assign "read" $ fmap ("zathura" `isInfixOf`) title + , assign "read" $ className =? "MuPDF" + , assign "read" $ className =? "Xournal" + , assign "read" $ appName =? "com-trollworks-gcs-app-GCS" + , assign "read" $ appName =? "Tux.py" + , assign "read" $ className =? "Gnucash" + , assign "comm" $ className =? "Skype" + , assign "comm" $ className =? "Daily" + , assign "comm" $ className =? "Pidgin" + , assign "comm" $ className =? "Slack" + , Just $ (resource =? "xvkbd") -?> doRectFloat $ RationalRect (1 % 8) (3 % 8) (6 % 8) (4 % 8) + , Just $ (stringProperty "_NET_WM_WINDOW_TYPE" =? "_NET_WM_WINDOW_TYPE_DIALOG") -?> doFloat + , Just $ (className =? "Dunst") -?> doFloat + , Just $ (className =? "Xmessage") -?> doCenterFloat + , Just $ (className =? "Nm-openconnect-auth-dialog") -?> centerFloat + , Just $ (className =? "Pinentry") -?> doCenterFloat + , Just $ (className =? "pinentry") -?> doCenterFloat + , Just $ (appName =? "Edit_with_Emacs_FRAME") -?> centerFloat + , Just $ (stringProperty "WM_WINDOW_ROLE" =? "GtkFileChooseDialog") -?> centerFloatSmall + , Just $ (className =? "Nvidia-settings") -?> doCenterFloat + , Just $ fmap ("Minetest" `isInfixOf`) title -?> doIgnore + , Just $ fmap ("Automachef" `isInfixOf`) title -?> doIgnore + ]) + , hWsp = hWsp + , hCoWsp = hCoWsp + , hKeysMod = \conf -> Map.union $ (Map.fromList $ join $ map (spawnBindings conf) [ (xK_e, ["emacsclient -c"]) + , (xK_d, [fromString browser, fromString $ browser ++ " $(xclip -o)", fromString $ "notmuch-links"]) + , (xK_f, ["urxvtc -name comm -title Feeds -e mosh odin -- tmux new-session -ADs comm"]) + , (xK_c, [ inputPrompt xPConfig "dc" ?+ dc ]) + , (xK_g, ["pidgin"]) + , (xK_s, ["skype"]) + -- , (xK_p, [mkPassPrompt "Type password" pwType xPConfig, mkPassPrompt "Show password" pwShow xPConfig, mkPassPrompt "Copy password" pwClip xPConfig]) + , (xK_w, ["sudo rewacom"]) + , (xK_y, [ "tmux new-window -dt media /var/media/link.hs $(xclip -o)" + , "urxvtc -name media -e tmuxp load /var/media" + ]) + , (xK_l, [ "tmux new-window -dt media mpv $(xclip -o)" + , "tmux new-window -dt media streamlink --retry-open 10 $(xclip -o)" + ]) + , (xK_m, [ "emacsclient -c -F \"'(title . \\\"Mail\\\")\" -e '(notmuch)'" + , "emacsclient -c -F \"'(title . \\\"Mail\\\")\" -e '(notmuch-mua-new-mail)'" + , "emacsclient -c -F \"'(title . \\\"Mail\\\")\" -e \"(browse-url-mail \"$(xclip -o)\")\"" + ]) + , (xK_Return, ["keynav start,windowzoom", "keynav start"]) + , (xK_t, [inputPrompt xPConfig "fuzzytime timer" ?+ fuzzytime, fuzzytime "unset", work_fuzzytime]) + , (xK_a, [inputPrompt xPConfig "adjmix" ?+ adjmix]) + , (xK_s, [ inputPromptWithCompl xPConfig "start synergy" synergyCompl ?+ synergyStart + , inputPromptWithCompl xPConfig "stop synergy" synergyCompl ?+ synergyStop + ]) + , (xK_h, [ "urxvtc -name htop -e htop" + , "urxvtc -name log -e journalctl -xef" + ]) + , (xK_x, [ "autorandr -c" + , "autorandr -fl default" + ]) + , (xK_z, [ "zulip -- --force-device-scale-factor=2" + ]) + ]) + `Map.union` + ( Map.fromList [ ((XMonad.modMask conf .|. controlMask, xK_Return), namedScratchpadAction scratchpads "term") + , ((XMonad.modMask conf .|. controlMask, xK_a), namedScratchpadAction scratchpads "pavucontrol") + , ((XMonad.modMask conf .|. controlMask, xK_w), namedScratchpadAction scratchpads "alarms") + , ((XMonad.modMask conf .|. controlMask, xK_b), namedScratchpadAction scratchpads "blueman") + , ((XMonad.modMask conf .|. controlMask, xK_p), namedScratchpadAction scratchpads "keepassxc") + , ((XMonad.modMask conf .|. controlMask, xK_t), namedScratchpadAction scratchpads "toggl") + , ((XMonad.modMask conf .|. controlMask, xK_e), namedScratchpadAction scratchpads "emacs") + , ((XMonad.modMask conf .|. controlMask, xK_m), namedScratchpadAction scratchpads "calendar") + , ((XMonad.modMask conf .|. controlMask, xK_f), namedScratchpadAction scratchpads "music") + , ((XMonad.modMask conf .|. mod1Mask, xK_Up), rotate U) + , ((XMonad.modMask conf .|. mod1Mask, xK_Down), rotate D) + , ((XMonad.modMask conf .|. mod1Mask, xK_Left), rotate L) + , ((XMonad.modMask conf .|. mod1Mask, xK_Right), rotate R) + -- , ((XMonad.modMask conf .|. shiftMask, xK_a), startMute "hel") + ] ) + , hKeyUpKeys = \conf -> Map.fromList [ -- ((XMonad.modMask conf .|. shiftMask, xK_a), stopMute "hel") + ] + , hScreens = hScreens defaultHost + , hCmds = return [ ("prev-workspace", prevWS) + , ("next-workspace", nextWS) + , ("prev-window", rotAllDown) + , ("next-window", rotAllUp) + , ("banish", banishScreen LowerRight) + , ("update-gpg-tty", safeSpawn "gpg-connect-agent" ["UPDATESTARTUPTTY", "/bye"]) + , ("rescreen", rescreen) + , ("repanel", do + spawn "nm-applet" + spawn "blueman-applet" + spawn "pasystray" + spawn "kdeconnect-indicator" + spawn "dunst -print" + spawn "udiskie" + spawn "autocutsel -s PRIMARY" + spawn "autocutsel -s CLIPBOARD" + ) + , ("pause", mediaMpv $ MpvSetProperty "pause" True) + , ("unpause", mediaMpv $ MpvSetProperty "pause" False) + , ("exit", io $ exitWith ExitSuccess) + ] + } + where + withGdkScale act = void . xfork $ setEnv "GDK_SCALE" "2" >> act + workspaceNames = Map.fromList [ (1, "comm") + , (2, "web") + , (3, "work") + , (4, "read") + , (5, "monitor") + , (6, "uni") + , (9, "media") + , (10, "mpv") + ] + scratchpads = [ NS "term" "urxvtc -name scratchpad -title scratchpad -e tmux new-session -AD -s scratch" (resource =? "scratchpad") centerFloat + , NS "pavucontrol" "pavucontrol" (resource =? "pavucontrol") centerFloat + , NS "alarms" "alarm-clock-applet" (className =? "Alarm-clock-applet" <&&> title =? "Alarms") centerFloat + , NS "blueman" "blueman-manager" (className =? ".blueman-manager-wrapped") centerFloat + , NS "keepassxc" "keepassxc" (className =? "KeePassXC") centerFloat + , NS "toggl" "toggldesktop" (className =? "Toggl Desktop") centerFloat + , NS "calendar" "minetime -- --force-device-scale-factor=1.6" (className =? "MineTime") centerFloat + , NS "emacs" "emacsclient -c -F \"'(title . \\\"Scratchpad\\\")\"" (className =? "Emacs" <&&> title =? "Scratchpad") centerFloat + , NS "music" "google-play-music-desktop-player --force-device-scale-factor=1.6" (className =? "Google Play Music Desktop Player") centerFloat + ] + centerFloat = customFloating $ RationalRect (1 % 16) (1 % 16) (7 % 8) (7 % 8) + centerFloatSmall = customFloating $ RationalRect (1 % 4) (1 % 4) (1 % 2) (1 % 2) + hWsp = wspFromMap workspaceNames + hCoWsp = coWspFromMap workspaceNames + assign wsp test = (\wsp -> test -?> doShift wsp) <$> hCoWsp wsp + assign' :: [String] -> Query Bool -> Maybe MaybeManageHook + assign' wsps test = do + wsIds <- mapM hCoWsp wsps + return $ test -?> go wsIds + where + go :: [WorkspaceId] -> ManageHook + go wsps = do + visWsps <- liftX $ (\wset -> W.tag . W.workspace <$> W.current wset : W.visible wset) <$> gets windowset + case (filter (`elem` visWsps) wsps, wsps) of + (wsp : _, _) -> doShift wsp + (_, wsp : _) -> doShift wsp + ([], []) -> return mempty + rotate rot = do + safeSpawn "xrandr" ["--output", "eDP-1", "--rotate", xrandrDir] + mapM_ rotTouch touchscreens + where + xrandrDir = case rot of + U -> "normal" + L -> "left" + R -> "right" + D -> "inverted" + matrix = case rot of + U -> [ [ 1, 0, 0] + , [ 0, 1, 0] + , [ 0, 0, 1] + ] + L -> [ [ 0, -1, 1] + , [ 1, 0, 0] + , [ 0, 0, 1] + ] + R -> [ [ 0, 1, 0] + , [-1, 0, 1] + , [ 0, 0, 1] + ] + D -> [ [-1, 0, 1] + , [ 0, -1, 1] + , [ 0, 0, 1] + ] + touchscreens = [ "Wacom Co.,Ltd. Pen and multitouch sensor Finger touch" + , "Wacom Co.,Ltd. Pen and multitouch sensor Pen stylus" + , "Wacom Co.,Ltd. Pen and multitouch sensor Pen eraser" + ] + rotTouch screen = do + safeSpawn "xinput" $ ["set-prop", screen, "Coordinate Transformation Matrix"] ++ map (\n -> show n ++ ",") (concat matrix) + safeSpawn "xinput" ["map-to-output", screen, "eDP-1"] + withPw f label = io . void . forkProcess $ do + uninstallSignalHandlers + void $ createSession + (dropWhileEnd isSpace -> pw) <- readCreateProcess (proc "pass" ["show", label]) "" + void $ f pw + pwType :: String -> X () + pwType = withPw $ readCreateProcess (proc "xdotool" ["type", "--clearmodifiers", "--file", "-"]) + pwClip label = safeSpawn "pass" ["show", "--clip", label] + pwShow :: String -> X () + pwShow = withPw $ \pw -> do + xmessage <- fromMaybe "xmessage" <$> liftIO (lookupEnv "XMONAD_XMESSAGE") + readCreateProcess (proc xmessage ["-file", "-"]) pw + fuzzytime str = safeSpawn "fuzzytime" $ "timer" : words str + work_fuzzytime = io . void . forkProcess $ do + readCreateProcess (proc "worktime" []) "" >>= safeSpawn "fuzzytime" . ("timer" : ) . pure + adjmix str = safeSpawn "adjmix" $ words str + dc expr = void . xfork $ do + result <- readProcess "dc" [] $ expr ++ "f" + let + (first : rest) = filter (not . null) $ lines result + notification = Notify.summary first <> Notify.body (unlines rest) <> Notify.timeout Infinite <> Notify.urgency Normal <> Notify.appName "dc" + void $ Notify.display notification + synergyCompl = mkComplFunFromList' ["mathw86"] + synergyStart host = safeSpawn "systemctl" ["--user", "start", "synergy-rtunnel@" ++ host ++ ".service"] + synergyStop host = safeSpawn "systemctl" ["--user", "stop", "synergy-rtunnel@" ++ host ++ ".service"] + +hostFromName _ = defaultHost + +-- muteRef :: IORef (Maybe (String, Notification)) +-- {-# NOINLINE muteRef #-} +-- muteRef = unsafePerformIO $ newIORef Nothing + +-- startMute, stopMute :: String -> X () +-- startMute sink = liftIO $ do +-- muted <- isJust <$> readIORef muteRef +-- when (not muted) $ do +-- let +-- notification = Notify.summary "Muted" <> Notify.timeout Infinite <> Notify.urgency Normal +-- level = "0.0dB" +-- -- level <- runProcessWithInput "ssh" ["bragi", "cat", "/dev/shm/mix/" ++ sink ++ "/level"] "" +-- -- callProcess "ssh" ["bragi", "adjmix", "-t", sink, "-o", "0"] +-- hPutStrLn stderr "Mute" +-- writeIORef muteRef . Just . (level, ) =<< Notify.display notification +-- stopMute sink = liftIO $ do +-- let +-- unmute (Just (level, notification)) = do +-- hPutStrLn stderr "Unmute" +-- -- callProcess "ssh" ["bragi", "adjmix", "-t", sink, "-o", level] +-- Notify.close notification +-- unmute Nothing = return () +-- muted <- isJust <$> readIORef muteRef +-- when muted . join . atomicModifyIORef muteRef $ (Nothing, ) . unmute + +wspFromMap workspaceNames = \i -> case Map.lookup i workspaceNames of + Just str -> show i ++ " " ++ str + Nothing -> show i + +coWspFromMap workspaceNames = \str -> case filter ((== str) . snd) $ Map.toList workspaceNames of + [] -> Nothing + [(i, _)] -> Just $ wspFromMap workspaceNames i + _ -> Nothing + +spawnModifiers = [0, controlMask, shiftMask .|. controlMask] +spawnBindings :: XConfig layout -> (KeySym, [X ()]) -> [((KeyMask, KeySym), X ())] +spawnBindings conf (k, cmds) = zipWith (\m cmd -> ((modm .|. mod1Mask .|. m, k), cmd)) spawnModifiers cmds + where + modm = XMonad.modMask conf + +manageScratchTerm = (resource =? "scratchpad" <||> resource =? "keysetup") -?> doRectFloat $ RationalRect (1 % 16) (1 % 16) (7 % 8) (7 % 8) + +tabbedLayout t = renamed [Replace "Tabbed"] $ reflectHoriz $ t CustomShrink $ tabbedTheme +tabbedLayoutHoriz t = renamed [Replace "Tabbed Horiz"] $ reflectVert $ t CustomShrink $ tabbedTheme +tabbedTheme = def + { activeColor = "black" + , inactiveColor = "black" + , urgentColor = "black" + , activeBorderColor = "grey" + , inactiveBorderColor = "#202020" + , urgentBorderColor = "#bb0000" + , activeTextColor = "grey" + , inactiveTextColor = "grey" + , urgentTextColor = "grey" + , decoHeight = 32 + , fontName = "xft:Fira Mono for Powerline:style=Medium:pixelsize=22.5" + } + +main :: IO () +main = do + arguments <- either (const []) id <$> tryIOError getArgs + case arguments of + ["--command", s] -> do + d <- openDisplay "" + rw <- rootWindow d $ defaultScreen d + a <- internAtom d "XMONAD_COMMAND" False + m <- internAtom d s False + allocaXEvent $ \e -> do + setEventType e clientMessage + setClientMessageEvent e rw a 32 m currentTime + sendEvent d rw False structureNotifyMask e + sync d False + _ -> do + -- batteryMon <- xfork $ monitorBattery Nothing Nothing + hostname <- getHostName + let + host = hostFromName hostname + setEnv "HOST" hostname + let myConfig = withHostUrgency . ewmh $ docks def + { manageHook = hManageHook host + , terminal = "urxvtc" + , layoutHook = smartBorders . avoidStruts $ windowNavigation layout' + , logHook = do + dynamicLogString xmobarPP' >>= writeProps + updatePointer (99 % 100, 98 % 100) (0, 0) + , modMask = mod4Mask + , keys = \conf -> hKeysMod host conf $ myKeys' conf host + , workspaces = take (length numKeys) $ map wsp [1..] + , startupHook = setDefaultCursor xC_left_ptr + , normalBorderColor = "#202020" + , focusedBorderColor = "grey" + , handleEventHook = fullscreenEventHook <+> (serverModeEventHookCmd' $ hCmds host) <+> keyUpEventHook + } + writeProps str = do + let encodeCChar = map $ fromIntegral . fromEnum + atoms = [ "_XMONAD_WORKSPACES" + , "_XMONAD_LAYOUT" + , "_XMONAD_TITLE" + ] + (flip mapM_) (zip atoms (lines str)) $ \(atom', content) -> do + ustring <- getAtom "UTF8_STRING" + atom <- getAtom atom' + withDisplay $ \dpy -> io $ do + root <- rootWindow dpy $ defaultScreen dpy + changeProperty8 dpy root atom ustring propModeReplace $ encodeCChar content + sync dpy True + wsp = hWsp host + -- We can´t define per-host layout modifiers because we lack dependent types + layout' = onHost "skadhi" ( onWorkspace (wsp 1) (Full ||| withIM (1%5) (Title "Buddy List") tabbedLayout') $ + onWorkspace (wsp 10) Full $ + onWorkspace (wsp 2) (Full ||| tabbedLayout') $ + onWorkspace (wsp 5) tabbedLayout' $ + onWorkspace (wsp 8) (withIM (1%5) (Title "Friends") tabbedLayout') $ + defaultLayouts + ) $ + onHost "vali" ( onWorkspace (wsp 2) (Full ||| tabbedLayout' ||| combineTwo (TwoPane 0.01 0.57) Full tabbedLayout') $ + onWorkspace (wsp 3) workLayouts $ + defaultLayouts + ) $ + onHost "hel" ( onWorkspace (wsp 1) (withIM (1 % 8) (Title "Buddy List") $ trackFloating tabbedLayout') $ + onWorkspace (wsp 2) (tabbedLayout''' ||| Dwindle R CW 1 (5 % 100)) $ + onWorkspace (wsp 3) workLayouts $ + onWorkspace (wsp 6) workLayouts $ + onWorkspace (wsp 4) (tabbedLayout' ||| tabbedLayoutHoriz' ||| Dwindle R CW 1 (5 % 100)) $ + onWorkspace (wsp 5) (tabbedLayout''' ||| Dwindle R CW 1 (5 % 100)) $ + onWorkspace (wsp 10) (tabbedLayout''' ||| combineTwoP (TwoPane (1 % 100) (3 % 4)) tabbedLayout''' tabbedLayout''' (ClassName "mpv") ||| Dwindle R CW 1 (5 % 100)) $ + defaultLayouts + ) $ + onHost "sif" ( onWorkspace (wsp 1) (withIM (1 % 8) (Title "Buddy List") $ trackFloating tabbedLayout') $ + onWorkspace (wsp 2) (tabbedLayout''' ||| Dwindle R CW 1 (5 % 100)) $ + onWorkspace (wsp 3) workLayouts $ + onWorkspace (wsp 6) workLayouts $ + onWorkspace (wsp 4) (tabbedLayout' ||| tabbedLayoutHoriz' ||| Dwindle R CW 1 (5 % 100)) $ + onWorkspace (wsp 5) (tabbedLayout''' ||| Dwindle R CW 1 (5 % 100)) $ + onWorkspace (wsp 10) (tabbedLayout''' ||| combineTwoP (TwoPane (1 % 100) (3 % 4)) tabbedLayout''' tabbedLayout''' (ClassName "mpv") ||| Dwindle R CW 1 (5 % 100)) $ + defaultLayouts + ) $ + defaultLayouts + -- tabbedLayout''' = renamed [Replace "Tabbed'"] $ IfMax 1 (noBorders Full) (tabbedLayout tabbedBottomAlways) + tabbedLayout''' = tabbedLayout tabbedBottom + tabbedLayout' = tabbedLayout tabbedBottomAlways + tabbedLayoutHoriz' = tabbedLayoutHoriz tabbedLeftAlways + defaultLayouts = {- spiralWithDir East CW (1 % 2) -} Dwindle R CW 1 (5 % 100) ||| tabbedLayout' ||| Full + -- workLayouts = {- spiralWithDir East CW (1 % 2) -} Dwindle R CW (2 % 1) (5 % 100) ||| tabbedLayout' ||| Full + workLayouts = tabbedLayout' ||| (renamed [Replace "Combined"] $ combineTwoP (TwoPane (1 % 100) (1891 % 2560)) tabbedLayout''' (Column 1.6) (ClassName "Postman" `Or` ClassName "Emacs" `Or` ClassName "jetbrains-idea-ce" `Or` (Resource "Devtools" `And` ClassName "Firefox"))) ||| Full ||| Dwindle R CW 1 (5 % 100) + sqrtTwo = approxRational (sqrt 2) (1 / 2560) + xmobarPP' = xmobarPP { ppTitle = shorten 80 + , ppSort = (liftM2 (.)) getSortByIndex $ return scratchpadFilterOutWorkspace + , ppUrgent = wrap "(" ")" . xmobarColor "red" "" + , ppHiddenNoWindows = xmobarColor "#202020" "" . wrap "(" ")" + , ppVisible = wrap "(" ")" . xmobarColor "yellow" "" + , ppCurrent = wrap "(" ")" . xmobarColor "green" "" + , ppHidden = wrap "(" ")" + , ppWsSep = " " + , ppSep = "\n" + } + withHostUrgency = case hostname of + "hel" -> withUrgencyHookC urgencyHook' $ urgencyConfig { suppressWhen = U.Never, remindWhen = Dont } + "sif" -> withUrgencyHookC urgencyHook' $ urgencyConfig { suppressWhen = U.Never, remindWhen = Dont } + _ -> id + urgencyHook' window = do + runQuery ((resource =? "comm" <||> resource =? "Pidgin" <||> className =? "Gajim" <||> className =? "Skype") --> safeSpawn "thinklight" ["Blink", "100"]) window + urgencyHook (BorderUrgencyHook { urgencyBorderColor = "#bb0000" }) window + shutdown :: SomeException -> IO a + shutdown e = do + let pids = [ -- batteryMon + ] + mapM_ (signalProcess sigTERM) pids + mapM_ (getProcessStatus False False) pids + throw e + keyUpEventHook :: Event -> X All + keyUpEventHook event = handle event >> return (All True) + where + handle (KeyEvent { ev_event_type = t, ev_state = m, ev_keycode = code }) + | t == keyRelease = withDisplay $ \dpy -> do + s <- io $ keycodeToKeysym dpy code 0 + mClean <- cleanMask m + ks <- asks $ hKeyUpKeys host . config + userCodeDef () $ whenJust (Map.lookup (mClean, s) ks) id + | otherwise = return () + handle _ = return () + handle shutdown $ launch myConfig + +secs :: Int -> Int +secs = (* 1000000) + +-- monitorBattery :: Maybe BatteryContext -> Maybe Notification -> IO () +-- monitorBattery Nothing n = do +-- ctx <- batteryContextNew +-- case ctx of +-- Nothing -> threadDelay (secs 10) >> monitorBattery Nothing n +-- Just _ -> monitorBattery ctx n +-- monitorBattery ctx@(Just ctx') n = do +-- batInfo <- getBatteryInfo ctx' +-- case batInfo of +-- Nothing -> threadDelay (secs 1) >> monitorBattery ctx n +-- Just batInfo -> do +-- let n' +-- | batteryState batInfo == BatteryStateDischarging +-- , timeLeft <= 1200 +-- , timeLeft > 0 = Just $ summary "Discharging" <> hint "value" percentage <> urgency u <> body (duz timeLeft ++ "left") +-- | otherwise = Nothing +-- u +-- | timeLeft <= 600 = Critical +-- | timeLeft <= 1800 = Normal +-- | otherwise = Low +-- timeLeft = batteryTimeToEmpty batInfo +-- percentage :: Int32 +-- percentage = round $ batteryPercentage batInfo +-- ts = [("s", 60), ("m", 60), ("h", 24), ("d", 365), ("y", 1)] +-- duz ms = ss +-- where (ss, _) = foldl (\(ss, x) (s, y) -> ((if rem x y > 0 then show (rem x y) ++ s ++ " " else "") ++ ss , quot x y)) ("", ms) ts +-- case n' of +-- Just n' -> Notify.display (maybe mempty reuse n <> Notify.appName "monitorBattery" <> n') >>= (\n -> threadDelay (secs 2) >> monitorBattery ctx (Just n)) +-- Nothing -> threadDelay (secs 30) >> monitorBattery ctx n + +disableTouchpad, disableTrackpoint, enableTrackpoint, enableTouchpad :: X () +enableTouchpad = safeSpawn "xinput" ["enable", "SynPS/2 Synaptics TouchPad"] +disableTouchpad = safeSpawn "xinput" ["disable", "SynPS/2 Synaptics TouchPad"] +enableTrackpoint = safeSpawn "xinput" ["enable", "TPPS/2 IBM TrackPoint"] +disableTrackpoint = safeSpawn "xinput" ["disable", "TPPS/2 IBM TrackPoint"] + +isDisabled :: String -> X Bool +isDisabled str = do + out <- runProcessWithInput "xinput" ["list", str] "" + return $ "disabled" `isInfixOf` out + + +spawnKeychain :: X () +spawnKeychain = do + home <- liftIO getHomeDirectory + let keys = (map ((home ) . (".ssh/" ++)) ["id", "id-rsa"]) ++ ["6B13AA67"] + liftIO (maybe (return ()) (setEnv "SSH_ASKPASS") =<< findAskpass) + safeSpawn "keychain" . (["--agents", "gpg,ssh"] ++)=<< liftIO (filterM doesFileExist keys) + where + findAskpass = filter `liftM` readFile "/etc/zshrc" + filter = listToMaybe . catMaybes . map (stripPrefix "export SSH_ASKPASS=") . lines + +assimilateKeychain :: X () +assimilateKeychain = liftIO $ assimilateKeychain' >> return () +assimilateKeychain' = tryIOError $ do + -- pid <- getProcessID + -- tmpDir <- lookupEnv "TMPDIR" + -- let tmpDir' = fromMaybe "/tmp" tmpDir + -- tmpFile = tmpDir' "xmonad-keychain" ++ (show pid) ++ ".env" + env <- runProcessWithInput "sh" ["-c", "eval $(keychain --eval --noask --agents gpg,ssh); env"] "" -- > " ++ tmpFile] "" + -- env <- readFile tmpFile + let envVars = Map.fromList $ map (\(k, v) -> (k, tail' v)) $ map (span (/= '=')) $ envLines + envVars' = Map.filterWithKey (\k _ -> k `elem` transfer) envVars + transfer = ["SSH_AUTH_SOCK", "SSH_AGENT_PID", "GPG_AGENT_INFO"] + envLines = filter (elem '=') $ lines env :: [String] + sequence $ map (\(k, c) -> setEnv k c) $ Map.toList envVars' + -- removeFile tmpFile + where + tail' [] = [] + tail' (x:xs) = xs + + +numKeys = [xK_parenleft, xK_parenright, xK_braceright, xK_plus, xK_braceleft, xK_bracketright, xK_bracketleft, xK_exclam, xK_equal, xK_asterisk] + +instance Shrinker CustomShrink where + shrinkIt _ "" = [""] + shrinkIt s cs + | length cs >= 4 = cs : shrinkIt s ((reverse . drop 4 . reverse $ cs) ++ "...") + | otherwise = cs : shrinkIt s (init cs) + +xPConfig :: XPConfig +xPConfig = def + { font = "xft:Fira Mono for Powerline:style=Medium:pixelsize=22.5" + , height = 32 + , bgColor = "black" + , fgColor = "grey" + , fgHLight = "green" + , bgHLight = "black" + , borderColor = "grey" + , searchPredicate = (\needle haystack -> all (`isInfixOf` map toLower haystack) . map (map toLower) $ words needle) + , position = Top + } + +sshOverrides = map (\h -> mkOverride { oHost = h, oCommand = moshCmd . inTmux } ) + [ + "odin", "odin.asgard.yggdrasil" + , "ymir", "ymir.yggdrasil.li", "ymir.niflheim.yggdrasil" + , "surtr", "yggdrasil.li", "surtr.yggdrasil.li", "praseodym.org", "surtr.praseodym.org", "surtr.141.li", "141.li" + , "vindler", "vindler.alfheim.yggdrasil" + , "ullr" + , "heimdallr", "heimdallr.asgard.yggdrasil" + , "testworx" + ] + ++ + map (\h -> mkOverride { oHost = h, oCommand = moshCmd' "/run/current-system/sw/bin/mosh-server" . withEnv [("TERM", "xterm")] . inTmux} ) + [ "bragi", "bragi.asgard.yggdrasil" + ] + ++ + map (\h -> mkOverride { oHost = h, oCommand = sshCmd . withEnv [("TERM", "xterm")] . inTmux } ) + [ "remote.cip.ifi.lmu.de" + , "uniworx3", "uniworx4", "uniworxdb" + ] + +backlight :: (Rational -> Rational) -> X () +backlight f = void . xfork . liftIO $ do + [ _device + , _class + , read . Text.unpack -> currentBright + , _currentPercentage + , read . Text.unpack -> maximumBright + ] <- Text.splitOn "," . Text.pack <$> readProcess "brightnessctl" ["-m"] "" + let current = currentBright % maximumBright + new' = f current * fromIntegral maximumBright + new :: Integer + new | floor new' < 0 = 0 + | ceiling new' > maximumBright = maximumBright + | new' >= maximumBright % 2 = ceiling new' + | otherwise = floor new' + callProcess "brightnessctl" ["-m", "s", show new] + +cycleThrough :: [Rational] -> (Rational -> Rational) +cycleThrough opts current = fromMaybe currentOpt $ listToMaybe next' + where currentOpt = minimumBy (comparing $ abs . subtract current) opts + (_, _ : next') = break (== currentOpt) opts + +cycleKbLayout :: [(String, Maybe String)] -> X () +cycleKbLayout [] = return () +cycleKbLayout layouts = liftIO $ do + next <- (getNext . extract) `liftM` runProcessWithInput "setxkbmap" ["-query"] "" + let + args = case next of + (l, Just v) -> [l, v] + (l, Nothing) -> [l] + safeSpawn "setxkbmap" args + where + extract :: String -> Maybe (String, Maybe String) + extract str = listToMaybe $ do + ["layout:", l] <- str' + [(l, Just v) | ["variant:", v] <- str'] ++ pure (l, Nothing) + where + str' = map words $ lines str + getNext :: Maybe (String, Maybe String) -> (String, Maybe String) + getNext = maybe (head layouts) getNext' + getNext' x = case elemIndex x layouts of + Nothing -> getNext Nothing + Just i -> layouts !! ((i + 1) `mod` length layouts) + +mpvAll' :: MpvCommand -> IO [MpvResponse] +mpvAll' = mpvAll "/var/media/.mpv-ipc" + +mpvOne' :: MpvCommand -> IO (Maybe MpvResponse) +mpvOne' = mpvOne "/var/media/.mpv-ipc" + +mediaMpv :: MpvCommand -> X () +mediaMpv cmd = void . xfork $ print =<< mpvAll' cmd + +mediaMpvTogglePause :: X () +mediaMpvTogglePause = void . xfork $ do + paused <- mapM mpvResponse <=< mpvAll' $ MpvGetProperty "pause" + if + | and paused -> print <=< mpvAll' $ MpvSetProperty "pause" False + | otherwise -> print <=< mpvOne' $ MpvSetProperty "pause" True + +myKeys' conf host = Map.fromList $ + -- launch a terminal + [ ((modm, xK_Return), spawn $ (XMonad.terminal conf) ++ " -e tmux") + , ((modm .|. shiftMask, xK_Return), spawn $ XMonad.terminal conf) + + -- launch dmenu + --, ((modm, xK_d ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") + , ((modm, xK_d ), shellPrompt "Run: " xPConfig) + , ((modm .|. shiftMask, xK_d ), prompt "Run in Terminal: " ("urxvtc" ++ " -e") xPConfig) + , ((modm, xK_at ), sshPrompt sshOverrides xPConfig) + + -- close focused window + , ((modm .|. shiftMask, xK_q ), kill) + , ((modm .|. controlMask .|. shiftMask, xK_q ), spawn "xkill") + + -- Rotate through the available layout algorithms + , ((modm, xK_space ), sendMessage NextLayout) + + -- Reset the layouts on the current workspace to default + , ((modm .|. controlMask, xK_r ), (setLayout $ XMonad.layoutHook conf) >> refresh) + + -- Resize viewed windows to the correct size + , ((modm, xK_r ), refresh) + + -- Move focus to the next window + , ((modm, xK_t ), windows W.focusDown) + + -- Move focus to the previous window + , ((modm, xK_n ), windows W.focusUp ) + + -- Move focus to the master window + , ((modm, xK_m ), windows W.focusMaster ) + + -- Swap the focused window and the master window + , ((modm .|. shiftMask, xK_m ), windows W.swapMaster) + + -- Swap the focused window with the next window + , ((modm .|. shiftMask, xK_t ), windows W.swapDown ) + + -- Swap the focused window with the previous window + , ((modm .|. shiftMask, xK_n ), windows W.swapUp ) + + -- Swap the focused window with the previous window + , ((modm .|. shiftMask .|. controlMask, xK_m), sendMessage SwapWindow) + + , ((modm, xK_Right), sendMessage $ Go R) + , ((modm, xK_Left ), sendMessage $ Go L) + , ((modm, xK_Up ), sendMessage $ Go U) + , ((modm, xK_Down ), sendMessage $ Go D) + , ((modm .|. shiftMask , xK_Right), sendMessage $ Move R) + , ((modm .|. shiftMask , xK_Left ), sendMessage $ Move L) + , ((modm .|. shiftMask , xK_Up ), sendMessage $ Move U) + , ((modm .|. shiftMask , xK_Down ), sendMessage $ Move D) + -- , ((modm .|. controlMask, xK_Right), withFocused $ keysMoveWindow (10, 0)) + -- , ((modm .|. controlMask, xK_Left ), withFocused $ keysMoveWindow (-10, 0)) + -- , ((modm .|. controlMask, xK_Up ), withFocused $ keysMoveWindow (0, -10)) + -- , ((modm .|. controlMask, xK_Down ), withFocused $ keysMoveWindow (0, 10)) + -- Shrink the master area + , ((modm, xK_h ), sendMessage Shrink) + + -- Expand the master area + , ((modm, xK_s ), sendMessage Expand) + + -- Push window back into tiling + , ((modm .|. shiftMask, xK_space ), withFocused $ windows . W.sink) + , ((modm, xK_BackSpace), focusUrgent) + , ((modm .|. shiftMask, xK_BackSpace), clearUrgents) + + -- Increment the number of windows in the master area + , ((modm , xK_comma ), sendMessage (IncMasterN 1)) + + -- Deincrement the number of windows in the master area + , ((modm , xK_period), sendMessage (IncMasterN (-1))) + + , ((0, xF86XK_AudioRaiseVolume), safeSpawn "pulseaudio-ctl" ["up", "2"]) + , ((0, xF86XK_AudioLowerVolume), safeSpawn "pulseaudio-ctl" ["down", "2"]) + , ((0, xF86XK_AudioMute), safeSpawn "pulseaudio-ctl" ["mute"]) + , ((0, xF86XK_AudioPause), mediaMpv $ MpvSetProperty "pause" False) + , ((0, {-xF86XK_AudioMicMute-} 269025202), safeSpawn "pulseaudio-ctl" ["mute-input"]) + , ((0, xF86XK_AudioPlay), mediaMpvTogglePause) + , ((modm .|. mod1Mask, xK_space), mediaMpvTogglePause) + + , ((0, xF86XK_MonBrightnessDown), backlight (subtract 5)) + , ((0, xF86XK_MonBrightnessUp), backlight (+ 5)) + + , ((modm , xK_Escape), cycleKbLayout (hKbLayouts host)) + , ((modm .|. controlMask, xK_Escape), safeSpawn "setxkbmap" $ fst (head $ hKbLayouts host) : maybeToList (snd . head $ hKbLayouts host)) + + -- Toggle the status bar gap + -- Use this binding with avoidStruts from Hooks.ManageDocks. + -- See also the statusBar function from Hooks.DynamicLog. + -- + , ((modm , xK_b ), sendMessage ToggleStruts) + + , ((modm .|. shiftMask, xK_p ), safeSpawn "playerctl" ["-a", "pause"]) + + -- Quit xmonad + , ((modm .|. shiftMask, xK_e ), io (exitWith ExitSuccess)) + + -- Restart xmonad + -- , ((modm .|. shiftMask .|. controlMask, xK_r ), void . xfork $ recompile False >>= flip when (safeSpawn "xmonad" ["--restart"])) + , ((modm .|. shiftMask, xK_r ), void . liftIO $ executeFile "xmonad" True [] Nothing) + , ((modm .|. shiftMask, xK_l ), void . xfork $ do + sessId <- getEnv "XDG_SESSION_ID" + safeSpawn "loginctl" ["lock-session", sessId] + ) + , ((modm .|. shiftMask, xK_s ), safeSpawn "systemctl" ["suspend"]) + , ((modm .|. shiftMask, xK_h ), safeSpawn "systemctl" ["hibernate"]) + , ((modm .|. shiftMask, xK_b ), backlight $ cycleThrough [1, 3 % 4, 1 % 2, 1 % 4, 1 % 10, 1 % 100, 0] + ) + , ((modm .|. shiftMask .|. controlMask, xK_b), backlight $ cycleThrough [0, 1 % 100, 1 % 10, 1 % 4, 1 % 2, 3 % 4, 1] + ) + , ((modm, xK_v ), windows copyToAll) -- @@ Make focused window always visible + , ((modm .|. shiftMask, xK_v ), killAllOtherCopies) -- @@ Toggle window state back + , ((modm .|. shiftMask, xK_g ), windowPrompt xPConfig Goto wsWindows) + , ((modm .|. shiftMask .|. controlMask, xK_g ), windowPrompt xPConfig Bring allWindows) + ] + ++ + + -- + -- mod-[1..9], Switch to workspace N + -- + -- mod-[1..9], Switch to workspace N + -- mod-shift-[1..9], Move client to workspace N + -- + [((m .|. modm, k), windows $ f i) + | (i, k) <- zip (XMonad.workspaces conf) $ numKeys + , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)] + ] + ++ + [((m .|. modm .|. controlMask, k), void . runMaybeT $ + MaybeT (P.getScreen def i) >>= MaybeT . screenWorkspace >>= lift . windows . f + ) + | (i, k) <- zip (hScreens host) [xK_g, xK_c, xK_r, xK_l] + , (f, m) <- [(W.view, 0), (W.shift, shiftMask)] + ] + where + modm = XMonad.modMask conf + + -- cgit v1.2.3