Skip to content
This repository
Browse code

Updating the ORM; Adding a mini-CMS; Adding a little HAML translator

  • Loading branch information...
commit a1aa2cd5e2e2c18cefb93572b5f0bbdfbf22f87b 1 parent 9a9af21
Alson Kemp authored

Showing 44 changed files with 916 additions and 236 deletions. Show diff stats Hide diff stats

  1. +6 3 App/Controllers/Home.hs
  2. +51 9 App/Controllers/Page.hs
  3. +6 6 App/Layouts/Default.hs
  4. +53 0 App/Layouts/Default.hs.old
  5. +114 0 App/Layouts/index.html
  6. +5 0 App/Models/AuthorModel.hs
  7. BIN  App/Models/Bases/.PageModelBase.hs.swp
  8. +58 0 App/Models/Bases/AuthorModelBase.hs
  9. +36 0 App/Models/Bases/ModelBase.hs
  10. +58 0 App/Models/Bases/PageModelBase.hs
  11. +5 0 App/Models/PageModel.hs
  12. +8 30 App/Views/Develop/Index.hs
  13. +0 21 App/Views/Home/About.hs
  14. +4 0 App/Views/Home/Architecture.hs
  15. +0 1  App/Views/Home/Hello.hs
  16. +19 1 App/Views/Home/Index.hs
  17. +46 0 App/Views/Home/Install.hs
  18. +0 1  App/Views/Home/Performance.hs
  19. +15 0 App/Views/Page/Edit.hs
  20. +15 0 App/Views/Page/Index.hs
  21. +13 0 App/Views/Page/New.hs
  22. +2 2 App/Views/Page/Show.hs
  23. +0 1  App/Views/Tutorial/Index.hs
  24. +3 3 Config/App.hs
  25. +3 4 Config/Master.hs
  26. +5 1 Turbinado/Controller.hs
  27. +14 8 Turbinado/Database/ORM/Generator.hs
  28. +80 58 Turbinado/Database/ORM/Output.hs
  29. +18 1 Turbinado/Database/ORM/PostgreSQL.hs
  30. +2 1  Turbinado/Database/ORM/Types.hs
  31. +0 47 Turbinado/Environment.hs
  32. +17 17 Turbinado/Environment/CodeStore.hs
  33. +15 2 Turbinado/Environment/Header.hs
  34. +49 0 Turbinado/Environment/Params.hs
  35. +1 1  Turbinado/Environment/Types.hs
  36. +1 0  Turbinado/Environment/ViewData.hs
  37. +3 5 Turbinado/Layout.hs
  38. +13 10 Turbinado/Server/Handlers/RequestHandler.hs
  39. +1 0  Turbinado/Stubs/Layout.hs
  40. +3 0  Turbinado/Stubs/View.hs
  41. +5 1 Turbinado/View.hs
  42. +159 0 Turbinado/View/HAML/trhaml.hs
  43. +1 0  static/css/turbinado.css
  44. +9 2 turbinado.cabal
9 App/Controllers/Home.hs
@@ -2,12 +2,15 @@
2 2 index :: Controller ()
3 3 index = return ()
4 4
5   -about :: Controller ()
6   -about = return ()
7   -
8 5 performance :: Controller ()
9 6 performance = return ()
10 7
  8 +install :: Controller ()
  9 +install = return ()
  10 +
  11 +architecture :: Controller ()
  12 +architecture= return ()
  13 +
11 14 hello :: Controller ()
12 15 hello = clearLayout
13 16
60 App/Controllers/Page.hs
... ... @@ -1,16 +1,58 @@
  1 +import App.Models.PageModel
  2 +
1 3 index :: Controller ()
2   -index = do pages <- quickQuery' "select * from page" []
3   - return ()
  4 +index = do conn <- liftIO $ fromJust $ databaseConnection
  5 + pages <- liftIO $ findAll conn
  6 + setViewDataValue "pages-list" $ map (\p -> (title p, _id p)) pages
4 7
5 8 show :: Controller ()
6   -show = do e <- getEnvironment
7   - let id' = getSetting "id" e :: Maybe String
8   - doIO $ debugM e $ "XXXXXXXX id' = " ++ (Prelude.show id')
  9 +show = do conn <- liftIO $ fromJust $ databaseConnection
  10 + e <- get
  11 + id' <- getSetting "id"
  12 + case id' of
  13 + Nothing -> redirectTo "/Home"
  14 + Just i -> do p <- find conn i
  15 + setViewDataValue "page-title" (title p)
  16 + setViewDataValue "page-content" (content p)
  17 +
  18 +new :: Controller ()
  19 +new = do conn <- liftIO $ fromJust $ databaseConnection
  20 + e <- get
  21 + id' <- getSetting "id"
9 22 case id' of
10 23 Nothing -> redirectTo "/Home"
11   - Just i -> do q <- quickQuery' "select title, content from page where id = ?" [toSql i]
12   - e' <- doIO $ setViewDataValue "page-title" (Prelude.show $ (head q) !! 0) e
13   - e''<- doIO $ setViewDataValue "page-content" (Prelude.show $ (head q) !! 1) e
14   - put e''
  24 + Just i -> do setViewDataValue "save-url" ("/Page/Create/" ++ i)
15 25
  26 +create :: Controller ()
  27 +create = do conn <- liftIO $ fromJust $ databaseConnection
  28 + e <- get
  29 + id' <- getSetting "id"
  30 + _title <- getParam_u "title"
  31 + _content <- getParam_u "content"
  32 + case id' of
  33 + Nothing -> redirectTo "/Home"
  34 + Just i -> do App.Models.PageModel.insert conn Page {authorId = Nothing,_id = i, title = _title, content = _content, version = 1}
  35 + redirectTo $ "/Page/Show/" ++ i
  36 +edit :: Controller ()
  37 +edit = do conn <- liftIO $ fromJust $ databaseConnection
  38 + e <- get
  39 + id' <- getSetting "id"
  40 + case id' of
  41 + Nothing -> redirectTo "/Home"
  42 + Just i -> do p <- find conn i
  43 + setViewDataValue "save-url" ("/Page/Save/" ++ i)
  44 + setViewDataValue "page-title" (title p)
  45 + setViewDataValue "page-content" (content p)
16 46
  47 +save :: Controller ()
  48 +save = do conn <- liftIO $ fromJust $ databaseConnection
  49 + e <- get
  50 + id' <- getSetting "id"
  51 + _title <- getParam_u "title"
  52 + _content <- getParam_u "content"
  53 + case id' of
  54 + Nothing -> redirectTo "/Home"
  55 + Just i -> do p <- find conn i
  56 + App.Models.PageModel.update conn p {title = _title, content = _content}
  57 + redirectTo $ "/Page/Show/" ++ i
  58 +
12 App/Layouts/Default.hs
@@ -4,7 +4,6 @@ import Data.Maybe
4 4 import qualified Network.HTTP as HTTP
5 5 import qualified Network.URI as URI
6 6
7   -page :: View XML
8 7 page = <html>
9 8 <head>
10 9 <% styleSheet "normalize" "screen" %>
@@ -30,11 +29,12 @@ page = <html>
30 29 </div>
31 30 <div id="menu">
32 31 <ul>
33   - <% menuItem "/Home/Index" "Home" %>
34   - <% menuItem "/Home/About" "About" %>
35   - <% menuItem "/Home/Performance" "Performance" %>
36   - <% menuItem "/Tutorial/Index" "Tutorial" %>
37   - <% menuItem "/Develop/Index" "Develop" %>
  32 + <% menuItem "/Home/Index" "Home" %>
  33 + <% menuItem "/Home/Performance" "Performance" %>
  34 + <% menuItem "/Home/Architecture" "Architecture" %>
  35 + <% menuItem "/Home/Install" "Install" %>
  36 + <% menuItem "/Tutorial/Index" "Tutorial" %>
  37 + <% menuItem "/Develop/Index" "Develop" %>
38 38 </ul>
39 39 </div>
40 40 <div id="page">
53 App/Layouts/Default.hs.old
... ... @@ -0,0 +1,53 @@
  1 +page :: View XML
  2 +page = <html>
  3 + <head>
  4 + <% styleSheet "normalize" "screen" %>
  5 + <% styleSheet "jsddm" "screen" %>
  6 + <% styleSheet "turbinado" "screen" %>
  7 + <% javaScript "jquery" %>
  8 + <% javaScript "jsddm" %>
  9 + <script type="text/javascript">
  10 + var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");
  11 + document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));
  12 + </script>
  13 + <script type="text/javascript">
  14 + var pageTracker = _gat._getTracker("UA-6158816-1");
  15 + pageTracker._trackViewview();
  16 + </script>
  17 + </head>
  18 + <body>
  19 + <table class="wrapper">
  20 + <tr>
  21 + <td class="title">
  22 + <h1>Turbinado</h1>
  23 + <img class="title-image" src="/images/turbinado.jpg" />
  24 + <h2>Sugar For</h2>
  25 + <h2>The Web</h2>
  26 + </td>
  27 + <td class="container">
  28 + <ul id="jsddm">
  29 + <li><a href="/Home/Index">Home</a>
  30 + <ul>
  31 + <li><a href="/Home/About">About</a></li>
  32 + <li><a href="/Home/Performance">Performance</a></li>
  33 + </ul>
  34 + </li>
  35 + <li><a href="/Tutorial/Index">Tutorial</a>
  36 + </li>
  37 + <li><a href="/Develop/Index">Develop</a></li>
  38 + </ul>
  39 + <div class="clear"></div>
  40 + <% breadCrumbs %>
  41 + <div id="content-block" class="content-block">
  42 + <% insertView %>
  43 + </div>
  44 + </td>
  45 + </tr>
  46 + <tr>
  47 + <td colspan="2">
  48 + <div class="footer">Turbinado - www.turbinado.org</div>
  49 + </td>
  50 + </tr>
  51 + </table>
  52 + </body>
  53 + </html>
