dvault (empty) → 0.1.0.0

raw patch · 6 files changed

+330/−0 lines, 6 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, crypto-rng, data-default, directory, process, vector

Files

ChangeLog.md +5/−0
LICENSE +20/−0
Setup.hs +2/−0
dvault.cabal +34/−0
src/Generate.hs +103/−0
src/Main.hs +166/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for dvault++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2017 Ian Denhardt++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ dvault.cabal view

@@ -0,0 +1,34 @@+-- Initial dvault.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                dvault+version:             0.1.0.0+synopsis:            Dead simple password manager+-- description:+homepage:            https://github.com/zenhack/dvault+license:             MIT+license-file:        LICENSE+author:              Ian Denhardt+maintainer:          ian@zenhack.net+-- copyright:+-- category:+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++executable dvault+  main-is:             Main.hs+  other-modules:+    Generate+  -- other-extensions:+  build-depends:+    directory >=1.3 && <1.4,+    process >=1.6 && <1.7,+    bytestring >=0.10 && <0.11,+    crypto-rng >=0.1 && <0.2,+    vector >=0.12 && <0.13,+    containers >=0.5 && <0.6,+    data-default >=0.7 && <0.8,+    base >=4.10 && <5.0+  hs-source-dirs:      src+  default-language:    Haskell2010

+ src/Generate.hs view

