Initial commit

Main.hs

@@ -0,0 +1,56 @@
+import Types
+import Pretty
+import Parser
+
+import Data.List       (isInfixOf)
+import System.FilePath (takeBaseName)
+import System.Process  (readProcess, callCommand)
+
+
+-- 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 =
+  runParser parseKeychainList <$>
+  readProcess "security" ["list-keychains"] ""
+
+getKeychain :: IO Keychain
+getKeychain = do
+  paths <- filter ((/="System") . takeBaseName) <$> keychainList
+  dump  <- readProcess "security" ("dump-keychain" : "-d" : paths) ""
+  return (runParser parseKeychain dump)
+
+sendClipboard :: String -> IO ()
+sendClipboard text =
+  callCommand $ "echo " ++ (show text) ++ " | pbcopy"
+
+
+main :: IO ()
+main = do
+  res <- fuzzy "gog.com" <$> getKeychain
+  sendClipboard (content (head res))
+  pprint res
+
+

Parser.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser
+( parseKeychain
+, parseKeychainList
+, runParser
+) where
+
+import Types
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8
+import Data.ByteString.Char8 (pack, unpack)
+import Data.Hex              (unhex)
+import Data.Time
+
+
+runParser :: Monoid a => Parser a -> String -> a
+runParser parser = handle . parseOnly parser . pack
+  where
+    handle (Left  _) = mempty
+    handle (Right x) = x
+
+
+-- Parsers --
+
+parseKeychain :: Parser Keychain
+parseKeychain = many item
+
+parseKeychainList :: Parser [FilePath]
+parseKeychainList = many $
+  between (many space >> quote) quote anyChar
+
+item :: Parser Item
+item = do
+  string "keychain: "
+  path <- quoted
+  endOfLine
+  string "class: "
+  class_ <- iclass <|> sclass
+  endOfLine
+  string "attributes:"
+  endOfLine
+  attrs <- many entry
+  endOfLine
+  string "data:"
+  endOfLine
+  raw <- raw  <|> hex' <|>
+         raw' <|> pure "" <* endOfLine
+  return Item { keychain  = path
+              , itemClass = class_
+              , attrs     = attrs 
+              , content   = raw }
+
+entry :: Parser Attrib
+entry = do
+  many space
+  name <- eitherP quoted hex
+  between (char '<') (char '>') anyChar
+  char '='
+  val <- value
+  return (name, val)
+
+value :: Parser Value
+value =
+  pure Null <$> string "<NULL>" <|>
+  Date      <$> date            <|>
+  Str       <$> quoted          <|>
+  Str       <$> quoted'         <|>
+  Num       <$> hex
+
+
+sclass :: Parser ItemClass
+sclass = do
+  quote
+  name <- str
+  quote
+  return name
+  where
+    str = pure Inet <*  string "inet" <|>
+          pure Genp <*  string "genp"
+
+iclass :: Parser ItemClass
+iclass = Id <$> hex
+
+
+-- Parser helpers --
+
+between :: Parser a -> Parser b -> Parser c -> Parser [c]
+between p q x = p >> manyTill x q
+
+hex :: Parser Integer
+hex = do
+  string "0x"
+  num <- hexadecimal
+  space
+  return num
+
+-- decoded hex string
+hex' :: Parser String
+hex' =
+  between (string "0x") (space >> endOfLine) anyChar >>= unhex
+
+quote :: Parser Char
+quote = char '"'
+
+-- literal string
+quoted :: Parser String
+quoted = between quote quote anyChar
+
+-- hex followed by string version
+quoted' :: Parser String
+quoted' = hex >> space >> quoted
+
+-- unescaped string
+raw :: Parser String
+raw = between quote (quote >> endOfLine) anyChar
+
+-- hex followed by unescaped string
+raw' :: Parser String
+raw' = hex >> space >> raw
+
+digits :: Read a => Int -> Parser a
+digits n = read <$> count n digit
+
+date :: Parser LocalTime
+date = do
+  hex >> space >> quote
+  year  <- digits 4
+  month <- digits 2
+  day   <- digits 2
+  hour  <- digits 2
+  min   <- digits 2
+  sec   <- digits 2
+  string "Z\\" >> decimal >> quote
+  return LocalTime { localDay = fromGregorian year month day
+                   , localTimeOfDay = TimeOfDay hour min sec }
+

Pretty.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE RecordWildCards, ViewPatterns #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+
+module Pretty
+( Pretty
+, pretty
+, pprint
+) where
+
+import Types
+import Data.List       (intercalate)
+import System.FilePath (takeBaseName)
+
+
+class Pretty a where
+  pretty :: a -> String
+
+pprint :: Pretty a => a -> IO ()
+pprint = putStrLn . pretty
+
+names :: [(Name, String)]
+names =
+  [ (Left "acct", "username"   )
+  , (Left "srvr", "url"        )
+  , (Left "cdat", "created"    )
+  , (Left "mdat", "last change")
+  , (Left "desc", "description")
+  ]
+
+
+instance Pretty Keychain where
+  pretty = intercalate spacer . map pretty
+    where spacer = '\n' : replicate 57 '~' ++ "\n\n"
+
+instance Pretty Item where
+  pretty Item {..} = unlines $
+    [ "name: "     ++ pretty title
+    , "content: "  ++ password
+    , "keychain: " ++ takeBaseName keychain
+    , "class: "    ++ show itemClass
+    , "info: "
+    ] ++ map pretty entries
+    where
+      title    = maybe (Str "") id (lookup (Right 7) attrs)
+      entries  = filter ((`elem` keys) . fst) attrs
+      keys     = map fst names
+      password = if length content < 45
+                   then content
+                   else take 45 content ++ "..."
+
+instance Pretty Attrib where
+  pretty (n,v) = "  " ++ pretty n ++ ": "++ pretty v
+
+instance Pretty Name where
+  pretty (flip lookup names -> Just x) = x
+  pretty (Left  x) = x
+  pretty (Right x) = show x
+
+instance Pretty Value where
+  pretty (Date x) = show x
+  pretty (Num  x) = show x
+  pretty (Str  x) = x
+  pretty Null     = ""

Types.hs

@@ -0,0 +1,25 @@
+module Types where
+
+import Data.Time (LocalTime)
+
+data Item =
+  Item { keychain  :: FilePath
+       , itemClass :: ItemClass
+       , attrs     :: [Attrib]
+       , content   :: String
+       } deriving (Eq, Show)
+
+data ItemClass =
+  Id Integer |
+  Inet       |
+  Genp deriving (Eq, Show)
+
+data Value =
+  Date LocalTime |
+  Str String     |
+  Num Integer    |
+  Null deriving (Eq, Show)
+
+type Keychain = [Item]
+type Attrib   = (Name, Value)
+type Name     = Either String Integer