| 1 | -- | SQLite storage: one file, WAL mode, one connection shared behind a |
| 2 | -- lock. SQLite runs one writer at a time anyway, and a TodoMVC request |
| 3 | -- is a handful of indexed statements, so a pool would buy nothing. |
| 4 | module Todo.Db |
| 5 | ( Db |
| 6 | , open |
| 7 | , close |
| 8 | , findList |
| 9 | , createList |
| 10 | , listTodos |
| 11 | , addTodo |
| 12 | , toggleTodo |
| 13 | , renameTodo |
| 14 | , deleteTodo |
| 15 | , toggleAll |
| 16 | , clearCompleted |
| 17 | ) where |
| 18 | |
| 19 | import Control.Concurrent.MVar |
| 20 | import Control.Monad (forM_) |
| 21 | import Data.Text (Text) |
| 22 | import Data.Text qualified as T |
| 23 | import Database.SQLite.Simple (Connection, Only (..), Query (..), execute, execute_, query, query_, withTransaction) |
| 24 | import Database.SQLite.Simple qualified as SQL |
| 25 | import Todo.Model |
| 26 | |
| 27 | newtype Db = Db (MVar Connection) |
| 28 | |
| 29 | -- | Opens (creating if needed) the database and brings its schema up to |
| 30 | -- date. |
| 31 | open :: FilePath -> IO Db |
| 32 | open path = do |
| 33 | conn <- SQL.open path |
| 34 | -- journal_mode answers with a row, so it goes through query_. |
| 35 | _ <- query_ conn "PRAGMA journal_mode = WAL" :: IO [Only Text] |
| 36 | execute_ conn "PRAGMA synchronous = NORMAL" |
| 37 | execute_ conn "PRAGMA foreign_keys = ON" |
| 38 | execute_ conn "PRAGMA busy_timeout = 5000" |
| 39 | migrate conn |
| 40 | Db <$> newMVar conn |
| 41 | |
| 42 | -- | Folds the WAL back into the main file and closes the connection. |
| 43 | close :: Db -> IO () |
| 44 | close (Db var) = withMVar var $ \conn -> do |
| 45 | _ <- query_ conn "PRAGMA wal_checkpoint(TRUNCATE)" :: IO [(Int, Int, Int)] |
| 46 | SQL.close conn |
| 47 | |
| 48 | -- | The schema's history. Each entry runs once, in order, and the number |
| 49 | -- applied is kept in @user_version@. Entries are only ever appended, and |
| 50 | -- they only ever add: no drops, no rewrites. |
| 51 | migrations :: [[Query]] |
| 52 | migrations = |
| 53 | [ [ "CREATE TABLE lists (\ |
| 54 | \ id INTEGER PRIMARY KEY,\ |
| 55 | \ token TEXT NOT NULL UNIQUE,\ |
| 56 | \ created_at TEXT NOT NULL DEFAULT (strftime('%Y-%m-%dT%H:%M:%fZ', 'now')))" |
| 57 | , "CREATE TABLE todos (\ |
| 58 | \ id INTEGER PRIMARY KEY,\ |
| 59 | \ list_id INTEGER NOT NULL REFERENCES lists (id),\ |
| 60 | \ title TEXT NOT NULL,\ |
| 61 | \ completed INTEGER NOT NULL DEFAULT 0,\ |
| 62 | \ created_at TEXT NOT NULL DEFAULT (strftime('%Y-%m-%dT%H:%M:%fZ', 'now')))" |
| 63 | , "CREATE INDEX todos_by_list ON todos (list_id, id)" |
| 64 | ] |
| 65 | ] |
| 66 | |
| 67 | migrate :: Connection -> IO () |
| 68 | migrate conn = do |
| 69 | applied <- query_ conn "PRAGMA user_version" |
| 70 | let done = case applied of |
| 71 | [Only n] -> n |
| 72 | _ -> 0 |
| 73 | forM_ (drop done (zip [1 :: Int ..] migrations)) $ \(n, statements) -> |
| 74 | withTransaction conn $ do |
| 75 | mapM_ (execute_ conn) statements |
| 76 | -- PRAGMA takes no parameters, so the number is written in. |
| 77 | execute_ conn (Query ("PRAGMA user_version = " <> T.pack (show n))) |
| 78 | |
| 79 | with :: Db -> (Connection -> IO a) -> IO a |
| 80 | with (Db var) = withMVar var |
| 81 | |
| 82 | findList :: Db -> Text -> IO (Maybe ListId) |
| 83 | findList db token = with db $ \conn -> do |
| 84 | rows <- query conn "SELECT id FROM lists WHERE token = ?" (Only token) |
| 85 | pure $ case rows of |
| 86 | [Only n] -> Just (ListId n) |
| 87 | _ -> Nothing |
| 88 | |
| 89 | createList :: Db -> Text -> IO ListId |
| 90 | createList db token = with db $ \conn -> do |
| 91 | execute conn "INSERT INTO lists (token) VALUES (?)" (Only token) |
| 92 | ListId <$> SQL.lastInsertRowId conn |
| 93 | |
| 94 | listTodos :: Db -> ListId -> IO [Todo] |
| 95 | listTodos db (ListId list) = with db $ \conn -> do |
| 96 | rows <- query conn "SELECT id, title, completed FROM todos WHERE list_id = ? ORDER BY id" (Only list) |
| 97 | pure [Todo (TodoId i) t c | (i, t, c) <- rows] |
| 98 | |
| 99 | addTodo :: Db -> ListId -> Text -> IO () |
| 100 | addTodo db (ListId list) title = with db $ \conn -> |
| 101 | execute conn "INSERT INTO todos (list_id, title) VALUES (?, ?)" (list, title) |
| 102 | |
| 103 | -- The functions that change one todo answer whether it was in that list. |
| 104 | |
| 105 | toggleTodo :: Db -> ListId -> TodoId -> IO Bool |
| 106 | toggleTodo db (ListId list) (TodoId todo) = with db $ \conn -> do |
| 107 | execute conn "UPDATE todos SET completed = NOT completed WHERE id = ? AND list_id = ?" (todo, list) |
| 108 | changed conn |
| 109 | |
| 110 | renameTodo :: Db -> ListId -> TodoId -> Text -> IO Bool |
| 111 | renameTodo db (ListId list) (TodoId todo) title = with db $ \conn -> do |
| 112 | execute conn "UPDATE todos SET title = ? WHERE id = ? AND list_id = ?" (title, todo, list) |
| 113 | changed conn |
| 114 | |
| 115 | deleteTodo :: Db -> ListId -> TodoId -> IO Bool |
| 116 | deleteTodo db (ListId list) (TodoId todo) = with db $ \conn -> do |
| 117 | execute conn "DELETE FROM todos WHERE id = ? AND list_id = ?" (todo, list) |
| 118 | changed conn |
| 119 | |
| 120 | changed :: Connection -> IO Bool |
| 121 | changed conn = (> 0) <$> SQL.changes conn |
| 122 | |
| 123 | -- | Completes everything, unless everything already is, in which case it |
| 124 | -- makes everything active again. |
| 125 | toggleAll :: Db -> ListId -> IO () |
| 126 | toggleAll db (ListId list) = with db $ \conn -> withTransaction conn $ do |
| 127 | rows <- query conn "SELECT EXISTS (SELECT 1 FROM todos WHERE list_id = ? AND NOT completed)" (Only list) |
| 128 | let anyActive = case rows of |
| 129 | [Only b] -> b |
| 130 | _ -> False |
| 131 | execute conn "UPDATE todos SET completed = ? WHERE list_id = ?" (anyActive, list) |
| 132 | |
| 133 | clearCompleted :: Db -> ListId -> IO () |
| 134 | clearCompleted db (ListId list) = with db $ \conn -> |
| 135 | execute conn "DELETE FROM todos WHERE list_id = ? AND completed" (Only list) |
| 136 | |
amadan