root / src / Ganeti / VCluster.hs @ a6a6a1b5
History | View | Annotate | Download (1.6 kB)
1 |
{-| Utilities for virtual clusters. |
---|---|
2 |
|
3 |
-} |
4 |
|
5 |
{- |
6 |
|
7 |
Copyright (C) 2014 Google Inc. |
8 |
|
9 |
This program is free software; you can redistribute it and/or modify |
10 |
it under the terms of the GNU General Public License as published by |
11 |
the Free Software Foundation; either version 2 of the License, or |
12 |
(at your option) any later version. |
13 |
|
14 |
This program is distributed in the hope that it will be useful, but |
15 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
16 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
17 |
General Public License for more details. |
18 |
|
19 |
You should have received a copy of the GNU General Public License |
20 |
along with this program; if not, write to the Free Software |
21 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
22 |
02110-1301, USA. |
23 |
|
24 |
-} |
25 |
|
26 |
module Ganeti.VCluster |
27 |
( makeVirtualPath |
28 |
) where |
29 |
|
30 |
import Control.Monad (liftM) |
31 |
import Data.Set (member) |
32 |
import System.Posix.Env (getEnv) |
33 |
import System.FilePath.Posix |
34 |
|
35 |
import Ganeti.ConstantUtils (unFrozenSet) |
36 |
import Ganeti.Constants |
37 |
|
38 |
getRootDirectory :: IO (Maybe FilePath) |
39 |
getRootDirectory = fmap normalise `liftM` getEnv vClusterRootdirEnvname |
40 |
|
41 |
-- | Pure computation of the virtual path from the original path |
42 |
-- and the vcluster root |
43 |
virtualPath :: FilePath -> FilePath -> FilePath |
44 |
virtualPath fpath root = |
45 |
let relpath = makeRelative root fpath |
46 |
in if member fpath (unFrozenSet vClusterVpathWhitelist) |
47 |
then fpath |
48 |
else vClusterVirtPathPrefix </> relpath |
49 |
|
50 |
-- | Given a path, make it a virtual one, if in a vcluster environment. |
51 |
-- Otherwise, return unchanged. |
52 |
makeVirtualPath :: FilePath -> IO FilePath |
53 |
makeVirtualPath fpath = maybe fpath (virtualPath fpath) `liftM` getRootDirectory |