haskellblog / src / Blog / Model.hs

module Blog.Model ( addPost
                  , addCategory
                  , addPostCategory
                  , addComment
                  , createUser
                  , getPostBySlug
                  , getRecentPosts
                  , getCategoriesForPost
                  , getCommentsForPost
                  , getRelatedPosts
                  , getCategoryBySlug
                  , getCategories
                  , getCategoriesBulk
                  , getPostsForCategory
                  , setPassword
                  , checkPassword
                  ) where

import Data.Digest.Pure.SHA (showDigest, sha1)
import Database.HDBC
import Blog.DBUtils (makeSlugGeneric, pagedQuery, sqlInIds, getDbId)
import Blog.Utils (regexReplace, randomStr, split)
import Ella.GenUtils (utf8)
import qualified Blog.DB as DB
import qualified Blog.Post as P
import qualified Blog.Category as Ct
import qualified Blog.Comment as Cm
import qualified Blog.Settings as Settings
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Lazy.UTF8 as UTF8

------ Create -------
addPost cn p = do theslug <- makePostSlug cn p
                  let p2 = p { P.slug = theslug }
                  DB.doInsert cn "posts" [
                         "title",
                         "slug",
                         "post_raw",
                         "post_formatted",
                         "summary_raw",
                         "summary_formatted",
                         "format_id",
                         "timestamp",
                         "comments_open"
                        ] [
                         toSql $ P.title p2,
                         toSql $ P.slug p2,
                         toSql $ P.post_raw p2,
                         toSql $ P.post_formatted p2,
                         toSql $ P.summary_raw p2,
                         toSql $ P.summary_formatted p2,
                         toSql $ fromEnum $ P.format p2,
                         toSql $ P.timestamp p2,
                         toSql $ P.comments_open p2
                        ]
                  newid <- getDbId cn
                  return p2 { P.uid = newid }

makePostSlug cn p = makeSlugGeneric cn (P.title p) "posts"

addCategory cn c =  do theslug <- makeCategorySlug cn c
                       let c2 = c { Ct.slug = theslug }
                       DB.doInsert cn "categories"
                             ["name",
                              "slug"]
                             [toSql $ Ct.name c2,
                              toSql $ Ct.slug c2]
                       newid <- getDbId cn
                       return c2 { Ct.uid = newid }

makeCategorySlug cn cat = makeSlugGeneric cn (Ct.name cat) "categories"

addPostCategory cn pc = do { DB.doInsert cn "post_categories"
                             ["post_id",
                              "category_id"]
                             [toSql $ fst pc,
                              toSql $ snd pc];
                             return pc; }


addComment cn cm = do
  DB.doInsert cn "comments" [
                    "post_id"
                   , "timestamp"
                   , "name"
                   , "email"
                   , "text_raw"
                   , "text_formatted"
                   , "format_id"
                   ] [
                    toSql $ Cm.post_id cm
                   , toSql $ Cm.timestamp cm
                   , toSql $ Cm.name cm
                   , toSql $ Cm.email cm
                   , toSql $ Cm.text_raw cm
                   , toSql $ Cm.text_formatted cm
                   , toSql $ fromEnum $ Cm.format cm
                   ]
  newid <- getDbId cn
  return cm { Cm.uid = newid }

createUser :: (IConnection conn) =>
              conn -> String -> Bool -> IO Int
createUser cn username superuser = do
  DB.doInsert cn "users"
        [ "username"
        , "password"
        , "superuser"
        ]
        [ toSql username
        , toSql ""
        , toSql superuser
        ]
  newid <- getDbId cn
  return newid

-------- Queries -----------

---- Statements -----

