Commits

Luke Plant  committed b2553eb

Reorganised db -> haskell layer into Model.hs module

  • Participants
  • Parent commits 326644d

Comments (0)

Files changed (6)

File src/Blog/Category.hs

                            slug :: String
                          } deriving (Show, Eq)
 
-addCategory cn c =  do theslug <- makeCategorySlug cn c
-                       let c2 = c { slug = theslug }
-                       DB.doInsert cn "categories"
-                             ["name",
-                              "slug"]
-                             [toSql $ name c2,
-                              toSql $ slug c2]
-                       [[newid]] <- quickQuery cn "SELECT last_insert_rowid();" [];
-                       return c2 { uid = fromSql $ newid }
-
-makeCategorySlug cn cat = makeSlugGeneric cn (name cat) "categories"
-
-makeCategory row =
-    Category { uid = fromSql (row !! 0)
-             , name = fromSql (row !! 1)
-             , slug = fromSql (row !! 2)
-             }

File src/Blog/Comment.hs

+module Blog.Comment where
+
+

File src/Blog/Model.hs

+module Blog.Model ( addPost
+                  , addCategory
+                  , makePostSlug
+                  , addPostCategory
+                  , getPostBySlug
+                  , getRecentPosts
+                  , getCategoriesForPost
+                  ) where
+
+import Database.HDBC
+import Blog.DBUtils (makeSlugGeneric)
+import qualified Blog.DB as DB
+import qualified Blog.Post as P
+import qualified Blog.Category as Ct
+import qualified Blog.Comment as Cm
+
+------ 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 $ P.format_id p2,
+                         toSql $ P.timestamp p2,
+                         toSql $ P.comments_open p2
+                        ]
+                  [[newid]] <- quickQuery' cn "SELECT last_insert_rowid();" []
+                  return p2 { P.uid = fromSql $ 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]] <- quickQuery cn "SELECT last_insert_rowid();" [];
+                       return c2 { Ct.uid = fromSql $ 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; }
+
+-------- 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 = ?;"
+getRecentPostQueries    = "SELECT id, title, slug, '',       '',             '',          summary_formatted, '',        timestamp, ''            FROM posts ORDER BY timestamp DESC LIMIT 20;"
+
+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;"
+
+
+---- 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_id = 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)
+                }
+
+---- Public API for queries ----
+
+getPostBySlug cn slug = do
+  res <- quickQuery' cn getPostBySlugQuery [toSql slug]
+  case res of
+    [] -> return Nothing
+    (postdata:_) -> return $ Just $ makePost postdata
+
+getRecentPosts cn = do
+  res <- quickQuery' cn getRecentPostQueries []
+  return $ map makePost res
+
+getCategoriesForPost cn post = do
+  res <- quickQuery' cn getCategoriesForPostQuery [toSql $ P.uid post]
+  return $ map makeCategory res

File src/Blog/Post.hs

 module Blog.Post where
 
-import Database.HDBC
-import Blog.DBUtils (makeSlugGeneric)
-import qualified Blog.DB as DB
-import qualified Blog.Category as C
-
 data Post = Post {
       uid :: Int,
       title :: String,
       comments_open :: Bool
     } deriving (Show, Eq)
 
-addPost cn p = do theslug <- makePostSlug cn p
-                  let p2 = p { slug = theslug }
-                  DB.doInsert cn "posts" [
-                         "title",
-                         "slug",
-                         "post_raw",
-                         "post_formatted",
-                         "summary_raw",
-                         "summary_formatted",
-                         "format_id",
-                         "timestamp",
-                         "comments_open"
-                        ] [
-                         toSql $ title p2,
-                         toSql $ slug p2,
-                         toSql $ post_raw p2,
-                         toSql $ post_formatted p2,
-                         toSql $ summary_raw p2,
-                         toSql $ summary_formatted p2,
-                         toSql $ format_id p2,
-                         toSql $ timestamp p2,
-                         toSql $ comments_open p2
-                        ]
-                  [[newid]] <- quickQuery' cn "SELECT last_insert_rowid();" []
-                  return p2 { uid = fromSql $ newid }
-
-makePostSlug cn p = makeSlugGeneric cn (title p) "posts"
-
-addPostCategory cn pc = do { DB.doInsert cn "post_categories"
-                             ["post_id",
-                              "category_id"]
-                             [toSql $ fst pc,
-                              toSql $ snd pc];
-                             return pc; }
-
-
--- 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 = ?;"
-getRecentPostQueries    = "SELECT id, title, slug, '',       '',             '',          summary_formatted, '',        timestamp, ''            FROM posts ORDER BY timestamp DESC LIMIT 20;"
-
-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;"
-
-getPostBySlug cn slug = do
-  res <- quickQuery' cn getPostBySlugQuery [toSql slug]
-  case res of
-    [] -> return Nothing
-    (postdata:_) -> return $ Just $ makePost postdata
-
-makePost row =
-    Post { uid = fromSql (row !! 0)
-         , title = fromSql (row !! 1)
-         , slug = fromSql (row !! 2)
-         , post_raw = fromSql (row !! 3)
-         , post_formatted = fromSql (row !! 4)
-         , summary_raw = fromSql (row !! 5)
-         , summary_formatted = fromSql (row !! 6)
-         , format_id = fromSql (row !! 7)
-         , timestamp = fromSql (row !! 8)
-         , comments_open = fromSql (row !! 9)
-         }
-
-getRecentPosts cn = do
-  res <- quickQuery' cn getRecentPostQueries []
-  return $ map makePost res
-
-getCategoriesForPost cn post = do
-  res <- quickQuery' cn getCategoriesForPostQuery [toSql $ uid post]
-  return $ map C.makeCategory res

File src/Blog/Views.hs

 import Blog.Templates
 import Blog.Links
 import Blog.DB (connect)
-import Blog.Post (getPostBySlug, getCategoriesForPost, getRecentPosts)
+import Blog.Model (getPostBySlug, getCategoriesForPost, getRecentPosts)
 
 standardResponse html = buildResponse [
                          addHtml html

File src/Migrate.hs

+import Blog.Model
 import Blog.Utils (regexReplace, split)
 import Data.Maybe (fromJust)
 import Data.Ord (comparing)
 main = handleSqlError $ do
   cn <- DB.connect
   origCats <- readCategories
-  newCats <- writeItems cn C.addCategory origCats
+  newCats <- writeItems cn addCategory origCats
   origPosts <- readPosts
-  newPosts <- writeItems cn P.addPost origPosts
+  newPosts <- writeItems cn addPost origPosts
   -- we need the new/old IDs of posts/categories to rewrite comments tables
   -- and the post/categories m2m
   let post_id_map = Map.fromList $ zip (map P.uid origPosts) (map P.uid newPosts)
   let cat_id_map = Map.fromList $ zip (map C.uid origCats) (map C.uid newCats)
   postCategories' <- readPostCategories
   let postCategories = correctIds postCategories' post_id_map cat_id_map
-  writeItems cn P.addPostCategory postCategories
+  writeItems cn addPostCategory postCategories
 
   let postUrlMap = Map.fromList $ zip (map (show . P.uid) origPosts)
                                       (map Links.postUrl newPosts)