never executed always true always false

    1 module PureClaw.Memory.SQLite
    2   ( -- * Construction
    3     mkSQLiteMemoryHandle
    4   , withSQLiteMemory
    5   ) where
    6 
    7 import Data.IORef
    8 import Data.Map.Strict qualified as Map
    9 import Data.Text (Text)
   10 import Data.Text qualified as T
   11 import Data.Time
   12 import Database.SQLite.Simple
   13 
   14 import PureClaw.Core.Types
   15 import PureClaw.Handles.Memory
   16 
   17 -- | Create a SQLite-backed memory handle. Opens the database at the
   18 -- given path and creates the schema if needed.
   19 mkSQLiteMemoryHandle :: FilePath -> IO MemoryHandle
   20 mkSQLiteMemoryHandle dbPath = do
   21   conn <- open dbPath
   22   initSchema conn
   23   counterRef <- newIORef (0 :: Int)
   24   pure MemoryHandle
   25     { _mh_search = searchMemories conn
   26     , _mh_save   = saveMemory conn counterRef
   27     , _mh_recall = recallMemory conn
   28     }
   29 
   30 -- | Convenience: open a SQLite memory handle, run an action, then close.
   31 withSQLiteMemory :: FilePath -> (MemoryHandle -> IO a) -> IO a
   32 withSQLiteMemory dbPath action = do
   33   mh <- mkSQLiteMemoryHandle dbPath
   34   action mh
   35 
   36 -- | Initialize the database schema.
   37 initSchema :: Connection -> IO ()
   38 initSchema conn = execute_ conn
   39   "CREATE TABLE IF NOT EXISTS memories (\
   40   \  id TEXT PRIMARY KEY,\
   41   \  content TEXT NOT NULL,\
   42   \  metadata TEXT NOT NULL DEFAULT '{}',\
   43   \  created_at TEXT NOT NULL\
   44   \)"
   45 
   46 -- | Save a memory entry.
   47 saveMemory :: Connection -> IORef Int -> MemorySource -> IO (Maybe MemoryId)
   48 saveMemory conn counterRef source = do
   49   n <- atomicModifyIORef' counterRef (\i -> (i + 1, i + 1))
   50   now <- getCurrentTime
   51   let mid = MemoryId (T.pack ("mem-" <> show n))
   52       ts = T.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" now)
   53       metaText = renderMetadata (_ms_metadata source)
   54   execute conn
   55     "INSERT INTO memories (id, content, metadata, created_at) VALUES (?, ?, ?, ?)"
   56     (unMemoryId mid, _ms_content source, metaText, ts)
   57   pure (Just mid)
   58 
   59 -- | Search memories using LIKE (case-insensitive substring match).
   60 -- SQLite FTS5 would be better for production, but LIKE is sufficient
   61 -- to get the interface working.
   62 searchMemories :: Connection -> Text -> SearchConfig -> IO [SearchResult]
   63 searchMemories conn queryText config = do
   64   rows <- query conn
   65     "SELECT id, content FROM memories WHERE content LIKE ? LIMIT ?"
   66     ("%" <> queryText <> "%" :: Text, _sc_maxResults config)
   67   pure [ SearchResult (MemoryId mid) content 1.0
   68        | (mid, content) <- rows :: [(Text, Text)]
   69        ]
   70 
   71 -- | Recall a specific memory by ID.
   72 recallMemory :: Connection -> MemoryId -> IO (Maybe MemoryEntry)
   73 recallMemory conn mid = do
   74   rows <- query conn
   75     "SELECT content, metadata, created_at FROM memories WHERE id = ?"
   76     (Only (unMemoryId mid))
   77   case rows of
   78     [] -> pure Nothing
   79     ((content, metaText, tsText) : _) ->
   80       pure $ Just MemoryEntry
   81         { _me_memoryId  = mid
   82         , _me_content   = content
   83         , _me_metadata  = parseMetadata metaText
   84         , _me_createdAt = parseTimestamp tsText
   85         }
   86 
   87 -- | Render metadata map as a simple key=value text.
   88 renderMetadata :: Map.Map Text Text -> Text
   89 renderMetadata m = T.intercalate ";" [ k <> "=" <> v | (k, v) <- Map.toList m ]
   90 
   91 -- | Parse metadata from key=value text.
   92 parseMetadata :: Text -> Map.Map Text Text
   93 parseMetadata t
   94   | T.null t = Map.empty
   95   | otherwise = Map.fromList
   96       [ (k, v)
   97       | pair <- T.splitOn ";" t
   98       , let (k, rawV) = T.breakOn "=" pair
   99       , not (T.null rawV)
  100       , let v = T.drop 1 rawV
  101       ]
  102 
  103 -- | Parse a timestamp, with a fallback.
  104 parseTimestamp :: Text -> UTCTime
  105 parseTimestamp t =
  106   case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (T.unpack t) of
  107     Just ts -> ts
  108     Nothing -> UTCTime (fromGregorian 2000 1 1) 0