Permalink
Browse files

Updating to match turbinado-website

  • Loading branch information...
1 parent 4c5c1b2 commit da95eda271763e881bce81e751f4f89bc46e334a @alsonkemp committed Mar 13, 2009
Showing with 805 additions and 451 deletions.
  1. +17 −15 Config/App.hs.sample
  2. +18 −0 Config/Database.hs.sample
  3. +3 −1 Config/Master.hs
  4. +0 −7 Config/Routes.hs
  5. +33 −1 Config/Routes.hs.sample
  6. +3 −1 README
  7. +4 −0 Turbinado/Controller.hs
  8. +42 −0 Turbinado/Controller/Routes.hs
  9. +1 −1 Turbinado/Database/ORM/Generator.hs
  10. +22 −14 Turbinado/Database/ORM/Output.hs
  11. +19 −12 Turbinado/Environment/CodeStore.hs
  12. +90 −88 Turbinado/Environment/Cookie.hs
  13. +2 −3 Turbinado/Environment/Database.hs
  14. +2 −1 Turbinado/Environment/Header.hs
  15. +3 −2 Turbinado/Environment/Logger.hs
  16. +4 −3 Turbinado/Environment/Params.hs
  17. +4 −0 Turbinado/Environment/Response.hs
  18. +34 −8 Turbinado/Environment/Routes.hs
  19. +0 −132 Turbinado/Environment/Session.hs
  20. +161 −0 Turbinado/Environment/Session/CookieSession.hs
  21. +15 −7 Turbinado/Environment/Settings.hs
  22. +61 −17 Turbinado/Environment/Types.hs
  23. +3 −2 Turbinado/Environment/ViewData.hs
  24. +3 −27 Turbinado/Layout.hs
  25. +8 −0 Turbinado/Layout/Helpers.hs
  26. +12 −0 Turbinado/Layout/Helpers/Misc.hs
  27. +10 −0 Turbinado/Layout/Helpers/Tags.hs
  28. +44 −32 Turbinado/Server.hs
  29. +3 −5 Turbinado/Server/{Handlers → }/ErrorHandler.hs
  30. +0 −26 Turbinado/Server/Handlers/SessionHandler.hs
  31. +70 −5 Turbinado/Server/Network.hs
  32. +7 −5 Turbinado/Server/{Handlers/RequestHandler.hs → RequestProcess.hs}
  33. +34 −29 Turbinado/Server/StandardResponse.hs
  34. +9 −0 Turbinado/Utility/Data.hs
  35. +35 −0 Turbinado/Utility/Naming.hs
  36. +2 −0 Turbinado/View.hs
  37. +5 −3 Turbinado/View/Helpers/Misc.hs
  38. +14 −2 Turbinado/View/Helpers/Tags.hs
  39. +4 −0 static/dispatch.cgi
  40. +4 −2 turbinado.cabal
