From 2366471f118a0459e885d0ac24da72e4f547b62e Mon Sep 17 00:00:00 2001 From: rnhmjoj Date: Tue, 7 Jul 2015 14:55:02 +0200 Subject: [PATCH] Initial commit --- Main.hs | 56 ++++++++++++++++++++++ Parser.hs | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ Pretty.hs | 63 +++++++++++++++++++++++++ Types.hs | 25 ++++++++++ 4 files changed, 281 insertions(+) create mode 100644 Main.hs create mode 100644 Parser.hs create mode 100644 Pretty.hs create mode 100644 Types.hs diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..a091bbf --- /dev/null +++ b/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 + + diff --git a/Parser.hs b/Parser.hs new file mode 100644 index 0000000..b80d0c8 --- /dev/null +++ b/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 "" <|> + 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 } + diff --git a/Pretty.hs b/Pretty.hs new file mode 100644 index 0000000..48d35e5 --- /dev/null +++ b/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 = "" diff --git a/Types.hs b/Types.hs new file mode 100644 index 0000000..eda7021 --- /dev/null +++ b/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 \ No newline at end of file