114 App/Layouts/index.html
... ... @@ -0,0 +1,114 @@
  1 +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
  2 +<!--
  3 +Design by Free CSS Templates
  4 +http://www.freecsstemplates.org
  5 +Released for free under a Creative Commons Attribution 2.5 License
  6 +
  7 +Name : Pressurized
  8 +Description: A two-column, fixed-width design with dark color scheme.
  9 +Version : 1.0
  10 +Released : 20081103
  11 +
  12 +-->
  13 +<html xmlns="http://www.w3.org/1999/xhtml">
  14 +<head>
  15 +<meta name="keywords" content="" />
  16 +<meta name="description" content="" />
  17 +<meta http-equiv="content-type" content="text/html; charset=utf-8" />
  18 +<title>Pressurized by Free CSS Templates</title>
  19 +<link href="style.css" rel="stylesheet" type="text/css" media="screen" />
  20 +</head>
  21 +<body>
  22 +<div id="wrapper">
  23 + <div id="header">
  24 + <div id="logo">
  25 + <h1><a href="#">Pressurized </a></h1>
  26 + <p> design by <a href="http://www.freecsstemplates.org/">Free CSS Templates</a></p>
  27 + </div>
  28 + </div>
  29 + <!-- end #header -->
  30 + <div id="menu">
  31 + <ul>
  32 + <li class="first"><a href="#">Home</a></li>
  33 + <li><a href="#">Blog</a></li>
  34 + <li><a href="#">Photos</a></li>
  35 + <li><a href="#">About</a></li>
  36 + <li><a href="#">Links</a></li>
  37 + <li><a href="#">Contact</a></li>
  38 + </ul>
  39 + </div>
  40 + <!-- end #menu -->
  41 + <div id="page">
  42 + <div id="content">
  43 + <div class="post">
  44 + <h1 class="title"><a href="#">Welcome to Pressurized </a></h1>
  45 + <div class="entry">
  46 + <p>This is <strong>Pressurized</strong>, a free, fully standards-compliant CSS template designed by FreeCssTemplates<a href="http://www.nodethirtythree.com/"></a> for <a href="http://www.freecsstemplates.org/">Free CSS Templates</a>. The photo used in this design is from <a href="http://www.pdphoto.org/">PDPhoto.rog</a>. This free template is released under a <a href="http://creativecommons.org/licenses/by/2.5/">Creative Commons Attributions 2.5</a> license, so you’re pretty much free to do whatever you want with it (even use it commercially) provided you keep the links in the footer intact. Aside from that, have fun with it :)</p>
  47 + <p>Sed lacus. Donec lectus. Nullam pretium nibh ut turpis. Nam bibendum. In nulla tortor, elementum ipsum. Proin imperdiet est. Phasellus dapibus semper urna. Pellentesque ornare, orci in felis. Donec ut ante. In id eros. Suspendisse lacus turpis, cursus egestas at sem.</p>
  48 + </div>
  49 + <p class="meta">Posted by <a href="#">Someone</a> on March 10, 2008
  50 + &nbsp;&bull;&nbsp; <a href="#" class="comments">Comments (64)</a> &nbsp;&bull;&nbsp; <a href="#" class="permalink">Full article</a></p>
  51 + </div>
  52 + <div class="post">
  53 + <h2 class="title"><a href="#">Lorem ipsum sed aliquam</a></h2>
  54 + <div class="entry">
  55 + <p>Sed lacus. Donec lectus. Nullam pretium nibh ut turpis. Nam bibendum. In nulla tortor, elementum vel, tempor at, varius non, purus. Mauris vitae nisl nec metus placerat consectetuer. Donec ipsum. Proin imperdiet est. Phasellus <a href="#">dapibus semper urna</a>. Pellentesque ornare, orci in consectetuer hendrerit, urna elit eleifend nunc, ut consectetuer nisl felis ac diam. Etiam non felis. Donec ut ante. In id eros. Suspendisse lacus turpis, cursus egestas at sem. Phasellus pellentesque. Mauris quam enim, molestie in, rhoncus ut, lobortis a, est.</p>
  56 + <p>Praesent ac lectus. Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Vivamus augue. Fusce eget tellus ultrices ligula volutpat adipiscing. Aenean ligula lectus, vehicula in, dictum a, fermentum nec, felis. Nunc ac turpis in leo posuere imperdiet.</p>
  57 + </div>
  58 + <p class="meta">Posted by <a href="#">Someone</a> on March 8, 2008
  59 + &nbsp;&bull;&nbsp; <a href="#" class="comments">Comments (64)</a> &nbsp;&bull;&nbsp; <a href="#" class="permalink">Full article</a></p>
  60 + </div>
  61 + <div class="post">
  62 + <h2 class="title"><a href="#">Phasellus pellentesque turpis </a></h2>
  63 + <div class="entry">
  64 + <p>Sed lacus. Donec lectus. Nullam pretium nibh ut turpis. Nam bibendum. In nulla tortor, elementum vel, tempor at, varius non, purus. Mauris vitae nisl nec metus placerat consectetuer. Donec ipsum. Proin imperdiet est. Pellentesque ornare, orci in consectetuer hendrerit, urna elit eleifend nunc, ut consectetuer nisl felis ac diam. Etiam non felis. Donec ut ante. In id eros. Suspendisse lacus turpis, cursus egestas at sem. Phasellus pellentesque. Mauris quam enim molestie rhoncus lobortis a, est.</p>
  65 + </div>
  66 + <p class="meta">Posted by <a href="#">Someone</a> on March 8, 2008
  67 + &nbsp;&bull;&nbsp; <a href="#" class="comments">Comments (64)</a> &nbsp;&bull;&nbsp; <a href="#" class="permalink">Full article</a></p>
  68 + </div>
  69 + </div>
  70 + <!-- end #content -->
  71 + <div id="sidebar">
  72 + <ul>
  73 + <li>
  74 + <h2>Aliquam tempus</h2>
  75 + <p>Mauris vitae nisl nec metus placerat perdiet est. Phasellus dapibus semper urna ornare consectetuer hendrerit.</p>
  76 + </li>
  77 + <li>
  78 + <h2>Categories</h2>
  79 + <ul>
  80 + <li><a href="#">Uncategorized</a> (3)<span>Lorem Ipsum Dolor Sit Amit</span></li>
  81 + <li><a href="#">Lorem Ipsum</a> (42)<span>Lorem Ipsum Dolor Sit Amit</span></li>
  82 + <li><a href="#">Urna Congue Rutrum</a> (28)<span>Lorem Ipsum Dolor Sit Amit</span> </li>
  83 + <li><a href="#">Vivamus Fermentum</a> (13)<span>Lorem Ipsum Dolor Sit Amit</span> </li>
  84 + </ul>
  85 + </li>
  86 + <li>
  87 + <h2>Blogroll</h2>
  88 + <ul>
  89 + <li><a href="#">Phasellus Pellentesque</a><span>Lorem Ipsum Dolor Sit Amit</span> </li>
  90 + <li><a href="#">Consectetuer Adipiscing</a><span>Lorem Ipsum Dolor Sit Amit</span> </li>
  91 + <li><a href="#">Urna Congue Rutrum</a><span>Lorem Ipsum Dolor Sit Amit</span> </li>
  92 + </ul>
  93 + </li>
  94 + <li>
  95 + <h2>Archives</h2>
  96 + <ul>
  97 + <li><a href="#">December 2007</a>&nbsp;(29)<span>Lorem Ipsum Dolor Sit Amit</span></li>
  98 + <li><a href="#">November 2007</a>&nbsp;(30)<span>Lorem Ipsum Dolor Sit Amit</span></li>
  99 + <li><a href="#">October 2007</a>&nbsp;(31)<span>Lorem Ipsum Dolor Sit Amit</span></li>
  100 + </ul>
  101 + </li>
  102 + </ul>
  103 + </div>
  104 + <!-- end #sidebar -->
  105 + <div style="clear: both;">&nbsp;</div>
  106 + </div>
  107 + <!-- end #page -->
  108 + <div id="footer">
  109 + <p>Copyright (c) 2008 Sitename.com. All rights reserved. Design by <a href="http://www.freecsstemplates.org/">Free CSS Templates</a>.</p>
  110 + </div>
  111 + <!-- end #footer -->
  112 +</div>
  113 +</body>
  114 +</html>
