Browse files

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

  • Loading branch information...
1 parent 9a9af21 commit a1aa2cd5e2e2c18cefb93572b5f0bbdfbf22f87b @alsonkemp committed Dec 11, 2008
Showing with 916 additions and 236 deletions.
  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
View
9 App/Controllers/Home.hs
@@ -2,12 +2,15 @@
index :: Controller ()
index = return ()
-about :: Controller ()
-about = return ()
-
performance :: Controller ()
performance = return ()
+install :: Controller ()
+install = return ()
+
+architecture :: Controller ()
+architecture= return ()
+
hello :: Controller ()
hello = clearLayout
View
60 App/Controllers/Page.hs
@@ -1,16 +1,58 @@
+import App.Models.PageModel
+
index :: Controller ()
-index = do pages <- quickQuery' "select * from page" []
- return ()
+index = do conn <- liftIO $ fromJust $ databaseConnection
+ pages <- liftIO $ findAll conn
+ setViewDataValue "pages-list" $ map (\p -> (title p, _id p)) pages
show :: Controller ()
-show = do e <- getEnvironment
- let id' = getSetting "id" e :: Maybe String
- doIO $ debugM e $ "XXXXXXXX id' = " ++ (Prelude.show id')
+show = do conn <- liftIO $ fromJust $ databaseConnection
+ e <- get
+ id' <- getSetting "id"
+ case id' of
+ Nothing -> redirectTo "/Home"
+ Just i -> do p <- find conn i
+ setViewDataValue "page-title" (title p)
+ setViewDataValue "page-content" (content p)
+
+new :: Controller ()
+new = do conn <- liftIO $ fromJust $ databaseConnection
+ e <- get
+ id' <- getSetting "id"
case id' of
Nothing -> redirectTo "/Home"
- Just i -> do q <- quickQuery' "select title, content from page where id = ?" [toSql i]
- e' <- doIO $ setViewDataValue "page-title" (Prelude.show $ (head q) !! 0) e
- e''<- doIO $ setViewDataValue "page-content" (Prelude.show $ (head q) !! 1) e
- put e''
+ Just i -> do setViewDataValue "save-url" ("/Page/Create/" ++ i)
+create :: Controller ()
+create = do conn <- liftIO $ fromJust $ databaseConnection
+ e <- get
+ id' <- getSetting "id"
+ _title <- getParam_u "title"
+ _content <- getParam_u "content"
+ case id' of
+ Nothing -> redirectTo "/Home"
+ Just i -> do App.Models.PageModel.insert conn Page {authorId = Nothing,_id = i, title = _title, content = _content, version = 1}
+ redirectTo $ "/Page/Show/" ++ i
+edit :: Controller ()
+edit = do conn <- liftIO $ fromJust $ databaseConnection
+ e <- get
+ id' <- getSetting "id"
+ case id' of
+ Nothing -> redirectTo "/Home"
+ Just i -> do p <- find conn i
+ setViewDataValue "save-url" ("/Page/Save/" ++ i)
+ setViewDataValue "page-title" (title p)
+ setViewDataValue "page-content" (content p)
+save :: Controller ()
+save = do conn <- liftIO $ fromJust $ databaseConnection
+ e <- get
+ id' <- getSetting "id"
+ _title <- getParam_u "title"
+ _content <- getParam_u "content"
+ case id' of
+ Nothing -> redirectTo "/Home"
+ Just i -> do p <- find conn i
+ App.Models.PageModel.update conn p {title = _title, content = _content}
+ redirectTo $ "/Page/Show/" ++ i
+
View
12 App/Layouts/Default.hs
@@ -4,7 +4,6 @@ import Data.Maybe
import qualified Network.HTTP as HTTP
import qualified Network.URI as URI
-page :: View XML
page = <html>
<head>
<% styleSheet "normalize" "screen" %>
@@ -30,11 +29,12 @@ page = <html>
</div>
<div id="menu">
<ul>
- <% menuItem "/Home/Index" "Home" %>
- <% menuItem "/Home/About" "About" %>
- <% menuItem "/Home/Performance" "Performance" %>
- <% menuItem "/Tutorial/Index" "Tutorial" %>
- <% menuItem "/Develop/Index" "Develop" %>
+ <% menuItem "/Home/Index" "Home" %>
+ <% menuItem "/Home/Performance" "Performance" %>
+ <% menuItem "/Home/Architecture" "Architecture" %>
+ <% menuItem "/Home/Install" "Install" %>
+ <% menuItem "/Tutorial/Index" "Tutorial" %>
+ <% menuItem "/Develop/Index" "Develop" %>
</ul>
</div>
<div id="page">
View
53 App/Layouts/Default.hs.old
@@ -0,0 +1,53 @@
+page :: View XML
+page = <html>
+ <head>
+ <% styleSheet "normalize" "screen" %>
+ <% styleSheet "jsddm" "screen" %>
+ <% styleSheet "turbinado" "screen" %>
+ <% javaScript "jquery" %>
+ <% javaScript "jsddm" %>
+ <script type="text/javascript">
+ var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");
+ document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));
+ </script>
+ <script type="text/javascript">
+ var pageTracker = _gat._getTracker("UA-6158816-1");
+ pageTracker._trackViewview();
+ </script>
+ </head>
+ <body>
+ <table class="wrapper">
+ <tr>
+ <td class="title">
+ <h1>Turbinado</h1>
+ <img class="title-image" src="/images/turbinado.jpg" />
+ <h2>Sugar For</h2>
+ <h2>The Web</h2>
+ </td>
+ <td class="container">
+ <ul id="jsddm">
+ <li><a href="/Home/Index">Home</a>
+ <ul>
+ <li><a href="/Home/About">About</a></li>
+ <li><a href="/Home/Performance">Performance</a></li>
+ </ul>
+ </li>
+ <li><a href="/Tutorial/Index">Tutorial</a>
+ </li>
+ <li><a href="/Develop/Index">Develop</a></li>
+ </ul>
+ <div class="clear"></div>
+ <% breadCrumbs %>
+ <div id="content-block" class="content-block">
+ <% insertView %>
+ </div>
+ </td>
+ </tr>
+ <tr>
+ <td colspan="2">
+ <div class="footer">Turbinado - www.turbinado.org</div>
+ </td>
+ </tr>
+ </table>
+ </body>
+ </html>
View
114 App/Layouts/index.html
@@ -0,0 +1,114 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<!--
+Design by Free CSS Templates
+http://www.freecsstemplates.org
+Released for free under a Creative Commons Attribution 2.5 License
+
+Name : Pressurized
+Description: A two-column, fixed-width design with dark color scheme.
+Version : 1.0
+Released : 20081103
+
+-->
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<meta name="keywords" content="" />
+<meta name="description" content="" />
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<title>Pressurized by Free CSS Templates</title>
+<link href="style.css" rel="stylesheet" type="text/css" media="screen" />
+</head>
+<body>
+<div id="wrapper">
+ <div id="header">
+ <div id="logo">
+ <h1><a href="#">Pressurized </a></h1>
+ <p> design by <a href="http://www.freecsstemplates.org/">Free CSS Templates</a></p>
+ </div>
+ </div>
+ <!-- end #header -->
+ <div id="menu">
+ <ul>
+ <li class="first"><a href="#">Home</a></li>
+ <li><a href="#">Blog</a></li>
+ <li><a href="#">Photos</a></li>
+ <li><a href="#">About</a></li>
+ <li><a href="#">Links</a></li>
+ <li><a href="#">Contact</a></li>
+ </ul>
+ </div>
+ <!-- end #menu -->
+ <div id="page">
+ <div id="content">
+ <div class="post">
+ <h1 class="title"><a href="#">Welcome to Pressurized </a></h1>
+ <div class="entry">
+ <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>
+ <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>
+ </div>
+ <p class="meta">Posted by <a href="#">Someone</a> on March 10, 2008
+ &nbsp;&bull;&nbsp; <a href="#" class="comments">Comments (64)</a> &nbsp;&bull;&nbsp; <a href="#" class="permalink">Full article</a></p>
+ </div>
+ <div class="post">
+ <h2 class="title"><a href="#">Lorem ipsum sed aliquam</a></h2>
+ <div class="entry">
+ <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>
+ <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>
+ </div>
+ <p class="meta">Posted by <a href="#">Someone</a> on March 8, 2008
+ &nbsp;&bull;&nbsp; <a href="#" class="comments">Comments (64)</a> &nbsp;&bull;&nbsp; <a href="#" class="permalink">Full article</a></p>
+ </div>
+ <div class="post">
+ <h2 class="title"><a href="#">Phasellus pellentesque turpis </a></h2>
+ <div class="entry">
+ <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>
+ </div>
+ <p class="meta">Posted by <a href="#">Someone</a> on March 8, 2008
+ &nbsp;&bull;&nbsp; <a href="#" class="comments">Comments (64)</a> &nbsp;&bull;&nbsp; <a href="#" class="permalink">Full article</a></p>
+ </div>
+ </div>
+ <!-- end #content -->
+ <div id="sidebar">
+ <ul>
+ <li>
+ <h2>Aliquam tempus</h2>
+ <p>Mauris vitae nisl nec metus placerat perdiet est. Phasellus dapibus semper urna ornare consectetuer hendrerit.</p>
+ </li>
+ <li>
+ <h2>Categories</h2>
+ <ul>
+ <li><a href="#">Uncategorized</a> (3)<span>Lorem Ipsum Dolor Sit Amit</span></li>
+ <li><a href="#">Lorem Ipsum</a> (42)<span>Lorem Ipsum Dolor Sit Amit</span></li>
+ <li><a href="#">Urna Congue Rutrum</a> (28)<span>Lorem Ipsum Dolor Sit Amit</span> </li>
+ <li><a href="#">Vivamus Fermentum</a> (13)<span>Lorem Ipsum Dolor Sit Amit</span> </li>
+ </ul>
+ </li>
+ <li>
+ <h2>Blogroll</h2>
+ <ul>
+ <li><a href="#">Phasellus Pellentesque</a><span>Lorem Ipsum Dolor Sit Amit</span> </li>
+ <li><a href="#">Consectetuer Adipiscing</a><span>Lorem Ipsum Dolor Sit Amit</span> </li>
+ <li><a href="#">Urna Congue Rutrum</a><span>Lorem Ipsum Dolor Sit Amit</span> </li>
+ </ul>
+ </li>
+ <li>
+ <h2>Archives</h2>
+ <ul>
+ <li><a href="#">December 2007</a>&nbsp;(29)<span>Lorem Ipsum Dolor Sit Amit</span></li>
+ <li><a href="#">November 2007</a>&nbsp;(30)<span>Lorem Ipsum Dolor Sit Amit</span></li>
+ <li><a href="#">October 2007</a>&nbsp;(31)<span>Lorem Ipsum Dolor Sit Amit</span></li>
+ </ul>
+ </li>
+ </ul>
+ </div>
+ <!-- end #sidebar -->
+ <div style="clear: both;">&nbsp;</div>
+ </div>
+ <!-- end #page -->
+ <div id="footer">
+ <p>Copyright (c) 2008 Sitename.com. All rights reserved. Design by <a href="http://www.freecsstemplates.org/">Free CSS Templates</a>.</p>
+ </div>
+ <!-- end #footer -->
+</div>
+</body>
+</html>
View
5 App/Models/AuthorModel.hs
@@ -0,0 +1,5 @@
+module App.Models.AuthorModel
+ ( module App.Models.AuthorModel
+ , module App.Models.Bases.AuthorModelBase
+ ) where
+import App.Models.Bases.AuthorModelBase
View
BIN App/Models/Bases/.PageModelBase.hs.swp
Binary file not shown.
View
58 App/Models/Bases/AuthorModelBase.hs
@@ -0,0 +1,58 @@
+{- DO NOT EDIT THIS FILE
+ THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD
+
+ All changes should go into the Model file (e.g. App/Models/ExampleModel.hs) and
+ not into the base file (e.g. App/Models/Bases/ExampleModelBase.hs) -}
+
+module App.Models.Bases.AuthorModelBase (
+ module App.Models.Bases.AuthorModelBase,
+ module App.Models.Bases.ModelBase) where
+
+import App.Models.Bases.ModelBase
+import qualified Database.HDBC as HDBC
+import System.Time
+
+data Author = Author {
+ id :: Int64, name :: Maybe String
+ } deriving (Eq, Show)
+
+instance DatabaseModel Author where
+ tableName _ = "author"
+
+instance IsModel Author where
+ insert conn m = do
+ res <- liftIO $ HDBC.run conn " INSERT INTO author (id,name) VALUES (?,?)"
+ [HDBC.toSql $ id m , HDBC.toSql $ name m]
+ liftIO $ HDBC.commit conn
+ i <- liftIO $ HDBC.catchSql (HDBC.quickQuery' conn "SELECT lastval()" []) (\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) )
+ return $ HDBC.fromSql $ head $ head i
+ findAll conn = do
+ res <- liftIO $ HDBC.quickQuery' conn "SELECT id , name FROM author" []
+ return $ map (\r -> Author (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1))) res
+ findAllBy conn ss sp = do
+ res <- liftIO $ HDBC.quickQuery' conn ("SELECT id , name FROM author WHERE (" ++ ss ++ ") ") sp
+ return $ map (\r -> Author (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1))) res
+ findOneBy conn ss sp = do
+ res <- liftIO $ HDBC.quickQuery' conn ("SELECT id , name FROM author WHERE (" ++ ss ++ ") LIMIT 1") sp
+ return $ (\r -> Author (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1))) (head res)
+instance HasFindByPrimaryKey Author (Int64) where
+ find conn pk@(pk1) = do
+ res <- liftIO $ HDBC.quickQuery' conn ("SELECT id , name FROM author WHERE (id = ? )") [HDBC.toSql pk1]
+ case res of
+ [] -> throwDyn $ HDBC.SqlError
+ {HDBC.seState = "",
+ HDBC.seNativeError = (-1),
+ HDBC.seErrorMsg = "No record found when finding by Primary Key:author : " ++ (show pk)
+ }
+ r:[] -> return $ Author (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1))
+ _ -> throwDyn $ HDBC.SqlError
+ {HDBC.seState = "",
+ HDBC.seNativeError = (-1),
+ HDBC.seErrorMsg = "Too many records found when finding by Primary Key:author : " ++ (show pk)
+ }
+
+ update conn m = do
+ res <- liftIO $ HDBC.run conn "UPDATE author SET (id , name) = (?,?) WHERE (id = ? )"
+ [HDBC.toSql $ id m , HDBC.toSql $ name m, HDBC.toSql $ id m]
+ liftIO $ HDBC.commit conn
+ return ()
View
36 App/Models/Bases/ModelBase.hs
@@ -0,0 +1,36 @@
+{- DO NOT EDIT THIS FILE
+ THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD -}
+
+module App.Models.Bases.ModelBase (
+ module App.Models.Bases.ModelBase,
+ module Control.Exception,
+ module Control.Monad.Trans,
+ module Data.Int
+ ) where
+
+import Control.Monad.Trans
+import Control.Exception
+import Database.HDBC
+import Data.Int
+
+import Turbinado.Controller.Monad
+
+-- Using phantom types here
+class DatabaseModel m where
+ tableName :: m -> String
+
+type SelectString = String
+type SelectParams = [SqlValue]
+
+class (DatabaseModel model) =>
+ IsModel model where
+ insert :: (MonadIO m, IConnection conn) => conn -> model -> m Integer
+ findAll :: (MonadIO m, IConnection conn) => conn -> m [model]
+ findAllBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m [model]
+ findOneBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m model
+
+class (DatabaseModel model) =>
+ HasFindByPrimaryKey model primaryKey | model -> primaryKey where
+ find :: (MonadIO m, IConnection conn) => conn -> primaryKey -> m model
+ update :: (MonadIO m, IConnection conn) => conn -> model -> m ()
+
View
58 App/Models/Bases/PageModelBase.hs
@@ -0,0 +1,58 @@
+{- DO NOT EDIT THIS FILE
+ THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD
+
+ All changes should go into the Model file (e.g. App/Models/ExampleModel.hs) and
+ not into the base file (e.g. App/Models/Bases/ExampleModelBase.hs) -}
+
+module App.Models.Bases.PageModelBase (
+ module App.Models.Bases.PageModelBase,
+ module App.Models.Bases.ModelBase) where
+
+import App.Models.Bases.ModelBase
+import qualified Database.HDBC as HDBC
+import System.Time
+
+data Page = Page {
+ _id :: String, authorId :: Maybe Int64, content :: String, title :: String, version :: Int64
+ } deriving (Eq, Show)
+
+instance DatabaseModel Page where
+ tableName _ = "page"
+
+instance IsModel Page where
+ insert conn m = do
+ res <- liftIO $ HDBC.run conn " INSERT INTO page (_id,author_id,content,title,version) VALUES (?,?,?,?,?)"
+ [HDBC.toSql $ _id m , HDBC.toSql $ authorId m , HDBC.toSql $ content m , HDBC.toSql $ title m , HDBC.toSql $ version m]
+ liftIO $ HDBC.commit conn
+ i <- liftIO $ HDBC.catchSql (HDBC.quickQuery' conn "SELECT lastval()" []) (\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) )
+ return $ HDBC.fromSql $ head $ head i
+ findAll conn = do
+ res <- liftIO $ HDBC.quickQuery' conn "SELECT _id , author_id , content , title , version FROM page" []
+ 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
+ findAllBy conn ss sp = do
+ res <- liftIO $ HDBC.quickQuery' conn ("SELECT _id , author_id , content , title , version FROM page WHERE (" ++ ss ++ ") ") sp
+ 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
+ findOneBy conn ss sp = do
+ res <- liftIO $ HDBC.quickQuery' conn ("SELECT _id , author_id , content , title , version FROM page WHERE (" ++ ss ++ ") LIMIT 1") sp
+ 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)
+instance HasFindByPrimaryKey Page (String) where
+ find conn pk@(pk1) = do
+ res <- liftIO $ HDBC.quickQuery' conn ("SELECT _id , author_id , content , title , version FROM page WHERE (_id = ? )") [HDBC.toSql pk1]
+ case res of
+ [] -> throwDyn $ HDBC.SqlError
+ {HDBC.seState = "",
+ HDBC.seNativeError = (-1),
+ HDBC.seErrorMsg = "No record found when finding by Primary Key:page : " ++ (show pk)
+ }
+ r:[] -> return $ Page (HDBC.fromSql (r !! 0)) (HDBC.fromSql (r !! 1)) (HDBC.fromSql (r !! 2)) (HDBC.fromSql (r !! 3)) (HDBC.fromSql (r !! 4))
+ _ -> throwDyn $ HDBC.SqlError
+ {HDBC.seState = "",
+ HDBC.seNativeError = (-1),
+ HDBC.seErrorMsg = "Too many records found when finding by Primary Key:page : " ++ (show pk)
+ }
+
+ update conn m = do
+ res <- liftIO $ HDBC.run conn "UPDATE page SET (_id , author_id , content , title , version) = (?,?,?,?,?) WHERE (_id = ? )"
+ [HDBC.toSql $ _id m , HDBC.toSql $ authorId m , HDBC.toSql $ content m , HDBC.toSql $ title m , HDBC.toSql $ version m, HDBC.toSql $ _id m]
+ liftIO $ HDBC.commit conn
+ return ()
View
5 App/Models/PageModel.hs
@@ -0,0 +1,5 @@
+module App.Models.PageModel
+ ( module App.Models.PageModel
+ , module App.Models.Bases.PageModelBase
+ ) where
+import App.Models.Bases.PageModelBase
View
38 App/Views/Develop/Index.hs
@@ -1,41 +1,19 @@
-page :: View XML
page = <div>
<h2>! Windows</h2>
<p>This software doesn't work on Windows. Linux/Unix only at this point.</p>
<h2>Git Repo</h2>
<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>
- <h2>Dependencies</h2>
- <p>You'll need the following:</p>
+ <h2>To Do</h2>
<ul class="standard-list">
- <li><% anchorTag "http://www.haskell.org/ghc" "GHC" %>
- <em> (darcs) </em>
+ <li>
+ 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.
</li>
-
- <li><% anchorTag "http://code.haskell.org/HSP/haskell-src-exts/" "haskell-src-exts" %>
- <em> (darcs) </em>
- </li>
-
- <li><% anchorTag "http://code.haskell.org/HSP/harp/" "harp" %>
- <em> (darcs) </em>
- </li>
-
- <li><% anchorTag "http://git.complete.org/hslogger" "hslogger" %>
- <em> (git) </em>
- </li>
-
- <li><% anchorTag "http://code.haskell.org/HSP/hsx/" "hsx" %>
- <em> (darcs) </em>
- </li>
-
- <li><% anchorTag "http://code.haskell.org/hs-plugins" "hs-plugins" %>
- <em> (darcs) </em>
- </li>
-
- <li><% anchorTag "http://code.haskell.org/http" "http" %>
- <em> (darcs) </em>
- </li>
-
+ <li>Build a mini-CMS to manage these pages.</li>
+ <li>Complete the ORM in Turbinado/Database/ORM.</li>
+ <li>Implement cookie sessions.</li>
+ <li>Implement authentication.</li>
+ <li>Copy a couple of tutorial apps from Rails/Django tutorials.</li>
</ul>
</div>
View
21 App/Views/Home/About.hs
@@ -1,21 +0,0 @@
-page = <div>
- <h1>Features</h1>
- <p>Turbinado gives you all of the benefits of coding in Haskell and adds:</p>
- <ul class="standard-list">
- <li> A fast HTTP server with static- and dynamic-content serving capabilities; </li>
- <li> Views built using a simple HTML-like templating syntax combined with tag-matching to guard against invalid HTML; </li>
- <li> Automagic recompilation of Controllers, Layouts and Views; </li>
- <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>
- <li> A rich set of tags to make designing pages simpler;. </li>
- </ul>
-
- <h1>... On The Backs of Giants ... </h1>
- <p>Turbinado wouldn't be possible without the original work of the following people:</p>
- <ul class="standard-list">
- <li> <% anchorTag "http://www.haskell.org/ghc" "The GHC Team" %> for something as insane as Haskell and GHC</li>
- <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>
- <li> <% anchorTag "http://www.cse.unsw.edu.au/~dons/hs-plugins/" "Don Stewart" %> for hs-plugins </li>
- <li> <% anchorTag "http://www.cs.chalmers.se/~bringert/projects.html" "Bjorn Bringert" %> for HTTP </li>
- <li> <% anchorTag "http://software.complete.org/software/projects/show/hdbc" "John Goerzen" %> for Haskell Database Connectivity.</li>
- </ul>
- </div>
View
4 App/Views/Home/Architecture.hs
@@ -0,0 +1,4 @@
+page = <div>
+ <h1>Architecture</h1>
+ <p>coming soon</p>
+ </div>
View
1 App/Views/Home/Hello.hs
@@ -1,2 +1 @@
-page :: View XML
page = return $ cdata $ "Hello World"
View
20 App/Views/Home/Index.hs
@@ -1,4 +1,3 @@
-page :: View XML
page = <div>
<h1>Turbinado?</h1>
<div style="float:right">
@@ -11,4 +10,23 @@ page = <div>
<h1>Why?</h1>
<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>
+ <h1>Features</h1>
+ <p>Turbinado gives you all of the benefits of coding in Haskell and adds:</p>
+ <ul class="standard-list">
+ <li> A fast HTTP server with static- and dynamic-content serving capabilities; </li>
+ <li> Views built using a simple HTML-like templating syntax combined with tag-matching to guard against invalid HTML; </li>
+ <li> Automagic recompilation of Controllers, Layouts and Views; </li>
+ <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>
+ <li> A rich set of tags to make designing pages simpler;. </li>
+ </ul>
+
+ <h1>... On The Backs of Giants ... </h1>
+ <p>Turbinado wouldn't be possible without the original work of the following people:</p>
+ <ul class="standard-list">
+ <li> <% anchorTag "http://www.haskell.org/ghc" "The GHC Team" %> for something as insane as Haskell and GHC</li>
+ <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>
+ <li> <% anchorTag "http://www.cse.unsw.edu.au/~dons/hs-plugins/" "Don Stewart" %> for hs-plugins </li>
+ <li> <% anchorTag "http://www.cs.chalmers.se/~bringert/projects.html" "Bjorn Bringert" %> for HTTP </li>
+ <li> <% anchorTag "http://software.complete.org/software/projects/show/hdbc" "John Goerzen" %> for Haskell Database Connectivity.</li>
+ </ul>
</div>
View
46 App/Views/Home/Install.hs
@@ -0,0 +1,46 @@
+page = <div>
+ <h1>Installation == Pain, Pain == Love</h1>
+ <p>
+ 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.
+ </p>
+ <p>
+ In addition to its many other joys, the ORM in Turbinado only works with PostgreSQL right now.
+ </p>
+ <h1>Suit up</h1>
+ <p>
+ You'll need to have the following packages installed to have a go at installation:
+ </p>
+ <ul class="standard-list">
+ <li><a href="http://www.haskell.org/ghc">GHC</a><em> (darcs) </em></li>
+ <li><a href="http://code.haskell.org/HSP/haskell-src-exts/">haskell-src-exts</a><em> (darcs) </em></li>
+ <li><a href="http://code.haskell.org/HSP/harp/">harp</a><em> (darcs) </em></li>
+ <li><a href="http://git.complete.org/hslogger">hslogger</a><em> (git) </em></li>
+ <li><a href="http://code.haskell.org/encoding/">encoding</a><em> (darcs) </em></li>
+ <li><a href="http://code.haskell.org/HSP/hsx/">hsx</a><em> (darcs) </em></li>
+ <li><a href="http://code.haskell.org/hs-plugins">hs-plugins</a><em> (darcs) </em></li>
+ <li><a href="http://code.haskell.org/http">http</a><em> (darcs) </em></li>
+ <li><a href="http://git.complete.org/hdbc">HDBC</a><em> (git) </em></li>
+ <li><a href="http://git.complete.org/hdbc-postgresql">HDBC-PostgreSQL</a><em> (git) </em></li>
+ </ul>
+ <h1>Grab the code:</h1>
+ <pre>
+ git clone git://github.com/alsonkemp/turbinado.git
+ </pre>
+ <h1>Build it</h1>
+ <p>
+ With all of the packages installed, wait for a new moon, stand on tip-toes, and do the following:
+ </p>
+ <pre>
+ runghc Setup.lhs configure
+ runghc Setup.lhs build
+ </pre>
+ <p>
+ If everything goes well, you should be able to do:
+ </p>
+ <pre>
+ dist/build/turbinado/turbinado -p 9999
+ </pre>
+ <p>
+ Try browsing to http://the-machines-name:9999/images/1x1.gif.
+ </p>
+ </div>
View
1 App/Views/Home/Performance.hs
@@ -1,4 +1,3 @@
-page :: View XML
page = <div>
<h1>Performance</h1>
<p>
View
15 App/Views/Page/Edit.hs
@@ -0,0 +1,15 @@
+page = <div>
+ <form action=(getViewDataValue_u "save-url" :: View String) method="post">
+ <div>
+ Title:
+ <input type="text" id="title" name="title" value=(getViewDataValue_u "page-title" :: View String) />
+ </div>
+ <div>
+ Content:
+ <textarea rows="25" columns="80" name="content" id="content">
+ <% (getViewDataValue_u "page-content" :: View String) %>
+ </textarea>
+ </div>
+ <input type="submit" value="Save"/>
+ </form>
+ </div>
View
15 App/Views/Page/Index.hs
@@ -0,0 +1,15 @@
+page = <div>
+ <h1>
+ Page Index
+ </h1>
+ <% (getViewDataValue_u "pages-list" :: View [(String, String)]) >>=
+ \l -> mapM indexItem l %>
+ </div>
+
+indexItem (t,i) = return $ cdata $ unlines $
+ ["<div style='padding: 0pt 5px;'>"
+ ," <a href=\"/Page/Show/" ++ i ++"\">"
+ ," "++ t
+ ," </a>"
+ ,"</div>"
+ ]
View
13 App/Views/Page/New.hs
@@ -0,0 +1,13 @@
+page = <div>
+ <form action=(getViewDataValue_u "save-url" :: View String) method="post">
+ <div>
+ Title:
+ <input type="text" id="title" name="title" />
+ </div>
+ <div>
+ Content:
+ <textarea rows="25" columns="80" name="content" id="content" />
+ </div>
+ <input type="submit" value="Save"/>
+ </form>
+ </div>
View
4 App/Views/Page/Show.hs
@@ -1,4 +1,4 @@
-page :: View XML
page = <div>
- <% getViewDataValue "page-content" %>
+ <h1><% getViewDataValue_u "page-title" :: View String %></h1>
+ <% getViewDataValue_u "page-content" :: View String %>
</div>
View
1 App/Views/Tutorial/Index.hs
@@ -1,4 +1,3 @@
-page :: View XML
page = <div>
<h2>DANGER WILL ROBINSON</h2>
<p>Developers only at this point!</p>
View
6 Config/App.hs
@@ -28,8 +28,8 @@ newAppEnvironment = AppEnvironment
-- Database connection
----------------------------------------------------------------
databaseConnection :: Maybe (IO Connection)
-databaseConnection = Nothing
-
+-- databaseConnection = Nothing
+databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado user=turbinado password=turbinado"
----------------------------------------------------------------
-- RequestHandler Filter List additions
@@ -41,6 +41,6 @@ customPostFilters = []
----------------------------------------------------------------
-- Logging
----------------------------------------------------------------
-logLevel = ERROR -- DEBUG < INFO < NOTICE < WARNING < ERROR < CRITICAL < ALERT < EMERGENCY
+logLevel = DEBUG -- DEBUG < INFO < NOTICE < WARNING < ERROR < CRITICAL < ALERT < EMERGENCY
View
7 Config/Master.hs
@@ -1,10 +1,8 @@
module Config.Master (
module Config.Master,
- module Config.App,
- Turbinado.Server.Handlers.SessionHandlers.Simple.getSessionHandler
+ module Config.App
) where
-import Turbinado.Server.Handlers.SessionHandlers.Simple
import Config.App
----------------------------------------------------------------
@@ -28,6 +26,7 @@ mUserPkgConf = [""]
-- Paths
----------------------------------------------------------------
+modelDir = "App/Models"
viewDir = "App/Views"
viewStub = "Turbinado/Stubs/View.hs"
layoutDir = "App/Layouts"
@@ -36,7 +35,7 @@ controllerDir = "App/Controllers"
controllerStub = "Turbinado/Stubs/Controller.hs"
configDir = "Config"
-searchDirs = [viewDir, layoutDir, controllerDir, rootDir, configDir, compiledDir]
+searchDirs = [modelDir, viewDir, layoutDir, controllerDir, rootDir, configDir, compiledDir]
staticDirs = ["static", "tmp/cache"]
compiledDir = "tmp/compiled"
View
6 Turbinado/Controller.hs
@@ -17,7 +17,9 @@ module Turbinado.Controller (
module Data.Maybe,
module Turbinado.Environment.CodeStore,
+ module Turbinado.Environment.Header,
module Turbinado.Environment.Logger,
+ module Turbinado.Environment.Params,
module Turbinado.Environment.Request,
module Turbinado.Environment.Response,
module Turbinado.Environment.Settings,
@@ -34,15 +36,17 @@ import qualified Network.HTTP as HTTP
import Prelude hiding (catch)
import qualified Database.HDBC as HDBC
+import Turbinado.Environment.CodeStore
import Turbinado.Environment.Database
+import Turbinado.Environment.Header
import Turbinado.Environment.Logger
+import Turbinado.Environment.Params
import Turbinado.Environment.Request
import Turbinado.Environment.Response
import Turbinado.Environment.Settings
import Turbinado.Environment.Types
import Turbinado.Environment.ViewData
import Turbinado.Controller.Monad
-import Turbinado.Environment.CodeStore
import Turbinado.Utility.General
import Turbinado.Server.StandardResponse
View
22 Turbinado/Database/ORM/Generator.hs
@@ -24,11 +24,13 @@ buildTable conn tcs t = do ds <- describeTable conn t
pks <- getPrimaryKeys conn t
let tcs'' = combinePrimaryKeys t pks tcs'
fks <- getForeignKeyReferences conn t
- return $ combineForeignKeyReferences t fks tcs''
+ let tcs''' = combineForeignKeyReferences t fks tcs''
+ hds <- getDefaultColumns conn t
+ return $ combineDefaultColumns t hds tcs'''
combineDescription t ds tcs = M.insert t (cols, []) tcs
where cols = M.fromList $
- map (\(columnName, columnDescription) -> (columnName, (columnDescription,[]))) ds
+ map (\(columnName, columnDescription) -> (columnName, (columnDescription,[], False))) ds
combinePrimaryKeys :: TableName -> [ColumnName] -> Tables -> Tables
combinePrimaryKeys t pks tcs = M.adjust (\(c, _) -> (c,pks)) t tcs
@@ -38,9 +40,13 @@ combineForeignKeyReferences t fks tcs =
M.adjust
(\(cs, pks) -> (foldl (worker) cs fks, pks))
t tcs
- where worker cs (c, tt, tc) = M.adjust (\(cd, deps) -> (cd, [(tt, tc)] `union` deps)) c cs
-{-
- - combineTablesColumns :: [TableName] -> [(ColumnName, SqlColDesc)] -> Tables
- - combineTablesColumsn ts cs =
- - M.fromList $ zipWith (\t (c, d) -> (t, (c, [])) ) ts cs
- -}
+ where worker cs (c, tt, tc) = M.adjust (\(cd, deps, hd) -> (cd, [(tt, tc)] `union` deps, hd)) c cs
+
+combineDefaultColumns :: TableName -> [ColumnName] -> Tables -> Tables
+combineDefaultColumns t hds tcs =
+ M.adjust
+ (\(cs, pks) -> (foldl (worker) cs hds, pks))
+ t tcs
+ where worker cs hd = M.adjust (\(cd, deps, _) -> (cd, deps, True)) hd cs
+
+
View
138 Turbinado/Database/ORM/Output.hs
@@ -40,14 +40,15 @@ generateModel t typeName pk cs =
["{- DO NOT EDIT THIS FILE"
," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
,""
- ," All changes should go into the Model file (e.g. ExampleModel.hs) and"
- ," not into the base file (e.g. ExampleModelBase.hs) -}"
+ ," All changes should go into the Model file (e.g. App/Models/ExampleModel.hs) and"
+ ," not into the base file (e.g. App/Models/Bases/ExampleModelBase.hs) -}"
,""
- ,"module Models.Bases." ++ typeName ++ "ModelBase ( "
- ," module Models.Bases." ++ typeName ++ "ModelBase, "
- ," module Models.Bases.ModelBase) where"
+ ,"module App.Models.Bases." ++ typeName ++ "ModelBase ( "
+ ," module App.Models.Bases." ++ typeName ++ "ModelBase, "
+ ," module App.Models.Bases.ModelBase) where"
, ""
- , "import Models.Bases.ModelBase"
+ , "import App.Models.Bases.ModelBase"
+ , "import qualified Database.HDBC as HDBC"
, "import System.Time"
, ""
, "data " ++ typeName ++ " = " ++ typeName ++ " {"
@@ -59,92 +60,109 @@ generateModel t typeName pk cs =
, " tableName _ = \"" ++ t ++ "\""
, ""
] ++
- generateFindByPrimaryKey t cs typeName pk ++
- generateFinders t cs typeName
+ generateIsModel t cs typeName ++
+ generateHasFindByPrimaryKey t cs typeName pk
generateModelFile typeName =
unlines $
- ["module Models." ++ typeName ++ "Model"
- ," ( module Models." ++ typeName ++ "Model"
- ," , module Models.Bases." ++ typeName ++ "ModelBase"
+ ["module App.Models." ++ typeName ++ "Model"
+ ," ( module App.Models." ++ typeName ++ "Model"
+ ," , module App.Models.Bases." ++ typeName ++ "ModelBase"
," ) where"
- ,"import Models.Bases." ++ typeName ++ "ModelBase"
+ ,"import App.Models.Bases." ++ typeName ++ "ModelBase"
]
generateModelBase :: String
generateModelBase = unlines $
["{- DO NOT EDIT THIS FILE"
," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD -}"
,""
- ,"module Models.Bases.ModelBase ("
- ," module Models.Bases.ModelBase,"
+ ,"module App.Models.Bases.ModelBase ("
+ ," module App.Models.Bases.ModelBase,"
," module Control.Exception,"
- ," module Database.HDBC,"
+ ," module Control.Monad.Trans,"
," module Data.Int"
- ,") where"
+ ," ) where"
,""
+ ,"import Control.Monad.Trans"
,"import Control.Exception"
,"import Database.HDBC"
,"import Data.Int"
,""
- ,"{- Using phantom types here -}"
+ ,"import Turbinado.Controller.Monad"
+ ,""
+ ,"-- Using phantom types here "
,"class DatabaseModel m where"
," tableName :: m -> String"
,""
,"type SelectString = String"
,"type SelectParams = [SqlValue]"
,""
,"class (DatabaseModel model) =>"
- ," HasFindByPrimaryKey model primaryKey | model -> primaryKey where"
- ," find :: IConnection conn => conn -> primaryKey -> IO model"
+ ," IsModel model where"
+ ," insert :: (MonadIO m, IConnection conn) => conn -> model -> m Integer"
+ ," findAll :: (MonadIO m, IConnection conn) => conn -> m [model]"
+ ," findAllBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m [model]"
+ ," findOneBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m model"
,""
,"class (DatabaseModel model) =>"
- ," HasFinders model where"
- ," findAll :: IConnection conn => conn -> IO [model]"
- ," findAllBy :: IConnection conn => conn -> SelectString -> SelectParams -> IO [model]"
- ," findOneBy :: IConnection conn => conn -> SelectString -> SelectParams -> IO model"
+ ," HasFindByPrimaryKey model primaryKey | model -> primaryKey where"
+ ," find :: (MonadIO m, IConnection conn) => conn -> primaryKey -> m model"
+ ," update :: (MonadIO m, IConnection conn) => conn -> model -> m () "
,""
]
---------------------------------------------------------------------------
-- Generator templates --
---------------------------------------------------------------------------
-generateFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
-generateFindByPrimaryKey t cs typeName pk =
+generateIsModel :: TableName -> Columns -> TypeName -> [String]
+generateIsModel t cs typeName =
+ ["instance IsModel " ++ typeName ++ " where"
+ ," insert conn m = do"
+ ," res <- liftIO $ HDBC.run conn \" INSERT INTO " ++ t ++ " (" ++ (concat $ intersperse "," $ M.keys cs) ++") VALUES (" ++ (intercalate "," (take (M.size cs) (repeat "?"))) ++ ")\""
+ ," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") (M.keys cs) ) ++ "]"
+ ," liftIO $ HDBC.commit conn"
+ ," i <- liftIO $ HDBC.catchSql (HDBC.quickQuery' conn \"SELECT lastval()\" []) (\\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) ) "
+ ," return $ HDBC.fromSql $ head $ head i"
+ ," findAll conn = do"
+ ," res <- liftIO $ HDBC.quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
+ ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
+ ," findAllBy conn ss sp = do"
+ ," res <- liftIO $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
+ ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
+ ," findOneBy conn ss sp = do"
+ ," res <- liftIO $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
+ ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
+ ]
+
+generateHasFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
+generateHasFindByPrimaryKey t cs typeName pk =
case (length pk) of
0 -> [""]
- _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ fst $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
+ _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ (\(c',_,_) -> c') $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
- ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t ++ " WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
+ ," 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..])) ++ "]"
," case res of"
- ," [] -> throwDyn $ SqlError"
- ," {seState = \"\","
- ," seNativeError = (-1),"
- ," seErrorMsg = \"No record found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
+ ," [] -> throwDyn $ HDBC.SqlError"
+ ," {HDBC.seState = \"\","
+ ," HDBC.seNativeError = (-1),"
+ ," HDBC.seErrorMsg = \"No record found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
," }"
," r:[] -> return $ " ++ (generateConstructor cs typeName)
- ," _ -> throwDyn $ SqlError"
- ," {seState = \"\","
- ," seNativeError = (-1),"
- ," seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
+ ," _ -> throwDyn $ HDBC.SqlError"
+ ," {HDBC.seState = \"\","
+ ," HDBC.seNativeError = (-1),"
+ ," HDBC.seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
," }"
+ ,""
+ ," update conn m = do"
+ ," res <- liftIO $ HDBC.run conn \"UPDATE " ++ t ++ " SET (" ++ (unwords $ intersperse "," $ M.keys cs) ++ ") = (" ++ (intercalate "," $ (take (M.size cs) (repeat "?"))) ++ ") WHERE (" ++ (generatePrimaryKeyWhere pk) ++")\""
+ ," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") (M.keys cs) ) ++ ", " ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") pk ) ++ "]"
+ ," liftIO $ HDBC.commit conn"
+ ," return ()"
]
-generateFinders :: TableName -> Columns -> TypeName -> [String]
-generateFinders t cs typeName =
- ["instance HasFinders " ++ typeName ++ " where"
- ," findAll conn = do"
- ," res <- quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
- ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
- ," findAllBy conn ss sp = do"
- ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
- ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
- ," findOneBy conn ss sp = do"
- ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
- ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
- ]
-
{-----------------------------------------------------------------------}
generatePrimaryKeyWhere pk =
unwords $
@@ -153,7 +171,7 @@ generatePrimaryKeyWhere pk =
generateConstructor cs typeName =
typeName ++ " " ++ (unwords $
- map (\i -> "(fromSql (r !! " ++ (show i) ++ "))") [0..((M.size cs) - 1)])
+ map (\i -> "(HDBC.fromSql (r !! " ++ (show i) ++ "))") [0..((M.size cs) - 1)])
---------------------------------------------------------------------------
@@ -162,12 +180,16 @@ generateConstructor cs typeName =
cols :: Columns -> String
cols cs = unwords $ intersperse "," $ M.keys cs
-columnToFieldLabel :: (String, (SqlColDesc, ForeignKeyReferences)) -> String
-columnToFieldLabel (name, (desc, _)) =
+columnToFieldLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
+columnToFieldLabel cd@(name, (desc, _, _)) =
" " ++ partiallyCapitalizeName name ++ " :: " ++
- (if ((colNullable desc) == Just True) then "Maybe " else "") ++
+ maybeColumnLabel cd ++
getHaskellTypeString (colType desc)
+maybeColumnLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
+maybeColumnLabel (_, (_, _, True)) = "Maybe " -- Does the column have a default
+maybeColumnLabel (_, (desc, _, _)) = if ((colNullable desc) == Just True) then "Maybe " else ""
+maybeColumnLabel _ = ""
getHaskellTypeString :: SqlTypeId -> String
getHaskellTypeString SqlCharT = "String"
@@ -202,11 +224,11 @@ class TableType a where
--
-- Converts "column_name" to "ColumnName" (for types)
--
-capitalizeName colname =
- concat $
- map (\(s:ss) -> (Data.Char.toUpper s) : ss) $
- words $
- map (\c -> if (c=='_') then ' ' else c) colname
+capitalizeName (colname':colname) =
+ concat
+ (map (\(s:ss) -> (Data.Char.toUpper s) : ss) $
+ words $ (Data.Char.toUpper colname') :
+ map (\c -> if (c=='_') then ' ' else c) colname)
--
View
19 Turbinado/Database/ORM/PostgreSQL.hs
@@ -46,7 +46,24 @@ getForeignKeyReferences conn t =
, " and c2.relname = ?;"
]) [toSql t]
return $ map (\r -> (fromSql $ r !! 0, fromSql $ r !! 1, fromSql $ r !! 2)) rs
-
+
+
+getDefaultColumns:: IConnection conn => conn -> String -> IO [String]
+getDefaultColumns conn t =
+ do rs <- quickQuery conn (concat
+ [ "select a.attname as column_name"
+ , " from pg_class c"
+ , " join pg_namespace n on (n.oid = c.relnamespace)"
+ , " join pg_attribute a on (a.attrelid = c.oid"
+ , " and not a.attisdropped"
+ , " and a.attnum > 0)"
+ , " left join pg_attrdef ad on (a.attrelid = ad.adrelid"
+ , " and a.attnum = ad.adnum)"
+ , " where n.nspname = 'public'"
+ , " and c.relname = ?"
+ , " and (ad.adsrc IS NOT NULL);"]) [toSql t]
+ return $ map (\r -> fromSql $ r !! 0) rs
+
{-
INDEX COLUMNS
View
3 Turbinado/Database/ORM/Types.hs
@@ -8,6 +8,7 @@ type TableName = String
type Columns = M.Map ColumnName ColumnDesc
type ColumnName = String
type PrimaryKey = [ColumnName]
-type ColumnDesc = (SqlColDesc, ForeignKeyReferences)
+type ColumnDesc = (SqlColDesc, ForeignKeyReferences, HasDefault)
+type HasDefault = Bool
type ForeignKeyReferences = [(TableName, ColumnName)] -- all columns which are targets of foreign keys
View
47 Turbinado/Environment.hs
@@ -1,47 +0,0 @@
-module Turbinado.Environment (
- Environment,
- newEnvironment,
- EnvironmentFilter
- ) where
-
-import Data.Map
-import Data.Maybe
-import System.IO
-import Config.Master
-
-import Turbinado.Environment.CodeStore
-import Turbinado.Environment.Logger
-import Turbinado.Environment.MimeTypes
-import Turbinado.Environment.Request
-import Turbinado.Environment.Response
-import Turbinado.Environment.Routes
-import Turbinado.Environment.Settings
-import Turbinado.Environment.ViewData
-
-data Environment = Environment { getCodeStore :: Maybe CodeStore
- , getLogger :: Maybe Logger
- , getMimeTypes :: Maybe MimeTypes
- , request :: Maybe Request
- , getResponse :: Maybe Response
- , getRoutes :: Maybe Routes
- , getSettings :: Maybe Settings
- , getViewData :: Maybe ViewData
- , getAppEnvironment :: Maybe AppEnvironment
- }
-
-type EnvironmentFilter = Environment -> IO Environment
-
-newEnvironment :: IO Environment
-newEnvironment = return $ Environment {
- getCodeStore = Nothing
- , getLogger = Nothing
- , getMimeTypes = Nothing
- , getRequest = Nothing
- , getResponse = Nothing
- , getRoutes = Nothing
- , getSettings = Nothing
- , getViewData = Nothing
- , getAppEnvironment = Nothing
- }
-
-
View
34 Turbinado/Environment/CodeStore.hs
@@ -47,27 +47,27 @@ retrieveCode ct cl' = do
cmap <- doIO $ takeMVar mv
let c= lookup cl cmap
cmap' <- case c of
- Nothing -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : fresh load")
- loadCode ct cmap cl
- Just CodeLoadFailure -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : previous failure; try load")
- loadCode ct cmap cl
- _ -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : checking reload")
- checkReloadCode ct cmap (fromJust c) cl
+ Nothing -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : fresh load")
+ loadCode ct cmap cl
+ Just (CodeLoadFailure _) -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : previous failure; try load")
+ loadCode ct cmap cl
+ _ -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : checking reload")
+ checkReloadCode ct cmap (fromJust c) cl
doIO $ putMVar mv cmap'
-- We _definitely_ have a code entry now, though it may have a MakeFailure
let c' = lookup cl cmap'
case c' of
- Nothing -> do debugM (fst cl ++ " : Not found in CodeStore")
- return CodeLoadFailure
- Just CodeLoadFailure -> do debugM (fst cl ++ " : CodeLoadFailure " )
- return CodeLoadFailure
+ Nothing -> do debugM (fst cl ++ " : Not found in CodeStore")
+ return (CodeLoadFailure (fst cl ++ " : Not found in CodeStore") )
+ Just (CodeLoadFailure e) -> do debugM (fst cl ++ " : CodeLoadFailure " )
+ return (CodeLoadFailure e)
Just clc@(CodeLoadController _ _ _) -> do debugM (fst cl ++ " : CodeLoadController " )
return clc
Just clv@(CodeLoadView _ _ _) -> do debugM (fst cl ++ " : CodeLoadView" )
return clv
checkReloadCode :: CodeType -> CodeMap -> CodeStatus -> CodeLocation -> Controller CodeMap
-checkReloadCode ct cmap CodeLoadFailure cl = error "ERROR: checkReloadCode was called with a CodeLoadFailure"
+checkReloadCode ct cmap (CodeLoadFailure e) cl = error "ERROR: checkReloadCode was called with a CodeLoadFailure"
checkReloadCode ct cmap cstat cl = do
debugM $ " CodeStore : checkReloadCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
r <- needReloadCode (fst cl) (getDate cstat)
@@ -96,7 +96,7 @@ mergeCode ct cmap cl = do
ms <- customMergeToDir (joinPath [{-normalise d,-} normalise $ getStub ct]) (fst cl) compiledDir
case ms of
MergeFailure err -> do debugM ("\tMerge error : " ++ (show err))
- return $ insert cl CodeLoadFailure cmap
+ return $ insert cl (CodeLoadFailure $ unlines err) cmap
MergeSuccess NotReq _ _ -> do debugM ("\tMerge success (No recompilation required) : " ++ (fst cl))
return cmap
MergeSuccess _ args fp -> do debugM ("\tMerge success : " ++ (fst cl))
@@ -107,9 +107,9 @@ makeCode ct cmap cl args fp = do
ms <- doIO $ makeAll fp (compileArgs++args)
case ms of
MakeFailure err -> do debugM ("\tMake error : " ++ (show err))
- return (insert cl CodeLoadFailure cmap)
+ return (insert cl (CodeLoadFailure $ unlines err) cmap)
MakeSuccess NotReq _ -> do debugM ("\tMake success : No recomp required")
- return (insert cl CodeLoadFailure cmap)
+ return cmap
MakeSuccess _ fp -> do debugM ("\tMake success : " ++ fp)
case ct of
CTController -> _loadController ct cmap cl fp
@@ -121,7 +121,7 @@ _loadController ct cmap cl fp = do
ls <- doIO $ load_ fp [compiledDir] (snd cl)
case ls of
LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
- return (insert cl CodeLoadFailure cmap)
+ return (insert cl (CodeLoadFailure $ unlines err) cmap)
LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
doIO $ unload m
t <- doIO $ getClockTime
@@ -133,7 +133,7 @@ _loadView ct cmap cl fp = do
ls <- doIO $ load_ fp (compiledDir:searchDirs) (snd cl)
case ls of
LoadFailure err -> do debugM ("\tLoadFailure : " ++ (show err))
- return (insert cl CodeLoadFailure cmap)
+ return (insert cl (CodeLoadFailure $ unlines err) cmap)
LoadSuccess m f -> do debugM ("\tLoadSuccess : " ++ fst cl )
doIO $ unload m
t <- doIO $ getClockTime
@@ -194,6 +194,6 @@ getStub ct = case ct of
CTController -> controllerStub
CTView -> viewStub
-getDate CodeLoadFailure = error "getDate called with CodeLoadFailure"
+getDate (CodeLoadFailure e) = error "getDate called with CodeLoadFailure"
getDate (CodeLoadView _ _ d) = d
getDate (CodeLoadController _ _ d) = d
View
17 Turbinado/Environment/Header.hs
@@ -1,5 +1,18 @@
-module Turbinado.Data.Header (
+module Turbinado.Environment.Header (
+ module Turbinado.Environment.Header,
module Network.HTTP.Headers
) where
-import Network.HTTP.Headers
+import Data.Maybe
+import Network.HTTP
+import Network.HTTP.Headers
+
+import Turbinado.Controller.Monad
+import Turbinado.Environment.Types
+import Turbinado.Environment.Request
+
+getHeader :: HeaderName -> Controller (Maybe String)
+getHeader h = do e <- get
+ return $ findHeader h (fromJust $ getRequest e)
+
+
View
49 Turbinado/Environment/Params.hs
@@ -0,0 +1,49 @@
+module Turbinado.Environment.Params(
+ getParam,
+ getParam_u
+ ) where
+
+import Data.Maybe
+import Network.HTTP
+import Network.HTTP.Headers
+import Network.URI
+
+import Turbinado.Controller.Monad
+import Turbinado.Environment.Header
+import Turbinado.Environment.Request
+import Turbinado.Environment.Types
+
+getParam_u :: String -> Controller String
+getParam_u p = do r <- getParam p
+ return $ fromJust r
+
+getParam :: String -> Controller (Maybe String)
+getParam p = do r <- getParamFromQueryString p
+ case r of
+ Just r' -> return r
+ Nothing -> getParamFromBody p
+
+getParamFromQueryString :: String -> Controller (Maybe String)
+getParamFromQueryString s = do e <- get
+ let qs = uriQuery $ rqURI (fromJust $ getRequest e)
+ return $ lookup s $ formDecode qs
+
+getParamFromBody :: String -> Controller (Maybe String)
+getParamFromBody s = do e <- get
+ ct <- getHeader HdrContentType
+ let rm = rqMethod (fromJust $ getRequest e)
+ rb = rqBody (fromJust $ getRequest e)
+ case rm of
+ POST -> -- TODO: ADD MULTIPART
+ return $ lookup s $ formDecode rb
+ _ -> return Nothing
+
+-- LIFTED FROM THE CGI PACKAGE
+
+-- | Gets the name-value pairs from application\/x-www-form-urlencoded data.
+formDecode :: String -> [(String,String)]
+formDecode "" = []
+formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs)
+ where (nv,rs) = break (=='&') s
+ (n,v) = break (=='=') nv
+
View
2 Turbinado/Environment/Types.hs
@@ -57,7 +57,7 @@ type CodeLocation = (FilePath, Function)
data CodeStore = CodeStore (MVar CodeMap)
type CodeMap = M.Map CodeLocation CodeStatus
-data CodeStatus = CodeLoadFailure |
+data CodeStatus = CodeLoadFailure String |
CodeLoadController (StateT Environment IO ()) Module CodeDate |
CodeLoadView (XMLGenT (StateT Environment IO) XML ) Module CodeDate
View
1 Turbinado/Environment/ViewData.hs
@@ -12,6 +12,7 @@ import Data.Maybe
import Data.Typeable
import Data.Dynamic
+import Turbinado.Environment.Logger
import Turbinado.Environment.Types
import Turbinado.Controller.Monad
import Turbinado.View.Monad
View
8 Turbinado/Layout.hs
@@ -15,15 +15,13 @@ import Turbinado.Environment.Settings
import Turbinado.View
insertView :: View XML
-insertView = do e <- getEnvironment
- let cs = fromJust $ getCodeStore e
- cl <- lift getView
- --debugM $ " Layout: insertView : loading " ++ (fst cl) ++ " - " ++ (snd cl)
+insertView = do cl <- lift getView
+ lift $ debugM $ " Layout: insertView : loading " ++ (fst cl) ++ " - " ++ (snd cl)
c <- lift $ retrieveCode CTView cl
case c of
CodeLoadView v _ _ -> v
CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
- CodeLoadFailure -> return $ cdata $ "CodeLoadFailure: insertView "
+ CodeLoadFailure e -> return $ cdata e
styleSheet :: String -> String -> View XML
styleSheet s m = return $ cdata $ "<link media=\"" ++ m ++"\" type=\"text/css\" rel=\"stylesheet\" href=\"/css/" ++ s ++".css\">"
View
23 Turbinado/Server/Handlers/RequestHandler.hs
@@ -73,18 +73,21 @@ retrieveAndRunController =
case p of
CodeLoadController p' _ _ -> p'
CodeLoadView _ _ _ -> error "retrieveAndRunView called, but returned CodeLoadView"
- CodeLoadFailure -> fileNotFoundResponse c
+ CodeLoadFailure e -> errorResponse e
retrieveAndRunLayout :: Controller ()
retrieveAndRunLayout =
- do l <- getLayout
- p <- case l of
- ("", _) -> do v <- getView
- retrieveCode CTView v -- If no Layout, then pull a View
- _ -> retrieveCode CTLayout l
- case p of
- CodeLoadView p' _ _ -> evalView p'
- CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
- CodeLoadFailure -> fileNotFoundResponse (joinPath [(fst l), (snd l)])
+ do e <- get
+ case (isResponseComplete e) of
+ True -> return ()
+ False -> do l <- getLayout
+ p <- case l of
+ ("", _) -> do v <- getView
+ retrieveCode CTView v -- If no Layout, then pull a View
+ _ -> retrieveCode CTLayout l
+ case p of
+ CodeLoadView p' _ _ -> evalView p'
+ CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
+ CodeLoadFailure e -> errorResponse e
View
1 Turbinado/Stubs/Layout.hs
@@ -4,4 +4,5 @@ import Turbinado.View
import Turbinado.View.Helpers
-- SPLIT HERE
+page :: View XML
View
3 Turbinado/Stubs/View.hs
@@ -1,5 +1,8 @@
import Config.Master
import Turbinado.View
import Turbinado.View.Helpers
+import Control.Monad.Trans
+
+page :: View XML
-- SPLIT HERE
View
6 Turbinado/View.hs
@@ -17,10 +17,12 @@ module Turbinado.View (
module Turbinado.View.XML.PCDATA,
module Turbinado.View.XMLGenerator,
module Turbinado.Environment.CodeStore,
+ module Turbinado.Environment.Params,
module Turbinado.Environment.Request,
module Turbinado.Environment.Response,
module Turbinado.Environment.Settings,
- module Turbinado.Environment.Types
+ module Turbinado.Environment.Types,
+ module Turbinado.Environment.ViewData
) where
import Control.Exception (catchDyn)
@@ -36,10 +38,12 @@ import System.FilePath
import Turbinado.Controller.Monad hiding (catch)
import Turbinado.Environment.CodeStore
+import Turbinado.Environment.Params
import Turbinado.Environment.Request
import Turbinado.Environment.Response
import Turbinado.Environment.Settings
import Turbinado.Environment.Types
+import Turbinado.Environment.ViewData
import Turbinado.Server.StandardResponse
import Turbinado.View.Exception
import Turbinado.View.HTML
View
159 Turbinado/View/HAML/trhaml.hs
@@ -0,0 +1,159 @@
+module Main where
+
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Language
+import Text.ParserCombinators.Parsec.Pos
+import qualified Text.ParserCombinators.Parsec.Token as T
+import Data.Char
+import Data.List
+import Data.Maybe
+import System.IO.Unsafe
+
+main = do s <- getContents
+ case (parse mainParser "stdin" s) of
+ Left err -> putStrLn "Error: " >> print err
+ Right hs -> putStrLn hs
+
+-- Try to parse HAML, otherwise re-output raw lines
+
+mainParser = do whiteSpace
+ ls <- many1 (hamlCode <|> tilEOL)
+ return $ unlines ls
+--
+-- * HAML lexer
+--
+hamlLexer = T.makeTokenParser emptyDef
+whiteSpace= T.whiteSpace hamlLexer
+lexeme = T.lexeme hamlLexer
+symbol = T.symbol hamlLexer
+natural = T.natural hamlLexer
+parens = T.parens hamlLexer
+semi = T.semi hamlLexer
+squares = T.squares hamlLexer
+stringLiteral= T.stringLiteral hamlLexer
+identifier= T.identifier hamlLexer
+reserved = T.reserved hamlLexer
+reservedOp= T.reservedOp hamlLexer
+commaSep1 = T.commaSep1 hamlLexer
+--
+-- * Main HAML parsers
+--
+
+-- hamlCode is just many identifiers followed by = followed by a hamlBlock
+-- f a b c = %somehaml
+hamlCode = try ( do is <- many1 identifier
+ symbol "="
+ currentPos <- getPosition
+ x <- manyTill1
+ (lexeme $ hamlBlock)
+ (notSameIndent currentPos)
+ return $ (concat $ intersperse " " is) ++
+ " = \n" ++
+ (concat $ (intersperse (indent currentPos ++ "+++\n") $ filter (not . null) $ x))
+ )
+
+-- A Block may start with some whitespace, then has a valid bit of data
+hamlBlock = do currentPos <- getPosition
+ bs <- manyTill1
+ (pTag <|> pText)
+ (notSameIndent currentPos)
+ return $ intercalate (indent currentPos ++ "+++\n") bs
+
+pTag = do currentPos <- getPosition
+ try
+ (do t <- lexeme tagParser
+ ts <- (isInline currentPos >> char '/' >> return []) <|>
+ (hamlBlock)
+ return $ intercalate "\n" $ filter (not . null) $
+ [ (indent currentPos) ++ "((" ++ (if (null ts) then "i" else "") ++ t ++ ")"
+ , if null ts then [] else ts
+ , (indent currentPos) ++ ")\n"]
+ )
+
+pText = lexeme stringParser
+
+notSameIndent p = (eof >> return []) <|>
+ (do innerPos <- getPosition
+ case (sourceColumn p) == (sourceColumn innerPos) of
+ True -> pzero
+ False -> return []
+ )
+
+--
+-- * Various little parsers
+--
+
+tagParser :: CharParser () String
+tagParser = do t <- optionMaybe tagParser'
+ i <- optionMaybe idParser
+ c <- optionMaybe (many1 classParser)
+ a <- optionMaybe attributesParser
+ if (isJust t || isJust i || isJust c || isJust a)
+ then
+ do return $ "tag \"" ++ (fromMaybe "div" t) ++ "\"" ++
+ (if not (isJust i || isJust c || isJust a) then "" else
+ concat $
+ [ "!["
+ , intercalate ", " $ filter (not . null)
+ [ (maybe "" (\i' -> "strAttr \"id\" \"" ++ i' ++ "\"") i)
+ , (maybe "" (\c' -> "strAttr \"class\" \"" ++ (intercalate " " c') ++ "\"") c)
+ , (maybe "" (\kv -> intercalate ", " $ map (\(k,v) -> "strAttr \"" ++ k ++ "\" \"" ++ v ++ "\"") kv) a)
+ ]
+ , "]"]
+ )
+ else pzero
+
+tagParser' :: CharParser () String
+tagParser' = do char '%'
+ many1 termChar
+
+idParser :: CharParser () String
+idParser = do char '#'
+ many1 termChar
+
+classParser :: CharParser () String
+classParser = do char '.'
+ many1 termChar
+
+attributesParser :: CharParser () [(String, String)]
+attributesParser = squares (commaSep1 attributeParser)
+
+attributeParser :: CharParser () (String, String)
+attributeParser = do k <- identifier
+ symbol "="
+ cs <- many1 identifier
+ return (k, intercalate " " cs)
+
+stringParser :: CharParser () String
+stringParser = do currentPos <- getPosition
+ modifier <- optionMaybe (char '=' <|> char '-')
+ whiteSpace
+ c <- alphaNum
+ cs<- tilEOL
+ case modifier of
+ Just '-' -> return $ (indent currentPos) ++ "-" ++ c:cs
+ Just '=' -> return $ (indent currentPos) ++ "(stringToHtml " ++ c:cs ++ ")"
+ Nothing -> return $ (indent currentPos) ++ "(stringToHtml \"" ++ c:cs ++ "\")"
+
+
+--
+-- * Utility functions
+--
+
+isInline p = do p2 <- getPosition
+ case (sourceLine p ) == (sourceLine p2) of
+ True -> return []
+ False -> pzero
+isSameIndent p1 p2 = (sourceColumn p1) == (sourceColumn p2)
+
+tilEOL = manyTill1 (noneOf "\n") eol
+eol = newline <|> (eof >> return '\n')
+
+termChar = satisfy (\c -> (isAlphaNum c) || (c `elem` termPunctuation) )
+termPunctuation = "-_"
+indent p = take (sourceColumn (p) - 1) (repeat ' ')
+
+manyTill1 p e = do ms <- manyTill p e
+ case (null ms) of
+ True -> pzero
+ False -> return ms
View
1 static/css/turbinado.css
@@ -1,6 +1,7 @@
h1 {
font-weight: bold;
font-size: 16px;
+ margin-top: 10px;
}
h2 {
View
11 turbinado.cabal
@@ -2,14 +2,19 @@ Name: turbinado
Version: 0.2
Synopsis: Haskell web application server
Description: The Haskell web application server
-License: BSD
+License: BSD3
License-file: LICENSE
Author: Alson Kemp
Maintainer: Alson Kemp (alson@alsonkemp.com)
Homepage: http://www.turbinado.org
Build-Type: Simple
-Executable server
+Executable trhaml
+ Main-is: Turbinado/View/HAML/trhaml.hs
+ Build-Depends: base, parsec
+ ghc-options: -O
+
+Executable turbinado
Main-is: Turbinado/Server.hs
Build-Depends: base, bytestring, containers, directory, filepath, harp, HDBC, HDBC-postgresql, hslogger, hsx, HTTP, mtl, network, old-locale, old-time, parsec, plugins, pretty, regex-compat, time
ghc-options: -F -pgmFtrhsx -O
@@ -30,3 +35,5 @@ Executable server
MultiParamTypeClasses,
PatternSignatures,
DeriveDataTypeable
+
+

0 comments on commit a1aa2cd

Please sign in to comment.