doc-review-0.7: src/State/SQLite.hs
{-| Comment storage in SQLite -}
module State.SQLite
( new
)
where
import Network.URI ( URI, parseRelativeReference )
import Data.Maybe ( listToMaybe, maybeToList )
import Data.List ( intercalate )
import System.IO ( hPutStrLn, stderr )
import qualified Data.Text.Encoding as E
import qualified Data.Text as T
import Database.SQLite ( openConnection
, SQLiteHandle
, execParamStatement
, execStatement_
, execParamStatement_
, execStatement
, defineTableOpt
)
import Control.Exception ( onException )
import qualified Database.SQLite as Q
import State.Types ( State(..), CommentId, commentId , ChapterId
, chapterId, mkCommentId, Comment(..)
, SessionId(..), SessionInfo(..) )
import Control.Monad ( forM_, when, (<=<) )
-- |Open a new SQLite comment store
new :: FilePath -> IO State
new dbName = do
hdl <- openConnection dbName
checkSchema hdl
return $ State { findComments = findComments' hdl
, getCounts = getCounts' hdl
, addComment = addComment' hdl
, addChapter = addChapter' hdl
, getLastInfo = getLastInfo' hdl
, getChapterComments = getChapterComments' hdl
, getChapterURI = getChapterURI' hdl
}
handleDefault :: b -> String -> Either String a -> (a -> IO b) -> IO b
handleDefault d msg (Left err) _ = do
hPutStrLn stderr $ "Error " ++ msg ++ ": " ++ err
return d
handleDefault _ _ (Right x) f = f x
getLastInfo' :: SQLiteHandle -> SessionId -> IO (Maybe SessionInfo)
getLastInfo' hdl sid = do
let sql = "SELECT name, email \
\FROM comments \
\WHERE session_id = :session_id \
\ORDER BY date DESC \
\LIMIT 1"
binder = [(":session_id", Q.Blob $ sidBS sid)]
res <- execParamStatement hdl sql binder
let toInfo [(_, Q.Blob n), (_, ef)] =
SessionInfo (E.decodeUtf8 n) `fmap` loadEmail ef
toInfo _ = []
handleDefault Nothing "loading info" res $
return . listToMaybe . concatMap toInfo . concat
loadEmail :: Q.Value -> [Maybe T.Text]
loadEmail Q.Null = return Nothing
loadEmail (Q.Blob s) = return $ Just $ E.decodeUtf8 s
loadEmail _ = []
-- Load all of the comments for a given comment id
findComments' :: SQLiteHandle -> CommentId -> IO [Comment]
findComments' hdl cId = do
let commentIdBlob = txtBlob $ commentId cId
sql = "SELECT name, comment, email, date, session_id \
\FROM comments WHERE comment_id = :comment_id"
binder = [(":comment_id", commentIdBlob)]
res <- execParamStatement hdl sql binder
let toComment [(_, Q.Blob n), (_, Q.Blob c), (_, ef), (_, Q.Double i), (_, Q.Blob sid)] =
do e <- loadEmail ef
let d = realToFrac i
[Comment (E.decodeUtf8 n) (E.decodeUtf8 c) e d (SessionId sid)]
toComment _ = []
handleDefault [] "loading comments" res $
return . concatMap toComment . concat
-- Load the comment counts for the current chapter, or all counts if
-- no chapter is supplied
getCounts' :: SQLiteHandle -> Maybe ChapterId -> IO [(CommentId, Int)]
getCounts' hdl mChId = do
res <- case mChId of
Nothing ->
let sql = "SELECT comment_id, COUNT(comment_id) \
\FROM comments GROUP BY comment_id"
in execStatement hdl sql
Just chId ->
let sql = "SELECT comments.comment_id, \
\ COUNT(comments.comment_id) \
\FROM comments JOIN chapters \
\ON comments.comment_id == chapters.comment_id \
\WHERE chapters.chapter_id = :chapter_id \
\ AND chapters.chapter_id IS NOT NULL \
\GROUP BY comments.comment_id"
chIdBlob = txtBlob $ chapterId chId
binder = [(":chapter_id", chIdBlob)]
in execParamStatement hdl sql binder
let convertRow [(_, Q.Blob cIdBS), (_, Q.Int cnt)] =
case mkCommentId $ E.decodeUtf8 cIdBS of
Just cId | cnt > 0 -> [(cId, fromIntegral cnt)]
_ -> []
convertRow _ = []
handleDefault [] "getting counts" res $
return . concatMap convertRow . concat
-- Add the comment, possibly associating it with a chapter
addComment' :: SQLiteHandle -> CommentId -> Maybe ChapterId -> Comment -> IO ()
addComment' hdl cId mChId c =
txn hdl $ do
case mChId of
Nothing -> return ()
Just chId -> insertChapterComment cId chId hdl
insertComment cId c hdl
-- Insert a row that adds a comment for the given comment id
insertComment :: CommentId -> Comment -> SQLiteHandle -> IO ()
insertComment cId c hdl = do
maybeErr =<< insertRowVal hdl "comments"
[ ("comment_id", txtBlob $ commentId cId)
, ("name", txtBlob $ cName c)
, ("comment", txtBlob $ cComment c)
, ("email", maybe Q.Null txtBlob $ cEmail c)
, ("date", Q.Double $ realToFrac $ cDate c)
, ("session_id", Q.Blob $ sidBS $ cSession c)
]
-- Insert a row that maps a comment id with a chapter
insertChapterComment :: CommentId -> ChapterId -> SQLiteHandle -> IO ()
insertChapterComment cId chId hdl = do
let sql = "SELECT 1 FROM chapters \
\WHERE chapter_id = :chId AND comment_id = :cId"
binder = [ (":chId", txtBlob $ chapterId chId)
, (":cId", txtBlob $ commentId cId)
]
res <- execParamStatement hdl sql binder
case (res :: Either String [[Q.Row ()]]) of
Left err -> error err
Right rs -> when (null $ concat rs) $
maybeErr =<< insertRowVal hdl "chapters"
[ ("chapter_id", txtBlob $ chapterId chId)
, ("comment_id", txtBlob $ commentId cId)
]
addChapter' :: SQLiteHandle -> ChapterId -> [CommentId] -> Maybe URI -> IO ()
addChapter' hdl chId cIds mURI =
txn hdl $ do
forM_ cIds $ \cId -> insertChapterComment cId chId hdl
case mURI of
Nothing -> return ()
Just uri ->
do let sql = "INSERT OR REPLACE INTO \
\ chapter_info (chapter_id, url) \
\VALUES (:chId, :url)"
binder = [ (":chId", txtBlob $ chapterId chId)
, (":url", txtBlob $ T.pack $ show uri)
]
maybeErr =<< execParamStatement_ hdl sql binder
getChapterURI' :: SQLiteHandle -> ChapterId -> IO (Maybe URI)
getChapterURI' hdl chId = do
let sql = "SELECT url FROM chapter_info WHERE chapter_id = :chId"
binder = [(":chId", txtBlob $ chapterId chId)]
convertRow [(_, Q.Blob u)] =
maybeToList $ parseRelativeReference $ T.unpack $ E.decodeUtf8 u
convertRow _ = []
res <- execParamStatement hdl sql binder
handleDefault Nothing "getting URI" res $
return . listToMaybe . concatMap convertRow . concat
-- If the tables we expect are not there, add them (to deal with the
-- case that this is a new database)
--
-- This can cause problems if the schema changes, since it does not
-- actually check to see that the schema matches what we expect.
checkSchema :: SQLiteHandle -> IO ()
checkSchema hdl =
txn hdl $ do
mapM_ (maybeErr <=< defineTableOpt hdl True)
[ t "comments"
[ tCol "comment_id"
, tCol "name"
, tCol "comment"
, tColN "email" []
, Q.Column "date" real [notNull]
, tCol "session_id"
]
, t "chapters" [ tCol "chapter_id"
, tCol "comment_id"
]
, t "chapter_info" [ tColN "chapter_id" [ notNull
, Q.PrimaryKey False
]
, tColN "url" []
]
]
mapM_ (maybeErr <=< execStatement_ hdl)
[ "CREATE INDEX IF NOT EXISTS comments_comment_id_idx \
\ON comments(comment_id)"
, "CREATE INDEX IF NOT EXISTS chapters_comment_id_idx \
\ON chapters(comment_id)"
, "CREATE INDEX IF NOT EXISTS chapters_chapter_id_idx \
\ON chapters(chapter_id)"
, "CREATE INDEX IF NOT EXISTS comments_date_idx \
\ON comments(date)"
, "CREATE INDEX IF NOT EXISTS comments_session_id \
\ON comments(session_id)"
, "CREATE INDEX IF NOT EXISTS chapter_info_chapter_id \
\ON chapters(chapter_id)"
]
where
real = Q.SQLFloat Nothing Nothing
tColN c cs = Q.Column c txt cs
notNull = Q.IsNullable False
tCol c = tColN c [notNull]
t n cs = Q.Table n cs []
txt = Q.SQLBlob $ Q.NormalBlob Nothing
getChapterComments' :: SQLiteHandle -> ChapterId -> IO [(CommentId, Comment)]
getChapterComments' hdl chId = do
let sql = "SELECT comments.comment_id, name, comment, \
\ email, date, session_id \
\FROM comments JOIN chapters \
\ ON comments.comment_id = chapters.comment_id \
\WHERE chapters.chapter_id = :chapter_id \
\ORDER BY comments.date DESC"
binder = [(":chapter_id", txtBlob $ chapterId chId)]
res <- execParamStatement hdl sql binder
let toResult [ (_, Q.Blob cIdB)
, (_, Q.Blob n)
, (_, Q.Blob c)
, (_, ef)
, (_, Q.Double i)
, (_, Q.Blob sid)
] = do
e <- loadEmail ef
cId <- maybeToList $ mkCommentId $ E.decodeUtf8 cIdB
let d = realToFrac i
name = E.decodeUtf8 n
commentTxt = E.decodeUtf8 c
sId = SessionId sid
comment = Comment name commentTxt e d sId
[(cId, comment)]
toResult _ = []
handleDefault [] "loading comments for chapter" res $
return . concatMap toResult . concat
--------------------------------------------------
-- Helpers
-- Convert a Data.Text.Text value to a UTF-8-encoded Blob. We use
-- Blobs to avoid dealing with database encodings (the application
-- does all of the encoding and decoding)
txtBlob :: T.Text -> Q.Value
txtBlob = Q.Blob . E.encodeUtf8
-- If there is a string in the value, throw an error. Otherwise, do
-- nothing.
maybeErr :: Maybe String -> IO ()
maybeErr Nothing = return ()
maybeErr (Just e) = error e
-- Perform the supplied action inside of a database transaction
txn :: SQLiteHandle -> IO () -> IO ()
txn hdl act = do
let execSql sql = maybeErr =<< execStatement_ hdl sql
execSql "BEGIN"
act `onException` (execSql "ROLLBACK" >> return ())
execSql "COMMIT"
return ()
-- Insert a row into a table, using type Value for the values
insertRowVal :: SQLiteHandle -> Q.TableName -> Q.Row Q.Value
-> IO (Maybe String)
insertRowVal hdl tbl r = execParamStatement_ hdl sql row
where
sql = "INSERT INTO " ++ tbl ++ cols ++ " VALUES " ++ vals
tupled l = '(':(intercalate "," l ++ ")")
cols = tupled $ map fst r
vals = tupled valNames
valNames = take (length r) $
map (showString ":val") $
map show [(1::Integer)..]
row = zip valNames $ map snd r