5 App/Models/AuthorModel.hs
... ... @@ -0,0 +1,5 @@
  1 +module App.Models.AuthorModel
  2 + ( module App.Models.AuthorModel
  3 + , module App.Models.Bases.AuthorModelBase
  4 + ) where
  5 +import App.Models.Bases.AuthorModelBase
BIN  App/Models/Bases/.PageModelBase.hs.swp
Binary file not shown
58 App/Models/Bases/AuthorModelBase.hs
... ... @@ -0,0 +1,58 @@
  1 +{- DO NOT EDIT THIS FILE
  2 + THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD
  3 +
  4 + All changes should go into the Model file (e.g. App/Models/ExampleModel.hs) and
  5 + not into the base file (e.g. App/Models/Bases/ExampleModelBase.hs) -}
  6 +
  7 +module App.Models.Bases.AuthorModelBase (
  8 + module App.Models.Bases.AuthorModelBase,
  9 + module App.Models.Bases.ModelBase) where
  10 +
  11 +import App.Models.Bases.ModelBase
  12 +import qualified Database.HDBC as HDBC
  13 +import System.Time
  14 +
  15 +data Author = Author {
  16 + id :: Int64, name :: Maybe String
  17 + } deriving (Eq, Show)
  18 +
  19 +instance DatabaseModel Author where
  20 + tableName _ = "author"
  21 +
  22 +instance IsModel Author where
  23 + insert conn m = do
  24 + res <- liftIO $ HDBC.run conn " INSERT INTO author (id,name) VALUES (?,?)"
  25 + [HDBC.toSql $ id m , HDBC.toSql $ name m]
  26 + liftIO $ HDBC.commit conn
  27 + i <- liftIO $ HDBC.catchSql (HDBC.quickQuery' conn "SELECT lastval()" []) (\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) )
  28 + return $ HDBC.fromSql $ head $ head i
  29 + findAll conn = do
  30 + res <- liftIO $ HDBC.quickQuery' conn "SELECT id , name FROM author" []
  31 + return $ map (\r -> Author (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1))) res
  32 + findAllBy conn ss sp = do
  33 + res <- liftIO $ HDBC.quickQuery' conn ("SELECT id , name FROM author WHERE (" ++ ss ++ ") ") sp
  34 + return $ map (\r -> Author (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1))) res
  35 + findOneBy conn ss sp = do
  36 + res <- liftIO $ HDBC.quickQuery' conn ("SELECT id , name FROM author WHERE (" ++ ss ++ ") LIMIT 1") sp
  37 + return $ (\r -> Author (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1))) (head res)
  38 +instance HasFindByPrimaryKey Author (Int64) where
  39 + find conn pk@(pk1) = do
  40 + res <- liftIO $ HDBC.quickQuery' conn ("SELECT id , name FROM author WHERE (id = ? )") [HDBC.toSql pk1]
  41 + case res of
  42 + [] -> throwDyn $ HDBC.SqlError
  43 + {HDBC.seState = "",
  44 + HDBC.seNativeError = (-1),
  45 + HDBC.seErrorMsg = "No record found when finding by Primary Key:author : " ++ (show pk)
  46 + }
  47 + r:[] -> return $ Author (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1))
  48 + _ -> throwDyn $ HDBC.SqlError
  49 + {HDBC.seState = "",
  50 + HDBC.seNativeError = (-1),
  51 + HDBC.seErrorMsg = "Too many records found when finding by Primary Key:author : " ++ (show pk)
  52 + }
  53 +
  54 + update conn m = do
  55 + res <- liftIO $ HDBC.run conn "UPDATE author SET (id , name) = (?,?) WHERE (id = ? )"
  56 + [HDBC.toSql $ id m , HDBC.toSql $ name m, HDBC.toSql $ id m]
  57 + liftIO $ HDBC.commit conn
  58 + return ()
36 App/Models/Bases/ModelBase.hs
... ... @@ -0,0 +1,36 @@
  1 +{- DO NOT EDIT THIS FILE
  2 + THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD -}
  3 +
  4 +module App.Models.Bases.ModelBase (
  5 + module App.Models.Bases.ModelBase,
  6 + module Control.Exception,
  7 + module Control.Monad.Trans,
  8 + module Data.Int
  9 + ) where
  10 +
  11 +import Control.Monad.Trans
  12 +import Control.Exception
  13 +import Database.HDBC
  14 +import Data.Int
  15 +
  16 +import Turbinado.Controller.Monad
  17 +
  18 +-- Using phantom types here
  19 +class DatabaseModel m where
  20 + tableName :: m -> String
  21 +
  22 +type SelectString = String
  23 +type SelectParams = [SqlValue]
  24 +
  25 +class (DatabaseModel model) =>
  26 + IsModel model where
  27 + insert :: (MonadIO m, IConnection conn) => conn -> model -> m Integer
  28 + findAll :: (MonadIO m, IConnection conn) => conn -> m [model]
  29 + findAllBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m [model]
  30 + findOneBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m model
  31 +
  32 +class (DatabaseModel model) =>
  33 + HasFindByPrimaryKey model primaryKey | model -> primaryKey where
  34 + find :: (MonadIO m, IConnection conn) => conn -> primaryKey -> m model
  35 + update :: (MonadIO m, IConnection conn) => conn -> model -> m ()
  36 +
