Pass Backend

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,124 @@
+-- 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,179 @@
+-- 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 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 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
+import Fmt (pretty)
+
+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.dioptional (Toml.string "pass_exe") Toml..= pbPassExe
+
+
+verifyPassStore
+  :: forall r .
+     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 :: Sem r (Either FsError (Maybe (Node' ())))
+    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 & pretty
+      ]
+      (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"
+      , pretty path
+      ]
+      Nothing
+
+  case exitCode of
+    ExitSuccess ->
+      pure $ T.decodeUtf8 (BS.toStrict stdout) ^? passTextPrism . E.entry
+    ExitFailure 1 ->
+      pure Nothing
+    ExitFailure _i ->
+      throw $ OtherError (T.decodeUtf8 $ BS.toStrict stderr)
+
+
+pbListSecrets
+  :: Effects r => PassBackend -> Path -> Sem r (Maybe [Text])
+pbListSecrets backend path = runFsInIO do
+  let storeDir = pbStoreDir backend
+  verifyPassStore storeDir
+
+  let qualifiedPath = stringToPath $ storeDir <> pretty path
+  dirPath <-
+    nodeExists qualifiedPath
+    >>= maybe (nodeNotFound path) pure
+    <&> bimap (const path) (const path)
+  runError (listDirectory dirPath) >>= \case
+    Left e
+       | isDoesNotExistError e -> pure Nothing
+       | otherwise -> throw $ OtherError (T.pack $ show e)
+    Right filePaths -> do
+      pure $ Just filePaths
+        <&> map (T.drop 4 . T.pack . makeRelative fpath)
+   where
+     nodeNotFound
+       :: Effects r
+       => Path
+       -> Sem r a
+     nodeNotFound = undefined
+
+
+pbDeleteSecret
+  :: Effects r => PassBackend -> EntryPath -> Sem r ()
+pbDeleteSecret backend path = do
+  (exitCode, _stdout, stderr) <-
+    wrapper
+      backend
+      [ "rm"
+      , "-f"
+      , pretty path
+      ]
+      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