-- We optimise queries by removing items that are not actually used and replacing them with ''
-- (we can then use the same 'makePost' function)
getPostByIdQuery        = "SELECT id, title, slug, post_raw, post_formatted, summary_raw, summary_formatted, format_id, timestamp, comments_open FROM posts WHERE id = ?;"
getPostBySlugQuery      = "SELECT id, title, slug, '',       post_formatted, '',          '',                '',        timestamp, comments_open FROM posts WHERE slug = ?;"
getRecentPostsQuery     = "SELECT id, title, slug, '',       '',             '',          summary_formatted, '',        timestamp, ''            FROM posts ORDER BY timestamp DESC $LIMITOFFSET;"
getPostsForCategoryQuery= "SELECT id, title, slug, '',       '',             '',          summary_formatted, '',        timestamp, ''            FROM posts INNER JOIN post_categories ON posts.id = post_categories.post_id WHERE post_categories.category_id = ? ORDER BY timestamp DESC $LIMITOFFSET;"

-- Used to get post related to a post, ordered to favour posts with
-- more matching categories and close in time to the original post
getRelatedPostsQuery ids = "SELECT id, title, slug, '',       '',             '',          '',                '',               '', ''            FROM posts INNER JOIN (SELECT post_id, COUNT(post_id) AS c from post_categories WHERE category_id IN " ++ sqlInIds ids ++ " GROUP BY post_id) as t2 ON posts.id = t2.post_id AND posts.id <> ? ORDER BY c DESC, abs(posts.timestamp - ?) ASC $LIMITOFFSET;"

getCategoryBySlugQuery    = "SELECT categories.id, categories.name, categories.slug FROM categories WHERE slug = ?;"
getCategoriesQuery        = "SELECT categories.id, categories.name, categories.slug FROM categories ORDER BY slug;"
getCategoriesForPostQuery = "SELECT categories.id, categories.name, categories.slug FROM categories INNER JOIN post_categories ON categories.id = post_categories.category_id WHERE post_categories.post_id = ? ORDER BY categories.slug;"
getCategoriesBulkQuery ids= "SELECT categories.id, categories.name, categories.slug, post_categories.post_id FROM categories INNER JOIN post_categories ON categories.id = post_categories.category_id WHERE post_categories.post_id IN " ++ sqlInIds ids ++ " ORDER BY categories.slug;"

getCommentByIdQuery      = "SELECT id, post_id, timestamp, name, email, text_raw, text_formatted, format_id FROM comments WHERE id = ?;"
getCommentsForPostQuery  = "SELECT id, '',      timestamp, name, email, '',       text_formatted, ''        FROM comments WHERE post_id = ? ORDER BY timestamp ASC;"

getPasswordForUsernameQuery = "SELECT password FROM users WHERE username = ?;"
setPasswordForUsernameQuery = "UPDATE users SET password = ? WHERE username = ?;"

---- Constructors ----

makePost row =
    P.Post { P.uid = fromSql (row !! 0)
           , P.title = fromSql (row !! 1)
           , P.slug = fromSql (row !! 2)
           , P.post_raw = fromSql (row !! 3)
           , P.post_formatted = fromSql (row !! 4)
           , P.summary_raw = fromSql (row !! 5)
           , P.summary_formatted = fromSql (row !! 6)
           , P.format = toEnum $ fromSql (row !! 7)
           , P.timestamp = fromSql (row !! 8)
           , P.comments_open = fromSql (row !! 9)
           }

makeCategory row =
    Ct.Category { Ct.uid = fromSql (row !! 0)
                , Ct.name = fromSql (row !! 1)
                , Ct.slug = fromSql (row !! 2)
                }

makeComment row =
    Cm.Comment { Cm.uid = fromSql (row !! 0)
               , Cm.post_id = fromSql (row !! 1)
               , Cm.timestamp = fromSql (row !! 2)
               , Cm.name = fromSql (row !! 3)
               , Cm.email = fromSql (row !! 4)
               , Cm.text_raw = fromSql (row !! 5)
               , Cm.text_formatted = fromSql (row !! 6)
               , Cm.format = toEnum $ fromSql (row !! 7)
               }

---- Public API for queries ----

getPostBySlug :: (IConnection conn) => conn -> String -> IO (Maybe P.Post)
getPostBySlug cn slug = do
  res <- quickQuery' cn getPostBySlugQuery [toSql slug]
  case res of
    [] -> return Nothing
    (postdata:_) -> return $ Just $ makePost postdata