58 App/Models/Bases/PageModelBase.hs
... ... @@ -0,0 +1,58 @@
  1 +{- DO NOT EDIT THIS FILE
  2 + THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD
  3 +
  4 + All changes should go into the Model file (e.g. App/Models/ExampleModel.hs) and
  5 + not into the base file (e.g. App/Models/Bases/ExampleModelBase.hs) -}
  6 +
  7 +module App.Models.Bases.PageModelBase (
  8 + module App.Models.Bases.PageModelBase,
  9 + module App.Models.Bases.ModelBase) where
  10 +
  11 +import App.Models.Bases.ModelBase
  12 +import qualified Database.HDBC as HDBC
  13 +import System.Time
  14 +
  15 +data Page = Page {
  16 + _id :: String, authorId :: Maybe Int64, content :: String, title :: String, version :: Int64
  17 + } deriving (Eq, Show)
  18 +
  19 +instance DatabaseModel Page where
  20 + tableName _ = "page"
  21 +
  22 +instance IsModel Page where
  23 + insert conn m = do
  24 + res <- liftIO $ HDBC.run conn " INSERT INTO page (_id,author_id,content,title,version) VALUES (?,?,?,?,?)"
  25 + [HDBC.toSql $ _id m , HDBC.toSql $ authorId m , HDBC.toSql $ content m , HDBC.toSql $ title m , HDBC.toSql $ version m]
  26 + liftIO $ HDBC.commit conn
  27 + i <- liftIO $ HDBC.catchSql (HDBC.quickQuery' conn "SELECT lastval()" []) (\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) )
  28 + return $ HDBC.fromSql $ head $ head i
  29 + findAll conn = do
  30 + res <- liftIO $ HDBC.quickQuery' conn "SELECT _id , author_id , content , title , version FROM page" []
  31 + return $ map (\r -> Page (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1)) (HDBC.fromSql (r !! 2)) (HDBC.fromSql (r !! 3)) (HDBC.fromSql (r !! 4))) res
  32 + findAllBy conn ss sp = do
  33 + res <- liftIO $ HDBC.quickQuery' conn ("SELECT _id , author_id , content , title , version FROM page WHERE (" ++ ss ++ ") ") sp
  34 + return $ map (\r -> Page (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1)) (HDBC.fromSql (r !! 2)) (HDBC.fromSql (r !! 3)) (HDBC.fromSql (r !! 4))) res
  35 + findOneBy conn ss sp = do
  36 + res <- liftIO $ HDBC.quickQuery' conn ("SELECT _id , author_id , content , title , version FROM page WHERE (" ++ ss ++ ") LIMIT 1") sp
  37 + return $ (\r -> Page (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1)) (HDBC.fromSql (r !! 2)) (HDBC.fromSql (r !! 3)) (HDBC.fromSql (r !! 4))) (head res)
  38 +instance HasFindByPrimaryKey Page (String) where
  39 + find conn pk@(pk1) = do
  40 + res <- liftIO $ HDBC.quickQuery' conn ("SELECT _id , author_id , content , title , version FROM page WHERE (_id = ? )") [HDBC.toSql pk1]
  41 + case res of
  42 + [] -> throwDyn $ HDBC.SqlError
  43 + {HDBC.seState = "",
  44 + HDBC.seNativeError = (-1),
  45 + HDBC.seErrorMsg = "No record found when finding by Primary Key:page : " ++ (show pk)
  46 + }
  47 + r:[] -> return $ Page (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1)) (HDBC.fromSql (r !! 2)) (HDBC.fromSql (r !! 3)) (HDBC.fromSql (r !! 4))
  48 + _ -> throwDyn $ HDBC.SqlError
  49 + {HDBC.seState = "",
  50 + HDBC.seNativeError = (-1),
  51 + HDBC.seErrorMsg = "Too many records found when finding by Primary Key:page : " ++ (show pk)
  52 + }
  53 +
  54 + update conn m = do
  55 + res <- liftIO $ HDBC.run conn "UPDATE page SET (_id , author_id , content , title , version) = (?,?,?,?,?) WHERE (_id = ? )"
  56 + [HDBC.toSql $ _id m , HDBC.toSql $ authorId m , HDBC.toSql $ content m , HDBC.toSql $ title m , HDBC.toSql $ version m, HDBC.toSql $ _id m]
  57 + liftIO $ HDBC.commit conn
  58 + return ()
5 App/Models/PageModel.hs
... ... @@ -0,0 +1,5 @@
  1 +module App.Models.PageModel
  2 + ( module App.Models.PageModel
  3 + , module App.Models.Bases.PageModelBase
  4 + ) where
  5 +import App.Models.Bases.PageModelBase
38 App/Views/Develop/Index.hs
... ... @@ -1,4 +1,3 @@
1   -page :: View XML
2 1 page = <div>
3 2 <h2>! Windows</h2>
4 3 <p>This software doesn't work on Windows. Linux/Unix only at this point.</p>
@@ -6,36 +5,15 @@ page = <div>
6 5 <h2>Git Repo</h2>
7 6 <p> The <em>git</em> repo is at <% anchorTag "http://github.com/alsonkemp/turbinado/tree/master" "http://github.com/alsonkemp/turbinado/tree/master" %>. Push patches into the repo.</p>
8 7
9   - <h2>Dependencies</h2>
10   - <p>You'll need the following:</p>
  8 + <h2>To Do</h2>
11 9 <ul class="standard-list">
12   - <li><% anchorTag "http://www.haskell.org/ghc" "GHC" %>
13   - <em> (darcs) </em>
  10 + <li>
  11 + Move to a simpler templating system (e.g. <% anchorTag "http://haml.hamptoncatlin.com/" "HAML" %>-like ). HSX is a lovely piece of work, but it's pretty finicky and I feel like I'm trying to "see the Matrix" when I read its compilation error messages.
14 12 </li>
15   -
16   - <li><% anchorTag "http://code.haskell.org/HSP/haskell-src-exts/" "haskell-src-exts" %>
17   - <em> (darcs) </em>
18   - </li>
19   -
20   - <li><% anchorTag "http://code.haskell.org/HSP/harp/" "harp" %>
21   - <em> (darcs) </em>
22   - </li>
23   -
24   - <li><% anchorTag "http://git.complete.org/hslogger" "hslogger" %>
25   - <em> (git) </em>
26   - </li>
27   -
28   - <li><% anchorTag "http://code.haskell.org/HSP/hsx/" "hsx" %>
29   - <em> (darcs) </em>
30   - </li>
31   -
32   - <li><% anchorTag "http://code.haskell.org/hs-plugins" "hs-plugins" %>
33   - <em> (darcs) </em>
34   - </li>
35   -
36   - <li><% anchorTag "http://code.haskell.org/http" "http" %>
37   - <em> (darcs) </em>
38   - </li>
39   -
  13 + <li>Build a mini-CMS to manage these pages.</li>
  14 + <li>Complete the ORM in Turbinado/Database/ORM.</li>
  15 + <li>Implement cookie sessions.</li>
  16 + <li>Implement authentication.</li>
  17 + <li>Copy a couple of tutorial apps from Rails/Django tutorials.</li>
