Skip to content

Commit 32e0702

Browse files
MagicRBMagicRB
committed
WIP
Signed-off-by: Magic_RB <magic_rb@redalder.org>
1 parent 38cd1be commit 32e0702

File tree

9 files changed

+735
-29
lines changed

9 files changed

+735
-29
lines changed

‎coffer.cabal‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,8 @@ library
2222
Backend
2323
Backend.Commands
2424
Backend.Interpreter
25+
Backend.Pass
26+
Backend.Debug
2527
Backend.Vault.Kv
2628
Backend.Vault.Kv.Internal
2729
BackendName
@@ -35,6 +37,8 @@ library
3537
Config
3638
Entry
3739
Entry.Json
40+
Entry.Pass
41+
Effect.Fs
3842
Error
3943
other-modules:
4044
Paths_coffer
@@ -95,9 +99,12 @@ library
9599
aeson
96100
, ansi-terminal
97101
, base >=4.14.3.0 && <5
102+
, bytestring
98103
, containers
104+
, directory
99105
, extra
100106
, fmt
107+
, filepath
101108
, hashable
102109
, http-client
103110
, http-client-tls
@@ -117,6 +124,7 @@ library
117124
, tomland
118125
, unordered-containers
119126
, validation-selective
127+
, typed-process
120128
default-language: Haskell2010
121129

122130
executable coffer

‎config.toml‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,11 @@
22
#
33
# SPDX-License-Identifier: MPL-2.0
44

5-
main_backend = "vault-local"
5+
main_backend = "pass"
66

77
[[backend]]
8-
type = "vault-kv"
9-
name = "vault-local"
10-
address = "localhost:8200"
11-
mount = "secret"
12-
token = "<vault token>"
8+
type = "debug"
9+
sub_type = "pass"
10+
name = "pass"
11+
store_dir = "/tmp/pass-store"
12+
pass_exe = "pass"

