From 41bfb68ee296a4ecdcbd9c02d242d6c9e149b7b8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 17 Aug 2016 15:23:00 -0400 Subject: make storage to use configurable on command line --- Storage/Local.hs | 105 ++++++++++++++++++++++++++++++++++++++++++++++++++ Storage/LocalFiles.hs | 105 -------------------------------------------------- Storage/Network.hs | 33 ++++++++++++++++ 3 files changed, 138 insertions(+), 105 deletions(-) create mode 100644 Storage/Local.hs delete mode 100644 Storage/LocalFiles.hs create mode 100644 Storage/Network.hs (limited to 'Storage') 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 + - + - 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" diff --git a/Storage/LocalFiles.hs b/Storage/LocalFiles.hs deleted file mode 100644 index ebcc492..0000000 --- a/Storage/LocalFiles.hs +++ /dev/null @@ -1,105 +0,0 @@ -{- Copyright 2016 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -{-# LANGUAGE OverloadedStrings #-} - -module Storage.LocalFiles (localFiles) 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 - -localFiles :: Storage -localFiles = 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" diff --git a/Storage/Network.hs b/Storage/Network.hs new file mode 100644 index 0000000..06b7545 --- /dev/null +++ b/Storage/Network.hs @@ -0,0 +1,33 @@ +{- Copyright 2016 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Storage.Network (networkStorage) where + +import Types +import Storage + +networkStorage :: Storage +networkStorage = Storage + { storeShard = store + , retrieveShard = retrieve + , obscureShards = obscure + , countShards = count + } + +store :: StorableObjectIdent -> Shard -> IO StoreResult +store _i _s = return $ StoreFailure "network storage not implemented yet" + +retrieve :: ShardNum -> StorableObjectIdent -> IO RetrieveResult +retrieve _n _i = return $ RetrieveFailure "network storage not implemented yet" + +-- | Servers should automatically obscure, so do nothing. +-- (Could upload chaff.) +obscure :: IO ObscureResult +obscure = return ObscureSuccess + +count :: IO CountResult +count = return $ CountFailure "network storage not implemented yet" -- cgit v1.2.3