40 18 </ul>
41 19 </div>
21 App/Views/Home/About.hs
... ... @@ -1,21 +0,0 @@
1   -page = <div>
2   - <h1>Features</h1>
3   - <p>Turbinado gives you all of the benefits of coding in Haskell and adds:</p>
4   - <ul class="standard-list">
5   - <li> A fast HTTP server with static- and dynamic-content serving capabilities; </li>
6   - <li> Views built using a simple HTML-like templating syntax combined with tag-matching to guard against invalid HTML; </li>
7   - <li> Automagic recompilation of Controllers, Layouts and Views; </li>
8   - <li> <span style="font-size:10px; font-style:italic">coming soon</span> A database <% anchorTag "http://en.wikipedia.org/wiki/Object-relational_mapping" "ORM" %> to make database interaction (especially with PostgreSQL) joyful; </li>
9   - <li> A rich set of tags to make designing pages simpler;. </li>
10   - </ul>
11   -
12   - <h1>... On The Backs of Giants ... </h1>
13   - <p>Turbinado wouldn't be possible without the original work of the following people:</p>
14   - <ul class="standard-list">
15   - <li> <% anchorTag "http://www.haskell.org/ghc" "The GHC Team" %> for something as insane as Haskell and GHC</li>
16   - <li> <% anchorTag "http://www.cs.chalmers.se/~d00nibro/" "Niklas Broberg" %> for Haskell Server Pages, the HSP Runtime, Haskell Source Extensions and Haskell Regular Expressions</li>
17   - <li> <% anchorTag "http://www.cse.unsw.edu.au/~dons/hs-plugins/" "Don Stewart" %> for hs-plugins </li>
18   - <li> <% anchorTag "http://www.cs.chalmers.se/~bringert/projects.html" "Bjorn Bringert" %> for HTTP </li>
19   - <li> <% anchorTag "http://software.complete.org/software/projects/show/hdbc" "John Goerzen" %> for Haskell Database Connectivity.</li>
20   - </ul>
21   - </div>
4 App/Views/Home/Architecture.hs
... ... @@ -0,0 +1,4 @@
  1 +page = <div>
  2 + <h1>Architecture</h1>
  3 + <p>coming soon</p>
  4 + </div>
1  App/Views/Home/Hello.hs
... ... @@ -1,2 +1 @@
1   -page :: View XML
2 1 page = return $ cdata $ "Hello World"
20 App/Views/Home/Index.hs
... ... @@ -1,4 +1,3 @@
1   -page :: View XML
2 1 page = <div>
3 2 <h1>Turbinado?</h1>
4 3 <div style="float:right">
@@ -11,4 +10,23 @@ page = <div>
11 10
12 11 <h1>Why?</h1>
13 12 <p>Haskell has no easy-to-use web framework. Turbinado is an effort to build one by lazily stealing the best ideas from <% anchorTag "http://www.rubyonrails.org" "Ruby On Rails" %>, <% anchorTag "http://www.asp.net" "ASP.NET" %>, etc.</p>
  13 + <h1>Features</h1>
  14 + <p>Turbinado gives you all of the benefits of coding in Haskell and adds:</p>
  15 + <ul class="standard-list">
  16 + <li> A fast HTTP server with static- and dynamic-content serving capabilities; </li>
  17 + <li> Views built using a simple HTML-like templating syntax combined with tag-matching to guard against invalid HTML; </li>
  18 + <li> Automagic recompilation of Controllers, Layouts and Views; </li>
  19 + <li> <span style="font-size:10px; font-style:italic">coming soon</span> A database <% anchorTag "http://en.wikipedia.org/wiki/Object-relational_mapping" "ORM" %> to make database interaction (especially with PostgreSQL) joyful; </li>
  20 + <li> A rich set of tags to make designing pages simpler;. </li>
  21 + </ul>
  22 +
  23 + <h1>... On The Backs of Giants ... </h1>
  24 + <p>Turbinado wouldn't be possible without the original work of the following people:</p>
  25 + <ul class="standard-list">
  26 + <li> <% anchorTag "http://www.haskell.org/ghc" "The GHC Team" %> for something as insane as Haskell and GHC</li>
  27 + <li> <% anchorTag "http://www.cs.chalmers.se/~d00nibro/" "Niklas Broberg" %> for Haskell Server Pages, the HSP Runtime, Haskell Source Extensions and Haskell Regular Expressions</li>
  28 + <li> <% anchorTag "http://www.cse.unsw.edu.au/~dons/hs-plugins/" "Don Stewart" %> for hs-plugins </li>
  29 + <li> <% anchorTag "http://www.cs.chalmers.se/~bringert/projects.html" "Bjorn Bringert" %> for HTTP </li>
  30 + <li> <% anchorTag "http://software.complete.org/software/projects/show/hdbc" "John Goerzen" %> for Haskell Database Connectivity.</li>
  31 + </ul>
14 32 </div>
46 App/Views/Home/Install.hs
... ... @@ -0,0 +1,46 @@
  1 +page = <div>
  2 + <h1>Installation == Pain, Pain == Love</h1>
  3 + <p>
  4 + Given the relative immaturity of Haskell's package installation tools, installation of Turbinado is fairly challenging. With <% anchorTag "http://hackage.haskell.org/trac/hackage/wiki/CabalInstall" "cabal-install" %> this should get better, but, for now, installation is an adventure.
  5 + </p>
  6 + <p>
  7 + In addition to its many other joys, the ORM in Turbinado only works with PostgreSQL right now.
  8 + </p>
  9 + <h1>Suit up</h1>
  10 + <p>
  11 + You'll need to have the following packages installed to have a go at installation:
  12 + </p>
  13 + <ul class="standard-list">
  14 + <li><a href="http://www.haskell.org/ghc">GHC</a><em> (darcs) </em></li>
  15 + <li><a href="http://code.haskell.org/HSP/haskell-src-exts/">haskell-src-exts</a><em> (darcs) </em></li>
  16 + <li><a href="http://code.haskell.org/HSP/harp/">harp</a><em> (darcs) </em></li>
  17 + <li><a href="http://git.complete.org/hslogger">hslogger</a><em> (git) </em></li>
  18 + <li><a href="http://code.haskell.org/encoding/">encoding</a><em> (darcs) </em></li>
  19 + <li><a href="http://code.haskell.org/HSP/hsx/">hsx</a><em> (darcs) </em></li>
  20 + <li><a href="http://code.haskell.org/hs-plugins">hs-plugins</a><em> (darcs) </em></li>
  21 + <li><a href="http://code.haskell.org/http">http</a><em> (darcs) </em></li>
  22 + <li><a href="http://git.complete.org/hdbc">HDBC</a><em> (git) </em></li>
  23 + <li><a href="http://git.complete.org/hdbc-postgresql">HDBC-PostgreSQL</a><em> (git) </em></li>
  24 + </ul>
  25 + <h1>Grab the code:</h1>
  26 + <pre>
  27 + git clone git://github.com/alsonkemp/turbinado.git
  28 + </pre>
  29 + <h1>Build it</h1>
  30 + <p>
  31 + With all of the packages installed, wait for a new moon, stand on tip-toes, and do the following:
  32 + </p>
  33 + <pre>
  34 + runghc Setup.lhs configure
  35 + runghc Setup.lhs build
  36 + </pre>
  37 + <p>
  38 + If everything goes well, you should be able to do:
  39 + </p>
  40 + <pre>
  41 + dist/build/turbinado/turbinado -p 9999
  42 + </pre>
  43 + <p>
  44 + Try browsing to http://the-machines-name:9999/images/1x1.gif.
  45 + </p>
  46 + </div>
1  App/Views/Home/Performance.hs
... ... @@ -1,4 +1,3 @@
1   -page :: View XML
2 1 page = <div>
3 2 <h1>Performance</h1>
4 3 <p>
15 App/Views/Page/Edit.hs
... ... @@ -0,0 +1,15 @@
  1 +page = <div>
  2 + <form action=(getViewDataValue_u "save-url" :: View String) method="post">
  3 + <div>
  4 + Title:
  5 + <input type="text" id="title" name="title" value=(getViewDataValue_u "page-title" :: View String) />
  6 + </div>
  7 + <div>
  8 + Content:
  9 + <textarea rows="25" columns="80" name="content" id="content">
  10 + <% (getViewDataValue_u "page-content" :: View String) %>
  11 + </textarea>
  12 + </div>
  13 + <input type="submit" value="Save"/>
  14 + </form>
  15 + </div>
