ghc-9.6.6; sqlite: fixed sqlite text/blob json wtf

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
+  withState $ select @(Only Text) sql bound
-        <&> fmap (Aeson.decode @Fixme . fromOnly)
+        <&> 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))
+    lift (withState $ select @(Only Text) sql (Only key))
-      <&> fmap (Aeson.decode @Fixme . fromOnly)
+      <&> fmap (sqliteToAeson . fromOnly)
       <&> catMaybes
       <&> headMay
       >>= toMPlus

flake.lock

@@ -26,16 +26,15 @@
         ]
       },
       "locked": {
-        "lastModified": 1713359411,
+        "lastModified": 1727252661,
-        "narHash": "sha256-BzOZ6xU+Li5nIe71Wy4p+lOEQlYK/e94T0gBcP8IKgE=",
+        "narHash": "sha256-8vmgF0Atw+m7a+2Wmlnwjjyw8nSYv0QMT+zN9R3DljQ=",
-        "ref": "generic-sql",
+        "ref": "refs/heads/master",
-        "rev": "03635c54b2e2bd809ec1196bc9082447279f6f24",
+        "rev": "8b614540a7f30f0227cb18ef2ad4c8d84db4a75c",
         "revCount": 9,
         "type": "git",
         "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
       },
       "original": {
-        "ref": "generic-sql",
         "type": "git",
         "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
       }

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";
 

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 <- getDefaultKeyPath conf
-  path <- [ p
-          | ListVal [SymbolVal "default-key-path", StringLike p] <- conf
-          ] & headMay & orThrowUser "default-key-path not set"
-
   creds <- newCredentialsEnc @'HBS2Basic n
 
   let s = show $ pretty $ AsCredFile (AsBase58 creds)
@@ -56,4 +52,3 @@ keymanNewCredentials suff n = do
   keymanUpdate
 
   pure psk
-

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 ]
+      path <- getDefaultKeyPath conf
-      mkdir path
       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)
-

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"
-

hbs2-keyman/hbs2-keyman/Main.hs

@@ -205,8 +205,9 @@ updateKeys = do
         pure ()
 
     updateLocalKeys prune = do
-
+      conf <- getConf
-      masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList
+      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
-
-