165 lines
3.8 KiB
Haskell
165 lines
3.8 KiB
Haskell
-- | Database interaction
|
|
module DB where
|
|
|
|
import GHC.Stack (HasCallStack)
|
|
import Data.Text qualified as T
|
|
import Database.Sqlite.Easy qualified as DB
|
|
import Text.RawString.QQ
|
|
import Fedi
|
|
|
|
-----------------------
|
|
-- * Database handler API
|
|
|
|
data DB
|
|
= DB
|
|
{ getNotes :: IO [Note]
|
|
, insertNote :: NoteEntry -> IO ()
|
|
}
|
|
|
|
-- * Data types
|
|
|
|
data NoteEntry
|
|
= NoteEntry
|
|
{ inReplyTo :: Maybe Url
|
|
, content :: T.Text
|
|
, name :: Maybe String
|
|
, url :: Maybe Url
|
|
}
|
|
|
|
-----------------------
|
|
-- * Handler smart constructor
|
|
|
|
mkDB :: DB.ConnectionString -> UserDetails -> IO DB
|
|
mkDB connstr details = do
|
|
pool <- DB.createSqlitePool connstr
|
|
DB.withPool pool runMigrations
|
|
pure DB
|
|
{ getNotes =
|
|
DB.withPool pool (getNotesFromDb $ actorUrl details)
|
|
, insertNote =
|
|
\note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
|
|
}
|
|
|
|
-----------------------
|
|
-- * Database migrations
|
|
|
|
runMigrations :: HasCallStack => DB.SQLite ()
|
|
runMigrations = DB.migrate migrations migrateUp migrateDown
|
|
|
|
migrations :: [DB.MigrationName]
|
|
migrations =
|
|
[ "note"
|
|
]
|
|
|
|
migrateUp :: HasCallStack => DB.MigrationName -> DB.SQLite ()
|
|
migrateUp = \case
|
|
"note" -> do
|
|
[] <- DB.run
|
|
[r| create table note(
|
|
id integer primary key autoincrement,
|
|
published datetime default (datetime('now')),
|
|
actor text not null,
|
|
content text not null,
|
|
name text,
|
|
inReplyTo text,
|
|
url text
|
|
)
|
|
|]
|
|
|
|
pure ()
|
|
|
|
name -> error $ "unexpected migration: " <> show name
|
|
|
|
migrateDown :: HasCallStack => DB.MigrationName -> DB.SQLite ()
|
|
migrateDown = \case
|
|
"notes" -> do
|
|
[] <- DB.run "DROP TABLE note"
|
|
pure ()
|
|
name -> error $ "unexpected migration: " <> show name
|
|
|
|
-----------------------
|
|
-- * Database actions
|
|
|
|
getNotesFromDb :: Url -> DB.SQLite [Note]
|
|
getNotesFromDb url =
|
|
map decodeNoteRow <$> uncurry DB.runWith (getNotesSQL url)
|
|
|
|
insertNoteToDb :: Url -> NoteEntry -> DB.SQLite ()
|
|
insertNoteToDb actor note = do
|
|
_ <- uncurry DB.runWith (insertNoteSQL actor note)
|
|
pure ()
|
|
|
|
-- ** SQL
|
|
|
|
getNotesSQL :: Url -> (DB.SQL, [DB.SQLData])
|
|
getNotesSQL url =
|
|
( [r|
|
|
SELECT
|
|
? || '/notes/' || id,
|
|
published,
|
|
actor,
|
|
content,
|
|
name,
|
|
inReplyTo,
|
|
url
|
|
FROM note
|
|
ORDER BY published DESC
|
|
|]
|
|
, [DB.SQLText $ T.pack url]
|
|
)
|
|
|
|
insertNoteSQL :: Url -> NoteEntry -> (DB.SQL, [DB.SQLData])
|
|
insertNoteSQL actor note =
|
|
( [r|
|
|
INSERT INTO note(actor, inReplyTo, content, name, url)
|
|
VALUES (?, ?, ?, ?, ?)
|
|
|]
|
|
, [ DB.SQLText (T.pack actor)
|
|
, toNullableString note.inReplyTo
|
|
, DB.SQLText note.content
|
|
, toNullableString note.name
|
|
, toNullableString note.url
|
|
]
|
|
)
|
|
|
|
-----------------------
|
|
-- ** Decode row
|
|
|
|
decodeNoteRow :: [DB.SQLData] -> Note
|
|
decodeNoteRow = \case
|
|
[ DB.SQLText noteid,
|
|
DB.SQLText published,
|
|
DB.SQLText actor,
|
|
DB.SQLText content,
|
|
nullableString -> Just name,
|
|
nullableString -> Just inReplyTo,
|
|
nullableString -> Just url
|
|
] ->
|
|
Note
|
|
{ id = T.unpack noteid
|
|
, published = read (T.unpack published)
|
|
, actor = T.unpack actor
|
|
, inReplyTo = inReplyTo
|
|
, content = content
|
|
, url = url
|
|
, name = name
|
|
, replies = Collection
|
|
{ id = T.unpack noteid <> "/replies"
|
|
, summary = "Replies"
|
|
, items = []
|
|
, first = Nothing
|
|
, last = Nothing
|
|
}
|
|
}
|
|
row -> error $ "Couldn't decode row as Note: " <> show row
|
|
|
|
nullableString :: DB.SQLData -> Maybe (Maybe String)
|
|
nullableString = \case
|
|
DB.SQLText text -> Just (Just $ T.unpack text)
|
|
DB.SQLNull -> Just Nothing
|
|
_ -> Nothing
|
|
|
|
toNullableString :: Maybe String -> DB.SQLData
|
|
toNullableString = \case
|
|
Nothing -> DB.SQLNull
|
|
Just str -> DB.SQLText (T.pack str)
|