‎flake.nix‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@
2727
cabal-install
2828
haskell-language-server
2929
haskellPackages.implicit-hie
30+
stylish-haskell
3031
];
3132
buildInputs = with pkgs;
3233
[ zlib

‎lib/Backend/Debug.hs‎

Lines changed: 120 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,120 @@
1+
-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
2+
--
3+
-- SPDX-License-Identifier: MPL-2.0
4+
5+
module Backend.Debug
6+
( DebugBackend
7+
, debugCodec
8+
) where
9+
10+
import Backend
11+
import Backends
12+
import Coffer.Path
13+
import Control.Lens
14+
import Data.HashMap.Lazy qualified as HS
15+
import Data.Text (Text)
16+
import Data.Text qualified as T
17+
import Entry (Entry)
18+
import Polysemy
19+
import Toml (TomlCodec, TomlEnv)
20+
import Toml qualified
21+
import Validation (Validation(Failure, Success))
22+
23+
data DebugBackend =
24+
DebugBackend
25+
{ dSubType :: Text
26+
, dSubBackend :: SomeBackend
27+
}
28+
deriving stock (Show)
29+
30+
debugCodec :: TomlCodec DebugBackend
31+
debugCodec = Toml.Codec input output
32+
where input :: TomlEnv DebugBackend
33+
input toml = case HS.lookup "sub_type" $ Toml.tomlPairs toml of
34+
Just x ->
35+
case Toml.backward Toml._Text x of
36+
Right t ->
37+
case supportedBackends t of
38+
Right y ->
39+
let newToml = toml { Toml.tomlPairs =
40+
Toml.tomlPairs toml
41+
& HS.delete "sub_type"
42+
}
43+
in
44+
case y newToml of
45+
Success b -> Success $ DebugBackend
46+
{ dSubType = t
47+
, dSubBackend = b
48+
}
49+
Failure e -> Failure e
50+
Left e ->
51+
Failure
52+
[ Toml.BiMapError "type" e
53+
]
54+
Left e ->
55+
Failure
56+
[ Toml.BiMapError "type" e
57+
]
58+
Nothing ->
59+
Failure
60+
[ Toml.BiMapError "sub_type" $
61+
Toml.ArbitraryError
62+
"Debug backend doesn't have a `sub_type` key"
63+
]
64+
output :: DebugBackend -> Toml.TomlState DebugBackend
65+
output debugBackend =
66+
case dSubBackend debugBackend of
67+
SomeBackend (be :: a) -> do
68+
Toml.codecWrite (Toml.text "type") "debug"
69+
Toml.codecWrite (Toml.text "sub_type") (dSubType debugBackend)
70+
Toml.codecWrite (_codec @a) be
71+
pure debugBackend
72+
73+
dbWriteSecret
74+
:: Effects r => DebugBackend -> Entry -> Sem r ()
75+
dbWriteSecret b entry = unSubBackend b $ \(SomeBackend backend) -> do
76+
embed $ putStrLn ("WriteSecret: \n" <> show entry)
77+
_writeSecret backend entry
78+
79+
dbReadSecret
80+
:: Effects r => DebugBackend -> EntryPath -> Sem r (Maybe Entry)
81+
dbReadSecret b path = unSubBackend b $ \(SomeBackend backend) -> do
82+
embed $ putStrLn ("ReadSecret: " <> show path)
83+
_readSecret backend path >>= showPass "out: "
84+
85+
dbListSecrets
86+
:: Effects r => DebugBackend -> Path -> Sem r (Maybe [Text])
87+
dbListSecrets b path = unSubBackend b $ \(SomeBackend backend) -> do
88+
embed $ putStrLn ("ListSecrets: " <> show path)
89+
_listSecrets backend path >>= showPass "out: "
90+
91+
dbDeleteSecret
92+
:: Effects r => DebugBackend -> EntryPath -> Sem r ()
93+
dbDeleteSecret b path = unSubBackend b $ \(SomeBackend backend) -> do
94+
embed $ putStrLn ("DeleteSecret: " <> show path)
95+
_deleteSecret backend path
96+
97+
unSubBackend
98+
:: DebugBackend
99+
-> (SomeBackend -> a)
100+
-> a
101+
unSubBackend b f = f (dSubBackend b)
102+
103+
showPass
104+
:: ( Member (Embed IO) r
105+
, Show a
106+
)
107+
=> Text -> a -> Sem r a
108+
showPass txt a = do
109+
let atxt = T.pack $ show a
110+
embed $ putStrLn (T.unpack $ txt <> atxt)
111+
pure a
112+
113+
114+
instance Backend DebugBackend where
115+
_name debugBackend = (\(SomeBackend x) -> _name x) $ dSubBackend debugBackend
116+
_codec = debugCodec
117+
_writeSecret = dbWriteSecret
118+
_readSecret = dbReadSecret
119+
_listSecrets = dbListSecrets
120+
_deleteSecret = dbDeleteSecret

‎lib/Backend/Pass.hs‎

Lines changed: 170 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,170 @@
1+
-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
2+
--
3+
-- SPDX-License-Identifier: MPL-2.0
4+
5+
module Backend.Pass
6+
( PassBackend ) where
7+
import Backend
8+
import BackendName
9+
import Coffer.Path
10+
import Coffer.Path qualified as P
11+
import Control.Exception (IOException)
12+
import Control.Lens
13+
import Data.ByteString.Lazy (ByteString)
14+
import Data.ByteString.Lazy qualified as BS
15+
import Data.Maybe
16+
import Data.Text (Text)
17+
import Data.Text qualified as T
18+
import Data.Text.Encoding (encodeUtf8)
19+
import Data.Text.Encoding qualified as T
20+
import Effect.Fs
21+
import Entry (Entry)
22+
import Entry qualified as E
23+
import Entry.Pass
24+
import Error
25+
import Fmt (build, fmt)
26+
import Polysemy
27+
import Polysemy.Error
28+
import System.Directory qualified as D
29+
import System.FilePath (makeRelative)
30+
import System.IO.Error (isDoesNotExistError)
31+
import System.Process.Typed
32+
import Toml (TomlCodec)
33+
import Toml qualified
34+
35+
data PassBackend =
36+
PassBackend
37+
{ pbName :: BackendName
38+
, pbStoreDir :: FilePath
39+
, pbPassExe :: Maybe FilePath
40+
}
41+
deriving stock (Show)
42+
43+
passCodec :: TomlCodec PassBackend
44+
passCodec =
45+
PassBackend
46+
<$> backendNameCodec "name" Toml..= pbName
47+
<*> Toml.string "store_dir" Toml..= pbStoreDir
48+
<*> Toml.dimatch fPathToT tToFPath (Toml.text "pass_exe") Toml..= pbPassExe
49+
where tToFPath = Just . T.unpack
50+
fPathToT :: Maybe String -> Maybe Text
51+
fPathToT a = a <&> T.pack
52+
53+
54+
verifyPassStore
55+
:: Member (Error CofferError) r
56+
=> Member (Embed IO) r
57+
=> FilePath
58+
-> Sem r ()
59+
verifyPassStore storeDir =
60+
res >>= \case
61+
Left e -> throw $ OtherError (show e & T.pack)
62+
Right (Just _) -> pure ()
63+
Right Nothing -> throw . OtherError $
64+
"You must first initialize the password store at: " <> T.pack storeDir
65+
where
66+
res = runError @FsError . runFsInIO $ do
67+
nodeExists (stringToPath $ storeDir <> "/.gpg-id")
68+
69+
70+
wrapper
71+
:: Effects r
72+
=> PassBackend
73+
-> [String]
74+
-> Maybe (StreamSpec 'STInput ())
75+
-> Sem r (ExitCode, ByteString, ByteString)
76+
wrapper backend args input = do
77+
let passExe = pbPassExe backend
78+
let storeDir = pbStoreDir backend
79+
verifyPassStore storeDir
80+
81+
proc (fromMaybe "pass" passExe) args
82+
& case input of
83+
Just a -> setStdin a
84+
Nothing -> setStdin nullStream
85+
& setEnv [("PASSWORD_STORE_DIR", storeDir)]
86+
& readProcess
87+
88+
89+
90+
pbWriteSecret
91+
:: Effects r => PassBackend -> Entry -> Sem r ()
92+
pbWriteSecret backend entry = do
93+
let input =
94+
entry ^. re E.entry . re passTextPrism
95+
& encodeUtf8
96+
& BS.fromStrict
97+
98+
(exitCode, _stdout, stderr) <-
99+
wrapper
100+
backend
101+
[ "insert"
102+
, "-mf"
103+
, entry ^. E.path & P.entryPathAsPath & build & fmt
104+
]
105+
(Just $ byteStringInput input)
106+
107+
case exitCode of
108+
ExitSuccess -> pure ()
109+
ExitFailure _i -> throw $ OtherError (T.decodeUtf8 $ BS.toStrict stderr)
110+
111+
112+
pbReadSecret
113+
:: Effects r => PassBackend -> EntryPath -> Sem r (Maybe Entry)
114+
pbReadSecret backend path = do
115+
(exitCode, stdout, stderr) <-
116+
wrapper
117+
backend
118+
[ "show"
119+
, path & P.entryPathAsPath & build & fmt
120+
]
121+
Nothing
122+
123+
case exitCode of
124+
ExitSuccess ->
125+
pure $ T.decodeUtf8 (BS.toStrict stdout) ^? passTextPrism . E.entry
126+
ExitFailure 1 ->
127+
pure Nothing
128+
ExitFailure _e ->
129+
throw $ OtherError (T.decodeUtf8 $ BS.toStrict stderr)
130+
131+
pbListSecrets
132+
:: Effects r => PassBackend -> Path -> Sem r (Maybe [Text])
133+
pbListSecrets backend path = do
134+
let storeDir = pbStoreDir backend
135+
verifyPassStore storeDir
136+
137+
let fpath = storeDir <> (path & build & fmt)
138+
contents <- runError (fromException @IOException $ D.listDirectory fpath)
139+
>>= (\case Left e ->
140+
if | isDoesNotExistError e -> pure Nothing
141+
| True -> throw $ OtherError (T.pack $ show e)
142+
Right v -> pure $ Just v)
143+
<&> \a -> a <&> map (makeRelative fpath)
144+
145+
pure $ contents <&> map (T.dropEnd 4 . T.pack)
146+
147+
pbDeleteSecret
148+
:: Effects r => PassBackend -> EntryPath -> Sem r ()
149+
pbDeleteSecret backend path = do
150+
(exitCode, _stdout, stderr) <-
151+
wrapper
152+
backend
153+
[ "rm"
154+
, "-f"
155+
, path & P.entryPathAsPath & build & fmt
156+
]
157+
Nothing
158+
159+
case exitCode of
160+
ExitSuccess -> pure ()
161+
ExitFailure _e -> throw $ OtherError (T.decodeUtf8 $ BS.toStrict stderr)
162+
163+
164+
instance Backend PassBackend where
165+
_name kvBackend = pbName kvBackend
166+
_codec = passCodec
167+
_writeSecret = pbWriteSecret
168+
_readSecret = pbReadSecret
169+
_listSecrets = pbListSecrets
170+
_deleteSecret = pbDeleteSecret

‎lib/Backends.hs‎

Lines changed: 2 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -4,36 +4,16 @@
44

55
module Backends
66
( supportedBackends
7-
, backendPackedCodec
87
) where
98

109
import Backend (Backend(..), SomeBackend(..))
10+
import Backend.Pass
1111
import Backend.Vault.Kv (VaultKvBackend)
12-
import Data.HashMap.Strict qualified as HS
1312
import Data.Text (Text)
14-
import Toml (TomlCodec)
1513
import Toml qualified
16-
import Validation (Validation(Failure))
17-
18-
backendPackedCodec :: TomlCodec SomeBackend
19-
backendPackedCodec = Toml.Codec input output
20-
where
21-
input :: Toml.TomlEnv SomeBackend
22-
input toml =
23-
case HS.lookup "type" $ Toml.tomlPairs toml of
24-
Just t -> do
25-
case Toml.backward Toml._Text t >>= supportedBackends of
26-
Right c -> c toml
27-
Left e -> Failure [ Toml.BiMapError "type" e ]
28-
Nothing -> Failure
29-
[ Toml.BiMapError "type" $ Toml.ArbitraryError
30-
"Backend doesn't have a `type` key"
31-
]
32-
output (SomeBackend a) = do
33-
SomeBackend <$> Toml.codecWrite _codec a
34-
<* Toml.codecWrite (Toml.text "type") "vault"
3514

3615
supportedBackends
3716
:: Text -> Either Toml.TomlBiMapError (Toml.TomlEnv SomeBackend)
3817
supportedBackends "vault-kv" = Right $ fmap SomeBackend . Toml.codecRead (_codec @VaultKvBackend)
18+
supportedBackends "pass" = Right $ fmap SomeBackend . Toml.codecRead (_codec @PassBackend)
3919
supportedBackends _ = Left (Toml.ArbitraryError "Unknown backend type")

0 commit comments

Comments
 (0)