skeleton-0.1.0.0: src/Main.hs

{-# LANGUAGE RecordWildCards #-}

import Skeleton.Types
import Skeleton.Pretty
import Skeleton.Parser

import Control.Monad       (when)
import Data.List           (isInfixOf)
import System.FilePath     (takeBaseName)
import System.Process      (readProcess, callCommand)
import System.Posix.Escape (escape)
import System.Console.ArgParser


-- Search functions --

byAttrib :: Attrib -> Keychain -> [Item]
byAttrib a = filter (elem a . attrs)

fuzzy :: String -> Keychain -> [Item]
fuzzy x = filter (any (isInfixOf x) . strings)
  where
    strings =  map unvalue . attrs
    unvalue (_, Str s) = s
    unvalue _          = ""


-- Keychain access --

keychainList :: IO [FilePath]
keychainList = do
  raw <- readProcess "security" ["list-keychains"] ""
  case runParser parseKeychainList raw of
    Just list -> return $ filter ((/="System") . takeBaseName) list
    Nothing   -> error "failed to parse active keychains list"

getKeychain :: [FilePath] -> IO Keychain
getKeychain paths = do
  raw <- readProcess "security" ("dump-keychain" : "-d" : paths) ""
  case runParser parseKeychain raw of
    Just items -> return items
    Nothing    -> error "failed to parse keychain"

sendClipboard :: String -> IO ()
sendClipboard text =
  callCommand $ "echo " ++ (escape text) ++ " | pbcopy"


-- CLI arguments --

data ProgArgs = ProgArgs
  { searchTerm   :: String
  , keychain     :: FilePath
  , exactMatches :: String
  , resultsLimit :: Int
  , contentOnly  :: Bool
  , noClipboard  :: Bool
  } deriving (Show)

parser :: ParserSpec ProgArgs
parser = ProgArgs
  `parsedBy` reqPos      "term"        `Descr` "Keychain search term"
  `andBy`    optFlag  "" "keychain"    `Descr` "Use a specific keychain (default: all except System)"
  `andBy`    optFlag  "" "exact"       `Descr` "Return exact matches with the given class"
  `andBy`    optFlag  10 "limit"       `Descr` "Set upper results limit (default: 10, 0: unlimited)"
  `andBy`    boolFlag    "content"     `Descr` "Print only the items content"
  `andBy`    boolFlag    "noclipboard" `Descr` "Disable paste to clipboard"

interface :: IO (CmdLnInterface ProgArgs)
interface =
  (`setAppDescr` "Quickly access the OSX keychain") <$>
  (`setAppEpilog` "The skeleton key") <$>
  mkApp parser

main :: IO ()
main = interface >>= (`runApp` search)


-- Program --

search :: ProgArgs -> IO ()
search ProgArgs {..} = do
  paths <- if null keychain 
             then keychainList
             else return [keychain]
  items <- getKeychain paths
  let select = if resultsLimit == 0
                 then id
                 else take resultsLimit
  let res = if null exactMatches
              then select (fuzzy searchTerm items)
              else select (byAttrib (Left exactMatches, Str searchTerm) items)
  if null res
    then putStrLn "No results found"
    else do
      if contentOnly
        then mapM_ putStrLn (map content res)
      else pprint res
      when (not noClipboard) (sendClipboard (content $ head res))