commit 49c4f4cf1cf135194f71f55c87845638be37d336 Author: ndwarshuis Date: Thu Apr 23 23:32:29 2020 -0400 init commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..30d4c0d --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +.stack-work/ +*~ +TAGS +*.cabal \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..8f536fc --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Nathan Dwarshuis (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Nathan Dwarshuis nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..dc34a36 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# rofi-extras diff --git a/app/rofi-bitwarden.hs b/app/rofi-bitwarden.hs new file mode 100644 index 0000000..e036051 --- /dev/null +++ b/app/rofi-bitwarden.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Main (main) where + +import Control.Concurrent +import Control.Monad + +import Data.Aeson +import Data.Maybe +import Data.String +import Data.UnixTime + +import DBus +import DBus.Client + +import GHC.Generics + +import Rofi.Command + +import Text.Read + +import System.Clipboard +import System.Directory +import System.Environment +import System.Exit +import System.Process + +main :: IO () +main = runChecks >> getArgs >>= parse + +parse :: [String] -> IO () +parse ["-d", t] = case readMaybe t of { Just t' -> runDaemon t'; _ -> usage } +parse ("-c":args) = runClient args +parse _ = usage + +usage :: IO () +usage = putStrLn $ joinNewline + [ "daemon mode: rofi-bw -d TIMEOUT" + , "client mode: rofi-bw -c [ROFI-ARGS]" + ] + +runChecks :: IO () +runChecks = checkExe "bw" >> checkExe "rofi" + +checkExe :: String -> IO () +checkExe cmd = do + res <- findExecutable cmd + unless (isJust res) $ do + putStrLn $ "Could not find executable: " ++ cmd + exitWith $ ExitFailure 1 + +-------------------------------------------------------------------------------- +-- | Daemon +-- +-- Daemon will export an interface on DBus with two methods: +-- * get current session id - if no session is active, launch Rofi to prompt +-- for a password; return session id or null if password is invalid +-- * lock session - destroy the current session id if active +-- +-- The session ID will be valid only as long as TIMEOUT + +newtype BWConf = BWConf + { timeout :: UnixDiffTime + } + +data CurrentSession = CurrentSession + { timestamp :: UnixTime + , hash :: String + } + +type Session = MVar (Maybe CurrentSession) + +runDaemon :: Int -> IO () +runDaemon t = do + ses <- newMVar Nothing + let c = BWConf { timeout = UnixDiffTime (fromIntegral t) 0 } + startService c ses + forever $ threadDelay 1000000 + +lockSession :: Session -> IO () +lockSession ses = void $ swapMVar ses Nothing + +getSession :: BWConf -> Session -> IO String +getSession BWConf { timeout = t } ses = do + ut <- getUnixTime + modifyMVar ses $ \s -> case s of + Just CurrentSession { timestamp = ts, hash = h } -> + if diffUnixTime ut ts > t then getNewSession else return (s, h) + Nothing -> getNewSession + where + getNewSession = do + pwd <- readPassword + newHash <- join <$> mapM readSession pwd + (, fromMaybe "" newHash) <$> mapM newSession newHash + newSession h = do + ut <- getUnixTime + return CurrentSession { timestamp = ut, hash = h } + +readPassword :: IO (Maybe String) +readPassword = readCmdSuccess "rofi" args "" + where + args = dmenuArgs ++ ["-p", "Password", "-password"] + +readSession :: String -> IO (Maybe String) +readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] "" + +-------------------------------------------------------------------------------- +-- | Client +-- +-- The client will get the current session from the daemon (if it can) and then +-- go through a decision-tree like selection process to retrieve information as +-- needed. This will be in the form of the following menus: +-- +-- Main menus +-- - Lock Session -> lock the session +-- - Browse logins -> show new menu of all logins +-- - select an entry -> show new menu with entry contents +-- - All -> copy all to clipboard +-- - username (if applicable) -> copy to clipboard +-- - password (if applicable) -> copy to clipboard +-- - anything else (notes and such) -> copy to clipboard + +runClient :: [String] -> IO () +runClient a = do + let c = RofiConf { defArgs = a } + runRofiPrompt c $ selectAction $ emptyMenu + { groups = [untitledGroup $ toRofiActions ras] + , prompt = Just "Action" + } + where + ras = [ ("Browse Logins", browseLogins) + , ("Lock Session", io callLockSession) + ] + +browseLogins :: RofiPrompt () +browseLogins = do + session <- io callGetSession + forM_ session $ getItems >=> selectItem + +getItems :: String -> RofiPrompt [Item] +getItems session = do + items <- io $ readProcess "bw" ["list", "items", "--session", session] "" + return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items + where + notEmpty Item { login = Login { username = Nothing, password = Nothing } } + = False + notEmpty _ = True + +data Item = Item + { name :: String + , login :: Login + } + deriving (Show) + +instance FromJSON Item where + parseJSON (Object o) = Item + <$> o .: "name" + <*> o .:? "login" .!= Login { username = Nothing, password = Nothing } + parseJSON _ = mzero + +data Login = Login + { username :: Maybe String + , password :: Maybe String + } + deriving (Show, Generic) + +instance FromJSON Login + +-- TODO make menu buttons here to go back and to copy without leaving +-- the current menu +selectItem :: [Item] -> RofiPrompt () +selectItem items = selectAction $ emptyMenu + { groups = [untitledGroup $ itemsToRofiActions items] + , prompt = Just "Login" + } + +itemsToRofiActions :: [Item] -> RofiActions +itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i)) + +selectCopy :: Login -> RofiPrompt () +selectCopy l = selectAction $ emptyMenu + { groups = [untitledGroup $ loginToRofiActions l copy] + , prompt = Just "Copy" + , hotkeys = [copyHotkey, backHotkey] + } + where + copy = io . setClipboardString + copyRepeat s = copy s >> selectCopy l + copyHotkey = Hotkey + { keyCombo = "Alt+c" + , keyIndex = 1 + , keyDescription = "Copy One" + , keyActions = loginToRofiActions l copyRepeat + } + backHotkey = Hotkey + { keyCombo = "Alt+q" + , keyIndex = 2 + , keyDescription = "Back" + -- TODO this is overly complicated, all entries do the same thing + -- TODO this is slow, we can cache the logins somehow... + , keyActions = loginToRofiActions l (const browseLogins) + } + +loginToRofiActions :: Login -> (String -> RofiPrompt ()) -> RofiActions +loginToRofiActions Login { username = u, password = p } a = + toRofiActions $ catMaybes [user, pwd] + where + copyIfJust f = fmap $ liftM2 (,) f a + fmtUsername s = "Username (" ++ s ++ ")" + fmtPassword s = "Password (" ++ take 32 (replicate (length s) '*') ++ ")" + user = copyIfJust fmtUsername u + pwd = copyIfJust fmtPassword p + +-------------------------------------------------------------------------------- +-- | DBus + +busname :: BusName +busname = "org.rofi.bitwarden" + +path :: ObjectPath +path = "/bitwarden" + +interface :: InterfaceName +interface = "org.rofi.bitwarden.session" + +memGetSession :: MemberName +memGetSession = "GetSession" + +memLockSession :: MemberName +memLockSession = "LockSession" + +startService :: BWConf -> Session -> IO () +startService c ses = do + client <- connectSession + let flags = [nameAllowReplacement, nameReplaceExisting] + _ <- requestName client busname flags + putStrLn "Started rofi bitwarden dbus client" + export client path defaultInterface + { interfaceName = interface + , interfaceMethods = + [ autoMethod memGetSession $ getSession c ses + , autoMethod memLockSession $ lockSession ses + ] + } + +callLockSession :: IO () +callLockSession = do + reply <- callMethod $ methodCall path interface memLockSession + case reply of + Left err -> putStrLn $ methodErrorMessage err + Right _ -> return () + +callGetSession :: IO (Maybe String) +callGetSession = do + reply <- callMethod $ methodCall path interface memGetSession + case reply of + Left err -> putStrLn (methodErrorMessage err) >> return Nothing + Right body -> return $ getBodySession body + +getBodySession :: [Variant] -> Maybe String +getBodySession [b] = case ses of { Just "" -> Nothing; _ -> ses } + where + ses = fromVariant b :: Maybe String +getBodySession _ = Nothing + +callMethod :: MethodCall -> IO (Either MethodError [Variant]) +callMethod mc = do + client <- connectSession + reply <- call client mc { methodCallDestination = Just busname } + disconnect client + return $ methodReturnBody <$> reply diff --git a/app/rofi-devices.hs b/app/rofi-devices.hs new file mode 100644 index 0000000..45dc473 --- /dev/null +++ b/app/rofi-devices.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import Control.Exception +import Control.Monad + +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Char +import Data.Csv hiding (lookup) +import Data.Either +import Data.List +import Data.List.Split (splitOn) +import qualified Data.Map as M +import qualified Data.Map.Ordered as O +import Data.Maybe +import Data.Vector (Vector, toList) + +import GHC.Generics (Generic) + +import Rofi.Command + +import Text.Printf +import Text.Regex.TDFA + +import System.Directory +import System.Environment +import System.Process + +main :: IO () +main = check >> getArgs >>= parse + +parse :: [String] -> IO () +parse = runMounts + +-- TODO +check :: IO () +check = return () + +runMounts :: [String] -> IO () +runMounts a = do + let c = RofiConf { defArgs = a } + runRofiPrompt c runPrompt + +runPrompt :: RofiPrompt () +runPrompt = do + net <- titledGroup "Network Devices" <$> io getNetActions + rmv <- titledGroup "Removable Devices" <$> io getRemovableActions + mtp <- titledGroup "MTP Devices" <$> io getMTPActions + selectAction $ emptyMenu + { groups = [net, rmv, mtp] + , prompt = Just "Select Device" + } + +getNetActions :: IO RofiActions +getNetActions = alignEntries . toRofiActions . catMaybes + <$> (mapM csvToAction =<< getCSV) + +alignSep :: String +alignSep = " | " + +alignSepPre :: String +alignSepPre = "@@@" + +alignEntries :: RofiActions -> RofiActions +alignEntries = O.fromList . withKeys . O.assocs + where + withKeys as = let (ks, vs) = unzip as in zip (align ks) vs + align ks = fmap (intercalate alignSep) + $ transpose + $ mapToLast pad + $ transpose + $ fmap (splitOn alignSepPre) ks + pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs + getMax = maximum . fmap length + mapToLast _ [] = [] + mapToLast _ [x] = [x] + mapToLast f (x:xs) = f x : mapToLast f xs + +-- | Class and methods for type representing mountable devices +class Mountable a where + -- | Mount the given type (or dismount if False is passed) + mount :: a -> Bool -> IO () + + -- | Check if the mounting utilities are present + allInstalled :: a -> IO Bool + + -- | Return a string to go in the Rofi menu for the given type + fmtEntry :: a -> String + + -- | Determine if the given type is mounted or not + isMounted :: a -> IO Bool + + -- | Given a mountable type, return a rofi action (string to go in the + -- Rofi prompt and an action to perform when it is selected) + mkAction :: a -> IO (String, RofiPrompt ()) + mkAction dev = do + m <- isMounted dev + i <- allInstalled dev + let a = when i $ io $ mount dev m + let s = mountedPrefix m i ++ fmtEntry dev + return (s, a) + where + mountedPrefix False True = " " + mountedPrefix True True = "* " + mountedPrefix _ False = "! " + +-- | Key/val pairs to represent mount options. A Nothing for the value signifies +-- a standalone option (eg 'rw' and 'ro') +type MountOptions = M.Map String (Maybe String) + +-- | Given a string of comma-separated 'key=val' pairs, return a mount options +-- map +parseMountOptions :: String -> MountOptions +parseMountOptions s = M.fromList $ toCell . splitEq <$> splitBy ',' s + where + splitEq e = e =~ ("=" :: String) :: (String, String, String) + toCell (k, "=", v) = (k, Just v) + toCell (k, _, _) = (k, Nothing) + +-- | Given a mount options map, return a string of comma separated items +fmtMountOptions :: MountOptions -> String +fmtMountOptions = intercalate "," . fmap fromCell . M.toList + where + fromCell (k, Just v) = k ++ "=" ++ v + fromCell (k, Nothing) = k + +-- | Various credentials to be used with a given mountable type. +-- Secret: represents a lookup using 'secret-tool' where the map represents +-- the attribute/value pairs to pass. +-- NoCredentials: self explanatory +data Credentials = Secret (M.Map String String) + | NoCredentials + deriving (Eq, Show) + +-- | Given a string, return a credentials type. The type of credentials is +-- determined by the prefix (which is followed by a colon) and is followed by +-- a comma-separated list of 'key=val' pairs +parseCredentials :: String -> Credentials +parseCredentials c = case splitPrefix c of + ("secret", ":", r) -> Secret $ M.fromList $ mapMaybe (toCell . splitEq) $ splitBy ',' r + -- TODO fetch from bitwarden + -- add more here... + _ -> NoCredentials + where + splitPrefix s = s =~ (":" :: String) :: (String, String, String) + splitEq e = e =~ ("=" :: String) :: (String, String, String) + toCell (k, "=", v) = Just (k, v) + toCell _ = Nothing + +-------------------------------------------------------------------------------- +-- | Removable devices +-- +-- A device which can be removed (which is all the devices we care about) +-- This can be minimally described by a device PATH and LABEL. If MOUNTPOINT is +-- Nothing, this represents the device being mounted at a default location. + +data Removable = Removable + { path :: String + , label :: String + , mountpoint :: Maybe String + } + deriving (Eq, Show) + +instance Mountable Removable where + -- | (Un)mount the device using udiskctl + mount Removable { path = p, label = l } m = do + res <- readCmdEither "udisksctl" [cmd, "-b", p] "" + notifyMounted (isRight res) m l + where + cmd = if m then "unmount" else "mount" + + -- | Need udisksctl to mount and umount + allInstalled _ = isJust <$> findExecutable "udisksctl" + + -- | Check if the device is mounted using /proc/mount + isMounted Removable { path = p, mountpoint = m } = do + cur <- curMountpoints + return $ case m of + Just m' -> (p, m') `elem` cur + Nothing -> p `elem` fmap fst cur + + -- | Format the Rofi entry like 'LABEL - PATH' and add a star in the front + -- if the device is mounted + fmtEntry Removable { path = p, label = l } = l ++ alignSepPre ++ p + + +-- | Return list of possible rofi actions for removable devices +-- A 'removable device' is defined as a hotplugged device with a filesystem as +-- reported by 'lsblk'. If the LABEL does not exist on the filesystem, the +-- label shown on the prompt will be 'SIZE Volume' where size is the size of +-- the device +getRemovableDevices :: IO [Removable] +getRemovableDevices = mapMaybe toDev + . lines + . stripWS + <$> readProcess "lsblk" ["-n", "-r", "-o", columns] "" + where + columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE" + -- can't use 'words' here since it will drop spaces in the front + toDev line = case splitBy ' ' line of + ("":_) -> Nothing + [_, "1", p, "", s] -> mk p $ s ++ " Volume" + [_, "1", p, l, _] -> mk p l + _ -> Nothing + mk p l = Just $ Removable { path = p + , label = l + , mountpoint = Nothing + } + +getRemovableActions :: IO RofiActions +getRemovableActions = alignEntries . toRofiActions + <$> (mapM mkAction =<< getRemovableDevices) + +-------------------------------------------------------------------------------- +-- | CIFS Devices +-- +-- This wraps the Removable device (since it is removable) and also adds its +-- own mount options and credentials for authentication. + +data CIFS = CIFS Removable MountOptions Credentials + +instance Mountable CIFS where + -- | Mount using udevil + mount (CIFS Removable{..} opts creds) False = do + pwd <- getPassword creds + let opts' = fmtOpts $ addPwd pwd opts + res <- readCmdEither "udevil" (["mount"] ++ opts' ++ ["-t", "cifs", path]) "" + notifyMounted (isRight res) False label + where + addPwd (Just pwd) o = M.insert "password" (Just pwd) o + addPwd Nothing o = o + fmtOpts o = if null o then [] else ["-o", fmtMountOptions o] + + -- | Unmount using udevil + mount (CIFS Removable{..} _ _) True = do + res <- readCmdEither "udevil" ["unmount", path] "" + notifyMounted (isRight res) True label + + -- | Need udevil and mount.cifs + allInstalled _ = all isJust <$> mapM findExecutable ["udevil", "mount.cifs"] + + -- | Return True if mounted. Only checks the removable type wrapped within + isMounted (CIFS r _ _) = isMounted r + + -- | Format the Rofi entry like 'LABEL - (CIFS) - PATH' and prefix with a star + -- if mounted + fmtEntry (CIFS r _ _) = fmtNetEntry r "CIFS" + +-------------------------------------------------------------------------------- +-- | SSHFS Devices +-- +-- This wraps the Removable device (since it is removable) and also adds its +-- own mount options. If the path does not point to an aliased entry in the ssh +-- config that specifies the port, hostname, user, and identity file, these +-- need to be passed as mount options. + +data SSHFS = SSHFS Removable MountOptions + +instance Mountable SSHFS where + -- | Mount using sshfs + mount (SSHFS Removable{..} opts) False = + case mountpoint of + Just m -> cmd m + -- TODO only destroy mountpoint if it is not already another mountpoint + Nothing -> bracketOnError (makeFuseMount label) + (const $ destroyFuseMount label) (const $ cmd $ fmtFusePath label) + where + -- TODO add auto-dismount to options + opts' = if null opts then [] else ["-o", fmtMountOptions opts] + cmd m' = do + res <- readCmdEither "sshfs" ([path, m'] ++ opts') "" + notifyMounted (isRight res) False label + + -- | Umount using fusermount + mount (SSHFS r _) True = fuseUnmount r + + -- | Need sshfs (assume fuse is also installed) + allInstalled _ = isJust <$> findExecutable "sshfs" + + -- | Return True if mounted. Only checks the removable type wrapped within + isMounted (SSHFS r _) = isMounted r + + -- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH' and prefix with a + -- star if mounted + fmtEntry (SSHFS r _) = fmtNetEntry r "SSHFS" + +-- | Given a removable device, type string, and boolean for if the device is +-- mounted, return a string like 'LABEL - (TYPESTRING) - PATH' and prefix with a +-- star if mounted +fmtNetEntry :: Removable -> String -> String +fmtNetEntry Removable { label = l, path = p } t = + intercalate alignSepPre [l, t, p] + +-------------------------------------------------------------------------------- +-- | MTP devices + +data MTPFS = MTPFS + { bus :: String + , device :: String + , mountpointMTP :: String + , description :: String + } + deriving (Eq, Show) + +instance Mountable MTPFS where + -- | Mount using sshfs + mount MTPFS {..} False = do + -- TODO add autodismount to options + let dev = "-device=" ++ bus ++ "," ++ device + bracketOnError (createDirectoryIfMissing False mountpointMTP) + (const $ removePathForcibly mountpointMTP) $ \_ -> do + res <- readCmdEither "jmtpfs" [dev, mountpointMTP] "" + notifyMounted (isRight res) False description + + -- | Umount using fusermount + mount MTPFS { mountpointMTP = m, description = d } True = + finally (fuseUnmount' d m) $ removePathForcibly m + + -- | Need jmtpfs (assume fuse is also installed) + allInstalled _ = isJust <$> findExecutable "jmtpfs" + + -- | Return True if mounted. Only checks the mountpoint path + isMounted MTPFS { mountpointMTP = m } = elem m . fmap snd <$> curMountpoints + + -- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH' + fmtEntry MTPFS { description = d } = d + +getMTPDevices :: IO [MTPFS] +getMTPDevices = mapMaybe toDev . toDevList <$> readProcess "jmtpfs" ["-l"] "" + where + toDevList = reverse + . takeWhile (not . isPrefixOf "Available devices") + . reverse + . lines + toDev s = case splitOn ", " s of + [busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc] + in Just $ MTPFS + { bus = busNum + , device = devNum + , mountpointMTP = fuseMount ++ canonicalize d + , description = d + } + _ -> Nothing + canonicalize = mapMaybe repl + repl c + | c `elem` ("\"*/:<>?\\|" :: String) = Nothing + | c == ' ' = Just '-' + | otherwise = Just c + +getMTPActions :: IO RofiActions +getMTPActions = toRofiActions <$> (mapM mkAction =<< getMTPDevices) + +-- TODO add truecrypt volumes (see tcplay, will need root) +-------------------------------------------------------------------------------- +-- | Csv device parsing +-- +-- These devices are stored in a CSV file which needs to be parsed into the +-- appropriate devices types + +-- | Represents one parsable line in the network device config .tsv file +data CsvDev = CsvDev + { csvLabel :: String + , csvType :: String + , csvPath :: String + , csvMountpoint :: Maybe String + , csvMountOptions :: Maybe String + , csvCredentials :: Maybe String + } + deriving (Generic, Show) + +instance FromRecord CsvDev + +-- | Return a list of all Csv lines from the network config file +getCSV :: IO [CsvDev] +getCSV = do + xdgConf <- getEnv "XDG_CONFIG_HOME" + -- TODO this shouldn't be hardcoded + contents <- B.readFile $ xdgConf ++ "/rofi/devices.tsv" + let opts = defaultDecodeOptions { decDelimiter = fromIntegral (ord '\t') } + case decodeWith opts HasHeader contents of + Left s -> putStrLn s >> return [] + Right v -> return $ toList (v :: Vector CsvDev) + +-- TODO split this into each device type so they can be separated in the prompt +-- | Given a parsed csv line from the network config file, return a +-- (ENTRY, ACTION) where ENTRY is a string to appear on the Rofi prompt and +-- ACTION is an action to perform on the device in the csv line when selected +csvToAction :: CsvDev -> IO (Maybe (String, RofiPrompt ())) +csvToAction CsvDev {..} + | csvType == "cifs" = Just <$> mkAction (CIFS r' opts creds) + | csvType == "sshfs" = Just <$> mkAction (SSHFS r opts) + | otherwise = return Nothing + where + r = Removable { label = csvLabel + , path = csvPath + , mountpoint = csvMountpoint + } + opts = maybe M.empty parseMountOptions csvMountOptions + creds = maybe NoCredentials parseCredentials csvCredentials + -- CIFS prefixes the path with two slashes + r' = r { path = smartSlashPrefix csvPath } + smartSlashPrefix s = if "//" `isPrefixOf` s then s else "//" ++ s + +-------------------------------------------------------------------------------- +-- | Low-level mount functions + +-- | Return a list of mountpoints like (PATH, MOUNTPOINT) from /proc/mount +curMountpoints :: IO [(String, String)] +curMountpoints = do + m <- readFile "/proc/mounts" + -- ASSUME this will never fail because the format of this file is fixed + return $ (\(path:mntpnt:_) -> (path, mntpnt)) . words <$> lines m + +-- | Given a path, return its mountpoint if it exists +lookupMountpoint :: String -> IO (Maybe String) +lookupMountpoint path = lookup path <$> curMountpoints + +-- | Given a removable device, unmount it using fuse +fuseUnmount :: Removable -> IO () +fuseUnmount Removable { path = p, mountpoint = m, label = l } = + maybe umountDef umount m + where + umount = fuseUnmount' l + umountDef = lookupMountpoint p >>= + mapM_ (liftM2 finally umount removePathForcibly) + +fuseUnmount' :: String -> String -> IO () +fuseUnmount' label path = do + res <- readCmdEither "fusermount" ["-u", path] "" + notifyMounted (isRight res) True label + +-- | Given credentials, return a password +getPassword :: Credentials -> IO (Maybe String) +getPassword NoCredentials = return Nothing +getPassword (Secret kvs) = do + let kvs' = concat [[a, b] | (a, b) <- M.toList kvs] + readCmdSuccess "secret-tool" ("lookup":kvs') "" + +-- TODO this shouldn't be hardcoded +fuseMount :: FilePath +fuseMount = "/media/ndwar-fuse/" + +-- TODO what if there is no trailing slash? +fmtFusePath :: String -> String +fmtFusePath label = fuseMount ++ label + +makeFuseMount :: String -> IO () +makeFuseMount label = createDirectoryIfMissing False $ fmtFusePath label + +destroyFuseMount :: String -> IO () +destroyFuseMount label = removePathForcibly $ fmtFusePath label + +-------------------------------------------------------------------------------- +-- | Other functions + +-- TODO this exists somewhere... +splitBy :: Char -> String -> [String] +splitBy delimiter = foldr f [[]] + where + f _ [] = [] + f c l@(x:xs) | c == delimiter = []:l + | otherwise = (c:x):xs + +notifyMounted :: Bool -> Bool -> String -> IO () +notifyMounted succeeded mounted label = void $ spawnProcess "notify-send" [msg] + where + f = if succeeded then "Successfully %sed %s" else "Failed to %s %s" + m = if mounted then "unmount" else "mount" :: String + msg = printf f m label diff --git a/lib/Rofi/Command.hs b/lib/Rofi/Command.hs new file mode 100644 index 0000000..a292921 --- /dev/null +++ b/lib/Rofi/Command.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Rofi.Command + ( RofiConf(..) + , RofiMenu(..) + , RofiAction + , RofiActions + , RofiPrompt + , Hotkey(..) + , io + , emptyMenu + , runRofiPrompt + , toRofiActions + , rofiActionKeys + , untitledGroup + , titledGroup + , selectAction + , readCmdSuccess + , readCmdEither + , dmenuArgs + , joinNewline + , stripWS + ) where + +import Control.Monad.Reader + +import Data.Char +import Data.List +import qualified Data.Map.Ordered as M +import Data.Maybe + +import System.Exit +import System.Process + +newtype RofiConf = RofiConf + { defArgs :: [String] + } + deriving (Eq, Show) + +type RofiAction = (String, RofiPrompt ()) + +type RofiActions = M.OMap String (RofiPrompt ()) + +data RofiGroup = RofiGroup + { actions :: RofiActions + , title :: Maybe String + } + +untitledGroup :: RofiActions -> RofiGroup +untitledGroup a = RofiGroup { actions = a, title = Nothing } + +titledGroup :: String -> RofiActions -> RofiGroup +titledGroup t a = (untitledGroup a) { title = Just t } + +data Hotkey = Hotkey + { keyCombo :: String + -- only 1-10 are valid + , keyIndex :: Int + , keyDescription :: String + , keyActions :: RofiActions + } + +hotkeyBinding :: Hotkey -> [String] +hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c] + where + k = "-kb-custom-" ++ show e + +hotkeyMsg1 :: Hotkey -> String +hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } = + c ++ ": " ++ d ++ "" + +hotkeyMsg :: [Hotkey] -> [String] +hotkeyMsg [] = [] +hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs] + +hotkeyArgs :: [Hotkey] -> [String] +hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks + +data RofiMenu = RofiMenu + { groups :: [RofiGroup] + , prompt :: Maybe String + , hotkeys :: [Hotkey] + } + +emptyMenu :: RofiMenu +emptyMenu = RofiMenu + { groups = [] + , prompt = Nothing + , hotkeys = [] + } + +newtype RofiPrompt a = RofiPrompt (ReaderT RofiConf IO a) + deriving (Functor, Monad, MonadIO, MonadReader RofiConf) + +instance Applicative RofiPrompt where + pure = return + (<*>) = ap + +io :: IO a -> RofiPrompt a +io = liftIO + +runRofiPrompt :: RofiConf -> RofiPrompt a -> IO a +runRofiPrompt c (RofiPrompt a) = runReaderT a c + +toRofiActions :: [(String, RofiPrompt ())] -> RofiActions +toRofiActions = M.fromList + +rofiActionKeys :: RofiActions -> String +rofiActionKeys = joinNewline . map fst . M.assocs + +lookupRofiAction :: String -> RofiActions -> RofiPrompt () +lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras + +groupEntries :: RofiGroup -> String +groupEntries RofiGroup { actions = a, title = t } + | null a = "" + | otherwise = title' ++ rofiActionKeys a + where + title' = maybe "" (++ "\n") t + +menuActions :: RofiMenu -> RofiActions +menuActions = foldr1 (M.<>|) . fmap actions . groups + +menuEntries :: RofiMenu -> String +menuEntries = intercalate "\n\n" . fmap groupEntries . groups + +selectAction :: RofiMenu -> RofiPrompt () +selectAction rm = do + let p = maybeOption "-p" $ prompt rm + let hArgs = hotkeyArgs $ hotkeys rm + res <- readRofi (p ++ hArgs) $ menuEntries rm + case res of + Right key -> lookupRofiAction key $ menuActions rm + Left (n, key, _) -> mapM_ (lookupRofiAction key . keyActions) + $ find ((==) n . (+ 9) . keyIndex) + $ hotkeys rm + +maybeOption :: String -> Maybe String -> [String] +maybeOption switch = maybe [] (\o -> [switch, o]) + +dmenuArgs :: [String] +dmenuArgs = ["-dmenu"] + +readRofi :: [String] -> String -> RofiPrompt (Either (Int, String, String) String) +readRofi uargs input = do + dargs <- asks defArgs + io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input + +readCmdSuccess :: String -> [String] -> String -> IO (Maybe String) +readCmdSuccess cmd args input = either (const Nothing) Just + <$> readCmdEither cmd args input + +readCmdEither :: String -> [String] -> String -> IO (Either (Int, String, String) String) +readCmdEither cmd args input = do + (ec, out, err) <- readProcessWithExitCode cmd args input + return $ case ec of + ExitSuccess -> Right $ stripWS out + ExitFailure n -> Left (n, stripWS out, stripWS err) + +stripWS :: String -> String +stripWS = reverse . dropWhile isSpace . reverse + +joinNewline :: [String] -> String +joinNewline = intercalate "\n" diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..df29643 --- /dev/null +++ b/package.yaml @@ -0,0 +1,64 @@ +name: rofi-extras +version: 0.1.0.0 +github: "ndwarshuis/rofi-extras" +license: BSD3 +author: "Nathan Dwarshuis" +maintainer: "ndwar@yavin4.ch" +copyright: "2020 Nathan Dwarshuis" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- process >= 1.6.5.0 +- aeson >= 1.4.5.0 +- unix-time >= 0.4.7 +- dbus >= 1.2.7 +- ordered-containers >= 0.2.2 +- Clipboard >= 2.3.2.0 +- mtl >= 2.2.2 +- directory >= 1.3.3.0 +- cassava >= 0.5.2.0 +- bytestring >= 0.10.8.2 +- vector >= 0.12.0.3 +- regex-tdfa >= 1.2.3.2 +- split >= 0.2.3.4 + +library: + source-dirs: lib/ + ghc-options: + - -Wall + - -Werror + - -threaded + exposed-modules: + - Rofi.Command + +executables: + rofi-bw: + main: rofi-bitwarden.hs + source-dirs: app + ghc-options: + - -Wall + - -Werror + - -threaded + dependencies: + - rofi-extras + rofi-dev: + main: rofi-devices.hs + source-dirs: app + ghc-options: + - -Wall + - -Werror + - -threaded + dependencies: + - rofi-extras diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..f5b329d --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-14.12 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..a311fe3 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 545658 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/12.yaml + sha256: 26b807457213126d26b595439d705dc824dbb7618b0de6b900adc2bf6a059406 + original: lts-14.12