15 App/Views/Page/Index.hs
... ... @@ -0,0 +1,15 @@
  1 +page = <div>
  2 + <h1>
  3 + Page Index
  4 + </h1>
  5 + <% (getViewDataValue_u "pages-list" :: View [(String, String)]) >>=
  6 + \l -> mapM indexItem l %>
  7 + </div>
  8 +
  9 +indexItem (t,i) = return $ cdata $ unlines $
  10 + ["<div style='padding: 0pt 5px;'>"
  11 + ," <a href=\"/Page/Show/" ++ i ++"\">"
  12 + ," "++ t
  13 + ," </a>"
  14 + ,"</div>"
  15 + ]
13 App/Views/Page/New.hs
... ... @@ -0,0 +1,13 @@
  1 +page = <div>
  2 + <form action=(getViewDataValue_u "save-url" :: View String) method="post">
  3 + <div>
  4 + Title:
  5 + <input type="text" id="title" name="title" />
  6 + </div>
  7 + <div>
  8 + Content:
  9 + <textarea rows="25" columns="80" name="content" id="content" />
  10 + </div>
  11 + <input type="submit" value="Save"/>
  12 + </form>
  13 + </div>
4 App/Views/Page/Show.hs
... ... @@ -1,4 +1,4 @@
1   -page :: View XML
2 1 page = <div>
3   - <% getViewDataValue "page-content" %>
  2 + <h1><% getViewDataValue_u "page-title" :: View String %></h1>
  3 + <% getViewDataValue_u "page-content" :: View String %>
4 4 </div>
1  App/Views/Tutorial/Index.hs
... ... @@ -1,4 +1,3 @@
1   -page :: View XML
2 1 page = <div>
3 2 <h2>DANGER WILL ROBINSON</h2>
4 3 <p>Developers only at this point!</p>
6 Config/App.hs
@@ -28,8 +28,8 @@ newAppEnvironment = AppEnvironment
28 28 -- Database connection
29 29 ----------------------------------------------------------------
30 30 databaseConnection :: Maybe (IO Connection)
31   -databaseConnection = Nothing
32   -
  31 +-- databaseConnection = Nothing
  32 +databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado user=turbinado password=turbinado"
33 33
34 34 ----------------------------------------------------------------
35 35 -- RequestHandler Filter List additions
@@ -41,6 +41,6 @@ customPostFilters = []
41 41 ----------------------------------------------------------------
42 42 -- Logging
43 43 ----------------------------------------------------------------
44   -logLevel = ERROR -- DEBUG < INFO < NOTICE < WARNING < ERROR < CRITICAL < ALERT < EMERGENCY
  44 +logLevel = DEBUG -- DEBUG < INFO < NOTICE < WARNING < ERROR < CRITICAL < ALERT < EMERGENCY
45 45
46 46
7 Config/Master.hs
... ... @@ -1,10 +1,8 @@
1 1 module Config.Master (
2 2 module Config.Master,
3   - module Config.App,
4   - Turbinado.Server.Handlers.SessionHandlers.Simple.getSessionHandler
  3 + module Config.App
5 4 ) where
6 5
7   -import Turbinado.Server.Handlers.SessionHandlers.Simple
8 6 import Config.App
9 7
10 8 ----------------------------------------------------------------
@@ -28,6 +26,7 @@ mUserPkgConf = [""]
28 26 -- Paths
29 27 ----------------------------------------------------------------
30 28
  29 +modelDir = "App/Models"
31 30 viewDir = "App/Views"
32 31 viewStub = "Turbinado/Stubs/View.hs"
33 32 layoutDir = "App/Layouts"
@@ -36,7 +35,7 @@ controllerDir = "App/Controllers"
36 35 controllerStub = "Turbinado/Stubs/Controller.hs"
37 36
38 37 configDir = "Config"
39   -searchDirs = [viewDir, layoutDir, controllerDir, rootDir, configDir, compiledDir]
  38 +searchDirs = [modelDir, viewDir, layoutDir, controllerDir, rootDir, configDir, compiledDir]
