diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,22 @@ +keysafe (0.20160831) unstable; urgency=medium + + * Server implementation is ready for initial deployment. + * Keysafe as a client is not yet ready for production use. + * Removed embedded copy of secret-sharing library, since finite-field + only supports prime fields. This caused shares to be twice the size of + the input value. + * Reduced chunk size to 32kb due to share size doubling. + * Fix gpg secret key list parser to support gpg 2. + * Tuned argon2 hash parameters on better hardware than my fanless laptop. + * Improve time estimates, taking into account the number of cores. + * Added basic test suite. + * Added options: --store-directory --test --port --address + * Added a Makefile + * Added a systemd service file. + * Added a desktop file. + + -- Joey Hess Wed, 31 Aug 2016 15:43:30 -0400 + keysafe (0.20160819) unstable; urgency=medium * First release of keysafe. This is not yet ready for production use. diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -6,32 +6,43 @@ module CmdLine where import Types +import Types.Storage import Tunables import qualified Gpg import Options.Applicative import qualified Data.ByteString.UTF8 as BU8 import System.Directory +import Network.Wai.Handler.Warp (Port) data CmdLine = CmdLine { mode :: Maybe Mode , secretkeysource :: Maybe SecretKeySource , localstorage :: Bool + , localstoragedirectory :: Maybe LocalStorageDirectory , gui :: Bool , testMode :: Bool , customShareParams :: Maybe ShareParams + , serverConfig :: ServerConfig } -data Mode = Backup | Restore | UploadQueued | Benchmark +data Mode = Backup | Restore | UploadQueued | Server | Benchmark | Test deriving (Show) +data ServerConfig = ServerConfig + { serverPort :: Port + , serverAddress :: String + } + parse :: Parser CmdLine parse = CmdLine - <$> optional (backup <|> restore <|> uploadqueued <|> benchmark) + <$> optional (backup <|> restore <|> uploadqueued <|> server <|> benchmark <|> test) <*> optional (gpgswitch <|> fileswitch) <*> localstorageswitch + <*> localstoragedirectory <*> guiswitch <*> testmodeswitch <*> optional (ShareParams <$> totalobjects <*> neededobjects) + <*> serverconfig where backup = flag' Backup ( long "backup" @@ -45,10 +56,18 @@ ( long "uploadqueued" <> help "Upload any data to servers that was queued by a previous --backup run." ) + server = flag' Server + ( long "server" + <> help "Run as a keysafe server, accepting objects and storing them to ~/.keysafe/objects/local/" + ) benchmark = flag' Benchmark ( long "benchmark" <> help "Benchmark speed of keysafe's cryptographic primitives." ) + test = flag' Test + ( long "test" + <> help "Run test suite." + ) gpgswitch = GpgKey . KeyId . BU8.fromString <$> strOption ( long "gpgkeyid" <> metavar "KEYID" @@ -61,8 +80,13 @@ ) localstorageswitch = switch ( long "store-local" - <> help "Store data locally, in ~/.keysafe/objects/local/. (The default is to store data in the cloud.)" + <> help "Store data locally. (The default is to store data in the cloud.)" ) + localstoragedirectory = optional $ LocalStorageDirectory <$> option str + ( long "store-directory" + <> metavar "DIR" + <> help "Where to store data locally. (default: ~/.keysafe/objects/)" + ) testmodeswitch = switch ( long "testmode" <> help "Avoid using expensive cryptographic operations to secure data. Use for testing only, not with real secret keys." @@ -74,14 +98,28 @@ totalobjects = option auto ( long "totalshares" <> metavar "M" - <> help ("Configure the number of shares to split encrypted secret key into. Default: " ++ show (totalObjects (shareParams defaultTunables)) ++ " (When this option is used to back up a key, it must also be provided at restore time.)") + <> help ("Configure the number of shares to split encrypted secret key into. (default: " ++ show (totalObjects (shareParams defaultTunables)) ++ ") (When this option is used to back up a key, it must also be provided at restore time.)") ) neededobjects = option auto ( long "neededshares" <> metavar "N" - <> help ("Configure the number of shares needed to restore. Default: " ++ show (neededObjects (shareParams defaultTunables)) ++ " (When this option is used to back up a key, it must also be provided at restore time.)") + <> help ("Configure the number of shares needed to restore. (default: " ++ show (neededObjects (shareParams defaultTunables)) ++ ") (When this option is used to back up a key, it must also be provided at restore time.)") ) - + serverconfig = ServerConfig + <$> option auto + ( long "port" + <> metavar "P" + <> value 80 + <> showDefault + <> help "Port for server to listen on." + ) + <*> option str + ( long "address" + <> metavar "A" + <> value "127.0.0.1" + <> showDefault + <> help "Address for server to bind to. (Use \"*\" to bind to all addresses.)" + ) get :: IO CmdLine get = execParser opts where diff --git a/Cost.hs b/Cost.hs --- a/Cost.hs +++ b/Cost.hs @@ -11,19 +11,36 @@ ) where import Types.Cost +import Data.List +import Data.Maybe +import Text.Read -- | Cost in seconds, with the type of hardware needed. totalCost :: Cost op -> (Seconds, [UsingHardware]) -totalCost (CPUCost s) = (s, [UsingCPU]) +totalCost (CPUCost s _) = (s, [UsingCPU]) raiseCostPower :: Cost c -> Entropy e -> Cost c -raiseCostPower c (Entropy e) = adjustCost c (* 2^e) +raiseCostPower c (Entropy e) = mapCost (* 2^e) c -adjustCost :: Cost c -> (Seconds -> Seconds) -> Cost c -adjustCost (CPUCost s) f = CPUCost (f s) +mapCost :: (Integer -> Integer) -> Cost op -> Cost op +mapCost f (CPUCost (Seconds n) d) = CPUCost (Seconds (f n)) d +type NumCores = Integer + +showCostMinutes :: NumCores -> Cost op -> String +showCostMinutes numcores (CPUCost (Seconds n) (Divisibility d)) + | n' < 61 = "1 minute" + | otherwise = show (n' `div` 60) ++ " minutes" + where + n' = n `div` min numcores d + +-- If an operation took n seconds on a number of cores, +-- multiply to get the CPUCost, which is for a single core. +coreCost :: NumCores -> Seconds -> Divisibility -> Cost op +coreCost cores (Seconds n) d = CPUCost (Seconds (cores * n)) d + castCost :: Cost a -> Cost b -castCost (CPUCost s) = CPUCost s +castCost (CPUCost s d) = CPUCost s d -- | CostCalc for a brute force linear search through an entropy space -- in which each step entails paying a cost. @@ -40,6 +57,10 @@ data DataCenterPrice = DataCenterPrice { instanceCpuCores :: Integer + , instanceCpuCoreMultiplier :: Integer + -- ^ If the cores are twice as fast as the commodity hardware + -- that keysafe's cost estimates are based on, use 2 to indicate + -- this, etc. , instanceCostPerHour :: Cents } @@ -47,6 +68,7 @@ spotAWS :: DataCenterPrice spotAWS = DataCenterPrice { instanceCpuCores = 36 + , instanceCpuCoreMultiplier = 2 , instanceCostPerHour = Cents 33 } @@ -63,7 +85,7 @@ cpuyears = cpuseconds `div` (60*60*24*365) costpercpuyear = Cents $ fromIntegral (instanceCostPerHour dc) * 24 * 365 - `div` instanceCpuCores dc + `div` (instanceCpuCores dc * instanceCpuCoreMultiplier dc) costcents = Cents cpuyears * costpercpuyear newtype Cents = Cents Integer @@ -112,3 +134,16 @@ in if yprev < y - 1 then go (s:" ...":t) y ys else go (s:t) y ys + +-- Number of physical cores. This is not the same as +-- getNumProcessors, which includes hyper-threading. +getNumCores :: IO (Maybe NumCores) +getNumCores = getmax . mapMaybe parse . lines <$> readFile "/proc/cpuinfo" + where + getmax [] = Nothing + getmax l = Just $ + maximum l + 1 -- add 1 because /proc/cpuinfo counts from 0 + parse l + | "core id" `isPrefixOf` l = + readMaybe $ drop 1 $ dropWhile (/= ':') l + | otherwise = Nothing diff --git a/Crypto/SecretSharing/Internal.hs b/Crypto/SecretSharing/Internal.hs deleted file mode 100644 --- a/Crypto/SecretSharing/Internal.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, GeneralizedNewtypeDeriving, TemplateHaskell #-} ------------------------------------------------------------------------------ --- | --- Module : Crypto.SecretSharing.Internal --- Copyright : Peter Robinson 2014 --- License : LGPL --- --- Maintainer : Peter Robinson --- Stability : experimental --- Portability : portable --- ------------------------------------------------------------------------------ - -module Crypto.SecretSharing.Internal -where -import Math.Polynomial.Interpolation - -import Data.ByteString.Lazy( ByteString ) -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.List as L -import Data.Char -import Data.Vector( Vector ) -import qualified Data.Vector as V -import Data.Typeable -import Control.Exception -import Control.Monad -import Data.Binary( Binary ) -import GHC.Generics -import Data.FiniteField.PrimeField as PF -import Data.FiniteField.Base(FiniteField,order) -import System.Random.Dice - - - --- | A share of an encoded byte. -data ByteShare = ByteShare - { shareId :: !Int -- ^ the index of this share - , reconstructionThreshold :: !Int -- ^ number of shares required for - -- reconstruction - , shareValue :: !Int -- ^ the value of p(shareId) where p(x) is the - -- generated (secret) polynomial - } - deriving(Typeable,Eq,Generic) - -instance Show ByteShare where - show = show . shareValue - --- | A share of the encoded secret. -data Share = Share - { theShare :: ![ByteShare] } - deriving(Typeable,Eq,Generic) - -instance Show Share where - show s = show (shareId $ head $ theShare s,BLC.pack $ map (chr . shareValue) $ theShare s) - -instance Binary ByteShare -instance Binary Share - --- | Encodes a 'ByteString' as a list of n shares, m of which are required for --- reconstruction. --- Lives in the 'IO' to access a random source. -encode :: Int -- ^ m - -> Int -- ^ n - -> ByteString -- ^ the secret that we want to share - -> IO [Share] -- a list of n-shares (per byte) -encode m n bstr - | n >= prime || m > n = throw $ AssertionFailed $ - "encode: require n < " ++ show prime ++ " and m<=n." - | BL.null bstr = return [] - | otherwise = do - let len = max 1 ((fromIntegral $ BL.length bstr) * (m-1)) - coeffs <- (groupInto (m-1) . map fromIntegral . take len ) - `liftM` (getDiceRolls prime len) - let byteVecs = zipWith (encodeByte m n) coeffs $ - map fromIntegral $ BL.unpack bstr - return [ Share $ map (V.! (i-1)) byteVecs | i <- [1..n] ] - - --- | Reconstructs a (secret) bytestring from a list of (at least @m@) shares. --- Throws 'AssertionFailed' if the number of shares is too small. -decode :: [Share] -- ^ list of at least @m@ shares - -> ByteString -- ^ reconstructed secret -decode [] = BL.pack [] -decode shares@((Share s):_) - | length shares < reconstructionThreshold (head s) = throw $ AssertionFailed - "decode: not enough shares for reconstruction." - | otherwise = - let origLength = length s in - let byteVecs = map (V.fromList . theShare) shares in - let byteShares = [ map ((V.! (i-1))) byteVecs | i <- [1..origLength] ] in - BL.pack . map (fromInteger . PF.toInteger . number) - . map decodeByte $ byteShares - - -encodeByte :: Int -> Int -> Polyn -> FField -> Vector ByteShare -encodeByte m n coeffs secret = - V.fromList[ ByteShare i m $ fromInteger . PF.toInteger . number $ - evalPolynomial (secret:coeffs) (fromIntegral i::FField) - | i <- [1..n] - ] - - -decodeByte :: [ByteShare] -> FField -decodeByte ss = - let m = reconstructionThreshold $ head ss in - if length ss < m - then throw $ AssertionFailed "decodeByte: insufficient number of shares for reconstruction!" - else - let shares = take m ss - pts = map (\s -> (fromIntegral $ shareId s,fromIntegral $ shareValue s)) - shares - in - polyInterp pts 0 - - --- | Groups a list into blocks of certain size. Running time: /O(n)/ -groupInto :: Int -> [a] -> [[a]] -groupInto num as - | num < 0 = throw $ AssertionFailed "groupInto: Need positive number as argument." - | otherwise = - let (fs,ss) = L.splitAt num as in - if L.null ss - then [fs] - else fs : groupInto num ss - - --- | A finite prime field. All computations are performed in this field. --- --- This is modified from the secret-sharing library to use 256 --- instead of 1021. That allows values in the field to be efficiently --- packed into bytes. It's beleived that the finite field can be a power of --- a prime number (in this case, 2). -newtype FField = FField { number :: $(primeField $ fromIntegral (256 :: Integer)) } - deriving(Show,Read,Ord,Eq,Num,Fractional,Generic,Typeable,FiniteField) - - --- | The size of the finite field -prime :: Int -prime = fromInteger $ order (0 :: FField) - - --- | A polynomial over the finite field given as a list of coefficients. -type Polyn = [FField] - --- | Evaluates the polynomial at a given point. -evalPolynomial :: Polyn -> FField -> FField -evalPolynomial coeffs x = - foldr (\c res -> c + (x * res)) 0 coeffs --- let clist = zipWith (\pow c -> (\x -> c * (x^pow))) [0..] coeffs --- in L.foldl' (+) 0 [ c x | c <- clist ] - diff --git a/ExpensiveHash.hs b/ExpensiveHash.hs --- a/ExpensiveHash.hs +++ b/ExpensiveHash.hs @@ -13,12 +13,14 @@ import Serialization () import qualified Data.Text as T import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BU8 import qualified Crypto.Argon2 as Argon2 import Raaz.Core.Encode import Data.Time.Clock import Control.DeepSeq import Control.Monad import Data.Monoid +import Data.Maybe -- | A hash that is expensive to calculate. -- @@ -46,18 +48,29 @@ in sb <> B.replicate (8 - B.length sb ) 32 benchmarkExpensiveHash :: Int -> ExpensiveHashTunable -> Cost op -> IO (BenchmarkResult (Cost op)) -benchmarkExpensiveHash rounds tunables expected = do +benchmarkExpensiveHash rounds tunables@(UseArgon2 _ hashopts) expected = do + numcores <- fromIntegral . fromMaybe (error "Unknown number of physical cores.") + <$> getNumCores start <- getCurrentTime - forM_ [1..rounds] $ \_ -> do + forM_ [1..rounds] $ \n -> do + -- Must vary the data being hashed to avoid laziness + -- caching hash results. + let base = BU8.fromString (show n) let ExpensiveHash _ t = expensiveHash tunables - (Salt (GpgKey (KeyId ("dummy" :: B.ByteString)))) - ("himom" :: B.ByteString) + (Salt (GpgKey (KeyId (base <> "dummy")))) + (base <> "himom") t `deepseq` return () end <- getCurrentTime let diff = floor $ end `diffUTCTime` start - let actual = CPUCost $ Seconds diff + let maxthreads = Argon2.hashParallelism hashopts + let actual = CPUCost (Seconds diff) (Divisibility $ fromIntegral maxthreads) + -- The expected cost is for a single core, so adjust it + -- based on the number of cores, up to a maximum of the number + -- of threads that the hash is configred to use. + let usedcores = min maxthreads numcores + let adjustedexpected = mapCost (`div` fromIntegral usedcores) expected return $ BenchmarkResult - { expectedBenchmark = expected + { expectedBenchmark = adjustedexpected , actualBenchmark = actual } @@ -65,12 +78,23 @@ benchmarkTunables tunables = do putStrLn "/proc/cpuinfo:" putStrLn =<< readFile "/proc/cpuinfo" - putStrLn "Note that expected times are for 1 core machine." - putStrLn "If this machine has 2 cores, the actual times should be half the expected times." - putStrLn "Benchmarking 16 rounds of key generation hash..." - print =<< benchmarkExpensiveHash 16 + + -- Rather than run all 256 rounds of this hash, which would + -- probably take on the order of 1 hour, run only 16, and scale + -- the expected cost accordingly. + let normalrounds = fromIntegral $ + 256 * randomSaltBytes (keyEncryptionKeyTunable tunables) + putStrLn $ "Benchmarking 16/" ++ show normalrounds ++ " rounds of key encryption key hash..." + r <- benchmarkExpensiveHash 16 (keyEncryptionKeyHash $ keyEncryptionKeyTunable tunables) - (mapCost (`div` 16) $ randomSaltBytesBruteForceCost $ keyEncryptionKeyTunable tunables) + (mapCost (`div` (normalrounds `div` 16)) $ randomSaltBytesBruteForceCost $ keyEncryptionKeyTunable tunables) + print r + putStrLn $ "Estimated time for " ++ show normalrounds ++ " rounds of key encryption key hash..." + print $ BenchmarkResult + { expectedBenchmark = mapCost (* 16) (expectedBenchmark r) + , actualBenchmark = mapCost (* 16) (actualBenchmark r) + } + putStrLn "Benchmarking 1 round of name generation hash..." print =<< benchmarkExpensiveHash 1 (nameGenerationHash $ nameGenerationTunable tunables) diff --git a/Gpg.hs b/Gpg.hs --- a/Gpg.hs +++ b/Gpg.hs @@ -11,7 +11,6 @@ import UI import System.Process import Data.List.Split -import Data.Maybe import System.IO import System.Exit import qualified Data.ByteString as B @@ -37,13 +36,20 @@ anyKey = GpgKey (KeyId "") listSecretKeys :: IO [(Name, KeyId)] -listSecretKeys = mapMaybe parse . lines <$> readProcess "gpg" - ["--batch", "--with-colons", "--list-secret-keys"] "" +listSecretKeys = map mk . parse . lines <$> readProcess "gpg" + ["--batch", "--with-colons", "--list-secret-keys", "--fixed-list-mode"] "" where - parse l = case splitOn ":" l of - ("sec":_:_:_:kid:_:_:_:_:n:_) -> Just - (Name (BU8.fromString n), KeyId (BU8.fromString kid)) - _ -> Nothing + parse = extract [] Nothing . map (splitOn ":") + extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) = + extract ((userid, keyid):c) Nothing rest + extract c (Just keyid) rest = + extract (("", keyid):c) Nothing rest + extract c _ [] = c + extract c _ (("sec":_:_:_:keyid:_):rest) = + extract c (Just keyid) rest + extract c k (_:rest) = + extract c k rest + mk (userid, keyid) = (Name (BU8.fromString userid), KeyId (BU8.fromString keyid)) getSecretKey :: KeyId -> IO SecretKey getSecretKey (KeyId kid) = do diff --git a/HTTP.hs b/HTTP.hs new file mode 100644 --- /dev/null +++ b/HTTP.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- Copyright 2016 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module HTTP where + +import Types +import Types.Storage +import Serialization () +import Servant.API +import Data.Text +import Data.Aeson.Types +import GHC.Generics hiding (V1) +import qualified Data.Text.Encoding as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Raaz.Core.Encode as Raaz + +-- | Keysafe's http API +type HttpAPI = + "keysafe" :> V1 :> "motd" :> Get '[JSON] Motd + :<|> "keysafe" :> V1 :> "objects" :> ObjectIdent :> POWParam + :> Get '[JSON] (ProofOfWorkRequirement StorableObject) + :<|> "keysafe" :> V1 :> "objects" :> ObjectIdent :> POWParam + :> ReqBody '[OctetStream] StorableObject + :> Put '[JSON] (ProofOfWorkRequirement StoreResult) + :<|> "keysafe" :> V1 :> "stats" :> "countobjects" :> POWParam + :> Get '[JSON] (ProofOfWorkRequirement CountResult) + +type V1 = "v1" + +newtype Motd = Motd Text + deriving (Generic) + +data ProofOfWorkRequirement t + = Result t + | ProofOfWorkRequirement + { leadingZeros :: Int + , argon2Iterations :: Int + } + deriving (Generic) + +newtype ProofOfWork = ProofOfWork Text + +type POWParam = QueryParam "proofofwork" ProofOfWork + +type ObjectIdent = Capture "ident" StorableObjectIdent + +instance ToJSON Motd +instance FromJSON Motd +instance ToJSON t => ToJSON (ProofOfWorkRequirement t) +instance FromJSON t => FromJSON (ProofOfWorkRequirement t) + +instance FromHttpApiData ProofOfWork where + parseUrlPiece = Right . ProofOfWork +instance ToHttpApiData ProofOfWork where + toUrlPiece (ProofOfWork t) = t + +-- StorableObjectIdent contains a hash, which is valid UTF-8. +instance ToHttpApiData StorableObjectIdent where + toUrlPiece (StorableObjectIdent b) = T.decodeUtf8 b +instance FromHttpApiData StorableObjectIdent where + parseUrlPiece = Right . StorableObjectIdent . T.encodeUtf8 + +instance MimeRender OctetStream StorableObject where + mimeRender _ = L.fromStrict . Raaz.toByteString +instance MimeUnrender OctetStream StorableObject where + mimeUnrender _ = maybe (Left "object encoding error") Right + . Raaz.fromByteString . L.toStrict + +-- StorableObject contains an arbitrary bytestring; it is not UTF-8 encoded. +-- So, to convert it to Text for Aeson, base64 encode it. +instance ToJSON StorableObject where + toJSON (StorableObject b) = object [ "data" .= b64 b ] +instance FromJSON StorableObject where + parseJSON (Object v) = StorableObject <$> (unb64 =<< v .: "data") + parseJSON invalid = typeMismatch "StorableObject" invalid + +b64 :: B.ByteString -> Text +b64 v = T.decodeUtf8 $ Raaz.toByteString (Raaz.encode v :: Raaz.Base64) + +unb64 :: Monad m => Text -> m B.ByteString +unb64 t = maybe (fail "bad base64 data") (return . Raaz.decodeFormat) f + where + f = Raaz.fromByteString (T.encodeUtf8 t) :: Maybe Raaz.Base64 diff --git a/HTTP/Client.hs b/HTTP/Client.hs new file mode 100644 --- /dev/null +++ b/HTTP/Client.hs @@ -0,0 +1,23 @@ +{- Copyright 2016 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module HTTP.Client where + +import HTTP +import Types +import Types.Storage +import Servant.API +import Servant.Client +import Data.Proxy +import Network.HTTP.Client (Manager) + +httpAPI :: Proxy HttpAPI +httpAPI = Proxy + +motd :: Manager -> BaseUrl -> ClientM Motd +getObject :: StorableObjectIdent -> Maybe ProofOfWork -> Manager -> BaseUrl -> ClientM (ProofOfWorkRequirement StorableObject) +putObject :: StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Manager -> BaseUrl -> ClientM (ProofOfWorkRequirement StoreResult) +countObjects :: Maybe ProofOfWork -> Manager -> BaseUrl -> ClientM (ProofOfWorkRequirement CountResult) +motd :<|> getObject :<|> putObject :<|> countObjects = client httpAPI diff --git a/HTTP/Server.hs b/HTTP/Server.hs new file mode 100644 --- /dev/null +++ b/HTTP/Server.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- Copyright 2016 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module HTTP.Server (runServer) where + +import HTTP +import Types +import Types.Storage +import Tunables +import Storage.Local +import Serialization () +import Servant +import Network.Wai +import Network.Wai.Handler.Warp +import Control.Monad.IO.Class +import Control.Concurrent +import Control.Concurrent.STM +import Data.String +import qualified Data.ByteString as B + +data ServerState = ServerState + { obscurerRequest :: TMVar () + , storageDirectory :: Maybe LocalStorageDirectory + } + +newServerState :: Maybe LocalStorageDirectory -> IO ServerState +newServerState d = ServerState + <$> newEmptyTMVarIO + <*> pure d + +runServer :: Maybe LocalStorageDirectory -> String -> Port -> IO () +runServer d bindaddress port = do + st <- newServerState d + _ <- forkIO $ obscurerThread st + runSettings settings (app st) + where + settings = setHost host $ setPort port $ defaultSettings + host = fromString bindaddress + +serverStorage :: ServerState -> Storage +serverStorage st = localStorage (storageDir $ storageDirectory st) "server" + +app :: ServerState -> Application +app st = serve userAPI (server st) + +userAPI :: Proxy HttpAPI +userAPI = Proxy + +server :: ServerState -> Server HttpAPI +server st = motd + :<|> getObject st + :<|> putObject st + :<|> countObjects st + +motd :: Handler Motd +motd = return $ Motd "Hello World!" + +getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (ProofOfWorkRequirement StorableObject) +getObject st i _pow = do + r <- liftIO $ retrieveShare (serverStorage st) dummyShareNum i + liftIO $ requestObscure st + case r of + RetrieveSuccess (Share _n o) -> return $ Result o + RetrieveFailure _ -> throwError err404 + +putObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Handler (ProofOfWorkRequirement StoreResult) +putObject st i _pow o = do + if validObjectsize o + then do + r <- liftIO $ storeShare (serverStorage st) i (Share dummyShareNum o) + liftIO $ requestObscure st + return $ Result r + else return $ Result $ StoreFailure "invalid object size" + +validObjectsize :: StorableObject -> Bool +validObjectsize o = any (sz ==) knownObjectSizes + where + sz = B.length (fromStorableObject o) + +countObjects :: ServerState -> Maybe ProofOfWork -> Handler (ProofOfWorkRequirement CountResult) +countObjects st _pow = liftIO $ Result <$> countShares (serverStorage st) + +-- | 1 is a dummy value; the server does not know the actual share numbers. +dummyShareNum :: ShareNum +dummyShareNum = 1 + +-- | This thread handles obscuring the shares after put and get operations. +-- Since obscuring can be an expensive process when there are many shares, +-- the thread runs a maximum of once per half-hour. +obscurerThread :: ServerState -> IO () +obscurerThread st = do + _ <- obscureShares (serverStorage st) + putStrLn "obscured shares" + threadDelay (1000000*60*30) + _ <- atomically $ takeTMVar (obscurerRequest st) + obscurerThread st + +requestObscure :: ServerState -> IO () +requestObscure st = do + _ <- atomically $ tryPutTMVar (obscurerRequest st) () + return () diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,43 @@ +## Quick installation + +This installs keysafe to ~/.local/bin, and is sufficient to use keysafe +to back up or restore your private key. + +First install Haskell's stack tool, the zlib, g++, readline and argon2 +libraries, and zenity. For example, on a Debian system: + + sudo apt-get install haskell-stack \ + zlib1g-dev g++ libreadline-dev libargon2-0-dev zenity + +Then to build and install keysafe, run this in the keysafe directory: + + stack install + +Note that there is a manpage, but stack doesn't install it yet. + +## System-wide installation + +This installs keysafe in /usr/bin, and includes the man page, +desktop file, systemd service file, etc. + +Start by installing the dependencies as shown in Quick installation. + +Then, in the keysafe directory: + + make + sudo make install + +## Packaging + +You will probably want to use the Makefile. +Set PREFIX to install to a different location. +Set BUILDER=cabal to use cabal rather than the default stack to build. + +The make install target creates a keysafe user. Use the install-files +target to avoid doing that at package build time. You may create the +keysafe user at package install time instead, although it is only used +by the keysafe server. + +While keysafe ships with a systemd service file, distributions should +not enable it to be started by default. (Or can put it in its own +keysafe-server package.) diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,32 @@ +PREFIX?= +# Can be stack or cabal +BUILDER?=stack + +build: keysafe + +keysafe: + $(BUILDER) build + if [ "$(BUILDER)" = stack ]; then \ + ln -sf $$(find .stack-work/ -name keysafe -type f | grep build/keysafe/keysafe | tail -n 1) keysafe; \ + else \ + ln -sf dist/build/keysafe/keysafe keysafe; \ + fi + +clean: + rm -rf keysafe dist .stack-work + +install: install-files + useradd --system keysafe + chmod 700 $(PREFIX)/var/lib/keysafe + chown keysafe:keysafe $(PREFIX)/var/lib/keysafe + +install-files: keysafe + install -d $(PREFIX)/var/lib/keysafe + install -d $(PREFIX)/usr/bin + install -s -m 0755 keysafe $(PREFIX)/usr/bin/keysafe + install -d $(PREFIX)/usr/share/man/man1 + install -m 0644 keysafe.1 $(PREFIX)/usr/share/man/man1/keysafe.1 + install -d $(PREFIX)/lib/systemd/system + install -m 0644 keysafe.service $(PREFIX)/lib/systemd/system/keysafe.service + install -d $(PREFIX)/usr/share/applications/ + install -m 0644 keysafe.desktop $(PREFIX)/usr/share/applications/keysafe.desktop diff --git a/Share.hs b/Share.hs --- a/Share.hs +++ b/Share.hs @@ -19,6 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Set as S +import Data.Word import Data.Monoid data ShareIdents = ShareIdents @@ -92,20 +93,34 @@ fromStorableObject so sharesneeded = neededObjects (shareParams tunables) --- | This efficient encoding relies on the share using a finite field of --- size 256, so it maps directly to bytes. --- -- Note that this does not include the share number in the encoded -- bytestring. This prevents an attacker from partitioning their shares -- by share number. encodeShare :: SS.Share -> B.ByteString -encodeShare = B.pack . map (fromIntegral . SS.shareValue) . SS.theShare +encodeShare = B.pack . concatMap (encodeShare' . SS.shareValue) . SS.theShare decodeShare :: Int -> Int -> B.ByteString -> SS.Share -decodeShare sharenum sharesneeded = SS.Share . map mk . B.unpack +decodeShare sharenum sharesneeded = SS.Share . map mk . decodeShare' . B.unpack where - mk w = SS.ByteShare + mk v = SS.ByteShare { SS.shareId = sharenum , SS.reconstructionThreshold = sharesneeded - , SS.shareValue = fromIntegral w + , SS.shareValue = v } + +-- | Each input byte generates a share in a finite field of size 1021, +-- so encode it as the product of two bytes. This is inneffient; if the +-- finite field was 255 then the encoded share would be the same size as +-- the input. But, the finite-field library used by secret-sharing does +-- not support a non-prime size. +encodeShare' :: Int -> [Word8] +encodeShare' v = + let (q, r) = quotRem v 255 + in [fromIntegral q, fromIntegral r] + +decodeShare' :: [Word8] -> [Int] +decodeShare' = go [] + where + go c [] = reverse c + go c (q:r:rest) = go (((255 * fromIntegral q) + fromIntegral r):c) rest + go _ _ = error "Badly encoded share has odd number of bytes" diff --git a/Storage.hs b/Storage.hs --- a/Storage.hs +++ b/Storage.hs @@ -16,15 +16,15 @@ import Control.Monad import qualified Data.Set as S -allStorageLocations :: IO StorageLocations -allStorageLocations = do +allStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations +allStorageLocations d = do servers <- networkServers return $ StorageLocations $ - map networkStorage servers <> map uploadQueue servers + map networkStorage servers <> map (uploadQueue d) servers -localStorageLocations :: StorageLocations -localStorageLocations = StorageLocations $ - map (localStorage . ("local" ) . show) +localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations +localStorageLocations d = StorageLocations $ + map (localStorage (storageDir d) . ("local" ) . show) [1..100 :: Int] type UpdateProgress = IO () @@ -99,7 +99,7 @@ -- all of them. go (unusedlocs++[loc]) usedlocs' rest shares' -uploadQueued :: IO () -uploadQueued = do +uploadQueued :: Maybe LocalStorageDirectory -> IO () +uploadQueued d = do servers <- networkServers - forM_ servers $ \s -> moveShares (uploadQueue s) (networkStorage s) + forM_ servers $ \s -> moveShares (uploadQueue d s) (networkStorage s) diff --git a/Storage/Local.hs b/Storage/Local.hs --- a/Storage/Local.hs +++ b/Storage/Local.hs @@ -3,7 +3,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -module Storage.Local (localStorage, uploadQueue) where +module Storage.Local (localStorage, storageDir, testStorageDir, uploadQueue) where import Types import Types.Storage @@ -23,25 +23,27 @@ import Control.Exception import Control.Monad +type GetShareDir = Section -> IO FilePath + newtype Section = Section String -localStorage :: String -> Storage -localStorage n = Storage - { storeShare = store section - , retrieveShare = retrieve section - , obscureShares = obscure section - , countShares = count section - , moveShares = move section +localStorage :: GetShareDir -> String -> Storage +localStorage getsharedir n = Storage + { storeShare = store section getsharedir + , retrieveShare = retrieve section getsharedir + , obscureShares = obscure section getsharedir + , countShares = count section getsharedir + , moveShares = move section getsharedir } where section = Section n -uploadQueue :: Server -> Storage -uploadQueue s = localStorage ("uploadqueue" serverName s) +uploadQueue :: Maybe LocalStorageDirectory -> Server -> Storage +uploadQueue d s = localStorage (storageDir d) ("uploadqueue" serverName s) -store :: Section -> StorableObjectIdent -> Share -> IO StoreResult -store section i s = onError (StoreFailure . show) $ do - dir <- shareDir section +store :: Section -> GetShareDir -> StorableObjectIdent -> Share -> IO StoreResult +store section getsharedir i s = onError (StoreFailure . show) $ do + dir <- getsharedir section createDirectoryIfMissing True dir let dest = dir shareFile i exists <- doesFileExist dest @@ -57,9 +59,9 @@ renameFile tmp dest return StoreSuccess -retrieve :: Section -> ShareNum -> StorableObjectIdent -> IO RetrieveResult -retrieve section n i = onError (RetrieveFailure . show) $ do - dir <- shareDir section +retrieve :: Section -> GetShareDir -> ShareNum -> StorableObjectIdent -> IO RetrieveResult +retrieve section getsharedir n i = onError (RetrieveFailure . show) $ do + dir <- getsharedir section fd <- openFd (dir shareFile i) ReadOnly Nothing defaultFileFlags h <- fdToHandle fd b <- B.hGetContents h @@ -75,22 +77,22 @@ -- -- Note that the contents of shares is never changed, so it's ok to set the -- mtime to the epoch; backup programs won't be confused. -obscure :: Section -> IO ObscureResult -obscure section = onError (ObscureFailure . show) $ do - dir <- shareDir section +obscure :: Section -> GetShareDir -> IO ObscureResult +obscure section getsharedir = onError (ObscureFailure . show) $ do + dir <- getsharedir section fs <- filter isShareFile <$> getDirectoryContents dir mapM_ (\f -> setFileTimes (dir f) 0 0) fs return ObscureSuccess -count :: Section -> IO CountResult -count section = onError (CountFailure . show) $ do - dir <- shareDir section +count :: Section -> GetShareDir -> IO CountResult +count section getsharedir = onError (CountFailure . show) $ do + dir <- getsharedir section CountResult . genericLength . filter isShareFile <$> getDirectoryContents dir -move :: Section -> Storage -> IO () -move section storage = do - dir <- shareDir section +move :: Section -> GetShareDir -> Storage -> IO () +move section getsharedir storage = do + dir <- getsharedir section fs <- getDirectoryContents dir forM_ fs $ \f -> case fromShareFile f of Nothing -> return () @@ -99,7 +101,7 @@ -- matter because we're not going to be -- recombining the share, just sending its contents -- on the the server. - r <- retrieve section 0 i + r <- retrieve section getsharedir 0 i case r of RetrieveFailure _ -> return () RetrieveSuccess share -> do @@ -115,13 +117,21 @@ Left e -> f e Right r -> r -shareDir :: Section -> IO FilePath -shareDir (Section section) = do +storageDir :: Maybe LocalStorageDirectory -> GetShareDir +storageDir Nothing (Section section) = do u <- getUserEntryForID =<< getEffectiveUserID return $ homeDirectory u dotdir section +storageDir (Just (LocalStorageDirectory d)) (Section section) = + pure $ d section +testStorageDir :: FilePath -> GetShareDir +testStorageDir tmpdir = storageDir (Just (LocalStorageDirectory tmpdir)) + +-- | The takeFileName ensures that, if the StorableObjectIdent somehow +-- contains a path (eg starts with "../" or "/"), it is not allowed +-- to point off outside the shareDir. shareFile :: StorableObjectIdent -> FilePath -shareFile i = U8.toString (toByteString i) <> ext +shareFile i = takeFileName (U8.toString (toByteString i)) <> ext fromShareFile :: FilePath -> Maybe StorableObjectIdent fromShareFile f diff --git a/Storage/Network.hs b/Storage/Network.hs --- a/Storage/Network.hs +++ b/Storage/Network.hs @@ -5,15 +5,47 @@ {-# LANGUAGE OverloadedStrings #-} -module Storage.Network (Server(..), networkServers, networkStorage) where +module Storage.Network ( + Server(..), + networkServers, + networkStorage, + torableManager +) where import Types import Types.Storage +import Data.List +import Data.Char +import HTTP +import HTTP.Client +import Servant.Client +import Network.Wai.Handler.Warp (Port) +import Network.HTTP.Client hiding (port, host) +import Network.HTTP.Client.Internal (Connection, makeConnection) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import qualified Network.Socket +import Network.Socket.ByteString (sendAll, recv) +import Network.Socks5 +import qualified Data.ByteString.UTF8 as BU8 -newtype Server = Server { serverName :: String } +type HostName = String +data Server = Server + { serverName :: HostName + , serverPort :: Port + } + +serverUrl :: Server -> BaseUrl +serverUrl srv = BaseUrl Http (serverName srv) (serverPort srv) "" + +-- | These can be either tor .onion addresses, or regular hostnames. +-- Using tor is highly recommended, to avoid correlation attacks. networkServers :: IO [Server] -networkServers = return [] -- none yet +networkServers = return + [ Server "localhost" 4242 + , Server "localhost" 4242 + , Server "localhost" 4242 + ] networkStorage :: Server -> Storage networkStorage server = Storage @@ -25,10 +57,14 @@ } store :: Server -> StorableObjectIdent -> Share -> IO StoreResult -store _server _i _s = return $ StoreFailure "network storage not implemented yet" +store srv i (Share _n o) = + serverRequest srv StoreFailure id $ \pow -> + putObject i pow o retrieve :: Server -> ShareNum -> StorableObjectIdent -> IO RetrieveResult -retrieve _server _n _i = return $ RetrieveFailure "network storage not implemented yet" +retrieve srv n i = + serverRequest srv RetrieveFailure (RetrieveSuccess . Share n) $ + getObject i -- | Servers should automatically obscure, so do nothing. -- (Could upload chaff.) @@ -36,8 +72,58 @@ obscure _ = return ObscureSuccess count :: Server -> IO CountResult -count _server = return $ CountFailure "network storage not implemented yet" +count srv = serverRequest srv CountFailure id countObjects -- | Not needed for servers. move :: Server -> Storage -> IO () -move _ _ = return () +move _ _ = error "move is not implemented for servers" + +serverRequest + :: Server + -> (String -> a) + -> (r -> a) + -> (Maybe ProofOfWork -> Manager -> BaseUrl -> ExceptT ServantError IO (ProofOfWorkRequirement r)) + -> IO a +serverRequest srv onerr onsuccess a = + -- A new Manager is allocated for each request, rather than reusing + -- any connection. This is a feature; it makes correlation attacks + -- harder because the server can't tell if two connections + -- (over tor) came from the same user. + go Nothing =<< torableManager + where + url = serverUrl srv + go pow manager = do + res <- runExceptT $ a pow manager url + case res of + Left err -> return $ onerr $ + "server failure: " ++ show err + Right (Result r) -> return $ onsuccess r + Right needpow -> error "NEEDPOW" -- loop with pow + +-- | HTTP Manager supporting tor .onion and regular hosts +torableManager :: IO Manager +torableManager = newManager $ defaultManagerSettings + { managerRawConnection = return conn + } + where + conn addr host port + | ".onion" `isSuffixOf` map toLower host = torConnection host port + | otherwise = do + regular <- managerRawConnection defaultManagerSettings + regular addr host port + +torConnection :: HostName -> Port -> IO Connection +torConnection onionaddress p = do + (socket, _) <- socksConnect torsockconf socksaddr + socketConnection socket 8192 + where + torsocksport = 9050 + torsockconf = defaultSocksConf "127.0.0.1" torsocksport + socksdomain = SocksAddrDomainName (BU8.fromString onionaddress) + socksaddr = SocksAddress socksdomain (fromIntegral p) + +socketConnection :: Network.Socket.Socket -> Int -> IO Connection +socketConnection socket chunksize = makeConnection + (recv socket chunksize) + (sendAll socket) + (Network.Socket.close socket) diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,11 +1,37 @@ -* test suite (eg, test basic storage and restore of various size data) -* tune hashes on more powerful hardware than thermal throttling laptop -* store to servers +Soon: + +* Run a key restore and make sure it takes 35 to 50 minutes. +* client/server Proof Of Work +* Implement the different categories of servers in the server list. +* Include an example tor hidden service config +* Get some keysafe servers set up. +* Keep a local record of keys that have been backed up, and the tunables + and password entropy. This will allow warning later if the crack estimate + has to be revised downward for some reason, or if a server is + compromised. * Run --uploadqueued periodically (systemd timer?) + +Later: + * improve restore progress bar points (update after every hash try) +* If we retrieved enough shares successfully, but decrypt failed, must + be a wrong password, so prompt for re-entry and retry with those shares. +* Don't require --totalshares and --neededshares on restore when unusual + values were used for backup. Instead, probe until enough shares are found + to restore. +* --no-jargon which makes the UI avoid terms like "secret key" and "crack + password". Do usability testing! +* --key-value=$N which eliminates the question about password value, + and rejects passwords that would cost less than $N to crack at current + rates. This should add a combo box to the password entry form in the + GUI to let the user adjust the $N there. +* --name and --othername to allow specifying those at the command line, + bypassing the prompts. With these and --key-value, keysafe would only + prompt for the password. + +Wishlist: + * Keep secret keys in locked memory until they're encrypted. (Raaz makes this possible to do.) Would be nice, but not super-important, since gpg secret keys are passphrase protected anyway.. -* If we retrieved enough shares successfully, but decrypt failed, must - be a wrong password, so prompt for re-entry and retry with those shares. diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- Copyright 2016 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Tests where + +import Types +import Tunables +import Encryption +import Share +import Storage +import Storage.Local +import Control.Exception +import System.Directory +import System.Posix.Temp +import System.IO +import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.ByteString as B +import qualified Data.Set as S +import Data.Monoid + +type TestDesc = B.ByteString + +type TestResult = Either String () + +type Test = (TestDesc, IO TestResult) + +testSuccess :: IO TestResult +testSuccess = return $ Right () + +testFailed :: String -> IO TestResult +testFailed = return . Left + +runTest :: Test -> IO Bool +runTest (d, t) = do + putStr $ "testing: " ++ show d ++ " ..." + hFlush stdout + r <- t + case r of + Right () -> do + putStrLn "ok" + return True + Left e -> do + putStrLn $ "failed: " ++ show e + return False + +runTests :: IO () +runTests = do + r <- mapM runTest tests + if all (== True) r + then putStrLn "All tests succeeded." + else error "Tests failed. Report a bug!" + +tests :: [Test] +tests = + [ backupRestoreTest "very small" $ + testSecretKey 1 + , backupRestoreTest "full size" $ + testSecretKey (objectSize testModeTunables) + , backupRestoreTest "two chunks" $ + testSecretKey (objectSize testModeTunables + 1) + , backupRestoreTest "many chunks" $ + testSecretKey (objectSize testModeTunables * 10) + , stableNamingTest "stable naming" + ] + +testSecretKey :: Int -> SecretKey +testSecretKey sz = SecretKey $ BU8.fromString $ take sz $ concatMap show [1..sz] + +withTestStorageLocations :: (StorageLocations -> IO a) -> IO a +withTestStorageLocations a = bracket setup cleanup go + where + setup = mkdtemp "keysafe-test" + cleanup = removeDirectoryRecursive + go tmpdir = a $ StorageLocations $ + map (localStorage (testStorageDir tmpdir) . show) + [1..100 :: Int] + +-- | Test of backup and restore of a SecretKey. +backupRestoreTest :: TestDesc -> SecretKey -> Test +backupRestoreTest testdesc secretkey = + ("backup and restore (" <> testdesc <> ")", runtest) + where + runtest = withTestStorageLocations $ \storagelocations -> do + backup storagelocations + restore storagelocations + + backup storagelocations = do + kek <- genKeyEncryptionKey tunables name password + let esk = encrypt tunables kek secretkey + shares <- genShares esk tunables + let sis = shareIdents tunables name secretkeysource + _ <- storeShares storagelocations sis shares (return ()) + return () + + restore storagelocations = do + let sis = shareIdents tunables name secretkeysource + (shares, sis') <- retrieveShares storagelocations sis (return ()) + let candidatekeys = candidateKeyEncryptionKeys tunables name password + case combineShares tunables [shares] of + Left e -> testFailed e + Right esk -> restorerest storagelocations [shares] sis' $ + tryDecrypt candidatekeys esk + + restorerest storagelocations firstshares sis r = case r of + DecryptFailed -> testFailed "DecryptFailed" + DecryptSuccess restoredsecretkey -> + if restoredsecretkey == secretkey + then testSuccess + else testFailed "restore yielded different value than was backed up" + DecryptIncomplete kek -> do + (nextshares, sis') <- retrieveShares storagelocations sis (return ()) + let shares = firstshares ++ [nextshares] + case combineShares tunables shares of + Left e -> testFailed e + Right esk -> restorerest storagelocations shares sis' $ + decrypt kek esk + + name = Name testdesc + password = Password "password" + secretkeysource = GpgKey (KeyId "dummy") + -- testModeTunables is used, to avoid this taking a very + -- long time to run. + tunables = testModeTunables + +-- | It's important that StorableObjectIdent generation be stable; +-- any change to it will cause shards to get lost. +stableNamingTest :: TestDesc -> Test +stableNamingTest testdesc = (testdesc, runtest $ map snd knownTunings) + where + runtest [] = testFailed "not stable!" + runtest (tunables:rest) = do + let sis = shareIdents tunables name secretkeysource + if S.member knownvalue (head (identsStream sis)) + then testSuccess + else runtest rest + + name = Name "stable name" + secretkeysource = GpgKey (KeyId "stable keyid") + knownvalue = StorableObjectIdent "18b112da9108b4b5e21fa07cfc672e11688110e4c2dc56c8365f0de488cca8cb" diff --git a/Tunables.hs b/Tunables.hs --- a/Tunables.hs +++ b/Tunables.hs @@ -38,6 +38,8 @@ -- ^ a StorableObject is exactly this many bytes in size -- (must be a multiple of AES block size 16, and cannot be smaller -- than 256 bytes) + , shareOverhead :: Int + -- ^ Share encoding overhead as a multiple of the objectSize , nameGenerationTunable :: NameGenerationTunable , keyEncryptionKeyTunable :: KeyEncryptionKeyTunable , encryptionTunable :: EncryptionTunable @@ -79,25 +81,25 @@ data EncryptionTunable = UseAES256 deriving (Show) +-- | Tunables used by default to backup. defaultTunables :: Tunables defaultTunables = Tunables { shareParams = ShareParams { totalObjects = 3, neededObjects = 2 } - , objectSize = 1024*64 -- 64 kb - -- The nameGenerationHash was benchmarked at 661 seconds CPU time - -- on a 2 core Intel(R) Core(TM) i5-4210Y CPU @ 1.50GHz. - -- Since cost is measured per core, we double that. + , objectSize = 1024*32 -- 32 kb + , shareOverhead = 2 + -- The nameGenerationHash was benchmarked at 600 seconds + -- on a 2 core Intel(R) Core(TM) i5-5200U CPU @ 2.20GHz. , nameGenerationTunable = NameGenerationTunable - { nameGenerationHash = argon2 10000 (CPUCost (Seconds (2*600))) + { nameGenerationHash = argon2 10000 (coreCost 2 (Seconds 600) d) } , keyEncryptionKeyTunable = KeyEncryptionKeyTunable - { keyEncryptionKeyHash = argon2 115 (CPUCost (Seconds 0)) + { keyEncryptionKeyHash = argon2 169 (CPUCost (Seconds 12) d) , randomSaltBytes = 1 -- The keyEncryptionKeyHash is run 256 times per -- random salt byte to brute-force, and its parameters -- were chosen so the total brute forcing time is 50 minutes, - -- on a 2 core Intel(R) Core(TM) i5-4210Y CPU @ 1.50GHz. - -- Since cost is measured per core, we double that. - , randomSaltBytesBruteForceCost = CPUCost (Seconds (2*50*60)) + -- on a 2 core Intel(R) Core(TM) i5-5200U CPU @ 2.20GHz. + , randomSaltBytesBruteForceCost = coreCost 2 (Seconds (50*60)) d } , encryptionTunable = UseAES256 } @@ -105,25 +107,35 @@ argon2 i c = UseArgon2 c $ Argon2.HashOptions { Argon2.hashIterations = i , Argon2.hashMemory = 131072 -- 128 mebibtyes per thread - , Argon2.hashParallelism = 4 -- 4 threads + , Argon2.hashParallelism = + let Divisibility n = d + in fromIntegral n , Argon2.hashVariant = Argon2.Argon2i } + d = Divisibility 4 -- argon2 uses 4 threads -- | Dials back hash difficulty, lies about costs. -- Not for production use! testModeTunables :: Tunables testModeTunables = Tunables { shareParams = ShareParams { totalObjects = 3, neededObjects = 2 } - , objectSize = 1024*64 + , objectSize = 1024*32 + , shareOverhead = 2 , nameGenerationTunable = NameGenerationTunable - { nameGenerationHash = weakargon2 (CPUCost (Seconds (2*600))) + { nameGenerationHash = weakargon2 (coreCost 2 (Seconds 600) d) } , keyEncryptionKeyTunable = KeyEncryptionKeyTunable - { keyEncryptionKeyHash = weakargon2 (CPUCost (Seconds 0)) + { keyEncryptionKeyHash = weakargon2 (CPUCost (Seconds 12) d) , randomSaltBytes = 1 - , randomSaltBytesBruteForceCost = CPUCost (Seconds (2*50*60)) + , randomSaltBytesBruteForceCost = coreCost 2 (Seconds (50*60)) d } , encryptionTunable = UseAES256 } where weakargon2 c = UseArgon2 c Argon2.defaultHashOptions + d = Divisibility 4 + +knownObjectSizes :: [Int] +knownObjectSizes = map (calc . snd) knownTunings + where + calc t = objectSize t * shareOverhead t diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, DeriveGeneric #-} {- Copyright 2016 Joey Hess - @@ -11,9 +11,11 @@ import qualified Data.ByteString as B import Data.String import Control.DeepSeq +import GHC.Generics (Generic) -- | keysafe stores secret keys. newtype SecretKey = SecretKey B.ByteString + deriving (Eq) -- | The secret key, encrypted with a password, in fixed size chunks. data EncryptedSecretKey = EncryptedSecretKey [B.ByteString] (CostCalc BruteForceOp UnknownPassword) @@ -29,7 +31,7 @@ -- | An object in a form suitable to be stored on a keysafe server. newtype StorableObject = StorableObject { fromStorableObject :: B.ByteString } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) -- | An identifier for a StorableObject newtype StorableObjectIdent = StorableObjectIdent B.ByteString diff --git a/Types/Cost.hs b/Types/Cost.hs --- a/Types/Cost.hs +++ b/Types/Cost.hs @@ -9,30 +9,26 @@ -- | An estimated cost to perform an operation. data Cost op - = CPUCost Seconds -- ^ using 1 CPU core + = CPUCost Seconds Divisibility + -- ^ cost in Seconds, using 1 physical CPU core deriving (Show, Eq, Ord) -unknownCost :: Cost op -unknownCost = CPUCost (Seconds 0) - newtype Seconds = Seconds Integer deriving (Num, Eq, Ord, Show) +-- | How many CPU cores a single run of an operation can be divided amoung. +newtype Divisibility = Divisibility Integer + deriving (Show, Eq, Ord) + data UsingHardware = UsingCPU | UsingGPU | UsingASIC deriving (Show) instance Monoid (Cost t) where - mempty = CPUCost (Seconds 0) - CPUCost (Seconds a) `mappend` CPUCost (Seconds b) = - CPUCost (Seconds (a+b)) - -mapCost :: (Integer -> Integer) -> Cost op -> Cost op -mapCost f (CPUCost (Seconds n)) = CPUCost (Seconds (f n)) - -showCostMinutes :: Cost op -> String -showCostMinutes (CPUCost (Seconds n)) - | n < 61 = "1 minute" - | otherwise = show (n `div` 60) ++ " minutes" + mempty = CPUCost (Seconds 0) (Divisibility 1) + CPUCost (Seconds a) (Divisibility x) `mappend` CPUCost (Seconds b) (Divisibility y) = + -- Take maximum divisibility, to avoid over-estimating + -- the total cost. + CPUCost (Seconds (a+b)) (Divisibility $ max x y) -- | Operations whose cost can be measured. data DecryptionOp diff --git a/Types/Storage.hs b/Types/Storage.hs --- a/Types/Storage.hs +++ b/Types/Storage.hs @@ -4,16 +4,21 @@ -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} module Types.Storage where import Types +import GHC.Generics +import Data.Aeson.Types -- | All known locations where shares can be stored, ordered with -- preferred locations first. newtype StorageLocations = StorageLocations [Storage] deriving (Monoid) +newtype LocalStorageDirectory = LocalStorageDirectory FilePath + -- | Storage interface. This can be used both for local storage, -- an upload queue, or a remote server. -- @@ -31,12 +36,18 @@ } data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String - deriving (Show) + deriving (Show, Generic) data RetrieveResult = RetrieveSuccess Share | RetrieveFailure String + deriving (Generic) data ObscureResult = ObscureSuccess | ObscureFailure String - deriving (Show) + deriving (Show, Generic) data CountResult = CountResult Integer | CountFailure String - deriving (Show) + deriving (Show, Generic) + +instance ToJSON StoreResult +instance FromJSON StoreResult +instance ToJSON CountResult +instance FromJSON CountResult diff --git a/keysafe.cabal b/keysafe.cabal --- a/keysafe.cabal +++ b/keysafe.cabal @@ -1,5 +1,5 @@ Name: keysafe -Version: 0.20160819 +Version: 0.20160831 Cabal-Version: >= 1.8 Maintainer: Joey Hess Author: Joey Hess @@ -20,16 +20,21 @@ Extra-Source-Files: CHANGELOG TODO + INSTALL keysafe.1 + keysafe.service + keysafe.desktop + Makefile Executable keysafe Main-Is: keysafe.hs - GHC-Options: -Wall -fno-warn-tabs -O2 + GHC-Options: -threaded -Wall -fno-warn-tabs -O2 Build-Depends: base (>= 4.5 && < 5.0) , bytestring == 0.10.* , deepseq == 1.4.* , random == 1.1.* + , secret-sharing == 1.0.* , raaz == 0.0.2 , time == 1.5.* , containers == 0.5.* @@ -44,15 +49,17 @@ , optparse-applicative == 0.12.* , readline == 1.0.* , zxcvbn-c == 1.0.* - - -- Inlined to change the finite field size to 256 - -- for efficient serialization. - -- secret-sharing == 1.0.* - , dice-entropy-conduit >= 1.0.0.0 - , binary >=0.5.1.1 - , vector >=0.10.11.0 - , finite-field >=0.8.0 - , polynomial >= 0.7.1 + , servant == 0.7.* + , servant-server == 0.7.* + , servant-client == 0.7.* + , aeson == 0.11.* + , wai == 3.2.* + , warp == 3.2.* + , http-client == 0.4.* + , transformers == 0.4.* + , stm == 2.4.* + , socks == 0.5.* + , network == 2.6.* -- Temporarily inlined due to https://github.com/ocharles/argon2/issues/3 -- argon2 == 1.1.* Extra-Libraries: argon2 @@ -61,17 +68,20 @@ Crypto.Argon2 CmdLine Cost - Crypto.SecretSharing.Internal Encryption Entropy ExpensiveHash Gpg + HTTP + HTTP.Client + HTTP.Server SecretKey Serialization Share Storage Storage.Local Storage.Network + Tests Tunables Types Types.Cost diff --git a/keysafe.desktop b/keysafe.desktop new file mode 100644 --- /dev/null +++ b/keysafe.desktop @@ -0,0 +1,8 @@ +[Desktop Entry] +Type=Application +Version=1.0 +Name=Keysafe +Comment=Back up or restore your private Gnupg key with Keysafe +Terminal=false +Exec=/usr/bin/keysafe +Categories=Network; diff --git a/keysafe.hs b/keysafe.hs --- a/keysafe.hs +++ b/keysafe.hs @@ -14,10 +14,12 @@ import Encryption import Entropy import ExpensiveHash +import Tests import Cost import SecretKey import Share import Storage +import HTTP.Server import qualified Gpg import Data.Maybe import Data.Time.Clock @@ -41,8 +43,8 @@ return (mkt testModeTunables, [mkt testModeTunables]) else return (mkt defaultTunables, map (mkt . snd) knownTunings) storagelocations <- if CmdLine.localstorage cmdline - then return localStorageLocations - else allStorageLocations + then pure $ localStorageLocations (CmdLine.localstoragedirectory cmdline) + else allStorageLocations (CmdLine.localstoragedirectory cmdline) dispatch cmdline ui storagelocations tunables possibletunables dispatch :: CmdLine.CmdLine -> UI -> StorageLocations -> Tunables -> [Tunables] -> IO () @@ -61,9 +63,16 @@ go CmdLine.Restore Nothing = restore storagelocations ui possibletunables Gpg.anyKey go CmdLine.UploadQueued _ = - uploadQueued + uploadQueued (CmdLine.localstoragedirectory cmdline) + go (CmdLine.Server) _ = + runServer + (CmdLine.localstoragedirectory cmdline) + (CmdLine.serverAddress $ CmdLine.serverConfig cmdline) + (CmdLine.serverPort $ CmdLine.serverConfig cmdline) go CmdLine.Benchmark _ = benchmarkTunables tunables + go CmdLine.Test _ = + runTests backup :: StorageLocations -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO () backup storagelocations ui tunables secretkeysource secretkey = do @@ -74,6 +83,7 @@ go theirname where go theirname = do + cores <- fromMaybe 1 <$> getNumCores Name othername <- fromMaybe (error "aborting on no othername") <$> promptName ui "Enter other name" othernamedesc Nothing validateName @@ -82,7 +92,7 @@ let sis = shareIdents tunables name secretkeysource let cost = getCreationCost kek <> getCreationCost sis r <- withProgressIncremental ui "Encrypting and storing data" - (encryptdesc cost) $ \addpercent -> do + (encryptdesc cost cores) $ \addpercent -> do let esk = encrypt tunables kek secretkey shares <- genShares esk tunables _ <- esk `deepseq` addpercent 25 @@ -156,8 +166,8 @@ crackdesc crackcost thisyear = unlines $ "Rough estimate of the cost to crack your password: " : costOverTimeTable crackcost thisyear - encryptdesc cost = unlines - [ "This will probably take around " ++ showCostMinutes cost + encryptdesc cost cores = unlines + [ "This will probably take around " ++ showCostMinutes cores cost , "" , "(It's a feature that this takes a while; it makes it hard" , "for anyone to find your data, or crack your password.)" @@ -176,6 +186,7 @@ restore :: StorageLocations -> UI -> [Tunables] -> SecretKeySource -> IO () restore storagelocations ui possibletunables secretkeydest = do + cores <- fromMaybe 1 <$> getNumCores username <- userName Name theirname <- fromMaybe (error "Aborting on no username") <$> promptName ui "Enter your name" @@ -199,14 +210,14 @@ Left e -> showError ui e Right esk -> do final <- withProgress ui "Decrypting" - (decryptdesc cost) $ \setpercent -> + (decryptdesc cost cores) $ \setpercent -> go tunables [shares] sis setpercent $ tryDecrypt candidatekeys esk final where go tunables firstshares sis setpercent r = case r of DecryptFailed -> return $ - showError ui "Decryption failed! Unknown why it would fail at this point." + showError ui "Decryption failed! Probably you entered the wrong password." DecryptSuccess secretkey -> do _ <- setpercent 100 writeSecretKey secretkeydest secretkey @@ -237,8 +248,8 @@ passworddesc = unlines [ "Enter the password to unlock your secret key." ] - decryptdesc cost = unlines - [ "This will probably take around " ++ showCostMinutes cost + decryptdesc cost cores = unlines + [ "This will probably take around " ++ showCostMinutes cores cost , "" , "(It's a feature that this takes so long; it prevents cracking your password.)" , "" @@ -246,7 +257,7 @@ ] -- | Try each possible tunable until the initial set of --- shares are found, the return the shares, and +-- shares are found, and return the shares, and -- ShareIdents to download subsequent sets. downloadInitialShares :: StorageLocations @@ -254,8 +265,9 @@ -> (Tunables -> ShareIdents) -> [Tunables] -> IO (Maybe (Tunables, S.Set Share, ShareIdents)) -downloadInitialShares storagelocations ui mksis possibletunables = - withProgressIncremental ui "Downloading encrypted data" message $ \addpercent -> do +downloadInitialShares storagelocations ui mksis possibletunables = do + cores <- fromMaybe 1 <$> getNumCores + withProgressIncremental ui "Downloading encrypted data" (message cores) $ \addpercent -> do go possibletunables addpercent where go [] _ = return Nothing @@ -272,9 +284,9 @@ else return $ Just (tunables, shares, sis') possiblesis = map mksis possibletunables - message = unlines + message cores = unlines [ "This will probably take around " - ++ showCostMinutes (mconcat $ map getCreationCost possiblesis) + ++ showCostMinutes cores (mconcat $ map getCreationCost possiblesis) , "" , "(It's a feature that this takes a while; it makes it hard" , "for anyone else to find your data.)" diff --git a/keysafe.service b/keysafe.service new file mode 100644 --- /dev/null +++ b/keysafe.service @@ -0,0 +1,15 @@ +[Unit] +Description=keysafe server + +[Service] +ExecStart=/usr/bin/keysafe --server --port 4242 --store-directory=/var/lib/keysafe/ +InaccessiblePaths=/home /etc +ReadWritePaths=/var/lib/keysafe +User=keysafe +Group=keysafe +StandardInput=null +StandardOutput=journal +StandardError=journal + +[Install] +WantedBy=multi-user.target