diff options
| -rw-r--r-- | CHANGELOG | 6 | ||||
| -rw-r--r-- | CmdLine.hs | 2 | ||||
| -rw-r--r-- | Storage/Local.hs | 23 | ||||
| -rw-r--r-- | Storage/Network.hs | 13 | ||||
| -rw-r--r-- | keysafe.hs | 6 |
5 files changed, 35 insertions, 15 deletions
@@ -1,3 +1,9 @@ +keysafe (0.20161007) UNRELEASED; urgency=medium + + * Check if --store-local directory is writable. + + -- Joey Hess <id@joeyh.name> Thu, 06 Oct 2016 16:48:57 -0400 + keysafe (0.20161006) unstable; urgency=medium * New --add-storage-directory and --add-server options, which can be used @@ -27,7 +27,7 @@ data CmdLine = CmdLine , customShareParams :: Maybe ShareParams , name :: Maybe Name , othername :: Maybe Name - , preferredStorage :: [Maybe LocalStorageDirectory -> Storage] + , preferredStorage :: [Maybe LocalStorageDirectory -> IO (Maybe Storage)] , serverConfig :: ServerConfig , chaffMaxDelay :: Maybe Seconds } diff --git a/Storage/Local.hs b/Storage/Local.hs index a79cc43..cac12b3 100644 --- a/Storage/Local.hs +++ b/Storage/Local.hs @@ -14,6 +14,7 @@ module Storage.Local import Types import Types.Storage +import Output import Serialization () import Utility.UserInfo import Utility.Exception @@ -50,8 +51,17 @@ localStorage storagelevel getsharedir n = Storage where section = Section n -localStorageOverride :: FilePath -> Storage -localStorageOverride d = localStorage LocallyPreferred (\_ -> pure d) "" +localStorageOverride :: FilePath -> IO (Maybe Storage) +localStorageOverride d = onError' accesserror $ do + -- Check that the directory can be written to. + createDirectoryIfMissing True d + writeFile (d </> "test.keysafe") "test" + removeFile (d </> "test.keysafe") + return $ Just $ localStorage LocallyPreferred (\_ -> pure d) "" + where + accesserror e = do + warn $ "Unable to access local storage directory " ++ d ++ " (" ++ show e ++ ")" + return Nothing store :: Section -> GetShareDir -> StorableObjectIdent -> Share -> IO StoreResult store section getsharedir i s = onError (StoreFailure . show) $ do @@ -141,11 +151,14 @@ move section getsharedir storage = do _ -> return StoreAlreadyExists onError :: (IOException -> a) -> IO a -> IO a -onError f a = do +onError f = onError' (pure . f) + +onError' :: (IOException -> IO a) -> IO a -> IO a +onError' f a = do v <- try a - return $ case v of + case v of Left e -> f e - Right r -> r + Right r -> return r storageDir :: Maybe LocalStorageDirectory -> GetShareDir storageDir Nothing (Section section) = do diff --git a/Storage/Network.hs b/Storage/Network.hs index 9d54a1c..41d1ff1 100644 --- a/Storage/Network.hs +++ b/Storage/Network.hs @@ -33,12 +33,13 @@ networkStorage storagelevel localdir server = Storage where ServerName name = serverName server -networkStorageOverride :: Maybe LocalStorageDirectory -> HostName -> Port -> Storage -networkStorageOverride lsd h p = networkStorage LocallyPreferred lsd $ Server - { serverName = ServerName h - , serverAddress = [ServerAddress h p] - , serverDesc = h - } +networkStorageOverride :: Maybe LocalStorageDirectory -> HostName -> Port -> IO (Maybe Storage) +networkStorageOverride lsd h p = return $ Just $ + networkStorage LocallyPreferred lsd $ Server + { serverName = ServerName h + , serverAddress = [ServerAddress h p] + , serverDesc = h + } store :: Server -> StorableObjectIdent -> Share -> IO StoreResult store srv i (Share _n o) = @@ -368,12 +368,12 @@ userName = do return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u) cmdLineStorageLocations :: CmdLine.CmdLine -> IO StorageLocations -cmdLineStorageLocations cmdline = +cmdLineStorageLocations cmdline = do + preflocs <- StorageLocations . catMaybes <$> + mapM (\mk -> mk lsd) (CmdLine.preferredStorage cmdline) shuffleStorageLocations (preflocs <> netlocs) where netlocs = networkStorageLocations lsd - preflocs = StorageLocations $ - map (\mk -> mk lsd) (CmdLine.preferredStorage cmdline) lsd = CmdLine.localstoragedirectory cmdline getPasswordEntropy :: Password -> Name -> IO (Entropy UnknownPassword) |