@@ -0,0 +1,103 @@+{-# LANGUAGE RecordWildCards #-}+{-|+Module: Generate+Description: Core logic for password generation.+-}+module Generate+    (generate, Options(..), upper, lower, letter, digit, symbol)+  where+import qualified Data.ByteString as B++import Control.Monad (replicateM, when)+import Crypto.RNG    (CryptoRNG, newCryptoRNGState, random, runCryptoRNGT)+import Data.Bits+import Data.Default  (Default(def))+import Data.Word++import qualified Data.Set    as S+import qualified Data.Vector as V++-- | Set of lowercase ascii letters+lower = S.fromList ['a'..'z']++-- | Set of uppercase ascii letters+upper = S.fromList ['A'..'Z']++-- | Set of ascii letters+letter = upper `S.union` lower++-- | Set of digits ('0' through '9')+digit = S.fromList ['0'..'9']++-- | Set of special characters+symbol = S.fromList "~`!@#$%^&*(){}[]-+=_,.<>?/;:|\\'\""++-- | @doUntil p m@ executes @m@ repeatedly, until it returns a value that+-- satisfies the predicate p.+doUntil :: Monad m => (a -> Bool) -> m a -> m a+doUntil p m = do+    ret <- m+    if p ret+        then return ret+        else doUntil p m++-- | @getUniform max@ gets a uniformly random value in the range [0, max).+getUniform :: CryptoRNG m => Word8 -> m Word8+getUniform max = doUntil (< max) $ do+    byte <- random+    return $ byte .&. maskFor max+  where+    -- compute the most restrictive mask that's still greater than max.+    -- this will statistically reduce the likelyhood that we'll need to reject a+    -- result.+    maskFor :: Word8 -> Word8+    maskFor n+        -- I'm sure there's a less dumb way to compute this, but doing every+        -- case is straightforward:+        | n < 2     = 1+        | n < 4     = 3+        | n < 8     = 7+        | n < 16    = 15+        | n < 32    = 31+        | n < 64    = 63+        | n < 128   = 127+        | otherwise = 255++++-- | Select a random element from the vector. If the vector's length cannot+-- be represented by a Word8, an error occurs.+choose :: CryptoRNG m => V.Vector a -> m a+choose vec = do+    let len = V.length vec+    when (len > 255) $ error "too many elements"+    index <- getUniform (fromIntegral len)+    return (vec V.! fromIntegral index)+++-- | Options for the password generator.+data Options = Options+    { charSets :: [S.Set Char] -- ^ Sets of legal characters for the password.+                               -- The generated password will have at least+                               -- one character from each set.+    , size     :: Int -- ^ The length of the password, in characters.+    }++instance Default Options where+    def = Options { charSets = [upper, lower, digit, symbol]+                  , size = 20+                  }++getPassword :: CryptoRNG m => Options -> m String+getPassword opts@Options{..} =+    doUntil isValid $ replicateM size $ choose vec+  where+    vec = V.fromList $ S.toList $ S.unions charSets+    isValid pass   = and $ [pass `has`      set | set <- charSets]+    pass `has` set = or  $ [char `S.member` set | char <- pass]++-- | Generate a cryptographically random password, using the provided options.+generate :: Options -> IO String+generate opts = do+    state <- newCryptoRNGState+    runCryptoRNGT state (getPassword opts)

+ src/Main.hs view

@@ -0,0 +1,166 @@+{-|+Module: Main+Description: dvault command line tool.+-}+module Main where++import Generate++import Control.Monad      (void)+import Data.Default       (def)+import Data.Maybe         (fromMaybe)+import System.Directory   (createDirectoryIfMissing, listDirectory)+import System.Environment (getArgs, getEnv)+import System.Exit        (exitFailure, exitSuccess)+import System.IO          (hClose, hPutStr)+import System.Process+    ( CreateProcess(..)+    , StdStream(CreatePipe)+    , createProcess+    , proc+    , readProcess+    , waitForProcess+    )+import Text.Read          (readMaybe)++import qualified Data.ByteString as B+import qualified Data.Set        as S++-- | Get the directory in which to store our data.+getVaultDir :: IO FilePath+getVaultDir = do+    -- It's not entirely obvious to me(zenhack) what's the "right" place to+    -- put our data; the xdg base spec mentions an $XDG_DATA_HOME that falls+    -- back to $HOME/.local/share, but other programs put stuff in ~/.local+    -- outside of ~/.local/share, and ~/.local/share doesn't feel right.+    -- If this were system wide, the right place would probably be /var/lib,+    -- but there's no xdg homedir equivalent. For now, we just do ~/.local+    home <- getEnv "HOME"+    let path = home ++ "/.local/dvault"+    createDirectoryIfMissing True path+    return path++-- | @'dmenu' options@ launches the dmenu(1) command, supplying it with+-- @options@, and returning the user's choice.+dmenu :: [String] -> IO String+dmenu options = fmap stripNewline $ readProcess "dmenu" [] $ unlines options+  where+    stripNewline = takeWhile (/= '\n')++-- | @'xclip' foo@ copies the string @foo@ to both x11 clipboards.+xclip :: String -> IO ()+xclip contents = do+    xclipI ["-sel", "clip"]+    xclipI []+  where+    xclipI args = do+        -- For some reason I don't understand, just doing readProcess hangs.+        let p = (proc "xclip" ("-i":args)) { std_in = CreatePipe }+        (Just inpipe, Nothing, Nothing, pid) <- createProcess p+        hPutStr inpipe contents+        hClose inpipe+        void $ waitForProcess pid++-- | Send a desktop notification+notify :: String -> IO ()+notify summary = void $ readProcess "notify-send" ["-t", "2000", summary] ""++main = do+    args <- getArgs+    dir <- getVaultDir+    case args of+        ["-h"] -> usage >> exitSuccess+        ["--help"] -> usage >> exitSuccess+        []                -> fetchPass dir+        [arg] | arg `elem` ["-h", "--help"] -> usage >> exitSuccess+        ("gen":name:args)+            | name `elem` ["-h", "--help"] -> usage >> exitSuccess+            | otherwise -> do+                opts <- genCmd Nothing S.empty args+                newPass opts (passFilename dir name)+        _ -> usage >> exitFailure++usage = putStrLn $ unlines+    [ "Usage: dvault [ gen <tag> [ --size <size> ] [ CHARSET... ] ] | -h | --help"+    , ""+    , "where CHARSET is one of:"+    , ""+    , "    --letters"+    , "    --upper"+    , "    --lower"+    , "    --digits"+    , "    --symbols"+    , ""+    , "Note that --letters cannot be combined with --upper or --lower."+    ]++genCmd :: Maybe Int -> S.Set (S.Set Char) -> [String] -> IO Options+genCmd _ sets _ | seq sets False = undefined -- force `sets` to be evaluated.+genCmd argSize sets []+    | letter `S.member` sets &&+        (lower `S.member` sets || upper `S.member` sets)+        = do+            putStrLn $ "Error : You cannot specify both --letters and " +++                "either --upper or --lower."+            usage >> exitFailure+    | otherwise = return+        Options+            { size = size def `fromMaybe` argSize+            , charSets = if S.null sets+                then charSets def+                else S.toList sets+            }+genCmd Nothing sets ("--size":size:args) = case readMaybe size of+    Just size' -> genCmd (Just size') sets args+    Nothing    -> usage >> exitFailure+genCmd (Just size) _ ("--size":_) = usage >> exitFailure+genCmd size sets ("--letters":args) =+    genCmd size (S.insert letter sets) args+genCmd size sets ("--upper":args) =+    genCmd size (S.insert upper sets) args+genCmd size sets ("--lower":args) =+    genCmd size (S.insert lower sets) args+genCmd size sets ("--digits":args) =+    genCmd size (S.insert digit sets) args+genCmd size sets ("--symbols":args) =+    genCmd size (S.insert symbol sets) args+genCmd _ _ ("--help":_) = usage >> exitSuccess+genCmd _ _ ("-h":_) = usage >> exitSuccess+genCmd _ _ _ = usage >> exitFailure+++-- | Generate a new password and save it (encrypted) to the supplied path.+newPass :: Options -> FilePath -> IO ()+newPass opts path = do+    plaintext <- generate opts+    ciphertext <- readProcess "gpg" ["-a", "-e"] plaintext+    writeFile path ciphertext++-- | Prompt the user for a password label given the available passwords in+-- directory @dir@, then decrypt then user's choice and copy it to the+-- x11 clipboards.+fetchPass dir = do+    sites <- map (`dropSuffix` theSuffix)+                <$> filter (`endsWith` theSuffix)+                <$> listDirectory dir+    selection <- dmenu sites+    ciphertext <- readFile (dir ++ "/" ++ selection ++ theSuffix)+    plaintext <- readProcess "gpg" ["-a", "-d"] ciphertext+    xclip plaintext+    notify $ "Password for " ++ selection ++ " copied to clipboard."+  where+    str    `endsWith` suffix | str == suffix = True+    []     `endsWith` _ = False+    (c:cs) `endsWith` suffix = cs `endsWith` suffix++str    `dropSuffix` suffix | str == suffix = []+[]     `dropSuffix` _ = []+(c:cs) `dropSuffix` suffix = c:(cs `dropSuffix` suffix)++-- | Suffix to append to the password's label to form a filename.+theSuffix = ".pass.asc"++-- | @'passFilename' vaultdir label@ is the file in which the password for @label@+-- is stored, given the storage directory @vaultdir@.+passFilename :: String -> String -> FilePath+passFilename dir name = dir ++ "/" ++ name ++ theSuffix