WIP

Signed-off-by: Magic_RB <[email protected]>

coffer.cabal

@@ -22,6 +22,8 @@ library
       Backend
       Backend.Commands
       Backend.Interpreter
+      Backend.Pass
+      Backend.Debug
       Backend.Vault.Kv
       Backend.Vault.Kv.Internal
       BackendName
@@ -35,6 +37,8 @@ library
       Config
       Entry
       Entry.Json
+      Entry.Pass
+      Effect.Fs
       Error
   other-modules:
       Paths_coffer
@@ -95,9 +99,12 @@ library
       aeson
     , ansi-terminal
     , base >=4.14.3.0 && <5
+    , bytestring
     , containers
+    , directory
     , extra
     , fmt
+    , filepath
     , hashable
     , http-client
     , http-client-tls
@@ -117,6 +124,7 @@ library
     , tomland
     , unordered-containers
     , validation-selective
+    , typed-process
   default-language: Haskell2010
 
 executable coffer

config.toml

@@ -2,11 +2,11 @@
 #
 # SPDX-License-Identifier: MPL-2.0
 
-main_backend = "vault-local"
+main_backend = "pass"
 
 [[backend]]
-type = "vault-kv"
-name = "vault-local"
-address = "localhost:8200"
-mount = "secret"
-token = "<vault token>"
+type = "debug"
+sub_type = "pass"
+name = "pass"
+store_dir = "/tmp/pass-store"
+pass_exe = "pass"

flake.nix

@@ -27,6 +27,7 @@
                     cabal-install
                     haskell-language-server
                     haskellPackages.implicit-hie
