diff options
Diffstat (limited to 'Storage/Local.hs')
-rw-r--r-- | Storage/Local.hs | 105 |
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" |