keysafe-0.20160831: Storage/Local.hs

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

module Storage.Local (localStorage, storageDir, testStorageDir, 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

type GetShareDir = Section -> IO FilePath

newtype Section = Section String

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 :: Maybe LocalStorageDirectory -> Server -> Storage
uploadQueue d s = localStorage (storageDir d) ("uploadqueue" </> serverName s)

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
	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 = onError (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 = onError (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 = onError (CountFailure . show) $ do
	dir <- getsharedir section
	CountResult . genericLength . filter isShareFile
		<$> getDirectoryContents dir

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 ()
		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 getsharedir 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

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 = takeFileName (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"