propellor/src/Propellor/PrivData.hs

222 lines
7.2 KiB
Haskell
Raw Permalink Normal View History

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
2015-01-19 19:20:12 +00:00
module Propellor.PrivData (
withPrivData,
withSomePrivData,
addPrivData,
setPrivData,
unsetPrivData,
2015-01-19 19:20:12 +00:00
dumpPrivData,
editPrivData,
filterPrivData,
listPrivDataFields,
makePrivDataDir,
decryptPrivData,
PrivMap,
) where
2014-03-30 23:11:24 +00:00
import Control.Applicative
import System.IO
import System.Directory
import Data.Maybe
2014-07-06 19:56:56 +00:00
import Data.Monoid
import Data.List
2014-03-30 23:11:24 +00:00
import Control.Monad
import Control.Monad.IfElse
import "mtl" Control.Monad.Reader
2014-07-06 19:56:56 +00:00
import qualified Data.Map as M
import qualified Data.Set as S
2014-03-30 23:11:24 +00:00
2014-03-31 03:37:54 +00:00
import Propellor.Types
import Propellor.Types.PrivData
2014-03-31 22:31:08 +00:00
import Propellor.Message
import Propellor.Info
2014-11-11 16:58:53 +00:00
import Propellor.Gpg
import Propellor.PrivData.Paths
2014-03-30 23:11:24 +00:00
import Utility.Monad
import Utility.PartialPrelude
import Utility.Exception
import Utility.Tmp
import Utility.SafeCommand
2014-03-31 01:01:18 +00:00
import Utility.Misc
import Utility.FileMode
import Utility.Env
2014-07-06 20:32:05 +00:00
import Utility.Table
2014-03-30 23:11:24 +00:00
2014-07-06 19:56:56 +00:00
-- | Allows a Property to access the value of a specific PrivDataField,
-- for use in a specific Context or HostContext.
2014-07-06 19:56:56 +00:00
--
-- Example use:
--
-- > withPrivData (PrivFile pemfile) (Context "joeyh.name") $ \getdata ->
-- > property "joeyh.name ssl cert" $ getdata $ \privdata ->
-- > liftIO $ writeFile pemfile privdata
-- > where pemfile = "/etc/ssl/certs/web.pem"
--
-- Note that if the value is not available, the action is not run
-- and instead it prints a message to help the user make the necessary
-- private data available.
--
-- The resulting Property includes Info about the PrivDataField
-- being used, which is necessary to ensure that the privdata is sent to
-- the remote host by propellor.
2014-07-06 19:56:56 +00:00
withPrivData
:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> s
-> c
-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i)
-> Property HasInfo
withPrivData s = withPrivData' snd [s]
-- Like withPrivData, but here any one of a list of PrivDataFields can be used.
withSomePrivData
:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> [s]
-> c
-> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i)
-> Property HasInfo
withSomePrivData = withPrivData' id
withPrivData'
:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> ((PrivDataField, PrivData) -> v)
-> [s]
-> c
-> (((v -> Propellor Result) -> Propellor Result) -> Property i)
-> Property HasInfo
withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
maybe missing (a . feed) =<< getM get fieldlist
2014-07-06 19:56:56 +00:00
where
get field = do
context <- mkHostContext hc <$> asks hostName
maybe Nothing (\privdata -> Just (field, privdata))
<$> liftIO (getLocalPrivData field context)
missing = do
Context cname <- mkHostContext hc <$> asks hostName
warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")"
liftIO $ putStrLn $ "Fix this by running:"
liftIO $ showSet $
map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist
2014-07-06 19:56:56 +00:00
return FailedChange
addinfo p = infoProperty
(propertyDesc p)
(propertySatisfy p)
(propertyInfo p <> mempty { _privData = privset })
(propertyChildren p)
privset = S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
fieldnames = map show fieldlist
fieldlist = map privDataField srclist
hc = asHostContext c
2014-07-06 19:56:56 +00:00
showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO ()
showSet l = forM_ l $ \(f, Context c, md) -> do
putStrLn $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\"
maybe noop (\d -> putStrLn $ " " ++ d) md
putStrLn ""
addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo
addPrivData v = pureInfoProperty (show v) $
mempty { _privData = S.singleton v }
2014-07-06 19:56:56 +00:00
{- Gets the requested field's value, in the specified context if it's
- available, from the host's local privdata cache. -}
getLocalPrivData :: PrivDataField -> Context -> IO (Maybe PrivData)
getLocalPrivData field context =
getPrivData field context . fromMaybe M.empty <$> localcache
2014-03-30 23:11:24 +00:00
where
2014-07-06 19:56:56 +00:00
localcache = catchDefaultIO Nothing $ readish <$> readFile privDataLocal
2014-07-06 23:40:03 +00:00
type PrivMap = M.Map (PrivDataField, Context) PrivData
2015-01-19 19:20:12 +00:00
-- | Get only the set of PrivData that the Host's Info says it uses.
2014-07-06 21:37:10 +00:00
filterPrivData :: Host -> PrivMap -> PrivMap
filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
where
used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $
_privData $ hostInfo host
2014-07-06 21:37:10 +00:00
getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
2014-07-06 19:56:56 +00:00
getPrivData field context = M.lookup (field, context)
setPrivData :: PrivDataField -> Context -> IO ()
setPrivData field context = do
2014-03-31 01:01:18 +00:00
putStrLn "Enter private data on stdin; ctrl-D when done:"
2014-07-06 19:56:56 +00:00
setPrivDataTo field context =<< hGetContentsStrict stdin
unsetPrivData :: PrivDataField -> Context -> IO ()
unsetPrivData field context = do
modifyPrivData $ M.delete (field, context)
putStrLn "Private data unset."
2014-07-06 19:56:56 +00:00
dumpPrivData :: PrivDataField -> Context -> IO ()
dumpPrivData field context =
maybe (error "Requested privdata is not set.") putStrLn
2014-07-06 19:56:56 +00:00
=<< (getPrivData field context <$> decryptPrivData)
2014-07-06 19:56:56 +00:00
editPrivData :: PrivDataField -> Context -> IO ()
editPrivData field context = do
v <- getPrivData field context <$> decryptPrivData
v' <- withTmpFile "propellorXXXX" $ \f h -> do
hClose h
maybe noop (writeFileProtected f) v
editor <- getEnvDefault "EDITOR" "vi"
unlessM (boolSystem editor [File f]) $
error "Editor failed; aborting."
readFile f
2014-07-06 19:56:56 +00:00
setPrivDataTo field context v'
listPrivDataFields :: [Host] -> IO ()
listPrivDataFields hosts = do
2014-07-06 20:03:28 +00:00
m <- decryptPrivData
section "Currently set data:"
showtable $ map mkrow (M.keys m)
let missing = M.keys $ M.difference wantedmap m
unless (null missing) $ do
section "Missing data that would be used if set:"
showtable $ map mkrow missing
section "How to set missing data:"
showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing
where
header = ["Field", "Context", "Used by"]
2014-07-07 07:42:35 +00:00
mkrow k@(field, (Context context)) =
2014-07-06 20:32:05 +00:00
[ shellEscape $ show field
, shellEscape context
, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby
2014-07-06 20:32:05 +00:00
]
mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $
S.toList $ _privData $ hostInfo host
usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const $ [hostName h]) hosts
2014-07-07 07:42:35 +00:00
wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")
descmap = M.unions $ map (\h -> mkhostmap h id) hosts
section desc = putStrLn $ "\n" ++ desc
showtable rows = do
2014-07-07 07:42:35 +00:00
putStr $ unlines $ formatTable $ tableWithHeader header rows
2014-07-06 19:56:56 +00:00
setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
setPrivDataTo field context value = do
modifyPrivData set
2014-03-31 01:01:18 +00:00
putStrLn "Private data set."
2014-04-01 22:42:32 +00:00
where
set = M.insert (field, context) (chomp value)
2014-04-01 22:42:32 +00:00
chomp s
| end s == "\n" = chomp (beginning s)
| otherwise = s
2014-03-30 23:11:24 +00:00
modifyPrivData :: (PrivMap -> PrivMap) -> IO ()
modifyPrivData f = do
makePrivDataDir
m <- decryptPrivData
let m' = f m
gpgEncrypt privDataFile (show m')
void $ boolSystem "git" [Param "add", File privDataFile]
2014-07-06 21:37:10 +00:00
decryptPrivData :: IO PrivMap
2014-07-06 19:56:56 +00:00
decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile
2014-03-30 23:19:29 +00:00
makePrivDataDir :: IO ()
makePrivDataDir = createDirectoryIfMissing False privDataDir