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