make storage to use configurable on command line

1 files changed, 105 insertions, 0 deletions

diff --git a/Storage/Local.hs b/Storage/Local.hs
new file mode 100644
index 0000000..93647df
--- /dev/null
+++ b/Storage/Local.hs
@@ -0,0 +1,105 @@
+{- Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Storage.Local (localStorage) where
+
+import Types
+import Storage
+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
+
+localStorage :: Storage
+localStorage = Storage
+	{ storeShard = store
+	, retrieveShard = retrieve
+	, obscureShards = obscure
+	, countShards = count
+	}
+
+store :: StorableObjectIdent -> Shard -> IO StoreResult
+store i s = onError (StoreFailure . show) $ do
+	dir <- shardDir
+	createDirectoryIfMissing True dir
+	let dest = dir </> shardFile i
+	exists <- doesFileExist dest
+	if exists
+		then return StoreAlreadyExists
+		else do
+			let tmp = dest ++ ".tmp"
+			fd <- openFd tmp WriteOnly (Just 0o666)
+				(defaultFileFlags { exclusive = True } )
+			h <- fdToHandle fd
+			B.hPut h (toByteString s)
+			hClose h
+			renameFile tmp dest
+			return StoreSuccess
+
+retrieve :: ShardNum -> StorableObjectIdent -> IO RetrieveResult
+retrieve n i = onError (RetrieveFailure . show) $ do
+	dir <- shardDir
+	fd <- openFd (dir </> shardFile i) ReadOnly Nothing defaultFileFlags
+	h <- fdToHandle fd
+	b <- B.hGetContents h
+	b `deepseq` hClose h
+	return $ RetrieveSuccess $ Shard 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 shards is never changed, so it's ok to set the
+-- mtime to the epoch; backup programs won't be confused.
+obscure :: IO ObscureResult
+obscure = onError (ObscureFailure . show) $ do
+	dir <- shardDir
+	fs <- filter isShardFile <$> getDirectoryContents dir
+	mapM_ (\f -> setFileTimes (dir </> f) 0 0) fs
+	return ObscureSuccess
+
+count :: IO CountResult
+count = onError (CountFailure . show) $ do
+	dir <- shardDir
+	CountResult . genericLength . filter isShardFile
+		<$> getDirectoryContents dir
+
+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
+
+shardDir :: IO FilePath
+shardDir = do
+	u <- getUserEntryForID =<< getEffectiveUserID
+	return $ homeDirectory u </> dotdir
+
+shardFile :: StorableObjectIdent -> String
+shardFile i = U8.toString (toByteString i) <> ext
+
+ext :: String
+ext = ".keysafe"
+
+isShardFile :: FilePath -> Bool
+isShardFile f = ext `isSuffixOf` f
+
+dotdir :: FilePath
+dotdir = ".keysafe" </> "objects"