module ConfCrypt.Commands (
Command,
evaluate,
ReadConfCrypt(..),
GetConfCrypt(..),
AddConfCrypt(..),
EditConfCrypt(..),
DeleteConfCrypt(..),
ValidateConfCrypt(..),
NewConfCrypt(..),
FileAction(..),
genNewFileState,
writeFullContentsToBuffer
) where
import ConfCrypt.Default (defaultLines)
import ConfCrypt.Types
import ConfCrypt.Encryption (MonadEncrypt, MonadDecrypt, encryptValue, decryptValue, TextKey(..), RemoteKey(..))
import ConfCrypt.Validation (runAllRules)
import ConfCrypt.Providers.AWS (AWSCtx)
import Control.Arrow (second)
import Control.Monad (unless, (<=<))
import Control.Monad.Reader (ask)
import Control.Monad.Except (throwError, runExcept, MonadError, Except)
import Crypto.Random (MonadRandom)
import Data.List (find, sortOn)
import Data.Maybe (maybeToList)
import GHC.Generics (Generic)
import qualified Crypto.PubKey.RSA.Types as RSA
import qualified Data.Text as T
import qualified Data.Map as M
data FileAction
= Add
| Edit
| Remove
class Monad m => Command a m where
evaluate :: a -> m [T.Text]
data ReadConfCrypt = ReadConfCrypt
instance (Monad m, MonadDecrypt (ConfCryptM m key) key) => Command ReadConfCrypt (ConfCryptM m key) where
evaluate _ = do
(ccFile, ctx) <- ask
let params = parameters ccFile
transformed <- mapM (\p -> decryptedParam p <$> decryptValue ctx (paramValue p)) params
processReadLines transformed ccFile
where
decryptedParam param v = ParameterLine ParamLine {pName = paramName param, pValue = v}
processReadLines transformed ccFile =
writeFullContentsToBuffer False =<< genNewFileState (fileContents ccFile) transformedLines
where
transformedLines = [(p, Edit)| p <- transformed]
data GetConfCrypt = GetConfCrypt {gName :: T.Text}
deriving (Eq, Read, Show, Generic)
instance (Monad m, MonadDecrypt (ConfCryptM m key) key) => Command GetConfCrypt (ConfCryptM m key) where
evaluate (GetConfCrypt name) = do
(ccFile, ctx) <- ask
let mParam = find ((==name) . paramName) (parameters ccFile)
traverse (decrypt ctx) $ maybeToList mParam
where
decrypt ctx = decryptValue ctx . paramValue
data AddConfCrypt = AddConfCrypt {aName :: T.Text, aValue :: T.Text, aType :: SchemaType}
deriving (Eq, Read, Show, Generic)
instance (Monad m, MonadRandom m, MonadEncrypt (ConfCryptM m key) key) =>
Command AddConfCrypt (ConfCryptM m key) where
evaluate ac@AddConfCrypt {aName, aValue, aType} = do
(ccFile, ctx ) <- ask
encryptedValue <- encryptValue ctx aValue
let contents = fileContents ccFile
instructions = [(SchemaLine sl, Add), (ParameterLine (pl {pValue = encryptedValue}), Add)]
newcontents <- genNewFileState contents instructions
writeFullContentsToBuffer False newcontents
where
(pl, Just sl) = parameterToLines Parameter {paramName = aName, paramValue = aValue, paramType = Just aType}
data EditConfCrypt = EditConfCrypt {eName:: T.Text, eValue :: T.Text, eType :: SchemaType}
deriving (Eq, Read, Show, Generic)
instance (Monad m, MonadRandom m, MonadEncrypt (ConfCryptM m key) key) =>
Command EditConfCrypt (ConfCryptM m key) where
evaluate ec@EditConfCrypt {eName, eValue, eType} = do
(ccFile, ctx) <- ask
unless ( any ((==) eName . paramName) $ parameters ccFile) $
throwError $ UnknownParameter eName
rawEncrypted <- encryptValue ctx eValue
editOutput ccFile ec rawEncrypted
where
editOutput ccFile EditConfCrypt {eName, eValue, eType} encryptedValue = do
let contents = fileContents ccFile
instructions = [(SchemaLine sl, Edit),
(ParameterLine (pl {pValue = encryptedValue}), Edit)
]
newcontents <- genNewFileState contents instructions
writeFullContentsToBuffer False newcontents
where
(pl, Just sl) = parameterToLines Parameter {paramName = eName, paramValue = eValue, paramType = Just eType}
data DeleteConfCrypt = DeleteConfCrypt {dName:: T.Text}
deriving (Eq, Read, Show, Generic)
instance Monad m => Command DeleteConfCrypt (ConfCryptM m ()) where
evaluate DeleteConfCrypt {dName} = do
(ccFile, ()) <- ask
unless (any ((==) dName . paramName) $ parameters ccFile) $
throwError $ UnknownParameter dName
let contents = fileContents ccFile
instructions = fmap (second (const Remove)) . M.toList $ M.filterWithKey findNamedLine contents
newcontents <- genNewFileState contents instructions
writeFullContentsToBuffer False newcontents
where
findNamedLine (SchemaLine Schema {sName}) _ = dName == sName
findNamedLine (ParameterLine ParamLine {pName}) _ = dName == pName
findNamedLine _ _ = False
data ValidateConfCrypt = ValidateConfCrypt
instance (Monad m, MonadDecrypt (ConfCryptM m key) key) => Command ValidateConfCrypt (ConfCryptM m key) where
evaluate _ = runAllRules
data NewConfCrypt = NewConfCrypt
instance Monad m => Command NewConfCrypt (ConfCryptM m ()) where
evaluate _ =
writeFullContentsToBuffer False (fileContents defaultLines)
genNewFileState :: (Monad m, MonadError ConfCryptError m) =>
M.Map ConfCryptElement LineNumber
-> [(ConfCryptElement, FileAction)]
-> m (M.Map ConfCryptElement LineNumber)
genNewFileState fileContents [] = pure fileContents
genNewFileState fileContents ((CommentLine _, _):rest) = genNewFileState fileContents rest
genNewFileState fileContents ((line, action):rest) =
case M.toList (mLine line) of
[] ->
case action of
Add -> let
nums = M.elems fileContents
LineNumber highestLineNum = if null nums then LineNumber 0 else maximum nums
fc' = M.insert line (LineNumber $ highestLineNum + 1) fileContents
in genNewFileState fc' rest
_ -> throwError $ MissingLine (T.pack $ show line)
[(key, lineNum@(LineNumber lnValue))] ->
case action of
Remove -> let
fc' = M.delete key fileContents
fc'' = (\(LineNumber l) -> if l > lnValue then LineNumber (l - 1) else LineNumber l) <$> fc'
in genNewFileState fc'' rest
Edit -> let
fc' = M.delete key fileContents
fc'' = M.insert line lineNum fc'
in genNewFileState fc'' rest
_ -> throwError $ WrongFileAction ((<> " is an Add, but the line already exists. Did you mean to edit?"). T.pack $ show line)
_ -> error "viloates map key uniqueness"
where
mLine l = M.filterWithKey (\k _ -> k == l) fileContents
writeFullContentsToBuffer :: Monad m =>
Bool
-> M.Map ConfCryptElement LineNumber
-> m [T.Text]
writeFullContentsToBuffer wrap contents =
return $ toDisplayLine wrap <$> sortedLines
where
sortedLines = fmap fst . sortOn snd $ M.toList contents
toDisplayLine ::
Bool
-> ConfCryptElement
-> T.Text
toDisplayLine _ (CommentLine comment) = "# " <> comment
toDisplayLine _ (SchemaLine (Schema name tpe)) = name <> " : " <> typeToOutputString tpe
toDisplayLine wrap (ParameterLine (ParamLine name val)) = name <> " = " <> if wrap then wrapEncryptedValue val else val
wrapEncryptedValue ::
T.Text
-> T.Text
wrapEncryptedValue v = "BEGIN"<>v<>"END"