40 39
41 40 staticDirs = ["static", "tmp/cache"]
42 41 compiledDir = "tmp/compiled"
6 Turbinado/Controller.hs
@@ -17,7 +17,9 @@ module Turbinado.Controller (
17 17 module Data.Maybe,
18 18
19 19 module Turbinado.Environment.CodeStore,
  20 + module Turbinado.Environment.Header,
20 21 module Turbinado.Environment.Logger,
  22 + module Turbinado.Environment.Params,
21 23 module Turbinado.Environment.Request,
22 24 module Turbinado.Environment.Response,
23 25 module Turbinado.Environment.Settings,
@@ -34,15 +36,17 @@ import qualified Network.HTTP as HTTP
34 36 import Prelude hiding (catch)
35 37 import qualified Database.HDBC as HDBC
36 38
  39 +import Turbinado.Environment.CodeStore
37 40 import Turbinado.Environment.Database
  41 +import Turbinado.Environment.Header
38 42 import Turbinado.Environment.Logger
  43 +import Turbinado.Environment.Params
39 44 import Turbinado.Environment.Request
40 45 import Turbinado.Environment.Response
41 46 import Turbinado.Environment.Settings
42 47 import Turbinado.Environment.Types
43 48 import Turbinado.Environment.ViewData
44 49 import Turbinado.Controller.Monad
45   -import Turbinado.Environment.CodeStore
46 50 import Turbinado.Utility.General
47 51 import Turbinado.Server.StandardResponse
48 52
22 Turbinado/Database/ORM/Generator.hs
@@ -24,11 +24,13 @@ buildTable conn tcs t = do ds <- describeTable conn t
24 24 pks <- getPrimaryKeys conn t
25 25 let tcs'' = combinePrimaryKeys t pks tcs'
26 26 fks <- getForeignKeyReferences conn t
27   - return $ combineForeignKeyReferences t fks tcs''
  27 + let tcs''' = combineForeignKeyReferences t fks tcs''
  28 + hds <- getDefaultColumns conn t
  29 + return $ combineDefaultColumns t hds tcs'''
28 30
29 31 combineDescription t ds tcs = M.insert t (cols, []) tcs
30 32 where cols = M.fromList $
31   - map (\(columnName, columnDescription) -> (columnName, (columnDescription,[]))) ds
  33 + map (\(columnName, columnDescription) -> (columnName, (columnDescription,[], False))) ds
32 34
33 35 combinePrimaryKeys :: TableName -> [ColumnName] -> Tables -> Tables
34 36 combinePrimaryKeys t pks tcs = M.adjust (\(c, _) -> (c,pks)) t tcs
@@ -38,9 +40,13 @@ combineForeignKeyReferences t fks tcs =
38 40 M.adjust
39 41 (\(cs, pks) -> (foldl (worker) cs fks, pks))
40 42 t tcs
41   - where worker cs (c, tt, tc) = M.adjust (\(cd, deps) -> (cd, [(tt, tc)] `union` deps)) c cs
42   -{-
43   - - combineTablesColumns :: [TableName] -> [(ColumnName, SqlColDesc)] -> Tables
44   - - combineTablesColumsn ts cs =
45   - - M.fromList $ zipWith (\t (c, d) -> (t, (c, [])) ) ts cs
46   - -}
  43 + where worker cs (c, tt, tc) = M.adjust (\(cd, deps, hd) -> (cd, [(tt, tc)] `union` deps, hd)) c cs
  44 +
  45 +combineDefaultColumns :: TableName -> [ColumnName] -> Tables -> Tables
  46 +combineDefaultColumns t hds tcs =
  47 + M.adjust
  48 + (\(cs, pks) -> (foldl (worker) cs hds, pks))
  49 + t tcs
  50 + where worker cs hd = M.adjust (\(cd, deps, _) -> (cd, deps, True)) hd cs
  51 +
  52 +
138 Turbinado/Database/ORM/Output.hs
@@ -40,14 +40,15 @@ generateModel t typeName pk cs =
40 40 ["{- DO NOT EDIT THIS FILE"
41 41 ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
42 42 ,""
43   - ," All changes should go into the Model file (e.g. ExampleModel.hs) and"
44   - ," not into the base file (e.g. ExampleModelBase.hs) -}"
  43 + ," All changes should go into the Model file (e.g. App/Models/ExampleModel.hs) and"
  44 + ," not into the base file (e.g. App/Models/Bases/ExampleModelBase.hs) -}"
45 45 ,""
46   - ,"module Models.Bases." ++ typeName ++ "ModelBase ( "
47   - ," module Models.Bases." ++ typeName ++ "ModelBase, "
48   - ," module Models.Bases.ModelBase) where"
  46 + ,"module App.Models.Bases." ++ typeName ++ "ModelBase ( "
  47 + ," module App.Models.Bases." ++ typeName ++ "ModelBase, "
  48 + ," module App.Models.Bases.ModelBase) where"
49 49 , ""
50   - , "import Models.Bases.ModelBase"
  50 + , "import App.Models.Bases.ModelBase"
  51 + , "import qualified Database.HDBC as HDBC"
51 52 , "import System.Time"
52 53 , ""
53 54 , "data " ++ typeName ++ " = " ++ typeName ++ " {"
@@ -59,16 +60,16 @@ generateModel t typeName pk cs =
59 60 , " tableName _ = \"" ++ t ++ "\""
60 61 , ""
61 62 ] ++
62   - generateFindByPrimaryKey t cs typeName pk ++
63   - generateFinders t cs typeName
  63 + generateIsModel t cs typeName ++
  64 + generateHasFindByPrimaryKey t cs typeName pk
64 65
65 66 generateModelFile typeName =
66 67 unlines $
67   - ["module Models." ++ typeName ++ "Model"
68   - ," ( module Models." ++ typeName ++ "Model"
69   - ," , module Models.Bases." ++ typeName ++ "ModelBase"
  68 + ["module App.Models." ++ typeName ++ "Model"
  69 + ," ( module App.Models." ++ typeName ++ "Model"
  70 + ," , module App.Models.Bases." ++ typeName ++ "ModelBase"
70 71 ," ) where"
71   - ,"import Models.Bases." ++ typeName ++ "ModelBase"
  72 + ,"import App.Models.Bases." ++ typeName ++ "ModelBase"
72 73 ]
73 74
74 75 generateModelBase :: String
@@ -76,18 +77,21 @@ generateModelBase = unlines $
76 77 ["{- DO NOT EDIT THIS FILE"
77 78 ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD -}"
78 79 ,""
79   - ,"module Models.Bases.ModelBase ("
80   - ," module Models.Bases.ModelBase,"
  80 + ,"module App.Models.Bases.ModelBase ("
  81 + ," module App.Models.Bases.ModelBase,"
81 82 ," module Control.Exception,"
82   - ," module Database.HDBC,"
  83 + ," module Control.Monad.Trans,"
83 84 ," module Data.Int"
84   - ,") where"
  85 + ," ) where"
85 86 ,""
  87 + ,"import Control.Monad.Trans"
86 88 ,"import Control.Exception"
87 89 ,"import Database.HDBC"
88 90 ,"import Data.Int"
89 91 ,""
90   - ,"{- Using phantom types here -}"
  92 + ,"import Turbinado.Controller.Monad"
  93 + ,""
  94 + ,"-- Using phantom types here "
91 95 ,"class DatabaseModel m where"
92 96 ," tableName :: m -> String"
93 97 ,""
@@ -95,14 +99,16 @@ generateModelBase = unlines $
95 99 ,"type SelectParams = [SqlValue]"
96 100 ,""
97 101 ,"class (DatabaseModel model) =>"
98   - ," HasFindByPrimaryKey model primaryKey | model -> primaryKey where"
99   - ," find :: IConnection conn => conn -> primaryKey -> IO model"
  102 + ," IsModel model where"
  103 + ," insert :: (MonadIO m, IConnection conn) => conn -> model -> m Integer"
  104 + ," findAll :: (MonadIO m, IConnection conn) => conn -> m [model]"
  105 + ," findAllBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m [model]"
  106 + ," findOneBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m model"
100 107 ,""
101 108 ,"class (DatabaseModel model) =>"
102   - ," HasFinders model where"
103   - ," findAll :: IConnection conn => conn -> IO [model]"
104   - ," findAllBy :: IConnection conn => conn -> SelectString -> SelectParams -> IO [model]"
105   - ," findOneBy :: IConnection conn => conn -> SelectString -> SelectParams -> IO model"
  109 + ," HasFindByPrimaryKey model primaryKey | model -> primaryKey where"
  110 + ," find :: (MonadIO m, IConnection conn) => conn -> primaryKey -> m model"
  111 + ," update :: (MonadIO m, IConnection conn) => conn -> model -> m () "
106 112 ,""
107 113 ]
108 114
@@ -110,41 +116,53 @@ generateModelBase = unlines $
110 116 -- Generator templates --
111 117 ---------------------------------------------------------------------------
112 118
113   -generateFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
114   -generateFindByPrimaryKey t cs typeName pk =
  119 +generateIsModel :: TableName -> Columns -> TypeName -> [String]
  120 +generateIsModel t cs typeName =
  121 + ["instance IsModel " ++ typeName ++ " where"
  122 + ," insert conn m = do"
  123 + ," res <- liftIO $ HDBC.run conn \" INSERT INTO " ++ t ++ " (" ++ (concat $ intersperse "," $ M.keys cs) ++") VALUES (" ++ (intercalate "," (take (M.size cs) (repeat "?"))) ++ ")\""
  124 + ," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") (M.keys cs) ) ++ "]"
  125 + ," liftIO $ HDBC.commit conn"
  126 + ," i <- liftIO $ HDBC.catchSql (HDBC.quickQuery' conn \"SELECT lastval()\" []) (\\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) ) "
  127 + ," return $ HDBC.fromSql $ head $ head i"
  128 + ," findAll conn = do"
  129 + ," res <- liftIO $ HDBC.quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
  130 + ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
  131 + ," findAllBy conn ss sp = do"
  132 + ," res <- liftIO $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
  133 + ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
  134 + ," findOneBy conn ss sp = do"
  135 + ," res <- liftIO $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
  136 + ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
  137 + ]
  138 +
  139 +generateHasFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
  140 +generateHasFindByPrimaryKey t cs typeName pk =
