From 981a4e587a82614b2ea1d6c39c4365dd7ee893e0 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 25 Sep 2024 12:54:06 +0300 Subject: [PATCH] ghc-9.6.6; sqlite: fixed sqlite text/blob json wtf --- fixme-new/lib/Fixme/State.hs | 16 +++++---- flake.lock | 9 +++-- flake.nix | 2 +- hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs | 9 ++--- hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs | 5 ++- .../HBS2/KeyMan/Config.hs | 33 +++++++++++++++++-- hbs2-keyman/hbs2-keyman/Main.hs | 7 ++-- 7 files changed, 53 insertions(+), 28 deletions(-) diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index b5719fd1..737ce8b4 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -40,6 +40,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.HashMap.Strict qualified as HM import Text.InterpolatedString.Perl6 (q,qc) import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text import Data.Maybe import Data.List qualified as List import Data.Either @@ -310,6 +311,9 @@ selectFixmeKey s = do <&> headMay +sqliteToAeson :: FromJSON a => Text -> Maybe a +sqliteToAeson = Aeson.decode . LBS.fromStrict . Text.encodeUtf8 + listFixme :: (FixmePerks m, MonadReader FixmeEnv m, HasPredicate q) => q -> m [Fixme] @@ -321,7 +325,7 @@ listFixme expr = do let sql = [qc| with s1 as ( - select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as blob) as blob + select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob from object o group by o.o ) @@ -336,15 +340,15 @@ listFixme expr = do debug $ pretty sql - withState $ select @(Only LBS.ByteString) sql bound - <&> fmap (Aeson.decode @Fixme . fromOnly) + withState $ select @(Only Text) sql bound + <&> fmap (sqliteToAeson . fromOnly) <&> catMaybes getFixme :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeKey -> m (Maybe Fixme) getFixme key = do let sql = [qc| - select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as blob) as blob + select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob from object o where o.o = ? group by o.o @@ -353,8 +357,8 @@ getFixme key = do runMaybeT do - lift (withState $ select @(Only LBS.ByteString) sql (Only key)) - <&> fmap (Aeson.decode @Fixme . fromOnly) + lift (withState $ select @(Only Text) sql (Only key)) + <&> fmap (sqliteToAeson . fromOnly) <&> catMaybes <&> headMay >>= toMPlus diff --git a/flake.lock b/flake.lock index 09804e7c..777ca7b7 100644 --- a/flake.lock +++ b/flake.lock @@ -26,16 +26,15 @@ ] }, "locked": { - "lastModified": 1713359411, - "narHash": "sha256-BzOZ6xU+Li5nIe71Wy4p+lOEQlYK/e94T0gBcP8IKgE=", - "ref": "generic-sql", - "rev": "03635c54b2e2bd809ec1196bc9082447279f6f24", + "lastModified": 1727252661, + "narHash": "sha256-8vmgF0Atw+m7a+2Wmlnwjjyw8nSYv0QMT+zN9R3DljQ=", + "ref": "refs/heads/master", + "rev": "8b614540a7f30f0227cb18ef2ad4c8d84db4a75c", "revCount": 9, "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" }, "original": { - "ref": "generic-sql", "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" } diff --git a/flake.nix b/flake.nix index aa72c8c4..df5dd018 100644 --- a/flake.nix +++ b/flake.nix @@ -16,7 +16,7 @@ inputs = { suckless-conf.inputs.fuzzy.follows = "fuzzy"; suckless-conf.inputs.haskell-flake-utils.follows = "haskell-flake-utils"; - db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft?ref=generic-sql"; + db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"; db-pipe.inputs.nixpkgs.follows = "nixpkgs"; db-pipe.inputs.haskell-flake-utils.follows = "haskell-flake-utils"; diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs index 79395988..6ab6dd36 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs @@ -7,6 +7,7 @@ import HBS2.Hash import HBS2.System.Dir import HBS2.Net.Auth.Credentials +import HBS2.KeyMan.Config (getDefaultKeyPath) import HBS2.KeyMan.Keys.Direct import HBS2.KeyMan.State import HBS2.KeyMan.App.Types @@ -20,7 +21,6 @@ import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) - keymanGetConfig :: (IsContext c, MonadUnliftIO m) => m [Syntax c] keymanGetConfig = do (_,lbs,_) <- readProcess (shell [qc|hbs2-keyman config|] & setStderr closed) @@ -38,11 +38,7 @@ keymanUpdate = do keymanNewCredentials :: MonadUnliftIO m => Maybe String -> Int -> m (PubKey 'Sign 'HBS2Basic) keymanNewCredentials suff n = do conf <- keymanGetConfig @C - - path <- [ p - | ListVal [SymbolVal "default-key-path", StringLike p] <- conf - ] & headMay & orThrowUser "default-key-path not set" - + path <- getDefaultKeyPath conf creds <- newCredentialsEnc @'HBS2Basic n let s = show $ pretty $ AsCredFile (AsBase58 creds) @@ -56,4 +52,3 @@ keymanNewCredentials suff n = do keymanUpdate pure psk - diff --git a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs index 68846f19..f0f371b4 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs @@ -10,6 +10,7 @@ import HBS2.CLI.Run.Internal.KeyMan import HBS2.Hash import HBS2.System.Dir +import HBS2.KeyMan.Config (getDefaultKeyPath) import HBS2.KeyMan.Keys.Direct import HBS2.KeyMan.State import HBS2.KeyMan.App.Types @@ -40,8 +41,7 @@ keymanEntries = do entry $ bindMatch "hbs2:keyman:keys:add" $ \case [ LitStrVal ke ] -> do conf <- keymanGetConfig @C - let path = head [ s | ListVal [ SymbolVal "default-key-path", StringLike s ] <- conf ] - mkdir path + path <- getDefaultKeyPath conf let n = hashObject @HbSync (serialise ke) & pretty & show let fname = n `addExtension` ".key" let fpath = path fname @@ -50,4 +50,3 @@ keymanEntries = do pure $ mkStr fpath _ -> throwIO (BadFormException @C nil) - diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Config.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Config.hs index c2089ef1..ae57cb45 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Config.hs +++ b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Config.hs @@ -1,6 +1,9 @@ module HBS2.KeyMan.Config ( keymanAppName , getConfigPath + , getDefaultKeyPath + , getDefaultKeyPath0 + , getDefaultKeyMask , getStatePath , readConfig , KeyFilesOpt @@ -16,7 +19,9 @@ import System.FilePath import Control.Exception import Data.Text.IO qualified as Text import Data.Either +import Data.Maybe import Data.Set (Set) +import HBS2.System.Dir (mkdir) data KeyFilesOpt @@ -27,6 +32,32 @@ keymanAppName = "hbs2-keyman" getConfigPath :: MonadIO m => m FilePath getConfigPath = liftIO (getXdgDirectory XdgConfig keymanAppName) <&> ( "config") +getDefaultKeyPath0 :: MonadIO m => m FilePath +getDefaultKeyPath0 = do + -- TODO: Use xdg path? + homeDirectory <- liftIO $ getHomeDirectory + let defaultDirectory = homeDirectory ("." <> keymanAppName) "keys" + pure defaultDirectory + +getDefaultKeyPath :: MonadIO m => [Syntax C] -> m FilePath +getDefaultKeyPath config = do + defaultDirectory <- getDefaultKeyPath0 + let path = [ p + | ListVal [SymbolVal "default-key-path", StringLike p] <- config + ] & headMay & fromMaybe defaultDirectory + + mkdir path + return path + +getDefaultKeyMask :: MonadIO m => [Syntax C] -> m String +getDefaultKeyMask config = do + path <- getDefaultKeyPath config + let mask = [ p + | ListVal [SymbolVal "default-key-mask", StringLike p] <- config + ] & headMay & fromMaybe "**/*.key" + + return $ path mask + getStatePath :: MonadIO m => m FilePath getStatePath = liftIO (getXdgDirectory XdgData keymanAppName) <&> ( "state.db") @@ -38,7 +69,5 @@ readConfig = do <&> parseTop <&> fromRight mempty - instance HasCfgKey KeyFilesOpt (Set String) where key = "key-files" - diff --git a/hbs2-keyman/hbs2-keyman/Main.hs b/hbs2-keyman/hbs2-keyman/Main.hs index bacad32b..2c269a01 100644 --- a/hbs2-keyman/hbs2-keyman/Main.hs +++ b/hbs2-keyman/hbs2-keyman/Main.hs @@ -205,8 +205,9 @@ updateKeys = do pure () updateLocalKeys prune = do - - masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList + conf <- getConf + defaultMask <- getDefaultKeyMask conf + masks <- cfgValue @KeyFilesOpt @(Set String) <&> (Set.toList . Set.insert defaultMask) files <- KeyRing.findFilesBy masks when prune do @@ -260,5 +261,3 @@ main :: IO () main = do (_, action) <- execParser opts runApp action - -