+                    stylish-haskell
                   ];
                 buildInputs = with pkgs;
                   [ zlib

lib/Backend/Debug.hs

@@ -0,0 +1,120 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module Backend.Debug
+  ( DebugBackend
+  , debugCodec
+  ) where
+
+import Backend
+import Backends
+import Coffer.Path
+import Control.Lens
+import Data.HashMap.Lazy qualified as HS
+import Data.Text (Text)
+import Data.Text qualified as T
+import Entry (Entry)
+import Polysemy
+import Toml (TomlCodec, TomlEnv)
+import Toml qualified
+import Validation (Validation(Failure, Success))
+
+data DebugBackend =
+  DebugBackend
+  { dSubType :: Text
+  , dSubBackend :: SomeBackend
+  }
+  deriving stock (Show)
+
+debugCodec :: TomlCodec DebugBackend
+debugCodec = Toml.Codec input output
+  where input :: TomlEnv DebugBackend
+        input toml = case HS.lookup "sub_type" $ Toml.tomlPairs toml of
+                       Just x ->
+                         case Toml.backward Toml._Text x of
+                           Right t ->
+                             case supportedBackends t of
+                               Right y ->
+                                 let newToml = toml { Toml.tomlPairs =
+                                                      Toml.tomlPairs toml
+                                                      & HS.delete "sub_type"
+                                                    }
+                                 in
+                                 case y newToml of
+                                   Success b -> Success $ DebugBackend
+                                                { dSubType = t
+                                                , dSubBackend = b
+                                                }
+                                   Failure e -> Failure e
+                               Left e ->
+                                 Failure
+                                 [ Toml.BiMapError "type" e
+                                 ]
+                           Left e ->
+                             Failure
+                             [ Toml.BiMapError "type" e
+                             ]
+                       Nothing ->
+                         Failure
+                         [ Toml.BiMapError "sub_type" $
+                           Toml.ArbitraryError
+                           "Debug backend doesn't have a `sub_type` key"
+                         ]
+        output :: DebugBackend -> Toml.TomlState DebugBackend
+        output debugBackend =
+          case dSubBackend debugBackend of
+            SomeBackend (be :: a) -> do
+              Toml.codecWrite (Toml.text "type") "debug"
+              Toml.codecWrite (Toml.text "sub_type") (dSubType debugBackend)
+              Toml.codecWrite (_codec @a) be
+              pure debugBackend
+
+dbWriteSecret
+  :: Effects r => DebugBackend -> Entry -> Sem r ()
+dbWriteSecret b entry = unSubBackend b $ \(SomeBackend backend) -> do
+  embed $ putStrLn ("WriteSecret: \n" <> show entry)
+  _writeSecret backend entry
+
+dbReadSecret
+  :: Effects r => DebugBackend -> EntryPath -> Sem r (Maybe Entry)
+dbReadSecret b path = unSubBackend b $ \(SomeBackend backend) -> do
+  embed $ putStrLn ("ReadSecret: " <> show path)
+  _readSecret backend path >>= showPass "out: "
+
+dbListSecrets
+  :: Effects r => DebugBackend -> Path -> Sem r (Maybe [Text])
+dbListSecrets b path = unSubBackend b $ \(SomeBackend backend) -> do
+  embed $ putStrLn ("ListSecrets: " <> show path)
+  _listSecrets backend path >>= showPass "out: "
+
+dbDeleteSecret
+  :: Effects r => DebugBackend -> EntryPath -> Sem r ()
+dbDeleteSecret b path = unSubBackend b $ \(SomeBackend backend) -> do
+  embed $ putStrLn ("DeleteSecret: " <> show path)
+  _deleteSecret backend path
+
+unSubBackend
+  :: DebugBackend
+  -> (SomeBackend -> a)
+  -> a
+unSubBackend b f = f (dSubBackend b)
+
+showPass
+  :: ( Member (Embed IO) r
+     , Show a
+     )
+  => Text -> a -> Sem r a
+showPass txt a = do
+  let atxt = T.pack $ show a
+  embed $ putStrLn (T.unpack $ txt <> atxt)
+  pure a
+
+
+instance Backend DebugBackend where
+  _name debugBackend = (\(SomeBackend x) -> _name x) $ dSubBackend debugBackend
+  _codec = debugCodec
+  _writeSecret = dbWriteSecret
+  _readSecret = dbReadSecret
+  _listSecrets = dbListSecrets
+  _deleteSecret = dbDeleteSecret

lib/Backend/Pass.hs

@@ -0,0 +1,170 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module Backend.Pass
+  ( PassBackend ) where
+import Backend
+import BackendName
+import Coffer.Path
+import Coffer.Path qualified as P
+import Control.Exception (IOException)
+import Control.Lens
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy qualified as BS
+import Data.Maybe
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Text.Encoding qualified as T
+import Effect.Fs
+import Entry (Entry)
+import Entry qualified as E
+import Entry.Pass
+import Error
+import Fmt (build, fmt)
+import Polysemy
+import Polysemy.Error
+import System.Directory qualified as D
+import System.FilePath (makeRelative)
+import System.IO.Error (isDoesNotExistError)
+import System.Process.Typed
+import Toml (TomlCodec)
+import Toml qualified
+
+data PassBackend =
+  PassBackend
+  { pbName :: BackendName
+  , pbStoreDir :: FilePath
+  , pbPassExe :: Maybe FilePath
+  }
+  deriving stock (Show)
+
+passCodec :: TomlCodec PassBackend
+passCodec =
+  PassBackend
+  <$> backendNameCodec "name" Toml..= pbName
+  <*> Toml.string "store_dir" Toml..= pbStoreDir
+  <*> Toml.dimatch fPathToT tToFPath (Toml.text "pass_exe") Toml..= pbPassExe
+  where tToFPath = Just . T.unpack
+        fPathToT :: Maybe String -> Maybe Text
+        fPathToT a = a <&> T.pack
+
+
+verifyPassStore
+  :: Member (Error CofferError) r
+  => Member (Embed IO) r
+  => FilePath
+  -> Sem r ()
+verifyPassStore storeDir =
+  res >>= \case
+    Left e -> throw $ OtherError (show e & T.pack)
+    Right (Just _) -> pure ()
+    Right Nothing -> throw . OtherError $
+      "You must first initialize the password store at: " <> T.pack storeDir
+  where
+    res = runError @FsError . runFsInIO $ do
+      nodeExists (stringToPath $ storeDir <> "/.gpg-id")
+
+
+wrapper
+  :: Effects r
+  => PassBackend
+  -> [String]
+  -> Maybe (StreamSpec 'STInput ())
+  -> Sem r (ExitCode, ByteString, ByteString)
+wrapper backend args input = do
+  let passExe = pbPassExe backend
+  let storeDir = pbStoreDir backend
+  verifyPassStore storeDir
+
+  proc (fromMaybe "pass" passExe) args
+    & case input of
+        Just a -> setStdin a
+        Nothing -> setStdin nullStream
+    & setEnv [("PASSWORD_STORE_DIR", storeDir)]
+    & readProcess
+
+
+
+pbWriteSecret
+  :: Effects r => PassBackend -> Entry -> Sem r ()
+pbWriteSecret backend entry = do
+  let input =
+        entry ^. re E.entry . re passTextPrism
+        & encodeUtf8
+        & BS.fromStrict
+
+  (exitCode, _stdout, stderr) <-
+    wrapper
+      backend
+      [ "insert"
+      , "-mf"
+      , entry ^. E.path & P.entryPathAsPath & build & fmt
+      ]
+      (Just $ byteStringInput input)
+
+  case exitCode of
+    ExitSuccess -> pure ()
+    ExitFailure _i -> throw $ OtherError (T.decodeUtf8 $ BS.toStrict stderr)
+
+
+pbReadSecret
+  :: Effects r => PassBackend -> EntryPath -> Sem r (Maybe Entry)
+pbReadSecret backend path = do
+  (exitCode, stdout, stderr) <-
+    wrapper
+      backend
+      [ "show"
+      , path & P.entryPathAsPath & build & fmt
+      ]
+      Nothing
+
+  case exitCode of
+    ExitSuccess ->
+      pure $ T.decodeUtf8 (BS.toStrict stdout) ^? passTextPrism . E.entry
+    ExitFailure 1 ->
+      pure Nothing
+    ExitFailure _e ->
+      throw $ OtherError (T.decodeUtf8 $ BS.toStrict stderr)
+
+pbListSecrets
+  :: Effects r => PassBackend -> Path -> Sem r (Maybe [Text])
+pbListSecrets backend path = do
+  let storeDir = pbStoreDir backend
+  verifyPassStore storeDir
+
+  let fpath = storeDir <> (path & build & fmt)
+  contents <- runError (fromException @IOException $ D.listDirectory fpath)
+              >>= (\case Left e ->
+                           if | isDoesNotExistError e -> pure Nothing
+                              | True -> throw $ OtherError (T.pack $ show e)
+                         Right v -> pure $ Just v)
+              <&> \a -> a <&> map (makeRelative fpath)
+
+  pure $ contents <&> map (T.dropEnd 4 . T.pack)
+
+pbDeleteSecret
+  :: Effects r => PassBackend -> EntryPath -> Sem r ()
+pbDeleteSecret backend path = do
+  (exitCode, _stdout, stderr) <-
+    wrapper
+      backend
+      [ "rm"
+      , "-f"
+      , path & P.entryPathAsPath & build & fmt
+      ]
+      Nothing
+
+  case exitCode of
+    ExitSuccess -> pure ()
+    ExitFailure _e -> throw $ OtherError (T.decodeUtf8 $ BS.toStrict stderr)
+
+
+instance Backend PassBackend where
+  _name kvBackend = pbName kvBackend
+  _codec = passCodec
+  _writeSecret = pbWriteSecret
+  _readSecret = pbReadSecret
+  _listSecrets = pbListSecrets
+  _deleteSecret = pbDeleteSecret

lib/Backends.hs

@@ -4,36 +4,16 @@
 
 module Backends
   ( supportedBackends
-  , backendPackedCodec
   ) where
 
 import Backend (Backend(..), SomeBackend(..))
+import Backend.Pass
 import Backend.Vault.Kv (VaultKvBackend)
-import Data.HashMap.Strict qualified as HS
 import Data.Text (Text)
-import Toml (TomlCodec)
 import Toml qualified
-import Validation (Validation(Failure))
-
-backendPackedCodec :: TomlCodec SomeBackend
-backendPackedCodec = Toml.Codec input output
-  where
-    input :: Toml.TomlEnv SomeBackend
-    input toml =
-      case HS.lookup "type" $ Toml.tomlPairs toml of
-        Just t -> do
-          case Toml.backward Toml._Text t >>= supportedBackends of
-            Right c -> c toml
-            Left e -> Failure [ Toml.BiMapError "type" e ]
-        Nothing -> Failure
-          [ Toml.BiMapError "type" $ Toml.ArbitraryError
-            "Backend doesn't have a `type` key"
-          ]
-    output (SomeBackend a) = do
-      SomeBackend <$> Toml.codecWrite _codec a
-        <* Toml.codecWrite (Toml.text "type") "vault"
 
 supportedBackends
   :: Text -> Either Toml.TomlBiMapError (Toml.TomlEnv SomeBackend)
 supportedBackends "vault-kv" = Right $ fmap SomeBackend . Toml.codecRead (_codec @VaultKvBackend)
+supportedBackends "pass" = Right $ fmap SomeBackend . Toml.codecRead (_codec @PassBackend)
 supportedBackends _ = Left (Toml.ArbitraryError "Unknown backend type")