skeleton/src/Main.hs

{-# LANGUAGE RecordWildCards #-}

import Types
import Pretty
import Parser

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


-- Search functions --

byServer :: String -> Keychain -> [Item]
byServer s = byAttrib (Left "srv", Str s)

byAccount :: String -> Keychain -> [Item]
byAccount a = byAttrib (Left "acct", Str a)

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

attrib :: Name -> Item -> Maybe Value
attrib a = lookup 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 list
    Nothing   -> error "failed to parse active keychains list"

getKeychain :: IO Keychain
getKeychain = do
  paths <- filter ((/="System") . takeBaseName) <$> keychainList
  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 " ++ (show 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"
  `andBy`    optFlag  "" "exact"     `Descr` "Only return exact matches"
  `andBy`    optFlag  10 "limit"     `Descr` "Set upper results limit"
  `andBy`    boolFlag    "content"   `Descr` "Print only the items content"
  `andBy`    boolFlag    "clipboard" `Descr` "Disable clipboard paste"

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

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


search :: ProgArgs -> IO ()
search ProgArgs {..} = do
  res <- fuzzy "gog.com" <$> getKeychain
  pprint res
  when (not noClipboard) (sendClipboard (content $ head res))