From 304691fc2702d46080b6c70ec5e5e94d9f741036 Mon Sep 17 00:00:00 2001 From: Magic_RB Date: Tue, 5 Apr 2022 21:08:24 +0200 Subject: [PATCH] WIP Signed-off-by: Magic_RB --- coffer.cabal | 8 ++ config.toml | 12 +-- lib/Backend/Debug.hs | 121 +++++++++++++++++++++++ lib/Backend/Pass.hs | 170 ++++++++++++++++++++++++++++++++ lib/Backends.hs | 24 +---- lib/Config.hs | 27 ++++- lib/Effect/Fs.hs | 173 ++++++++++++++++++++++++++++++++ lib/Entry/Pass.hs | 228 +++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 734 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/lib/Backend/Debug.hs b/lib/Backend/Debug.hs new file mode 100644 index 00000000..420a3ec8 --- /dev/null +++ b/lib/Backend/Debug.hs @@ -0,0 +1,121 @@ +-- 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..26ba0935 --- /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 qualified as BS +import Data.Maybe +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 +import Data.Text (Text) +import Data.ByteString.Lazy (ByteString) + +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..9737986a --- /dev/null +++ b/lib/Effect/Fs.hs @@ -0,0 +1,173 @@ +-- 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 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 +import Control.Monad (forM) + +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 + { fePath :: Path + } + | FENodeExists + { feWanted :: Node' Path + , feFound :: Node' Path + } + | FEMissingParent + { feNode :: Node' Path + } + | FEInvalidPath + { fePode :: Path + } + 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..9e75a07d --- /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.HashMap.Lazy qualified as HS +import Data.Maybe +import Data.Set qualified as S +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 +import Data.Text (Text) +import Data.Either.Extra (eitherToMaybe) + +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)