keysafe-0.20160819: Storage/Local.hs

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

module Storage.Local (localStorage, uploadQueue) where

import Types
import Types.Storage
import Storage.Network (Server(..))
import Serialization ()
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as U8
import Data.Monoid
import Data.List
import System.Posix.User
import System.IO
import System.Directory
import System.Posix
import System.FilePath
import Raaz.Core.Encode
import Control.DeepSeq
import Control.Exception
import Control.Monad

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
	}
  where
	section = Section n

uploadQueue :: Server -> Storage
uploadQueue s = localStorage ("uploadqueue" </> serverName s)

store :: Section -> StorableObjectIdent -> Share -> IO StoreResult
store section i s = onError (StoreFailure . show) $ do
	dir <- shareDir 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 -> ShareNum -> StorableObjectIdent -> IO RetrieveResult
retrieve section n i = onError (RetrieveFailure . show) $ do
	dir <- shareDir 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 -> IO ObscureResult
obscure section = onError (ObscureFailure . show) $ do
	dir <- shareDir 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
	CountResult . genericLength . filter isShareFile
		<$> getDirectoryContents dir

move :: Section -> Storage -> IO ()
move section storage = do
	dir <- shareDir section
	fs <- getDirectoryContents dir
	forM_ fs $ \f -> case fromShareFile f of
		Nothing -> return ()
		Just i -> do
			-- Use a dummy share number of 0; it doesn't
			-- matter because we're not going to be
			-- recombining the share, just sending its contents
			-- on the the server.
			r <- retrieve section 0 i
			case r of
				RetrieveFailure _ -> return ()
				RetrieveSuccess share -> do
					s <- storeShare storage i share
					case s of
						StoreFailure _ -> return ()
						_ -> removeFile f

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

shareDir :: Section -> IO FilePath
shareDir (Section section) = do
	u <- getUserEntryForID =<< getEffectiveUserID
	return $ homeDirectory u </> dotdir </> section

shareFile :: StorableObjectIdent -> FilePath
shareFile i = U8.toString (toByteString i) <> ext

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

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

ext :: String
ext = ".keysafe"

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