From 32e07022ae13a9687c68b3a8d49dc11426873b71 Mon Sep 17 00:00:00 2001 From: Magic_RB Date: Tue, 5 Apr 2022 21:08:24 +0200 Subject: [PATCH 1/2] WIP Signed-off-by: Magic_RB --- coffer.cabal | 8 ++ config.toml | 12 +-- flake.nix | 1 + lib/Backend/Debug.hs | 120 +++++++++++++++++++++++ lib/Backend/Pass.hs | 170 ++++++++++++++++++++++++++++++++ lib/Backends.hs | 24 +---- lib/Config.hs | 27 ++++- lib/Effect/Fs.hs | 174 +++++++++++++++++++++++++++++++++ lib/Entry/Pass.hs | 228 +++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 735 insertions(+), 29 deletions(-) create mode 100644 lib/Backend/Debug.hs create mode 100644 lib/Backend/Pass.hs create mode 100644 lib/Effect/Fs.hs create mode 100644 lib/Entry/Pass.hs diff --git a/coffer.cabal b/coffer.cabal index cb9cbf2d..25f24f0e 100644 --- a/coffer.cabal +++ b/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 diff --git a/config.toml b/config.toml index dc068e4b..15309180 100644 --- a/config.toml +++ b/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 = "" +type = "debug" +sub_type = "pass" +name = "pass" +store_dir = "/tmp/pass-store" +pass_exe = "pass" \ No newline at end of file diff --git a/flake.nix b/flake.nix index 478ff0f1..7a20a413 100644 --- a/flake.nix +++ b/flake.nix @@ -27,6 +27,7 @@ cabal-install haskell-language-server haskellPackages.implicit-hie + stylish-haskell ]; buildInputs = with pkgs; [ zlib diff --git a/lib/Backend/Debug.hs b/lib/Backend/Debug.hs new file mode 100644 index 00000000..6e6298f8 --- /dev/null +++ b/lib/Backend/Debug.hs @@ -0,0 +1,120 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- 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 diff --git a/lib/Backend/Pass.hs b/lib/Backend/Pass.hs new file mode 100644 index 00000000..b612ad4c --- /dev/null +++ b/lib/Backend/Pass.hs @@ -0,0 +1,170 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- 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 diff --git a/lib/Backends.hs b/lib/Backends.hs index 1b40ebc0..6d99e73b 100644 --- a/lib/Backends.hs +++ b/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") diff --git a/lib/Config.hs b/lib/Config.hs index da54b18c..99ad4ea3 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -5,13 +5,16 @@ module Config where import Backend (Backend(..), SomeBackend(..)) +import Backend.Debug import BackendName (BackendName, backendNameCodec) -import Backends (backendPackedCodec) +import Backends (supportedBackends) import Data.Foldable (toList) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HS +import Data.Text (Text) import Toml (TomlCodec, (.=)) import Toml qualified +import Validation data Config = Config @@ -20,6 +23,28 @@ data Config = } deriving stock (Show) +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 >>= supportedBackendsWithDebug 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" + +supportedBackendsWithDebug + :: Text -> Either Toml.TomlBiMapError (Toml.TomlEnv SomeBackend) +supportedBackendsWithDebug "debug" = Right $ fmap SomeBackend . Toml.codecRead (_codec @DebugBackend) +supportedBackendsWithDebug t = supportedBackends t configCodec :: TomlCodec Config configCodec = Config diff --git a/lib/Effect/Fs.hs b/lib/Effect/Fs.hs new file mode 100644 index 00000000..71efe8bb --- /dev/null +++ b/lib/Effect/Fs.hs @@ -0,0 +1,174 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +{-# LANGUAGE ImportQualifiedPost #-} +module Effect.Fs + ( FsEffect + , nodeExists + , getNode + , listDirectory + , listDirectoryRec + , runFsInIO + , stringToPath + , pathToString + , FsError + , Node + , Node' + , File (..) + , Directory (..) + ) + where + +import Control.Lens +import Control.Monad (forM) +import Data.ByteString (ByteString) +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Polysemy +import Polysemy.Error +import System.Directory hiding (listDirectory) +import System.Directory qualified as D + +type Node f d = Either (File f) (Directory d) +type Node' a = Node a a +type Path = ByteString + +newtype File a = File a + deriving stock (Show) +newtype Directory a = Directory a + deriving stock (Show) + +data FsError + = FENodeNotFound Path + | FENodeExists (MismatchError (Node' Path)) + | FEMissingParent (Node' Path) + | FEInvalidPath Path + deriving stock (Show) + +data MismatchError a = MismatchError + { meWanted :: a + , mwFound :: a + } + deriving stock (Show) + +newtype NodeRec = NodeRec (Node Path [NodeRec]) + +pathToString :: Path -> Either FsError String +pathToString path = + case decodeUtf8' path of + Left a -> Left $ FEInvalidPath path + Right b -> Right $ T.unpack b +stringToPath :: String -> Path +stringToPath = encodeUtf8 . T.pack + +extractNodePath + :: Node' Path + -> Path +extractNodePath = + \case Left (File path) -> path + Right (Directory path) -> path + +eitherError + :: Member (Error e) r + => (a -> e) + -> Either a b + -> Sem r b +eitherError f = either (throw . f) pure + +data FsEffect m a where + NodeExists :: Path -> FsEffect m (Maybe (Node' ())) + GetNode :: Path -> FsEffect m (Maybe (Node' Path)) + ListDirectory :: Directory Path -> FsEffect m [Node' ByteString] + ListDirectoryRec :: Directory Path -> FsEffect m [NodeRec] +-- ReadNode :: Node' Path -> FsEffect m (Node ByteString [ByteString]) +-- CreateNode :: Node' Path -> FsEffect m (Node' ()) +-- GetHandle :: File Path -> FsEffect m (File Handle) +makeSem ''FsEffect + +runFsInIO + :: Member (Error FsError) r + => Member (Embed IO) r + => Sem (FsEffect ': r) a + -> Sem r a +runFsInIO = interpret + \case + NodeExists path -> _nodeExists path + GetNode path -> _getNode path + ListDirectory dirPath -> _listDirectory dirPath + ListDirectoryRec dirPath -> _listDirectoryRec dirPath + -- ReadNode nodePath -> undefined + -- CreateNode nodePath -> undefined + +_nodeExists + :: ( Member (Error FsError) r + , Member (Embed IO) r + ) + => Path + -> Sem r (Maybe (Node' ())) +_nodeExists path = do + stringPath <- + eitherError + (const $ FEInvalidPath path) + (decodeUtf8' path <&> T.unpack) + file <- embed $ doesFileExist stringPath + dir <- embed $ doesDirectoryExist stringPath + + case (file, dir) of + (True, False) -> pure . Just . Left $ File () + (False, True) -> pure . Just . Right $ Directory () + (_, _) -> pure Nothing + +_getNode + :: ( Member (Error FsError) r + , Member (Embed IO) r + ) + => Path + -> Sem r (Maybe (Node' Path)) +_getNode path = do + mNode <- _nodeExists path + pure + $ mNode <&> bimap + (const (File path)) + (const (Directory path)) + + +_listDirectory + :: ( Member (Error FsError) r + , Member (Embed IO) r + ) + => Directory Path + -> Sem r [Node' ByteString] +_listDirectory (Directory path) = do + stringPath <- eitherError id (pathToString path) + nodes <- embed $ D.listDirectory stringPath + mapM (_getNodeThrow . stringToPath) nodes + where + _getNodeThrow path = + _getNode path >>= maybe (throw $ FENodeNotFound path) pure + +_listDirectoryRec + :: ( Member (Error FsError) r + , Member (Embed IO) r + ) + => Directory Path + -> Sem r [NodeRec] +_listDirectoryRec dirPath = do + list <- _listDirectory dirPath + forM list $ \case Left f -> pure $ NodeRec $ Left f + Right d -> _listDirectoryRec d + <&> NodeRec . Right . Directory + +-- _readNode +-- :: Member (Error FsError) r +-- => Member (Embed IO) r +-- => Node' Path +-- -> Sem r (Node ByteString [ByteString]) +-- _readNode nodePath = undefined + +-- _createNode +-- :: Member (Error FsError) r +-- => Member (Embed IO) r +-- => Node' Path +-- -> Sem r () +-- _createNode nodePath = undefined diff --git a/lib/Entry/Pass.hs b/lib/Entry/Pass.hs new file mode 100644 index 00000000..9fb812e3 --- /dev/null +++ b/lib/Entry/Pass.hs @@ -0,0 +1,228 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module Entry.Pass + ( passTextPrism + ) where + +import Coffer.Path (entryPathAsPath, mkEntryPath) +import Control.Lens +import Control.Monad (guard) +import Data.Either.Extra (eitherToMaybe) +import Data.HashMap.Lazy qualified as HS +import Data.Maybe +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime(UTCTime, utctDay), secondsToDiffTime) +import Data.Time.Calendar.OrdinalDate.Compat +import Data.Time.Clock.Compat (UTCTime(utctDayTime)) +import Data.Time.Format.ISO8601 +import Data.Void +import Entry qualified as E +import Fmt +import Text.Megaparsec +import Text.Megaparsec.Char + +data PassKv = PassKv (Maybe Text) [(Text, Text)] + +data PassField = + PassField + { pfKey :: Text + , pfDateModified :: Text + , pfVisibility :: Text + , pfValue :: Text + } + deriving stock (Show) +makeLensesWith abbreviatedFields ''PassField + +data PassEntry = + PassEntry + { peMasterFieldKey :: Maybe Text + , peMasterFieldValue :: Maybe Text + , peDateModified :: Text + , peFields :: [PassField] + , peTags :: [Text] + , pePath :: Text + } + deriving stock (Show) +makeLensesWith abbreviatedFields ''PassEntry + +passFieldPrism :: Prism' PassField (E.FieldKey, E.Field) +passFieldPrism = prism' to from + where to :: (E.FieldKey, E.Field) -> PassField + to (fieldKey, field) = PassField + { pfKey = E.getFieldKey fieldKey + , pfDateModified = + T.pack . iso8601Show $ + field ^. E.dateModified + , pfVisibility = case field ^. E.visibility of + E.Public -> "public" + E.Private -> "private" + , pfValue = E.unFieldValue $ field ^. E.value + } + from :: PassField -> Maybe (E.FieldKey, E.Field) + from passField = do + let fieldValue = E.FieldValue $ passField ^. value + fieldKey <- passField ^. key & E.newFieldKey & eitherToMaybe + dateModified <- iso8601ParseM . T.unpack $ passField ^. dateModified + visibility <- case passField ^. visibility of + "public" -> Just E.Public + "private" -> Just E.Private + _ -> Nothing + + pure ( fieldKey + , E.newField dateModified fieldValue + & E.visibility .~ visibility + ) + +instance E.EntryConvertible PassEntry where + entry = prism' to from + where to :: E.Entry -> PassEntry + to entry = + PassEntry + { peMasterFieldKey = entry ^. E.masterField <&> E.getFieldKey + , peMasterFieldValue = + (entry ^. E.masterField) + >>= \fk -> entry ^. E.fields . at fk + <&> (E.unFieldValue . (^. E.value)) + , peDateModified = + T.pack . iso8601Show $ + entry ^. E.dateModified + , peFields = + map (^. re passFieldPrism) (entry ^. E.fields & HS.toList) + , peTags = entry ^. E.tags & S.toList & map E.getEntryTag + , pePath = entry ^. E.path & entryPathAsPath & build & fmt + } + from :: PassEntry -> Maybe E.Entry + from passEntry = do + let masterField = passEntry ^. masterFieldKey + dateModified <- passEntry ^. dateModified & iso8601ParseM . T.unpack + fields <- mapM (^? passFieldPrism) (passEntry ^. fields) + <&> HS.fromList + tags <- mapM (eitherToMaybe . E.newEntryTag) (passEntry ^. tags) + <&> S.fromList + entryPath <- eitherToMaybe . mkEntryPath $ passEntry ^. path + + pure $ E.newEntry entryPath dateModified + & E.fields .~ fields + & E.tags .~ tags + & E.masterField .~ (masterField >>= eitherToMaybe . E.newFieldKey) + +instance E.EntryConvertible PassKv where + entry = prism' to from + where to :: E.Entry -> PassKv + to entry = + let passEntry = entry ^. re E.entry :: PassEntry + masterValue = passEntry ^. masterFieldValue + in PassKv masterValue . onlyJust $ + concat (flip map (passEntry ^. fields) + \field -> + map Just + [ (field ^. key, field ^. value) + , ("#$" <> field ^. key <> ".DATE_MODIFIED", field ^. dateModified) + , ("#$" <> field ^. key <> ".VISIBILITY", field ^. visibility) + ]) + <> + [ Just ("#$DATE_MODIFIED", passEntry ^. dateModified) + , Just ("#$TAGS", T.intercalate "," (passEntry ^. tags)) + , Just ("#$PATH", passEntry ^. path) + ] + + onlyJust :: [Maybe a] -> [a] + onlyJust = unsafeOnlyJust . filter isJust + unsafeOnlyJust :: [Maybe a] -> [a] + unsafeOnlyJust = map $ + \case Just a -> a + Nothing -> undefined + isJust :: Maybe a -> Bool + isJust = \case Just _ -> True + Nothing -> False + + from :: PassKv -> Maybe E.Entry + from (PassKv masterValue passKv) = do + let hs = HS.fromList passKv + fhs = HS.fromList $ map (\(a, b) -> (b, a)) passKv + utcUnixEpoch = iso8601Show $ + UTCTime + { utctDay = YearDay 0 0 + , utctDayTime = secondsToDiffTime 0 + } + masterKey = masterValue >>= \a -> fhs ^. at a + dateModified = fromMaybe + (T.pack utcUnixEpoch) + (hs ^. at "#$DATE_MODIFIED") + tags = fromMaybe + [] + (hs ^. at "#$TAGS" + <&> T.split (== ',') + <&> filter (/= "")) + fields = hs + & HS.filterWithKey (\k _v -> T.take 2 k /= "#$") + & HS.mapKeys (T.split (== '.')) + & HS.filterWithKey (\k _v -> length k == 1) + & HS.mapKeys head + & HS.toList + & mapM \(k, v) -> + PassField k + <$> hs ^. at ("#$" <> k <> ".DATE_MODIFIED") + <*> hs ^. at ("#$" <> k <> ".VISIBILITY") + <*> pure v + entryPath = hs ^. at "#$PATH" + + + + guard (isNothing masterValue == isNothing masterKey) + + PassEntry + masterKey + masterValue + dateModified + <$> fields + <*> pure tags + <*> entryPath + >>= (^? E.entry) + +type Parser = Parsec Void Text + +passTextPrism :: Prism' Text PassKv +passTextPrism = prism' to from + where to :: PassKv -> Text + to (PassKv masterValue hs) = + fromMaybe "" masterValue + <> "\n\n" + <> + (map (\(k, v) -> k <> "=" <> v) hs + & T.intercalate "\n") + + from :: Text -> Maybe PassKv + from text = parseMaybe parser text + where parseLine + :: Maybe String + -> Parser Text + parseLine label = + do + x <- takeWhileP label (/='\n') + try newline + pure x + + parsePair + :: Parser (Text, Text) + parsePair = do + key <- takeWhileP (Just "key") (/='=') + char '=' + value <- takeWhileP (Just "value") (/='\n') + char '\n' <|> pure '\n' + pure (key, value) + + parser :: Parser PassKv + parser = do + masterValue <- parseLine (Just "character") + <&> \case "" -> Nothing + a -> Just a + takeWhileP (Just "empty line") (=='\n') + + pairs <- many parsePair + eof + pure (PassKv masterValue pairs) From 5a6bbeb6c6a2dc1244be1375b7fd22d95505294e Mon Sep 17 00:00:00 2001 From: Magic_RB Date: Wed, 27 Apr 2022 21:22:16 +0200 Subject: [PATCH 2/2] fixup! WIP Signed-off-by: Magic_RB --- lib/Backend/Debug.hs | 84 +++++------ lib/Backend/Pass.hs | 57 ++++---- lib/Effect/Fs.hs | 59 ++++---- lib/Entry/Pass.hs | 323 +++++++++++++++++++++---------------------- 4 files changed, 271 insertions(+), 252 deletions(-) diff --git a/lib/Backend/Debug.hs b/lib/Backend/Debug.hs index 6e6298f8..34ca0ca5 100644 --- a/lib/Backend/Debug.hs +++ b/lib/Backend/Debug.hs @@ -29,46 +29,50 @@ data DebugBackend = 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 + 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 () diff --git a/lib/Backend/Pass.hs b/lib/Backend/Pass.hs index b612ad4c..1e6e03cd 100644 --- a/lib/Backend/Pass.hs +++ b/lib/Backend/Pass.hs @@ -7,7 +7,6 @@ module Backend.Pass 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) @@ -22,15 +21,15 @@ 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.FilePath (makeRelative, ()) import System.IO.Error (isDoesNotExistError) import System.Process.Typed import Toml (TomlCodec) import Toml qualified +import Fmt (pretty) data PassBackend = PassBackend @@ -40,19 +39,18 @@ data PassBackend = } 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 + <*> Toml.dioptional (Toml.string "pass_exe") Toml..= pbPassExe verifyPassStore - :: Member (Error CofferError) r + :: forall r . + Member (Error CofferError) r => Member (Embed IO) r => FilePath -> Sem r () @@ -63,8 +61,9 @@ verifyPassStore storeDir = 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") + nodeExists (stringToPath $ storeDir "/.gpg-id") wrapper @@ -85,8 +84,7 @@ wrapper backend args input = do & setEnv [("PASSWORD_STORE_DIR", storeDir)] & readProcess - - + pbWriteSecret :: Effects r => PassBackend -> Entry -> Sem r () pbWriteSecret backend entry = do @@ -100,7 +98,7 @@ pbWriteSecret backend entry = do backend [ "insert" , "-mf" - , entry ^. E.path & P.entryPathAsPath & build & fmt + , entry ^. E.path & pretty ] (Just $ byteStringInput input) @@ -116,7 +114,7 @@ pbReadSecret backend path = do wrapper backend [ "show" - , path & P.entryPathAsPath & build & fmt + , pretty path ] Nothing @@ -125,24 +123,35 @@ pbReadSecret backend path = do pure $ T.decodeUtf8 (BS.toStrict stdout) ^? passTextPrism . E.entry ExitFailure 1 -> pure Nothing - ExitFailure _e -> + ExitFailure _i -> throw $ OtherError (T.decodeUtf8 $ BS.toStrict stderr) + pbListSecrets :: Effects r => PassBackend -> Path -> Sem r (Maybe [Text]) -pbListSecrets backend path = do +pbListSecrets backend path = runFsInIO 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) + 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 - pure $ contents <&> map (T.dropEnd 4 . T.pack) pbDeleteSecret :: Effects r => PassBackend -> EntryPath -> Sem r () @@ -152,7 +161,7 @@ pbDeleteSecret backend path = do backend [ "rm" , "-f" - , path & P.entryPathAsPath & build & fmt + , pretty path ] Nothing diff --git a/lib/Effect/Fs.hs b/lib/Effect/Fs.hs index 71efe8bb..8c39507a 100644 --- a/lib/Effect/Fs.hs +++ b/lib/Effect/Fs.hs @@ -2,7 +2,6 @@ -- -- SPDX-License-Identifier: MPL-2.0 -{-# LANGUAGE ImportQualifiedPost #-} module Effect.Fs ( FsEffect , nodeExists @@ -29,6 +28,7 @@ import Polysemy import Polysemy.Error import System.Directory hiding (listDirectory) import System.Directory qualified as D +import Data.Text (Text) type Node f d = Either (File f) (Directory d) type Node' a = Node a a @@ -43,7 +43,7 @@ data FsError = FENodeNotFound Path | FENodeExists (MismatchError (Node' Path)) | FEMissingParent (Node' Path) - | FEInvalidPath Path + | FEInvalidPath Text Path deriving stock (Show) data MismatchError a = MismatchError @@ -57,18 +57,12 @@ newtype NodeRec = NodeRec (Node Path [NodeRec]) pathToString :: Path -> Either FsError String pathToString path = case decodeUtf8' path of - Left a -> Left $ FEInvalidPath path + Left a -> Left $ FEInvalidPath (T.pack $ show a) path Right b -> Right $ T.unpack b + stringToPath :: String -> Path stringToPath = encodeUtf8 . T.pack -extractNodePath - :: Node' Path - -> Path -extractNodePath = - \case Left (File path) -> path - Right (Directory path) -> path - eitherError :: Member (Error e) r => (a -> e) @@ -77,9 +71,14 @@ eitherError eitherError f = either (throw . f) pure data FsEffect m a where + -- | Checks whether a 'Node' exists and retuns 'Just (Node' ())' or 'Nothing' + -- | if the node wasn't found. 'Node'' is either a 'Directory ()' or a + -- | 'File ()' according to what was found. NodeExists :: Path -> FsEffect m (Maybe (Node' ())) - GetNode :: Path -> FsEffect m (Maybe (Node' Path)) - ListDirectory :: Directory Path -> FsEffect m [Node' ByteString] + GetNode :: Path -> FsEffect m (Maybe (Node' ByteString)) + -- | Lists a directories contents, returns the path to each of its contents. + -- | If the directory is not found or it's a file, it returns a 'Nothing' + ListDirectory :: Directory Path -> FsEffect m (Maybe [Node' Path]) ListDirectoryRec :: Directory Path -> FsEffect m [NodeRec] -- ReadNode :: Node' Path -> FsEffect m (Node ByteString [ByteString]) -- CreateNode :: Node' Path -> FsEffect m (Node' ()) @@ -109,7 +108,7 @@ _nodeExists _nodeExists path = do stringPath <- eitherError - (const $ FEInvalidPath path) + (\unicodeError -> FEInvalidPath (T.pack $ show unicodeError) path) (decodeUtf8' path <&> T.unpack) file <- embed $ doesFileExist stringPath dir <- embed $ doesDirectoryExist stringPath @@ -134,18 +133,27 @@ _getNode path = do _listDirectory - :: ( Member (Error FsError) r + :: forall r. + ( Member (Error FsError) r , Member (Embed IO) r ) => Directory Path - -> Sem r [Node' ByteString] + -> Sem r (Maybe [Node' Path]) _listDirectory (Directory path) = do stringPath <- eitherError id (pathToString path) nodes <- embed $ D.listDirectory stringPath - mapM (_getNodeThrow . stringToPath) nodes - where - _getNodeThrow path = - _getNode path >>= maybe (throw $ FENodeNotFound path) pure + + _getNode path >>= + \case + Just _ -> mapM (_getNodeThrow . stringToPath) nodes <&> Just + _ -> pure Nothing + + where + _getNodeThrow + :: Path + -> Sem r (Node' Path) + _getNodeThrow path = + _getNode path >>= maybe (throw $ FENodeNotFound path) pure _listDirectoryRec :: ( Member (Error FsError) r @@ -153,11 +161,14 @@ _listDirectoryRec ) => Directory Path -> Sem r [NodeRec] -_listDirectoryRec dirPath = do - list <- _listDirectory dirPath - forM list $ \case Left f -> pure $ NodeRec $ Left f - Right d -> _listDirectoryRec d - <&> NodeRec . Right . Directory +_listDirectoryRec dirPath@(Directory path) = + _listDirectory dirPath >>= \case + Nothing -> throw $ FENodeNotFound path + Just nodes -> do + forM nodes $ \case + Left f -> pure $ NodeRec $ Left f + Right d -> + _listDirectoryRec d <&> NodeRec . Right . Directory -- _readNode -- :: Member (Error FsError) r diff --git a/lib/Entry/Pass.hs b/lib/Entry/Pass.hs index 9fb812e3..33afedce 100644 --- a/lib/Entry/Pass.hs +++ b/lib/Entry/Pass.hs @@ -51,178 +51,173 @@ makeLensesWith abbreviatedFields ''PassEntry passFieldPrism :: Prism' PassField (E.FieldKey, E.Field) passFieldPrism = prism' to from - where to :: (E.FieldKey, E.Field) -> PassField - to (fieldKey, field) = PassField - { pfKey = E.getFieldKey fieldKey - , pfDateModified = - T.pack . iso8601Show $ - field ^. E.dateModified - , pfVisibility = case field ^. E.visibility of - E.Public -> "public" - E.Private -> "private" - , pfValue = E.unFieldValue $ field ^. E.value - } - from :: PassField -> Maybe (E.FieldKey, E.Field) - from passField = do - let fieldValue = E.FieldValue $ passField ^. value - fieldKey <- passField ^. key & E.newFieldKey & eitherToMaybe - dateModified <- iso8601ParseM . T.unpack $ passField ^. dateModified - visibility <- case passField ^. visibility of - "public" -> Just E.Public - "private" -> Just E.Private - _ -> Nothing - - pure ( fieldKey - , E.newField dateModified fieldValue - & E.visibility .~ visibility - ) + where + to :: (E.FieldKey, E.Field) -> PassField + to (fieldKey, field) = PassField + { pfKey = E.getFieldKey fieldKey + , pfDateModified = + T.pack . iso8601Show $ + field ^. E.dateModified + , pfVisibility = case field ^. E.visibility of + E.Public -> "public" + E.Private -> "private" + , pfValue = E.unFieldValue $ field ^. E.value + } + from :: PassField -> Maybe (E.FieldKey, E.Field) + from passField = do + let fieldValue = E.FieldValue $ passField ^. value + fieldKey <- passField ^. key & E.newFieldKey & eitherToMaybe + dateModified <- iso8601ParseM . T.unpack $ passField ^. dateModified + visibility <- case passField ^. visibility of + "public" -> Just E.Public + "private" -> Just E.Private + _ -> Nothing + + pure ( fieldKey + , E.newField dateModified fieldValue + & E.visibility .~ visibility + ) instance E.EntryConvertible PassEntry where entry = prism' to from - where to :: E.Entry -> PassEntry - to entry = - PassEntry - { peMasterFieldKey = entry ^. E.masterField <&> E.getFieldKey - , peMasterFieldValue = - (entry ^. E.masterField) - >>= \fk -> entry ^. E.fields . at fk - <&> (E.unFieldValue . (^. E.value)) - , peDateModified = - T.pack . iso8601Show $ - entry ^. E.dateModified - , peFields = - map (^. re passFieldPrism) (entry ^. E.fields & HS.toList) - , peTags = entry ^. E.tags & S.toList & map E.getEntryTag - , pePath = entry ^. E.path & entryPathAsPath & build & fmt - } - from :: PassEntry -> Maybe E.Entry - from passEntry = do - let masterField = passEntry ^. masterFieldKey - dateModified <- passEntry ^. dateModified & iso8601ParseM . T.unpack - fields <- mapM (^? passFieldPrism) (passEntry ^. fields) - <&> HS.fromList - tags <- mapM (eitherToMaybe . E.newEntryTag) (passEntry ^. tags) - <&> S.fromList - entryPath <- eitherToMaybe . mkEntryPath $ passEntry ^. path - - pure $ E.newEntry entryPath dateModified - & E.fields .~ fields - & E.tags .~ tags - & E.masterField .~ (masterField >>= eitherToMaybe . E.newFieldKey) + where + to :: E.Entry -> PassEntry + to entry = + PassEntry + { peMasterFieldKey = entry ^. E.masterField <&> E.getFieldKey + , peMasterFieldValue = + (entry ^. E.masterField) + >>= \fieldKey -> entry ^. E.fields . at fieldKey + <&> (E.unFieldValue . (^. E.value)) + , peDateModified = + T.pack . iso8601Show $ + entry ^. E.dateModified + , peFields = + map (^. re passFieldPrism) (entry ^. E.fields & HS.toList) + , peTags = entry ^. E.tags & S.toList & map E.getEntryTag + , pePath = pretty $ entry ^. E.path + } + from :: PassEntry -> Maybe E.Entry + from passEntry = do + let masterField = passEntry ^. masterFieldKey + dateModified <- passEntry ^. dateModified & iso8601ParseM . T.unpack + fields <- mapM (^? passFieldPrism) (passEntry ^. fields) + <&> HS.fromList + tags <- mapM (eitherToMaybe . E.newEntryTag) (passEntry ^. tags) + <&> S.fromList + entryPath <- eitherToMaybe . mkEntryPath $ passEntry ^. path + + pure $ E.newEntry entryPath dateModified + & E.fields .~ fields + & E.tags .~ tags + & E.masterField .~ (masterField >>= eitherToMaybe . E.newFieldKey) instance E.EntryConvertible PassKv where entry = prism' to from - where to :: E.Entry -> PassKv - to entry = - let passEntry = entry ^. re E.entry :: PassEntry - masterValue = passEntry ^. masterFieldValue - in PassKv masterValue . onlyJust $ - concat (flip map (passEntry ^. fields) - \field -> - map Just - [ (field ^. key, field ^. value) - , ("#$" <> field ^. key <> ".DATE_MODIFIED", field ^. dateModified) - , ("#$" <> field ^. key <> ".VISIBILITY", field ^. visibility) - ]) - <> - [ Just ("#$DATE_MODIFIED", passEntry ^. dateModified) - , Just ("#$TAGS", T.intercalate "," (passEntry ^. tags)) - , Just ("#$PATH", passEntry ^. path) - ] - - onlyJust :: [Maybe a] -> [a] - onlyJust = unsafeOnlyJust . filter isJust - unsafeOnlyJust :: [Maybe a] -> [a] - unsafeOnlyJust = map $ - \case Just a -> a - Nothing -> undefined - isJust :: Maybe a -> Bool - isJust = \case Just _ -> True - Nothing -> False - - from :: PassKv -> Maybe E.Entry - from (PassKv masterValue passKv) = do - let hs = HS.fromList passKv - fhs = HS.fromList $ map (\(a, b) -> (b, a)) passKv - utcUnixEpoch = iso8601Show $ - UTCTime - { utctDay = YearDay 0 0 - , utctDayTime = secondsToDiffTime 0 - } - masterKey = masterValue >>= \a -> fhs ^. at a - dateModified = fromMaybe - (T.pack utcUnixEpoch) - (hs ^. at "#$DATE_MODIFIED") - tags = fromMaybe - [] - (hs ^. at "#$TAGS" - <&> T.split (== ',') - <&> filter (/= "")) - fields = hs - & HS.filterWithKey (\k _v -> T.take 2 k /= "#$") - & HS.mapKeys (T.split (== '.')) - & HS.filterWithKey (\k _v -> length k == 1) - & HS.mapKeys head - & HS.toList - & mapM \(k, v) -> - PassField k - <$> hs ^. at ("#$" <> k <> ".DATE_MODIFIED") - <*> hs ^. at ("#$" <> k <> ".VISIBILITY") - <*> pure v - entryPath = hs ^. at "#$PATH" - - - - guard (isNothing masterValue == isNothing masterKey) - - PassEntry - masterKey - masterValue - dateModified - <$> fields - <*> pure tags - <*> entryPath - >>= (^? E.entry) + where + to :: E.Entry -> PassKv + to entry = + let passEntry = entry ^. re E.entry :: PassEntry + masterValue = passEntry ^. masterFieldValue + in PassKv masterValue . catMaybes $ + concat (flip map (passEntry ^. fields) + \field -> + map Just + [ (field ^. key, field ^. value) + , ("#$" <> field ^. key <> ".DATE_MODIFIED", field ^. dateModified) + , ("#$" <> field ^. key <> ".VISIBILITY", field ^. visibility) + ]) + <> + [ Just ("#$DATE_MODIFIED", passEntry ^. dateModified) + , Just ("#$TAGS", T.intercalate "," (passEntry ^. tags)) + , Just ("#$PATH", passEntry ^. path) + ] + + from :: PassKv -> Maybe E.Entry + from (PassKv masterValue passKv) = do + let hs = HS.fromList passKv + fhs = HS.fromList $ map (\(a, b) -> (b, a)) passKv + utcUnixEpoch = iso8601Show $ + UTCTime + { utctDay = YearDay 0 0 + , utctDayTime = secondsToDiffTime 0 + } + masterKey = masterValue >>= \val -> fhs ^. at val + dateModified = fromMaybe + (T.pack utcUnixEpoch) + (hs ^. at "#$DATE_MODIFIED") + tags = fromMaybe + [] + (hs ^. at "#$TAGS" + <&> T.split (== ',') + <&> filter (/= "")) + fields = hs + & HS.filterWithKey (\k _v -> T.take 2 k /= "#$") + & HS.mapKeys (T.split (== '.')) + & HS.filterWithKey (\k _v -> length k == 1) + & HS.mapKeys head + & HS.toList + & mapM \(k, v) -> + PassField k + <$> hs ^. at ("#$" <> k <> ".DATE_MODIFIED") + <*> hs ^. at ("#$" <> k <> ".VISIBILITY") + <*> pure v + entryPath = hs ^. at "#$PATH" + + + + guard (isNothing masterValue == isNothing masterKey) + + PassEntry + masterKey + masterValue + dateModified + <$> fields + <*> pure tags + <*> entryPath + >>= (^? E.entry) type Parser = Parsec Void Text passTextPrism :: Prism' Text PassKv passTextPrism = prism' to from - where to :: PassKv -> Text - to (PassKv masterValue hs) = - fromMaybe "" masterValue - <> "\n\n" - <> - (map (\(k, v) -> k <> "=" <> v) hs - & T.intercalate "\n") - - from :: Text -> Maybe PassKv - from text = parseMaybe parser text - where parseLine - :: Maybe String - -> Parser Text - parseLine label = - do - x <- takeWhileP label (/='\n') - try newline - pure x - - parsePair - :: Parser (Text, Text) - parsePair = do - key <- takeWhileP (Just "key") (/='=') - char '=' - value <- takeWhileP (Just "value") (/='\n') - char '\n' <|> pure '\n' - pure (key, value) - - parser :: Parser PassKv - parser = do - masterValue <- parseLine (Just "character") - <&> \case "" -> Nothing - a -> Just a - takeWhileP (Just "empty line") (=='\n') - - pairs <- many parsePair - eof - pure (PassKv masterValue pairs) + where + to :: PassKv -> Text + to (PassKv masterValue hs) = + fromMaybe "" masterValue + <> "\n\n" + <> + (map (\(k, v) -> k <> "=" <> v) hs + & T.intercalate "\n") + + from :: Text -> Maybe PassKv + from text = parseMaybe parser text + where + parseLine + :: Maybe String + -> Parser Text + parseLine label = + do + x <- takeWhileP label (/='\n') + try newline + pure x + + parsePair + :: Parser (Text, Text) + parsePair = do + key <- takeWhileP (Just "key") (/='=') + char '=' + value <- takeWhileP (Just "value") (/='\n') + char '\n' <|> pure '\n' + pure (key, value) + + parser :: Parser PassKv + parser = do + masterValue <- parseLine (Just "character") + <&> \case "" -> Nothing + a -> Just a + takeWhileP (Just "empty line") (=='\n') + + pairs <- many parsePair + eof + pure (PassKv masterValue pairs)