115 141 case (length pk) of
116 142 0 -> [""]
117   - _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ fst $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
  143 + _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ (\(c',_,_) -> c') $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
118 144 ," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
119   - ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t ++ " WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
  145 + ," res <- liftIO $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t ++ " WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "HDBC.toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
120 146 ," case res of"
121   - ," [] -> throwDyn $ SqlError"
122   - ," {seState = \"\","
123   - ," seNativeError = (-1),"
124   - ," seErrorMsg = \"No record found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
  147 + ," [] -> throwDyn $ HDBC.SqlError"
  148 + ," {HDBC.seState = \"\","
  149 + ," HDBC.seNativeError = (-1),"
  150 + ," HDBC.seErrorMsg = \"No record found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
125 151 ," }"
126 152 ," r:[] -> return $ " ++ (generateConstructor cs typeName)
127   - ," _ -> throwDyn $ SqlError"
128   - ," {seState = \"\","
129   - ," seNativeError = (-1),"
130   - ," seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
  153 + ," _ -> throwDyn $ HDBC.SqlError"
  154 + ," {HDBC.seState = \"\","
  155 + ," HDBC.seNativeError = (-1),"
  156 + ," HDBC.seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
131 157 ," }"
  158 + ,""
  159 + ," update conn m = do"
  160 + ," res <- liftIO $ HDBC.run conn \"UPDATE " ++ t ++ " SET (" ++ (unwords $ intersperse "," $ M.keys cs) ++ ") = (" ++ (intercalate "," $ (take (M.size cs) (repeat "?"))) ++ ") WHERE (" ++ (generatePrimaryKeyWhere pk) ++")\""
  161 + ," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") (M.keys cs) ) ++ ", " ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") pk ) ++ "]"
  162 + ," liftIO $ HDBC.commit conn"
  163 + ," return ()"
132 164 ]
133 165
134   -generateFinders :: TableName -> Columns -> TypeName -> [String]
135   -generateFinders t cs typeName =
136   - ["instance HasFinders " ++ typeName ++ " where"
137   - ," findAll conn = do"
138   - ," res <- quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
139   - ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
140   - ," findAllBy conn ss sp = do"
141   - ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
142   - ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
143   - ," findOneBy conn ss sp = do"
144   - ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
145   - ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
146   - ]
147   -
148 166 {-----------------------------------------------------------------------}
149 167 generatePrimaryKeyWhere pk =
150 168 unwords $
@@ -153,7 +171,7 @@ generatePrimaryKeyWhere pk =
153 171
154 172 generateConstructor cs typeName =
155 173 typeName ++ " " ++ (unwords $
156   - map (\i -> "(fromSql (r !! " ++ (show i) ++ "))") [0..((M.size cs) - 1)])
  174 + map (\i -> "(HDBC.fromSql (r !! " ++ (show i) ++ "))") [0..((M.size cs) - 1)])
157 175
158 176
159 177 ---------------------------------------------------------------------------
@@ -162,12 +180,16 @@ generateConstructor cs typeName =
162 180 cols :: Columns -> String
163 181 cols cs = unwords $ intersperse "," $ M.keys cs
164 182
165   -columnToFieldLabel :: (String, (SqlColDesc, ForeignKeyReferences)) -> String
166   -columnToFieldLabel (name, (desc, _)) =
  183 +columnToFieldLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
  184 +columnToFieldLabel cd@(name, (desc, _, _)) =
167 185 " " ++ partiallyCapitalizeName name ++ " :: " ++
168   - (if ((colNullable desc) == Just True) then "Maybe " else "") ++
  186 + maybeColumnLabel cd ++
169 187 getHaskellTypeString (colType desc)
170 188
  189 +maybeColumnLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
  190 +maybeColumnLabel (_, (_, _, True)) = "Maybe " -- Does the column have a default
  191 +maybeColumnLabel (_, (desc, _, _)) = if ((colNullable desc) == Just True) then "Maybe " else ""
  192 +maybeColumnLabel _ = ""
171 193
172 194 getHaskellTypeString :: SqlTypeId -> String
173 195 getHaskellTypeString SqlCharT = "String"
@@ -202,11 +224,11 @@ class TableType a where
202 224 --
203 225 -- Converts "column_name" to "ColumnName" (for types)
204 226 --
205   -capitalizeName colname =
206   - concat $
207   - map (\(s:ss) -> (Data.Char.toUpper s) : ss) $
208   - words $
209   - map (\c -> if (c=='_') then ' ' else c) colname
  227 +capitalizeName (colname':colname) =
  228 + concat
  229 + (map (\(s:ss) -> (Data.Char.toUpper s) : ss) $
  230 + words $ (Data.Char.toUpper colname') :
  231 + map (\c -> if (c=='_') then ' ' else c) colname)
210 232
211 233
212 234 --
19 Turbinado/Database/ORM/PostgreSQL.hs
@@ -46,7 +46,24 @@ getForeignKeyReferences conn t =
46 46 , " and c2.relname = ?;"
47 47 ]) [toSql t]
48 48 return $ map (\r -> (fromSql $ r !! 0, fromSql $ r !! 1, fromSql $ r !! 2)) rs
49   -
  49 +
  50 +
  51 +getDefaultColumns:: IConnection conn => conn -> String -> IO [String]
  52 +getDefaultColumns conn t =
  53 + do rs <- quickQuery conn (concat
  54 + [ "select a.attname as column_name"
  55 + , " from pg_class c"
  56 + , " join pg_namespace n on (n.oid = c.relnamespace)"
  57 + , " join pg_attribute a on (a.attrelid = c.oid"
  58 + , " and not a.attisdropped"
  59 + , " and a.attnum > 0)"
  60 + , " left join pg_attrdef ad on (a.attrelid = ad.adrelid"
  61 + , " and a.attnum = ad.adnum)"
  62 + , " where n.nspname = 'public'"
  63 + , " and c.relname = ?"
  64 + , " and (ad.adsrc IS NOT NULL);"]) [toSql t]
  65 + return $ map (\r -> fromSql $ r !! 0) rs
  66 +
50 67 {-
51 68
52 69 INDEX COLUMNS
3  Turbinado/Database/ORM/Types.hs
@@ -8,6 +8,7 @@ type TableName = String
8 8 type Columns = M.Map ColumnName ColumnDesc
9 9 type ColumnName = String
10 10 type PrimaryKey = [ColumnName]
11   -type ColumnDesc = (SqlColDesc, ForeignKeyReferences)
  11 +type ColumnDesc = (SqlColDesc, ForeignKeyReferences, HasDefault)
  12 +type HasDefault = Bool
12 13 type ForeignKeyReferences = [(TableName, ColumnName)] -- all columns which are targets of foreign keys
13 14
47 Turbinado/Environment.hs
... ... @@ -1,47 +0,0 @@
1   -module Turbinado.Environment (
2   - Environment,
3   - newEnvironment,
4   - EnvironmentFilter
5   - ) where
6   -
7   -import Data.Map
8   -import Data.Maybe
9   -import System.IO
10   -import Config.Master
11   -
12   -import Turbinado.Environment.CodeStore
13   -import Turbinado.Environment.Logger
14   -import Turbinado.Environment.MimeTypes
15   -import Turbinado.Environment.Request
16   -import Turbinado.Environment.Response
17   -import Turbinado.Environment.Routes
18   -import Turbinado.Environment.Settings
19   -import Turbinado.Environment.ViewData
20   -
21   -data Environment = Environment { getCodeStore :: Maybe CodeStore
22   - , getLogger :: Maybe Logger
23   - , getMimeTypes :: Maybe MimeTypes
24   - , request :: Maybe Request
25   - , getResponse :: Maybe Response
26   - , getRoutes :: Maybe Routes
27   - , getSettings :: Maybe Settings
28   - , getViewData :: Maybe ViewData
29   - , getAppEnvironment :: Maybe AppEnvironment
30   - }
31   -
32   -type EnvironmentFilter = Environment -> IO Environment
33   -
34   -newEnvironment :: IO Environment
35   -newEnvironment = return $ Environment {
36   - getCodeStore = Nothing
37   - , getLogger = Nothing
38   - , getMimeTypes = Nothing
39   - , getRequest = Nothing
40   - , getResponse = Nothing
41   - , getRoutes = Nothing
42   - , getSettings = Nothing
43   - , getViewData = Nothing
44   - , getAppEnvironment = Nothing
45   - }
46   -
47   -
34 Turbinado/Environment/CodeStore.hs