keysafe-0.20200214: Storage/Local.hs

{- Copyright 2016 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module Storage.Local
	( localStorage
	, localStorageOverride
	, storageDir
	, storageTopDir
	, testStorageDir
	, localDiskUsage
	) where

import Types
import Types.Storage
import Output
import Serialization ()
import Utility.UserInfo
import Utility.Exception
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as U8
import Data.List
import Data.Maybe
import System.IO
import System.Directory
import System.Posix
import System.FilePath
import Raaz.Core.Encode
import Control.DeepSeq
import Control.Monad
import System.DiskSpace
import Control.Exception (IOException)

type GetShareDir = Section -> IO FilePath

newtype Section = Section String

localStorage :: StorageLevel -> GetShareDir -> String -> Storage
localStorage storagelevel getsharedir n = Storage
	{ storeShare = store section getsharedir
	, retrieveShare = retrieve section getsharedir
	, obscureShares = obscure section getsharedir
	, countShares = count section getsharedir
	, moveShares = move section getsharedir
	, storageLevel = storagelevel
	, uploadQueue = Nothing
	, getServer = Nothing
	}
  where
	section = Section n

localStorageOverride :: FilePath -> IO (Maybe Storage)
localStorageOverride d = onStorageError' accesserror $ do
	-- Check that the directory can be written to.
	createDirectoryIfMissing True d
	-- Use a filename as long as used for keysafe share files.
	let f = d </> "testtesttesttesttesttesttesttesttesttesttesttesttesttesttesttest.keysafe"
	writeFile f "test"
	_ <- readFile f
	removeFile f
	return $ Just $ localStorage LocallyPreferred (\_ -> pure d) ""
  where
	accesserror e = do
		warn $ "Unable to access local storage directory " ++ d ++ " (" ++ show e ++ ")"
		return Nothing

store :: Section -> GetShareDir -> StorableObjectIdent -> Share -> IO StoreResult
store section getsharedir i s = onStorageError (StoreFailure . show) $ do
	dir <- getsharedir section
	createDirectoryIfMissing True dir
	let dest = dir </> shareFile i
	exists <- doesFileExist dest
	if exists
		then return StoreAlreadyExists
		else do
			let tmp = dest ++ ".tmp"
			fd <- openFd tmp WriteOnly (Just 0o400)
				(defaultFileFlags { exclusive = True } )
			h <- fdToHandle fd
			B.hPut h (toByteString s)
			hClose h
			renameFile tmp dest
			return StoreSuccess

retrieve :: Section -> GetShareDir -> ShareNum -> StorableObjectIdent -> IO RetrieveResult
retrieve section getsharedir n i = onStorageError (RetrieveFailure . show) $ do
	dir <- getsharedir section
	fd <- openFd (dir </> shareFile i) ReadOnly Nothing defaultFileFlags
	h <- fdToHandle fd
	b <- B.hGetContents h
	b `deepseq` hClose h
	return $ RetrieveSuccess $ Share n (StorableObject b)

-- | Set atime and mtime to epoch, to obscure access and modification
-- patterns.
--
-- There is no way to set the ctime to the epoch, but setting the other
-- times does at least set it to the current time, which makes all
-- currently stored files look alike.
--
-- 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 -> GetShareDir -> IO ObscureResult
obscure section getsharedir = onStorageError (ObscureFailure . show) $ do
	dir <- getsharedir section
	fs <- filter isShareFile <$> getDirectoryContents dir
	mapM_ (\f -> setFileTimes (dir </> f) 0 0) fs
	return ObscureSuccess

count :: Section -> GetShareDir -> IO CountResult
count section getsharedir = onStorageError (CountFailure . show) $ do
	dir <- getsharedir section
	exists <- doesDirectoryExist dir
	if exists
		then CountResult . genericLength . filter isShareFile
			<$> getDirectoryContents dir
		else return (CountResult 0)

move :: Section -> GetShareDir -> Storage -> IO [StoreResult]
move section getsharedir storage = do
	dir <- getsharedir section
	fs <- map (dir </>) <$> catchDefaultIO [] (getDirectoryContents dir)
	rs <- forM fs $ \f -> case fromShareFile f of
		Nothing -> return Nothing
		Just i -> Just <$> go f i
	return (catMaybes rs)
  where
	-- Use a dummy share number of 0; it doesn't
	-- matter because we're not going to be
	-- recombining the share here.
	sharenum = 0

	go f i = do
		r <- retrieve section getsharedir sharenum i
		case r of
			RetrieveFailure e -> return (StoreFailure e)
			RetrieveSuccess share -> do
				s <- storeShare storage i share
				case s of
					StoreSuccess -> movesuccess f
					StoreAlreadyExists -> alreadyexists share i f
					StoreFailure e -> return (StoreFailure e)

	movesuccess f = do
		removeFile f
		return StoreSuccess

	-- Detect case where the same data is already
	-- stored on the other storage.
	alreadyexists share i f = do
		check <- retrieveShare storage sharenum i
		case check of
			RetrieveSuccess share'
				| share' == share -> movesuccess f
			_ -> return StoreAlreadyExists

onStorageError :: (IOException -> a) -> IO a -> IO a
onStorageError f = onStorageError' (pure . f)

onStorageError' :: (IOException -> IO a) -> IO a -> IO a
onStorageError' f a = do
	v <- try a
	case v of
		Left e -> f e
		Right r -> return r

storageDir :: Maybe LocalStorageDirectory -> GetShareDir
storageDir Nothing (Section section) = do
	home <- myHomeDir
	return $ home </> dotdir </> section
storageDir (Just (LocalStorageDirectory d)) (Section section) =
	pure $ d </> section

storageTopDir :: Maybe LocalStorageDirectory -> IO FilePath
storageTopDir lsd = storageDir lsd (Section ".")

testStorageDir :: FilePath -> GetShareDir
testStorageDir tmpdir = storageDir (Just (LocalStorageDirectory tmpdir))

localDiskUsage :: Maybe LocalStorageDirectory -> IO DiskUsage
localDiskUsage lsd = getDiskUsage =<< storageTopDir lsd

-- | 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 = takeFileName (U8.toString (toByteString i)) <> ext

fromShareFile :: FilePath -> Maybe StorableObjectIdent
fromShareFile f
	| isShareFile f = fromByteString $ U8.fromString $ takeFileName $ dropExtension f
	| otherwise = Nothing

isShareFile :: FilePath -> Bool
isShareFile f = ext `isSuffixOf` f

ext :: String
ext = ".keysafe"

dotdir :: FilePath
dotdir = ".keysafe" </> "objects"