getRecentPosts :: (IConnection conn) => conn -> Int -> IO ([P.Post], Bool)
getRecentPosts cn page = do
  (res,more) <- pagedQuery cn getRecentPostsQuery [] page Settings.post_page_size
  return (map makePost res, more)

getPostsForCategory :: (IConnection conn) => conn -> Ct.Category -> Int -> IO ([P.Post], Bool)
getPostsForCategory cn cat curpage = do
  (res,more) <- pagedQuery cn getPostsForCategoryQuery [toSql $ Ct.uid cat] curpage Settings.post_page_size
  return (map makePost res, more)

getCategoryBySlug :: (IConnection conn) => conn -> String -> IO (Maybe Ct.Category)
getCategoryBySlug cn slug = do
  res <- quickQuery' cn getCategoryBySlugQuery [toSql slug]
  case res of
    [] -> return Nothing
    (rs:_) -> return $ Just $ makeCategory rs

getCategories :: (IConnection conn) => conn -> IO [Ct.Category]
getCategories cn = do
  res <- quickQuery' cn getCategoriesQuery []
  return $ map makeCategory res

getCategoriesForPost :: (IConnection conn) => conn -> P.Post -> IO [Ct.Category]
getCategoriesForPost cn post = do
  res <- quickQuery' cn getCategoriesForPostQuery [toSql $ P.uid post]
  return $ map makeCategory res

getCommentsForPost :: (IConnection conn) => conn -> P.Post -> IO [Cm.Comment]
getCommentsForPost cn post = do
  res <- quickQuery' cn getCommentsForPostQuery [toSql $ P.uid post]
  return $ map makeComment res

-- | Gets the categories for a list of posts.  Results are returned
-- as a list of list of categories
getCategoriesBulk :: (IConnection conn) =>
                     conn                  -- ^ connection
                  -> [P.Post]              -- ^ list of posts
                  -> IO [[Ct.Category]]
getCategoriesBulk cn posts = do
  let ids = map (P.uid) posts
  res <- quickQuery' cn (getCategoriesBulkQuery ids) []
  -- Create (Category, post id) pairs:
  let cats = map (\r -> (makeCategory r, (fromSql $ r !! 3) :: Int)) res
  -- split them up according to ids
  return [ [ cat | (cat, pid) <- cats, P.uid p == pid ] | p <- posts]


getRelatedPosts :: (IConnection conn) =>
                   conn -> P.Post -> [Ct.Category] -> IO [P.Post]
getRelatedPosts cn post categories = do
  let ids = map (Ct.uid) categories
  (res,_) <- pagedQuery cn (getRelatedPostsQuery ids) [ toSql $ P.uid post
                                                      , toSql $ P.timestamp post ] 1 7
  return $ map makePost res

makePasswordHash password = do
  salt <- randomStr 10
  let digest = sha1 $ utf8 (salt ++ password)
  return ("sha1:" ++ salt ++ ":" ++ (showDigest $ digest))

checkPasswordHash salt hash password =
    (showDigest $ sha1 $ utf8 (salt ++ password)) == hash

-- | Checks that the password for a user is correct
checkPassword :: (IConnection conn) =>
                 conn -> String -> String -> IO Bool
checkPassword cn username password = do
  res <- quickQuery' cn getPasswordForUsernameQuery [ toSql username ]
  if null res
     then return False
     else do
         [[SqlByteString pwdData]] <- return res -- force pattern match
         -- pwdData stores algo;salt;hash
         ["sha1", salt, hash] <- return $ split (UTF8.toString $ BL.fromChunks [pwdData]) ':'
         return $ checkPasswordHash salt hash password

-- | Sets the password for a user
setPassword :: (IConnection conn) =>
               conn -> String -> String -> IO ()
setPassword cn username password = do
  pwdHash <- makePasswordHash password
  withTransaction cn (\cn ->
                      run cn setPasswordForUsernameQuery [ toSql pwdHash
                                                         , toSql username ]
                     )
  return ()
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.