View
@@ -1,9 +1,5 @@
module Config.App (
- applicationPath,
- applicationHost,
- AppEnvironment (..),
- newAppEnvironment,
- databaseConnection,
+ useLowerCasePaths,
Connection,
customSetupFilters,
customPreFilters,
@@ -16,28 +12,34 @@ import System.Log.Logger
-- Your favorite HDBC driver
import Database.HDBC.PostgreSQL
+import Turbinado.Controller.Monad
+import Turbinado.Environment.Types
+import Turbinado.Environment.Session.CookieSession
+
----------------------------------------------------------------
-- Environment settings
----------------------------------------------------------------
-applicationPath = ""
-applicationHost = "localhost:8080"
-data AppEnvironment = AppEnvironment
-newAppEnvironment = AppEnvironment
+-- | Determines whether the server uses URLs of the form FooBar/BimBam or foo_bar/bim_bam.
+-- The Controllers and Views must still be named FooBar.hs and BimBam.hs.
+useLowerCasePaths = True
----------------------------------------------------------------
--- Database connection
+-- Session settings
----------------------------------------------------------------
-databaseConnection :: Maybe (IO Connection)
--- databaseConnection = Nothing
-databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado user=turbinado password=turbinado"
+sessionOpts = [ ("cookie-name", "turb-sess")
+ , ("cipher-key", "super secret phrase")
+ ]
----------------------------------------------------------------
-- RequestHandler Filter List additions
----------------------------------------------------------------
+customSetupFilters :: [Controller ()]
customSetupFilters = []
-customPreFilters = []
-customPostFilters = []
+customPreFilters :: [Controller ()]
+customPreFilters = [retrieveSession sessionOpts]
+customPostFilters :: [Controller ()]
+customPostFilters = [persistSession sessionOpts]
----------------------------------------------------------------
View
@@ -0,0 +1,18 @@
+module Config.Database (
+ databaseConnection,
+ ) where
+
+import System.Log.Logger
+
+-- Your favorite HDBC driver
+import Database.HDBC.PostgreSQL
+
+import Turbinado.Environment.Types
+----------------------------------------------------------------
+-- Database connection
+----------------------------------------------------------------
+-- databaseConnection :: Maybe (IO Connection)
+-- databaseConnection = Nothing
+databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado user=turbinado password=turbinado"
+
+
View
4 Config/Master.hs 100644 → 100755
@@ -1,9 +1,11 @@
module Config.Master (
module Config.Master,
- module Config.App
+ module Config.App,
+ module Config.Database
) where
import Config.App
+import Config.Database
----------------------------------------------------------------
-- Arguments to the make system used in the Dynamic Loader
View
@@ -1,7 +0,0 @@
-module Config.Routes where
-
-routes = [ "/:controller/:action/:id"
- , "/:controller/:action.:format"
- , "/:controller/:action"
- , "/:controller"
- ]
View
@@ -1,7 +1,39 @@
module Config.Routes where
-routes = [ "/:controller/:action/:id"
+--
+-- Import modules for which you'll be creating static routes.
+--
+import App.Layouts.Default
+import App.Controllers.Home
+import App.Controllers.Develop
+import App.Views.Home.Index
+import App.Views.Develop.Index
+
+--
+-- Configure dynamic routes for on-the-fly compiled-and-loaded
+-- modules (ala Rails)
+--
+routes = [ "/:controller/:action/:id.:format"
+ , "/:controller/:action/:id"
, "/:controller/:action.:format"
, "/:controller/:action"
, "/:controller"
+ , "/home"
]
+
+--
+-- Statically compile and load these Layouts, Controllers and Views
+--
+staticLayouts =
+ [ ("App/Layouts/Default.hs", "markup", App.Layouts.Default.markup)
+ ]
+
+staticControllers =
+ [ ("App/Controllers/Home.hs", "index", App.Controllers.Home.index)
+ , ("App/Controllers/Develop.hs", "index", App.Controllers.Develop.index)
+ ]
+
+staticViews =
+ [ ("App/Views/Home/Index.hs", "markup", App.Views.Home.Index.markup)
+ , ("App/Views/Develop/Index.hs", "markup", App.Views.Develop.Index.markup)
+ ]
View
4 README 100644 → 100755
@@ -1 +1,3 @@
-Turbinado is a stab at producing a Rails-ish MVC web framework for Haskell. A very early stab...
+Turbinado is a Rails-ish MVC web framework for Haskell.
+See the homepage @ http://www.turbinado.org
+
View
@@ -21,7 +21,9 @@ module Turbinado.Controller (
module Data.Maybe,
module Config.Master,
+ module Turbinado.Controller.Routes,
module Turbinado.Environment.CodeStore,
+ module Turbinado.Environment.Cookie,
module Turbinado.Environment.Header,
module Turbinado.Environment.Logger,
module Turbinado.Environment.Params,
@@ -43,6 +45,7 @@ import qualified Database.HDBC as HDBC
import Config.Master
import Turbinado.Environment.CodeStore
+import Turbinado.Environment.Cookie
import Turbinado.Environment.Database
import Turbinado.Environment.Header
import Turbinado.Environment.Logger
@@ -53,6 +56,7 @@ import Turbinado.Environment.Settings
import Turbinado.Environment.Types
import Turbinado.Environment.ViewData
import Turbinado.Controller.Monad
+import Turbinado.Controller.Routes
import Turbinado.Utility.General
import Turbinado.Server.StandardResponse
@@ -0,0 +1,42 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Turbinado.Controller.Routes
+-- Copyright : (c) Alson Kemp 2009
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Alson Kemp (alson@alsonkemp.com)
+-- Stability : experimental
+-----------------------------------------------------------------------------
+module Turbinado.Controller.Routes (
+ checkFormats
+ ) where
+
+import Data.Maybe
+import Network.HTTP.Headers
+
+import Turbinado.Environment.MimeTypes
+import Turbinado.Environment.Request
+import Turbinado.Environment.Response
+import Turbinado.Environment.Settings
+import Turbinado.Environment.Types
+import Turbinado.Controller.Monad
+
+-- | Automates the process of responding to various file formats
+checkFormats:: Controller ()
+checkFormats = do f' <- getSetting "format"
+ case f' of
+ Nothing -> return ()
+ Just f -> do clearLayout
+ oldAction <- getSetting_u "action"
+ setSetting "action" (oldAction ++ f)
+ e <- getEnvironment
+ let mts = fromJust $ getMimeTypes e
+ mt = mimeTypeOf mts f
+ rsp = fromJust $ getResponse e
+ case mt of
+ Nothing -> return ()
+ Just (MimeType s1 s2) -> setResponse $
+ replaceHeader
+ HdrContentType
+ (s1 ++ "/" ++ s2)
+ rsp
View
@@ -8,7 +8,7 @@ import qualified Data.Map as M
import Data.Maybe
import Database.HDBC
-import Config.Master
+import Config.Database
import Turbinado.Database.ORM.Types
import Turbinado.Database.ORM.Output
import Turbinado.Database.ORM.PostgreSQL
View
36 Turbinado/Database/ORM/Output.hs 100644 → 100755
@@ -1,3 +1,4 @@
+
module Turbinado.Database.ORM.Output where
import qualified Data.Char
@@ -49,15 +50,15 @@ generateType t typeName pk ts cs =
, ""
, "import App.Models.Bases.Common"
, "import Data.Maybe"
+ , "import Data.Time"
, "import Data.Typeable"
- , "import System.Time"
, ""
] ++
["-- The data type for this model"] ++
[ "data " ++ typeName ++ " = " ++ typeName ++ " {"
] ++
[intercalate ",\n" (map columnToFieldLabel (M.toList cs))] ++
- [ " } deriving (Eq, Show, Typeable)"
+ [ " } deriving (Show, Typeable)"
, ""
, "instance DatabaseModel " ++ typeName ++ " where"
, " tableName _ = \"" ++ t ++ "\""
@@ -83,7 +84,7 @@ generateFunctions t typeName pk ts cs =
, "import App.Models.Bases.Common"
, "import qualified Database.HDBC as HDBC"
, "import Data.Maybe"
- , "import System.Time"
+ , "import Data.Time"
, ""
, " -- My type"
, "import App.Models.Bases." ++ typeName ++ "Type"
@@ -123,7 +124,7 @@ generateRelations t typeName pk ts cs =
, "import App.Models.Bases.Common"
, "import qualified Database.HDBC as HDBC"
, "import Data.Maybe"
- , "import System.Time"
+ , "import Data.Time"
, ""
, " -- Model imports"
, "import App.Models.Bases." ++ typeName ++ "Type"
@@ -382,6 +383,7 @@ maybeColumnLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) ->
maybeColumnLabel (_, (_, _, True)) = "Maybe " -- Does the column have a default
maybeColumnLabel (_, (desc, _, _)) = if ((colNullable desc) == Just True) then "Maybe " else ""
+-- Derived from hdbc-postgresql/Database/PostgreSQL/Statement.hs and hdbc/Database/HDBC/SqlValue.hs
getHaskellTypeString :: SqlTypeId -> String
getHaskellTypeString SqlCharT = "String"
getHaskellTypeString SqlVarCharT = "String"
@@ -391,19 +393,25 @@ getHaskellTypeString SqlWVarCharT = "String"
getHaskellTypeString SqlWLongVarCharT = "String"
getHaskellTypeString SqlDecimalT = "Rational"
getHaskellTypeString SqlNumericT = "Rational"
+getHaskellTypeString SqlTinyIntT = "Int32"
getHaskellTypeString SqlSmallIntT ="Int32"
getHaskellTypeString SqlIntegerT = "Int32"
-getHaskellTypeString SqlRealT = "Rational"
-getHaskellTypeString SqlFloatT = "Float"
+getHaskellTypeString SqlBigIntT = "Integer"
+getHaskellTypeString SqlRealT = "Double"
+getHaskellTypeString SqlFloatT = "Double"
getHaskellTypeString SqlDoubleT = "Double"
-getHaskellTypeString SqlTinyIntT = "Int32"
-getHaskellTypeString SqlBigIntT = "Int64"
-getHaskellTypeString SqlDateT = "ClockTime"
-getHaskellTypeString SqlTimeT = "ClockTime"
-getHaskellTypeString SqlTimestampT = "ClockTime"
-getHaskellTypeString SqlUTCDateTimeT = "ClockTime"
-getHaskellTypeString SqlUTCTimeT = "TimeDiff"
-getHaskellTypeString _ = error "Don't know how to translate this SqlTypeId to a SqlValue"
+getHaskellTypeString SqlBitT = "Bool"
+getHaskellTypeString SqlDateT = "Day"
+getHaskellTypeString SqlTimestampWithZoneT = "ZonedTime"
+getHaskellTypeString SqlTimestampT = "UTCTime"
+getHaskellTypeString SqlUTCDateTimeT = "UTCTime"
+getHaskellTypeString SqlTimeT = "TimeOfDay"
+getHaskellTypeString SqlUTCTimeT = "TimeOfDay"
+getHaskellTypeString SqlTimeWithZoneT = error "Turbinado ORM Generator: SqlTimeWithZoneT is not supported"
+getHaskellTypeString SqlBinaryT = "B.ByteString"
+getHaskellTypeString SqlVarBinaryT = "B.ByteString"
+getHaskellTypeString SqlLongVarBinaryT = "B.ByteString"
+getHaskellTypeString t = error "Turbinado ORM Generator: Don't know how to translate this SqlTypeId (" ++ show t ++ " to a Haskell Type"
-- | Used for safety. Lowercases the first letter to
@@ -9,6 +9,8 @@ import Control.Monad ( when, foldM)
import Data.Map hiding (map)
import Data.List (isPrefixOf, intersperse)
import Data.Maybe
+import Data.Time
+import Data.Time.Clock.POSIX
import Data.Typeable
import qualified Network.HTTP as HTTP
import Prelude hiding (lookup,catch)
@@ -26,25 +28,26 @@ import Turbinado.Environment.Logger
import Turbinado.Environment.Types
import Turbinado.Environment.Request
import Turbinado.Environment.Response
+import Turbinado.Utility.Data
import Turbinado.View.Monad hiding (liftIO)
import Turbinado.View.XML
import Turbinado.Controller.Monad
-- | Create a new store for Code data
addCodeStoreToEnvironment :: (HasEnvironment m) => m ()
addCodeStoreToEnvironment = do e <- getEnvironment
- mv <- liftIO $ newMVar $ empty
+ let cm = empty
+ mv <- liftIO $ newMVar cm
setEnvironment $ e {getCodeStore = Just $ CodeStore mv}
-- | This function attempts to pull a function from a pre-loaded cache or, if
-- the function doesn't exist or is out-of-date, loads the code from disk.
retrieveCode :: (HasEnvironment m) => CodeType -> CodeLocation -> m CodeStatus
retrieveCode ct cl' = do
e <- getEnvironment
- let (CodeStore mv) = fromJust $ getCodeStore e
+ let (CodeStore mv) = fromJust' "CodeStore: retrieveCode" $ getCodeStore e
path = getDir ct
- cl <- do -- d <- getCurrentDirectory
- return (addExtension (joinPath $ map normalise [path, dropExtension $ fst cl']) "hs", snd cl')
+ cl <- return (addExtension (joinPath $ map normalise [path, dropExtension $ fst cl']) "hs", snd cl')
debugM $ " CodeStore : retrieveCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
cmap <- liftIO $ takeMVar mv
let c= lookup cl cmap
@@ -54,7 +57,7 @@ retrieveCode ct cl' = do
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
+ checkReloadCode ct cmap (fromJust' "CodeStore: retrieveCode2" c) cl
liftIO $ putMVar mv cmap'
-- We _definitely_ have a code entry now, though it may have a MakeFailure
let c' = lookup cl cmap'
@@ -92,8 +95,8 @@ checkReloadCode ct cmap cstat cl = do
needReloadCode fp fd = do
fe <- liftIO $ doesFileExist fp
case fe of
- True -> do mt <- liftIO $ getModificationTime fp
- return $ (True, mt > fd)
+ True -> do TOD mt _ <- liftIO $ getModificationTime fp
+ return $ (True, fromIntegral mt > utcTimeToPOSIXSeconds fd)
False-> return (False, True)
@@ -152,7 +155,7 @@ _loadView ct cmap cl args fp = do
return (insert cl (CodeLoadFailure $ unlines err) cmap)
LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
liftIO $ unload m
- t <- liftIO $ getClockTime
+ t <- liftIO $ getCurrentTime
case ct of
CTLayout -> return (insert cl (CodeLoadView f t) cmap)
CTView -> return (insert cl (CodeLoadView f t) cmap)
@@ -170,7 +173,7 @@ _loadController ct cmap cl args fp = do
return (insert cl (CodeLoadFailure $ unlines err) cmap)
LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
liftIO $ unload m
- t <- liftIO $ getClockTime
+ t <- liftIO $ getCurrentTime
case ct of
CTController -> return (insert cl (CodeLoadController f t) cmap)
CTComponentController -> return (insert cl (CodeLoadComponentController f t) cmap)
@@ -197,9 +200,13 @@ customMergeToDir stb src dir = do
MergeFailure ["Source file does not exist : "++stb]
_ -> do
src_str <- liftIO $ readFile src
- stb_str <- liftIO $ readFile stb
- let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
- mrg_str = outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
+ stb_str <- liftIO $ readFile stb
+ -- Check to see whether the file start with "module ". If so, the user
+ -- should already have added the require preamble. Otherwise, merge the stub.
+ let mrg_str = case src_str of
+ ('m':'o':'d':'u':'l':'e':' ':_) -> src_str
+ _ -> let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
+ in outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
liftIO $ createDirectoryIfMissing True outDir
hdl <- liftIO $ openFile outFile WriteMode -- overwrite!
liftIO $ hPutStr hdl mrg_str
Oops, something went wrong.

1 comment on commit da95eda

That’s a big commit.

Please sign in to comment.