Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Updating to match turbinado-website

  • Loading branch information...
commit da95eda271763e881bce81e751f4f89bc46e334a 1 parent 4c5c1b2
@alsonkemp authored
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
32 Config/App.hs.sample
@@ -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
18 Config/Database.hs.sample
@@ -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
7 Config/Routes.hs
@@ -1,7 +0,0 @@
-module Config.Routes where
-
-routes = [ "/:controller/:action/:id"
- , "/:controller/:action.:format"
- , "/:controller/:action"
- , "/:controller"
- ]
View
34 Config/Routes.hs.sample
@@ -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
4 Turbinado/Controller.hs
@@ -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
View
42 Turbinado/Controller/Routes.hs
@@ -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
2  Turbinado/Database/ORM/Generator.hs 100644 → 100755
@@ -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
View
31 Turbinado/Environment/CodeStore.hs
@@ -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,6 +28,7 @@ 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
@@ -33,7 +36,8 @@ 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
@@ -41,10 +45,9 @@ addCodeStoreToEnvironment = do e <- getEnvironment
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
View
178 Turbinado/Environment/Cookie.hs 100644 → 100755
@@ -1,116 +1,108 @@
-module Turbinado.Data.Cookie where
+-----------------------------------------------------------------------------
+-- |
+-- Module : Turbinado.Environment.Cookie
+-- Copyright : (c) Alson Kemp 2008-2009
+-- (c) Bjorn Bringert 2004-2005
+-- (c) Ian Lynagh 2005
+-- License : BSD-style
+--
+-- Maintainer : alson@alsonkemp.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- General server side HTTP cookie library.
+-- Based on <http://wp.netscape.com/newsref/std/cookie_spec.html>
+-- Lifted in near entirety from the CGI package (http://hackage.haskell.org/cgi-bin/hackage-scripts/package/cgi)
+--
+-----------------------------------------------------------------------------
+
+module Turbinado.Environment.Cookie
+ ( mkCookie
+ , getCookie
+ , setCookie
+ , deleteCookie
+ , showCookie
+ ) where
import Data.Char (isSpace)
-import Data.List (intersperse)
+import Data.List (intercalate)
import Data.Maybe (catMaybes)
import System.Locale (defaultTimeLocale, rfc822DateFormat)
-import System.Time (CalendarTime(..), Month(..), Day(..),
- formatCalendarTime)
+import Data.Time
+import Network.HTTP.Headers
+import Turbinado.Environment.Header
+import Turbinado.Environment.Response
+import Turbinado.Environment.Types
+import Turbinado.Utility.Data (fromJust')
--
--- * Types
+-- * Getting cookies
--
--- | Contains all information about a cookie set by the server.
-data Cookie = Cookie {
- -- | Name of the cookie.
- cookieName :: String,
- -- | Value of the cookie.
- cookieValue :: String,
- -- | Expiry date of the cookie. If 'Nothing', the
- -- cookie expires when the browser sessions ends.
- -- If the date is in the past, the client should
- -- delete the cookie immediately.
- cookieExpires :: Maybe CalendarTime,
- -- | The domain suffix to which this cookie will be sent.
- cookieDomain :: Maybe String,
- -- | The path to which this cookie will be sent.
- cookiePath :: Maybe String,
- -- | 'True' if this cookie should only be sent using
- -- secure means.
- cookieSecure :: Bool
- }
- deriving (Show, Read, Eq, Ord)
-
-
-
---
--- * Constructing cookies
+-- | Get the value of a cookie from a string on the form
+-- @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@.
+-- This is the format of the @Cookie@ HTTP header.
+getCookie :: HasEnvironment m =>
+ String -- ^ Cookie name
+ -> m (Maybe String) -- ^ Cookie value, if found
+getCookie name = do e <- getEnvironment
+ h <- getHeader HdrCookie
+ case h of
+ Nothing -> return Nothing
+ Just h' -> return $ maybeLast [ cv | (cn,cv) <- readCookies h', cn == name ]
+
+--
+-- * Setting Cookies
--
+-- | Set a cookie (which you should have created using something like 'mkCookie'
+setCookie :: HasEnvironment m =>
+ Cookie ->
+ m ()
+setCookie c = do e <- getEnvironment
+ let r = fromJust' "setCookie" $ getResponse e
+ setResponse $ insertHeaders [Header HdrSetCookie $ showCookie c] r
+
-- | Construct a cookie with only name and value set.
-- This client will expire when the browser sessions ends,
-- will only be sent to the server and path which set it
-- and may be sent using any means.
-newCookie :: String -- ^ Name
- -> String -- ^ Value
- -> Cookie -- ^ Cookie
-newCookie name value = Cookie { cookieName = name,
- cookieValue = value,
- cookieExpires = Nothing,
- cookieDomain = Nothing,
- cookiePath = Nothing,
- cookieSecure = False
+mkCookie :: String -- ^ Name
+ -> String -- ^ Value
+ -> Cookie -- ^ Cookie
+mkCookie name value = Cookie { cookieName = name,
+ cookieValue = value,
+ cookieExpires = Nothing,
+ cookieDomain = Nothing,
+ cookiePath = Nothing
}
---
--- * Getting and setting cookies
---
-
--- | Get the value of a cookie from a string on the form
--- @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@.
--- This is the format of the @Cookie@ HTTP header.
-findCookie :: String -- ^ Cookie name
- -> String -- ^ Semicolon separated list of name-value pairs
- -> Maybe String -- ^ Cookie value, if found
-findCookie name s = maybeLast [ cv | (cn,cv) <- readCookies s, cn == name ]
-
-- | Delete a cookie from the client by setting the cookie expiry date
-- to a date in the past.
-deleteCookie :: Cookie -- ^ Cookie to delete. The only fields that matter
- -- are 'cookieName', 'cookieDomain' and 'cookiePath'
- -> Cookie
-deleteCookie c = c { cookieExpires = Just epoch }
- where
- epoch = CalendarTime {
- ctYear = 1970,
- ctMonth = January,
- ctDay = 1,
- ctHour = 0,
- ctMin = 0,
- ctSec = 0,
- ctPicosec = 0,
- ctWDay = Thursday,
- ctYDay = 1,
- ctTZName = "GMT",
- ctTZ = 0,
- ctIsDST = False
- }
-
+deleteCookie :: HasEnvironment m =>
+ String -- ^ Cookie to delete.
+ -> m ()
+deleteCookie c = setCookie $ c' { cookieExpires = Just epoch }
+ where
+ c' = mkCookie c ""
+ epoch = UTCTime (ModifiedJulianDay 100) (secondsToDiffTime 0)
--
--- * Reading and showing cookies
+-- * Showing cookies
--
--- | Show a cookie on the format used as the value of the Set-Cookie header.
+-- | Show a cookie in the format used as the value of the Set-Cookie header.
showCookie :: Cookie -> String
-showCookie c = concat $ intersperse "; " $
+showCookie c = intercalate "; " $
showPair (cookieName c) (cookieValue c)
- : catMaybes [expires, path, domain, secure]
+ : catMaybes [expires, path, domain]
where expires = fmap (showPair "expires" . dateFmt) (cookieExpires c)
domain = fmap (showPair "domain") (cookieDomain c)
- path = fmap (showPair "path") (cookiePath c)
- secure = if cookieSecure c then Just "secure" else Nothing
- dateFmt = formatCalendarTime defaultTimeLocale rfc822DateFormat
-
--- | Show a name-value pair. FIXME: if the name or value
--- contains semicolons, this breaks. The problem
--- is that the original cookie spec does not mention
--- how to do escaping or quoting.
-showPair :: String -- ^ name
- -> String -- ^ value
- -> String
-showPair name value = name ++ "=" ++ value
+ path = fmap (showPair "path") (maybe (Just "/") Just (cookiePath c))
+ dateFmt = formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"
+--
+-- * Reading cookies
+--
-- | Gets all the cookies from a Cookie: header value
readCookies :: String -- ^ String to parse
@@ -121,7 +113,7 @@ readCookies s =
in if null xs then [] else (xs,zs):readCookies (drop 1 ws)
--
--- Utilities
+-- * Utilities
--
-- | Return 'Nothing' is the list is empty, otherwise return
@@ -130,4 +122,14 @@ maybeLast :: [a] -> Maybe a
maybeLast [] = Nothing
maybeLast xs = Just (last xs)
+-- | Show a name-value pair. FIXME: if the name or value
+-- contains semicolons, this breaks. The problem
+-- is that the original cookie spec does not mention
+-- how to do escaping or quoting.
+showPair :: String -- ^ name
+ -> String -- ^ value
+ -> String
+showPair name value = name ++ "=" ++ value
+
+
View
5 Turbinado/Environment/Database.hs
@@ -10,8 +10,7 @@ import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.Maybe
-import qualified Database.HDBC as HDBC
-import Database.HDBC (IConnection)
+import Database.HDBC
import Config.Master
import Turbinado.Controller.Monad
@@ -23,5 +22,5 @@ addDatabaseToEnvironment = do e <- getEnvironment
case databaseConnection of
Nothing -> return ()
Just conn -> do c <- liftIO $ conn
- setEnvironment $ e {getDatabase = Just c}
+ setEnvironment $ e {getDatabase = Just (ConnWrapper c)}
View
3  Turbinado/Environment/Header.hs
@@ -10,11 +10,12 @@ import Network.HTTP.Headers
import Turbinado.Controller.Monad
import Turbinado.Environment.Types
import Turbinado.Environment.Request
+import Turbinado.Utility.Data
-- | Attempts to pull a HTTP header value.
getHeader :: (HasEnvironment m) => HeaderName -> m (Maybe String)
getHeader h = do e <- getEnvironment
- return $ findHeader h (fromJust $ getRequest e)
+ return $ findHeader h (fromJust' "Header: getHeader" $ getRequest e)
-- | Unsafe version of getHeader. Fails if the key is not found.
getHeader_u :: (HasEnvironment m) => HeaderName -> m String
View
5 Turbinado/Environment/Logger.hs
@@ -11,6 +11,7 @@ import Data.Dynamic
import Data.Maybe
import System.IO.Unsafe
+import Turbinado.Utility.Data
addLoggerToEnvironment :: (HasEnvironment m) => m ()
addLoggerToEnvironment = do e <- getEnvironment
@@ -21,11 +22,11 @@ addLoggerToEnvironment = do e <- getEnvironment
takeLoggerLock :: (HasEnvironment m) => m ()
takeLoggerLock = do e <- getEnvironment
- liftIO $ takeMVar (fromJust $ getLoggerLock e)
+ liftIO $ takeMVar (fromJust' "Logger: takeLoggerLock" $ getLoggerLock e)
putLoggerLock :: (HasEnvironment m) => m ()
putLoggerLock = do e <- getEnvironment
- liftIO $ putMVar (fromJust $ getLoggerLock e) ()
+ liftIO $ putMVar (fromJust' "Logger: putLoggerLock" $ getLoggerLock e) ()
wrapLoggerLock :: (HasEnvironment m) => (String -> IO ()) -> String -> m ()
wrapLoggerLock lf s = do takeLoggerLock
View
7 Turbinado/Environment/Params.hs
@@ -11,6 +11,7 @@ import Network.URI
import Turbinado.Environment.Header
import Turbinado.Environment.Request
import Turbinado.Environment.Types
+import Turbinado.Utility.Data
-- | Attempt to get a Parameter from the Request query string
-- or POST body.
@@ -30,14 +31,14 @@ getParam_u p = do r <- getParam p
-- Functions used by getParam. Not exported.
getParamFromQueryString :: (HasEnvironment m) => String -> m (Maybe String)
getParamFromQueryString s = do e <- getEnvironment
- let qs = uriQuery $ rqURI (fromJust $ getRequest e)
+ let qs = uriQuery $ rqURI (fromJust' "Params : getParamFromQueryString" $ getRequest e)
return $ lookup s $ formDecode qs
getParamFromBody :: (HasEnvironment m) => String -> m (Maybe String)
getParamFromBody s = do e <- getEnvironment
ct <- getHeader HdrContentType
- let rm = rqMethod (fromJust $ getRequest e)
- rb = rqBody (fromJust $ getRequest e)
+ let rm = rqMethod (fromJust' "Params : getParamsFromBody" $ getRequest e)
+ rb = rqBody (fromJust' "Params : getParamsFromBody" $ getRequest e)
case rm of
POST -> -- TODO: ADD MULTIPART
return $ lookup s $ formDecode rb
View
4 Turbinado/Environment/Response.hs
@@ -16,6 +16,10 @@ import System.Time
import System.Locale
+--getResponse :: (HasEnvironment m) => m HTTP.Response
+--getResponse = do e <- getEnvironment
+-- return $ getResponse e
+
setResponse :: (HasEnvironment m) => HTTP.Response -> m ()
setResponse resp = do e <- getEnvironment
setEnvironment $ e {getResponse = Just resp}
View
42 Turbinado/Environment/Routes.hs 100644 → 100755
@@ -2,27 +2,37 @@ module Turbinado.Environment.Routes (
addRoutesToEnvironment,
runRoutes
) where
-
+
+import Control.Concurrent.MVar
import Text.Regex
import Data.Maybe
import Data.Typeable
import Data.Dynamic
import qualified Data.Map as M
+import Data.Time
import Control.Monad
import qualified Network.HTTP as HTTP
import qualified Network.URI as URI
+import Turbinado.Controller.Monad
import Turbinado.Controller.Exception
import Turbinado.Environment.Types
import Turbinado.Environment.Logger
import Turbinado.Environment.Request
import Turbinado.Environment.Settings
import qualified Turbinado.Environment.Settings as S
+import Turbinado.Utility.Data
import qualified Config.Routes
addRoutesToEnvironment :: (HasEnvironment m) => m ()
addRoutesToEnvironment = do e <- getEnvironment
- setEnvironment $ e {getRoutes = Just $ Routes $ parseRoutes Config.Routes.routes}
+ let CodeStore mv = fromJust' "Turbinado.Environment.Routes.addRoutesToEnvironment : no CodeStore" $ getCodeStore e
+ cm <- liftIO $ takeMVar mv
+ let cm' = addStaticControllers Config.Routes.staticControllers cm
+ cm'' = addStaticViews (Config.Routes.staticViews ++ Config.Routes.staticLayouts) cm'
+ liftIO $ putMVar mv cm''
+ setEnvironment $ e {
+ getRoutes = Just $ Routes $ parseRoutes Config.Routes.routes}
------------------------------------------------------------------------------
@@ -32,18 +42,19 @@ addRoutesToEnvironment = do e <- getEnvironment
runRoutes :: (HasEnvironment m) => m ()
runRoutes = do debugM $ " Routes.runRoutes : starting"
e <- getEnvironment
- let Routes rs = fromJust $ getRoutes e
- r = fromJust $ getRequest e
+ let Routes rs = fromJust' "Routes : runRoutes : getRoutes" $ getRoutes e
+ r = fromJust' "Routes : runRoutes : getRequest" $ getRequest e
p = URI.uriPath $ HTTP.rqURI r
- sets = msum $ map (\(r, k) -> maybe [] (zip k) (matchRegex r p)) rs
+ sets = filter (not . null) $ map (\(r, k) -> maybe [] (zip k) (matchRegex r p)) rs
case sets of
- [] -> throwController $ ParameterLookupFailed $ "No routes matched for " ++ p
- _ -> do mapM (\(k, v) -> setSetting k v) sets
+ [] -> do setSetting "controller" $ last Config.Routes.routes -- no match, so use the last route
+ addDefaultAction
+ _ -> do mapM (\(k, v) -> setSetting k v) $ head sets
addDefaultAction
addDefaultAction :: (HasEnvironment m) => m ()
addDefaultAction = do e <- getEnvironment
- let s = fromJust $ getSettings e
+ let s = fromJust' "Routes : addDefaultAction : getSettings" $ getSettings e
setEnvironment $ e {getSettings = Just (M.insertWith (\ a b -> b) "action" (toDyn "Index") s)}
------------------------------------------------------------------------------
@@ -72,3 +83,18 @@ splitOn c l = reverse $ worker c l []
worker c (l:ls) (r:rs) = if (l == c)
then worker c ls ([]:r:rs)
else worker c ls ((r++[l]):rs)
+
+
+----------------------------------------------------------------------------
+-- Handle static routes
+----------------------------------------------------------------------------
+
+--addStaticViews :: [(String, String, View XML)] -> CodeMap -> CodeMap
+addStaticViews [] cm = cm
+addStaticViews ((p,f,v):vs) cm = let cm' = M.insert (p,f) (CodeLoadView v $ UTCTime (ModifiedJulianDay 1000000) (secondsToDiffTime 0)) cm in
+ addStaticViews vs cm'
+
+addStaticControllers [] cm = cm
+addStaticControllers ((p,f,c):cs) cm = let cm' = M.insert (p,f) (CodeLoadController c $ UTCTime (ModifiedJulianDay 1000000) (secondsToDiffTime 0)) cm in
+ addStaticControllers cs cm'
+
View
132 Turbinado/Environment/Session.hs
@@ -1,132 +0,0 @@
-module Turbinado.Environment.Session (
- Session -- ^ Abstract
- -- * Functions used in HSP
- , getVarValue -- ^ :: Session -> Key -> (Maybe Value)
- , setVarValue -- ^ :: Session -> Key -> Value -> ()
- , deleteVar -- ^ :: Session -> Key -> ()
- , abandon -- ^ :: Session -> ()
- , setExpires -- ^ :: Session -> UTCTime -> ()
- -- * Functions used by the RTS
- , isSession -- ^ :: Session -> Bool
- , getSessionId -- ^ :: Session -> (Maybe SessionId)
- , getExpires -- ^ :: Session -> Expires
- , initSession -- ^ :: [(Key, Value)] -> Session
- , noSession -- ^ :: Session
- , getNewVars -- ^ :: Session -> [(Key, (Value, Expires))]
- , getUpdatedVars -- ^ :: Session -> [(Key, (Value, Expires))]
- , getDeletedVars -- ^ :: Session -> [Key]
- ) where
-
-import qualified Data.Map as M
-import Data.Time
-
--------------------------------------
--- Help types
-
-type Expires = Maybe UTCTime
-type Key = String
-type Value = String
-type SessionId = Int
-
-neverExpire :: Expires
-neverExpire = Nothing
-
-expire :: UTCTime -> Expires
-expire = Just
-
-data Status = New | Orig | Updated | Deleted
- deriving (Eq)
-
-updateStatus :: Status -> Status
-updateStatus s = case s of
- New -> New
- _ -> Updated
-
-----------------------------------------
--- The main datatypes
-
--- | The 'Session' datatype is basically a data repository.
--- To keep tracks of updates, we use an extra repository.
-newtype Session = Session (Maybe SessionData)
-
-data SessionData = SessionData {
- sessionId :: Maybe SessionId,
- expires :: Expires,
- dataRep :: M.Map Key (Value,Expires,Status)
- }
-
--- | Create a new 'Session' object with initial data.
-initSession :: SessionId -> Expires -> [(Key, (Value, Expires))] -> Session
-initSession sid exps initData =
- let dat = map (\(k,(v,e)) -> (k,(v,e,Orig))) initData
- rep = M.fromList dat
- sd = SessionData {
- dataRep = rep,
- expires = exps,
- sessionId = Just sid } in
- Session (Just sd)
-
-noSession :: Session
-noSession = Session Nothing
-
----------------------------------------
--- Operate on sessions
-
--- | Retrieve the value of a variable in the repository.
-getVarValue :: Session -> Key -> Maybe Value
-getVarValue (Session Nothing) k = Nothing
-getVarValue (Session (Just sd)) k =
- case (M.lookup k (dataRep sd)) of
- Nothing -> Nothing
- Just (v,e,Deleted) -> Nothing
- Just (v,e,_) -> Just v
-
-setVarValue :: Session -> Key -> Value -> Session
-setVarValue (Session Nothing) k v = error "Tried to setVarValue without a valid session"
-setVarValue (Session (Just sd)) k v =
- case (M.lookup k (dataRep sd)) of
- Nothing -> Session $ Just $ sd {dataRep = M.insert k (v, neverExpire, New) (dataRep sd)}
- Just (_,e,st) -> Session $ Just $ sd {dataRep = M.insert k (v, e, updateStatus st) (dataRep sd)}
-
-deleteVar :: Session -> Key -> Session
-deleteVar (Session Nothing) k = (Session Nothing)
-deleteVar (Session (Just sd)) k = Session $ Just $ sd {dataRep = M.delete k (dataRep sd)}
-
-abandon :: Session -> Session
-abandon (Session mvs) = (Session Nothing)
-
-setExpires :: Session -> UTCTime -> Session
-setExpires (Session Nothing) ct = error "Tried to setVarValue without a valid session"
-setExpires (Session (Just sd)) ct = Session $ Just $ sd {expires = expire ct}
-
------------------------------------------
--- Used by HSPR
-
-isSession :: Session -> Bool
-isSession (Session Nothing) = False
-isSession _ = True
-
-
-getSessionId :: Session -> Maybe SessionId
-getSessionId (Session Nothing) = Nothing
-getSessionId (Session (Just sd)) = sessionId sd
-
-getExpires :: Session -> Expires
-getExpires (Session Nothing) = Nothing
-getExpires (Session (Just sd)) = expires sd
-
-
-getVars :: Status -> Session -> [(Key, (Value, Expires))]
-getVars status (Session Nothing) = []
-getVars status (Session (Just sd)) =
- let vals = M.toList (dataRep sd)
- newVals = filter (\(_,(_,_,st)) -> st == status) vals
- in map (\(k,(v,e,_)) -> (k,(v,e))) newVals
-
-getNewVars, getUpdatedVars :: Session -> [(Key, (Value, Expires))]
-getNewVars = getVars New
-getUpdatedVars = getVars Updated
-
-getDeletedVars :: Session -> [Key]
-getDeletedVars (Session Nothing) = []
-getDeletedVars s = map fst $ getVars Deleted s
View
161 Turbinado/Environment/Session/CookieSession.hs
@@ -0,0 +1,161 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Turbinado.Environment.Session.CookieSession
+-- Copyright : (c) Niklas Broberg 2004, Michael Snoyman 2008-2009, Alson Kemp 2009
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Alson Kemp, alson@alsonkemp.com
+-- Stability : experimental
+-- Portability : requires undecidable and overlapping instances
+--
+-- Much of this code is lifted/derived from Niklas' HSP and from Michael's HWeb.
+-----------------------------------------------------------------------------
+module Turbinado.Environment.Session.CookieSession where
+
+import Control.Monad.Trans
+import Data.List
+import Data.Maybe
+import qualified Data.Map as M
+import Data.Time
+import System.IO
+
+import qualified Data.Digest.MD5 as MD5
+import Data.LargeWord (Word128)
+import Data.Word (Word8)
+import Codec.Encryption.Modes
+import qualified Codec.Encryption.AES as AES
+import qualified Codec.Binary.Base64 as Base64
+import Codec.Utils
+import qualified Network.HTTP.Headers as Headers
+import Turbinado.Environment.Cookie
+import Turbinado.Environment.Types
+import Turbinado.Utility.Data
+
+type Key = String
+type Value = String
+
+
+instance (HasEnvironment m) => HasSession m where
+ newSession opts = let n = maybe
+ (error "'cookie-name' didn't exist in options passed to newSession")
+ id
+ (lookup "cookie-name" opts)
+ in _setSession $ emptySession { sessionName = Just n }
+ hasValidSession = do e <- getEnvironment
+ case getSession e of
+ Nothing -> return False
+ Just s -> case expires s of
+ Nothing -> return True
+ Just t -> do now <- liftIO $ getCurrentTime
+ return $ t > now
+ retrieveSession opts = do let c = maybe
+ (error "'cipher-key' didn't exist in options passed to retrieveSession")
+ id
+ (lookup "cipher-key" opts)
+ n = maybe
+ (error "'cookie-name' didn't exist in options passed to retrieveSession")
+ id
+ (lookup "cookie-name" opts)
+ message'' <- getCookie n
+ e <- getEnvironment
+ case message'' of
+ Nothing -> newSession opts
+ Just m'' -> let message' = maybeRead m'' in
+ case message' of
+ Nothing -> newSession opts
+ Just (m, h) -> do let messageBlocks = unCbc AES.decrypt 0 (w8ToKey $ MD5.hash $ stringToW8 c) (w8ToBlocks $ fromJust' "CookieSession : retrieveSession" $ Base64.decode m)
+ hashCode = fromJust' "CookieSession : retreiveSession(2)" $ Base64.decode h
+ hashCheck = MD5.hash $ blocksToW8 messageBlocks
+ if (hashCode == hashCheck)
+ then let s = read (w8ToString $ blocksToW8 messageBlocks) in
+ case (expires s) of
+ Nothing -> do _setSession s
+ Just t -> do t' <- liftIO $ getCurrentTime
+ if (t > t')
+ then _setSession s
+ else newSession opts
+ else newSession opts
+ persistSession opts = do e <- getEnvironment
+ let s' = getSession e
+ case s' of
+ Nothing -> return ()
+ Just s -> do let c = maybe
+ (error "'cipher-key' didn't exist in options passed to persistSession")
+ id
+ (lookup "cipher-key" opts)
+ ex = maybe
+ Nothing
+ maybeReadUTC
+ (lookup "session-expires" opts)
+ message = stringToW8 $ show s
+ cipheredMessage = Base64.encode $ blocksToW8 $ cbc AES.encrypt 0 (w8ToKey $ MD5.hash $ stringToW8 c) (w8ToBlocks message)
+ hashCode = Base64.encode $ MD5.hash message
+ setCookie
+ (Cookie {cookieName = fromJust' "CookieSession : persistSession" $ sessionName s
+ ,cookieValue = (show $ (cipheredMessage, hashCode))
+ ,cookieExpires = ex
+ ,cookieDomain = Nothing
+ ,cookiePath = Nothing
+ }
+ )
+ abandonSession = do e <- getEnvironment
+ let s = getSession e
+ setEnvironment $ e {getSession = Nothing}
+ case s of
+ Nothing -> return ()
+ Just s' -> deleteCookie (fromJust' "CookieSession : abandonSession" $ sessionName s')
+ getSessionValue k = do s <- _getSession
+ return $ M.lookup k $ dataRep s
+ setSessionValue k v = do s <- _getSession
+ let s' = s {dataRep = M.insert k v (dataRep s)}
+ _setSession s'
+ deleteSessionKey k = do s <- _getSession
+ let s' = s {dataRep = M.delete k (dataRep s)}
+ _setSession s'
+ getSessionExpires = (return . expires) =<< _getSession
+ setSessionExpires ct = do s <- _getSession
+ let s' = s {expires = ct}
+ _setSession s'
+ setSessionId sid = do s <- _getSession
+ let s' = s {sessionId = sid}
+ _setSession s'
+ getSessionId = (return . sessionId) =<< _getSession
+
+
+--
+-- * Helpers
+--
+stringToW8 :: String -> [Word8]
+stringToW8 = map (fromInteger . toInteger . fromEnum)
+
+w128ToW8 :: Word128 -> [Word8]
+w128ToW8 w128 = toOctets 256 w128
+
+w8ToString :: [Word8] -> String
+w8ToString = map (toEnum . fromInteger . toInteger)
+
+blocksToString :: [[Word8]] -> String
+blocksToString ws = concat $ map w8ToString ws
+
+blocksToW8 :: [Word128] -> [Word8]
+blocksToW8 ws = concat $ map w128ToW8 ws
+
+w8ToKey :: [Word8] -> Word128
+w8ToKey ws = fromInteger $ foldl (\acc i -> acc*256 + toInteger i) (0::Integer) ws
+
+w8ToBlocks :: [Word8] -> [Word128]
+w8ToBlocks ws = map w8ToKey $ breakup ws
+ where breakup [] = []
+ breakup ws = (take 16 ws) : (breakup $ drop 16 ws)
+
+maybeRead = listToMaybe . map fst . filter (null . snd) . reads
+maybeReadUTC :: String -> Maybe UTCTime
+maybeReadUTC = listToMaybe . map fst . filter (null . snd) . reads
+
+_getSession :: (HasEnvironment m) => m Session
+_getSession = getEnvironment >>= (return . fromJust' "CookieSession : _getSession" . getSession)
+
+_setSession :: (HasEnvironment m) => Session -> m ()
+_setSession s = getEnvironment >>= (\e -> setEnvironment $ e {getSession = Just s})
+
+
View
22 Turbinado/Environment/Settings.hs
@@ -18,6 +18,9 @@ import System.FilePath
import Turbinado.Environment.Logger
import Turbinado.Environment.Types
import Turbinado.Controller.Monad
+import Turbinado.Utility.Naming
+import Turbinado.Utility.Data
+import qualified Config.Master as Config
-- | Used during request initialization to add the 'Settings' 'Map'
-- to the 'Environment'.
@@ -37,7 +40,7 @@ addSettingsToEnvironment = do e <- getEnvironment
-- then @getSetting "number" :: 'Controller' Integer@ will return @'Controller' Nothing@.
getSetting :: (HasEnvironment m, Typeable a) => String -> m (Maybe a)
getSetting s = do e <- getEnvironment
- return $ maybe Nothing (fromDynamic) ( M.lookup s (fromJust $ getSettings e) )
+ return $ maybe Nothing (fromDynamic) ( M.lookup s (fromJust' "Settings : getSetting" $ getSettings e) )
-- | This function is an "unsafe" version of 'getSetting' in that this function assumes that the key
-- *does* exist in the map. If no key exists or if the value type does not match the inferred
@@ -57,13 +60,12 @@ getSetting_u s = do v <- getSetting s
-- 'show' to convert to a String).
setSetting :: (HasEnvironment m, Typeable a) => String -> a -> m ()
setSetting k v = do e <- getEnvironment
- debugM $ " setSetting : " ++ k
- setEnvironment $ e { getSettings = Just (M.insert k (toDyn v) (fromJust $ getSettings e))}
+ setEnvironment $ e { getSettings = Just (M.insert k (toDyn v) (fromJust' "Settings : setSetting" $ getSettings e))}
-- | Unsets a setting. If the key does not exist, no error is thrown.
unsetSetting :: (HasEnvironment m) => String -> m ()
unsetSetting k = do e <- getEnvironment
- setEnvironment $ e { getSettings = Just (M.delete k (fromJust $ getSettings e))}
+ setEnvironment $ e { getSettings = Just (M.delete k (fromJust' "Settings : unsetSetting" $ getSettings e))}
-- ! The 'Settings' to use at the start of each request.
defaultSettings :: [(String, Dynamic)]
@@ -76,8 +78,11 @@ defaultSettings = [ ("layout", toDyn "Default") ]
getController :: (HasEnvironment m) => m (FilePath, String)
getController = do c <- getSetting_u "controller"
a <- getSetting_u "action"
- return $ (c,
- actionName a)
+ let converter = if Config.useLowerCasePaths
+ then fromUnderscore
+ else id
+ return $ (converter c,
+ actionName $ converter a)
where actionName s = (toLower $ head s) : (tail s)
-- | Tells the 'Controller' to use a particular 'Layout' for the 'View'.
@@ -92,5 +97,8 @@ clearLayout = unsetSetting "layout"
getView :: (HasEnvironment m) => m (FilePath, String)
getView = do c <- getSetting_u "controller"
a <- getSetting_u "action"
- return (joinPath $ map normalise [c,a], "markup")
+ let converter = if Config.useLowerCasePaths
+ then fromUnderscore
+ else id
+ return (joinPath $ map normalise [converter c, converter a], "markup")
View
78 Turbinado/Environment/Types.hs 100644 → 100755
@@ -3,6 +3,7 @@ module Turbinado.Environment.Types where
import Data.Dynamic
import qualified Data.Map as M
import Data.Maybe
+import Data.Time
import System.IO
import System.IO.Unsafe
import System.Log.Logger
@@ -12,8 +13,7 @@ import Control.Monad.State
import qualified Network.HTTP as HTTP
import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)
import Turbinado.View.XML
-import Config.Master
-import System.Time
+import Database.HDBC
-- | The class of types which hold an 'Environment'.
@@ -25,17 +25,18 @@ class (MonadIO m) => HasEnvironment m where
-- | The Environment in which each request is handled.
-- All components are held within 'Maybe's so that the
-- Environment can be partially constructed.
-data Environment = Environment { getCodeStore :: Maybe CodeStore
- , getDatabase :: Maybe Database
- , getLoggerLock :: Maybe LoggerLock
- , getMimeTypes :: Maybe MimeTypes
- , getRequest :: Maybe HTTP.Request
- , getResponse :: Maybe HTTP.Response
- , getRoutes :: Maybe Routes
- , getSettings :: Maybe Settings
- , getViewData :: Maybe ViewData
- , getAppEnvironment :: Maybe AppEnvironment
- }
+data Environment = Environment { getCodeStore :: Maybe CodeStore
+ , getDatabase :: Maybe ConnWrapper
+ , getLoggerLock :: Maybe LoggerLock
+ , getMimeTypes :: Maybe MimeTypes
+ , getRequest :: Maybe HTTP.Request
+ , getResponse :: Maybe HTTP.Response
+ , getRoutes :: Maybe Routes
+ , getSession :: Maybe Session
+ , getSettings :: Maybe Settings
+ , getViewData :: Maybe ViewData
+ , getAppEnvironment :: Maybe (MVar Dynamic)
+ }
-- | Construct a new empty 'Environment'.
newEnvironment :: Environment
@@ -46,6 +47,7 @@ newEnvironment = Environment { getCodeStore = Nothing
, getRequest = Nothing
, getResponse = Nothing
, getRoutes = Nothing
+ , getSession = Nothing
, getSettings = Nothing
, getViewData = Nothing
, getAppEnvironment = Nothing
@@ -56,7 +58,7 @@ newEnvironment = Environment { getCodeStore = Nothing
--
data CodeType = CTView | CTController | CTComponentView | CTComponentController | CTLayout deriving (Show)
-type CodeDate = ClockTime
+type CodeDate = UTCTime
type Function = String
type CodeLocation = (FilePath, Function)
@@ -69,12 +71,28 @@ data CodeStatus = CodeLoadMissing |
CodeLoadComponentController (StateT Environment IO ()) CodeDate |
CodeLoadComponentView (XMLGenT (StateT Environment IO) XML ) CodeDate
+
--
--- * Types for Database
+-- * Types for Cookies
--
-type Database = Connection
-
+-- | Contains all information about a cookie set by the server.
+data Cookie = Cookie {
+ -- | Name of the cookie.
+ cookieName :: String,
+ -- | Value of the cookie.
+ cookieValue :: String,
+ -- | Expiry date of the cookie. If 'Nothing', the
+ -- cookie expires when the browser sessions ends.
+ -- If the date is in the past, the client should
+ -- delete the cookie immediately.
+ cookieExpires :: Maybe UTCTime,
+ -- | The domain suffix to which this cookie will be sent.
+ cookieDomain :: Maybe String,
+ -- | The path to which this cookie will be sent.
+ cookiePath :: Maybe String
+ }
+ deriving (Show, Read, Eq, Ord)
--
-- * Types for Logger
@@ -113,6 +131,32 @@ type Keys = [String]
data Routes = Routes [(Regex, Keys)]
--
+-- * Types for Session
+--
+data Session = Session {
+ sessionName :: Maybe String, -- Used by Cookie session
+ sessionId :: Maybe Int, -- Used by DB and Filesystem sessions
+ expires :: Maybe UTCTime,
+ dataRep :: M.Map String String
+ } deriving (Eq, Read, Show)
+
+emptySession = Session Nothing Nothing Nothing M.empty
+
+class HasSession m where
+ newSession :: [(String, String)] -> m ()
+ retrieveSession :: [(String, String)] -> m ()
+ persistSession :: [(String, String)] -> m ()
+ hasValidSession :: m Bool
+ abandonSession :: m ()
+ getSessionValue :: String -> m (Maybe String)
+ setSessionValue :: String -> String -> m ()
+ deleteSessionKey :: String -> m ()
+ getSessionId :: m (Maybe Int)
+ setSessionId :: Maybe Int -> m ()
+ getSessionExpires :: m (Maybe UTCTime)
+ setSessionExpires :: Maybe UTCTime -> m ()
+
+--
-- * Types for Settings
--
View
5 Turbinado/Environment/ViewData.hs 100644 → 100755
@@ -14,6 +14,7 @@ import Data.Dynamic
import Turbinado.Environment.Logger
import Turbinado.Environment.Types
+import Turbinado.Utility.Data
-- | Used during request initialization to add the 'ViewData' 'Map
-- to the 'Environment'.
@@ -29,7 +30,7 @@ addViewDataToEnvironment = do e <- getEnvironment
-- then @getViewDataValue "number" :: 'Controller' Integer@ will return @'Controller' Nothing@.
getViewDataValue :: (HasEnvironment m, Typeable a) => String -> m (Maybe a)
getViewDataValue k = do e <- getEnvironment
- case (M.lookup k $ fromJust $ getViewData e) of
+ case (M.lookup k $ fromJust' "ViewData : getViewDataValue" $ getViewData e) of
Nothing -> return $ Nothing
Just l -> return $ fromDynamic l
@@ -51,6 +52,6 @@ getViewDataValue_u k = do v <- getViewDataValue k
-- 'show' to convert to a String).
setViewDataValue :: (HasEnvironment m, Typeable a) => String -> a -> m ()
setViewDataValue k v = do e <- getEnvironment
- let vd = fromJust $ getViewData e
+ let vd = fromJust' "ViewData : setViewDataValue" $ getViewData e
vd' = M.insert k (toDyn v) vd
setEnvironment $ e {getViewData = Just vd'}
View
30 Turbinado/Layout.hs
@@ -1,33 +1,9 @@
module Turbinado.Layout (
- styleSheet,
- javaScript,
- googleAnalytics,
+ module Turbinado.Layout.Helpers,
module Turbinado.View
) where
-import Control.Monad.State
-import Control.Monad.Trans
-import Data.Maybe
-import Data.Dynamic
-import Turbinado.Environment.Types
-import Turbinado.Environment.CodeStore
-import Turbinado.Environment.Logger
-import Turbinado.Environment.Settings
-import Turbinado.View
-
-styleSheet :: String -> String -> View XML
-styleSheet s m = return $ cdata $ "<link media=\"" ++ m ++"\" type=\"text/css\" rel=\"stylesheet\" href=\"/css/" ++ s ++".css\">"
+import Turbinado.Layout.Helpers
+import Turbinado.View
-javaScript :: String -> View XML
-javaScript j = return $ cdata $ "<script type=\"text/javascript\" src=\"/js/" ++ j ++ ".js\"></script>"
-googleAnalytics :: String -> View XML
-googleAnalytics g = return $ cdata $
- "<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(\"" ++ g ++ "\"); " ++
- " pageTracker._trackPageview(); " ++
- "</script> "
View
8 Turbinado/Layout/Helpers.hs
@@ -0,0 +1,8 @@
+module Turbinado.Layout.Helpers (
+ module Turbinado.Layout.Helpers.Misc,
+ module Turbinado.Layout.Helpers.Tags
+ ) where
+
+import Turbinado.Layout.Helpers.Misc
+import Turbinado.Layout.Helpers.Tags
+
View
12 Turbinado/Layout/Helpers/Misc.hs
@@ -0,0 +1,12 @@
+module Turbinado.Layout.Helpers.Misc (
+ googleAnalytics
+ ) where
+
+import Turbinado.View
+
+googleAnalytics :: String -> View XML
+googleAnalytics g = javaScriptBlock $
+ " 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\")); " ++
+ " var pageTracker = _gat._getTracker(\"" ++ g ++ "\"); " ++
+ " pageTracker._trackPageview(); "
View
10 Turbinado/Layout/Helpers/Tags.hs
@@ -0,0 +1,10 @@
+module Turbinado.Layout.Helpers.Tags (
+ styleSheetTag
+ ) where
+
+import Turbinado.View
+
+styleSheetTag :: String -> String -> View XML
+styleSheetTag s m = return $ cdata $ "<link media=\"" ++ m ++"\" type=\"text/css\" rel=\"stylesheet\" href=\"/css/" ++ s ++".css\">"
+
+
View
76 Turbinado/Server.hs 100644 → 100755
@@ -13,6 +13,7 @@ import Network hiding (accept)
import Network.Socket
import Prelude hiding (catch)
import Data.Dynamic ( fromDynamic )
+import Data.Maybe
import Data.Time
import Network.URI
@@ -33,23 +34,22 @@ import Turbinado.Environment.Types
import Turbinado.Environment.ViewData
import Turbinado.Environment.CodeStore (addCodeStoreToEnvironment)
import Turbinado.Server.Exception
-import Turbinado.Server.Handlers.ErrorHandler (handleError, handleTurbinado)
-import Turbinado.Server.Handlers.RequestHandler (requestHandler)
-import Turbinado.Server.Handlers.SessionHandler
+import Turbinado.Server.ErrorHandler (handleError, handleTurbinado)
+import Turbinado.Server.RequestProcess (processRequest)
import Turbinado.Server.Network (receiveRequest, sendResponse)
-import Turbinado.Server.StandardResponse (pageResponse)
+import Turbinado.Server.StandardResponse (addEmptyResponse, pageResponse)
import Turbinado.Server.StaticContent
data Flag
= Port Integer
- | Eval String
+ | UseCGI
| Help
deriving (Show, Eq)
options :: [OptDescr Flag]
options =
[ Option ['p'] ["port"] (ReqArg (Port . read) "PORTNUMBER") "start hsp runtime on port PORTNUMBER"
- , Option ['e'] ["eval"] (ReqArg Eval "FILE") "eval page with hsp runtime"
+ , Option ['c'] ["eval"] (NoArg UseCGI) "run as a CGI app"
, Option ['h','?'] ["help"] (NoArg Help) "show this message"
]
@@ -59,12 +59,16 @@ main =
do args <- getArgs
case getOpt Permute options args of
([Port n],[],[]) -> startServer (fromIntegral n)
+ ([UseCGI],[],[]) -> startServer runAsCGIPort
(opts,[],[]) | Help `elem` opts -> putStr $ usageInfo header options
(_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
where
header = "Usage: turbinado [OPTION]"
+runAsCGIPort :: PortNumber
+runAsCGIPort = fromIntegral 0
+
-- | Starts the server, builds the basic 'Environment', builds the 'WorkerPool',
-- starts listening on the specified port. As soon as a request is noticed,
-- it's handed off to a 'WorkerThread' to be handled. Lather, Rinse, Repeat.
@@ -80,16 +84,21 @@ startServer pnr
++ customSetupFilters
)
newEnvironment
- sock <- listenOn $ PortNumber pnr
- workerPoolMVar <- newMVar $ WorkerPool 0 [] []
- mainLoop sock workerPoolMVar e
+ case (pnr == runAsCGIPort) of
+ True -> do mainLoop Nothing e Nothing
+ False -> do sock <- listenOn $ PortNumber pnr
+ workerPoolMVar <- newMVar $ WorkerPool 0 [] []
+ mainLoop (Just sock) e (Just workerPoolMVar)
where
--mainLoop :: Socket -> WorkerPool -> IO ()
- mainLoop sock workerPoolMVar e =
+ mainLoop Nothing e Nothing = -- Run as Server
+ do e' <- runController (addDatabaseToEnvironment) e -- need to add DB for this request (rather than per thread)
+ workerLoop Nothing e' Nothing
+ mainLoop (Just sock) e (Just workerPoolMVar) = -- Run as Server
do (sock', sockAddr) <- accept sock
WorkerThread _ chan <- getWorkerThread workerPoolMVar e
writeChan chan sock'
- mainLoop sock workerPoolMVar e
+ mainLoop (Just sock) e (Just workerPoolMVar)
------------------------------------------------
@@ -98,37 +107,40 @@ startServer pnr
-- | The basic loop for a 'WorkerThread': get the socket from the server mainloop,
-- receive a request, handle it, then put myself back into the 'WorkerPool'.
-workerLoop :: MVar WorkerPool ->
+workerLoop :: Maybe (MVar WorkerPool) ->
Environment ->
- Chan Socket ->
+ Maybe (Chan Socket) ->
IO ()
-workerLoop workerPoolMVar e chan
- = do mainLoop
- where
- mainLoop
- = do sock <- readChan chan
- handleRequest sock e
- putWorkerThread workerPoolMVar chan
- mainLoop
+workerLoop Nothing e Nothing
+ = do workerProcessRequest Nothing e
+workerLoop (Just workerPoolMVar) e (Just chan)
+ = do sock <- readChan chan
+ workerProcessRequest (Just sock) e
+ putWorkerThread workerPoolMVar chan
+ workerLoop (Just workerPoolMVar) e (Just chan)
+workerLoop _ e _ = error "Turbinado.Server: workerLoop: Not CGI mode and not Server mode."
-- | Basic request handling: setup the 'Environment' for this request,
-- run the real requestHandler, then ship the response back to the client.
-handleRequest :: Socket -> Environment -> IO ()
-handleRequest sock e
+workerProcessRequest :: Maybe Socket -> Environment -> IO ()
+workerProcessRequest msock e
= (do mytid <- myThreadId
- e' <- runController (sequence_ [ addViewDataToEnvironment
+ e' <- runController (sequence_ [ addEmptyResponse
+ , addViewDataToEnvironment
, addSettingsToEnvironment
- , receiveRequest sock
+ , receiveRequest msock
, tryStaticContent
]) e
case (isResponseComplete e') of
- True -> sendResponse sock e'
- False -> do e'' <- runController requestHandler e'
- sendResponse sock e''
+ True -> sendResponse msock e'
+ False -> do e'' <- runController processRequest e'
+ sendResponse msock e''
)
- `catchTurbinado` (\ex -> handleTurbinado sock ex e)
- `catch` (\ex -> handleError sock ex e)
- `finally` (sClose sock)
+ `catchTurbinado` (\ex -> handleTurbinado msock ex e)
+ `catch` (\ex -> handleError msock ex e)
+ `finally` (when (isJust msock)
+ (sClose $ fromJust msock)
+ )
@@ -159,7 +171,7 @@ getWorkerThread mv e =
WorkerPool n [] bs ->
do chan <- newChan
e' <- runController (addDatabaseToEnvironment) e
- tid <- forkIO $ workerLoop mv e' chan
+ tid <- forkIO $ workerLoop (Just mv) e' (Just chan)
let workerThread = WorkerThread tid chan
expiresTime <- getCurrentTime >>= \utct -> return $ addUTCTime (fromInteger stdTimeOut) utct
putMVar mv $ WorkerPool (n+1) [] ((workerThread, expiresTime):bs)
View
8 Turbinado/Server/Handlers/ErrorHandler.hs → Turbinado/Server/ErrorHandler.hs 100644 → 100755
@@ -1,4 +1,4 @@
-module Turbinado.Server.Handlers.ErrorHandler where
+module Turbinado.Server.ErrorHandler where
import System.IO
import Prelude hiding (catch)
@@ -12,16 +12,14 @@ import Turbinado.Server.Exception
import Turbinado.Server.Network
import Turbinado.Server.StandardResponse
---import Turbinado.PrintDebug
-
-handleError :: Socket -> Exception -> Environment -> IO ()
+handleError :: (Maybe Socket) -> Exception -> Environment -> IO ()
handleError s ex e = do e' <- runController (errorResponse err) e
sendResponse s e'
where err = unlines [ "Error in server: " ++ show ex
," please report as a bug to alson@alsonkemp.com"]
-handleTurbinado :: Socket -> TurbinadoException -> Environment -> IO ()
+handleTurbinado :: (Maybe Socket) -> TurbinadoException -> Environment -> IO ()
handleTurbinado s he e = do
e' <- runController (case he of
CompilationFailed errs -> errorResponse err
View
26 Turbinado/Server/Handlers/SessionHandler.hs
@@ -1,26 +0,0 @@
-module Turbinado.Server.Handlers.SessionHandler (
- SessionHandler(..),
- SessionId, Key, Value, Expires, SessionData, SessionItem
- ) where
-
-import Data.Time
-
-type SessionId = Int
-type Key = String
-type Value = String
-type Expires = Maybe UTCTime
-
-type SessionData = (Expires, [SessionItem])
-type SessionItem = (Key, (Value, Expires))
-
-----------------------------------------------------
--- The SessionHandler class
-
-class SessionHandler sh where
- lookupData :: sh -> SessionId -> IO (Maybe SessionData)
- insertNew :: sh -> SessionId -> Expires -> IO ()
- insertNewData :: sh -> SessionId -> SessionItem -> IO ()
- updateExpires :: sh -> SessionId -> Expires -> IO ()
- updateData :: sh -> SessionId -> SessionItem -> IO ()
- deleteSession :: sh -> SessionId -> IO ()
- deleteData :: sh -> SessionId -> Key -> IO ()
View
75 Turbinado/Server/Network.hs 100644 → 100755
@@ -5,6 +5,10 @@ module Turbinado.Server.Network (
import Data.Maybe
import Network.Socket
+import Network.HTTP
+import Network.URI
+import qualified System.Environment as Env
+import System.IO
import Turbinado.Controller.Monad
import Turbinado.Server.Exception
@@ -12,13 +16,16 @@ import Turbinado.Environment.Logger
import Turbinado.Environment.Types
import Turbinado.Environment.Request
import Turbinado.Environment.Response
+import Turbinado.Server.StandardResponse
+import Turbinado.Utility.Data
-import Network.HTTP
-- | Read the request from client.
-receiveRequest :: Socket -> Controller ()
-receiveRequest sock = do
+receiveRequest :: Maybe Socket -> Controller ()
+receiveRequest Nothing = do e <- getEnvironment
+ acceptCGI
+receiveRequest (Just sock) = do
req <- liftIO $ receiveHTTP sock
case req of
Left e -> throwTurbinado $ BadRequest $ "In receiveRequest : " ++ show e
@@ -27,5 +34,63 @@ receiveRequest sock = do
-- | Get the 'Response' from the 'Environment' and send
-- it back to the client.
-sendResponse :: Socket -> Environment -> IO ()
-sendResponse sock e = respondHTTP sock $ fromJust $ getResponse e
+sendResponse :: Maybe Socket -> Environment -> IO ()
+sendResponse Nothing e = respondCGI $ fromJust' "Network : sendResponse" $ getResponse e
+sendResponse (Just sock) e = respondHTTP sock $ fromJust' "Network : sendResponse" $ getResponse e
+
+-- | Pull a CGI request from stdin
+acceptCGI :: Controller ()
+acceptCGI = do body <- liftIO $ hGetContents stdin
+ hdrs <- liftIO $ Env.getEnvironment
+ let rqheaders = parseHeaders $ extractHTTPHeaders hdrs
+ rquri = fromJust' "Network: acceptCGI: parseURI failed" $ parseURI $
+ fromJust' "Network: acceptCGI: No REQUEST_URI in hdrs" $ lookup "SCRIPT_URI" hdrs
+ rqmethod = fromJust' "Network: acceptCGI: REQUEST_METHOD invalid" $ flip lookup rqMethodMap $
+ fromJust' "Network: acceptCGI: No REQUEST_METHOD in hdrs" $ lookup "REQUEST_METHOD" hdrs
+ case rqheaders of
+ Left err -> errorResponse $ show err
+ Right r -> do e' <- getEnvironment
+ setEnvironment $ e' {
+ getRequest = Just Request { rqURI = rquri
+ , rqMethod = rqmethod
+ , rqHeaders = r
+ , rqBody = body
+ }
+ }
+
+matchRqMethod :: String -> RequestMethod
+matchRqMethod m = fromJust' "Turbinado.Server.Network:matchRqMethod" $
+ lookup m [ ("GET", GET)
+ , ("POST", POST)
+ , ("HEAD", HEAD)
+ , ("PUT" , PUT)
+ , ("DELETE", DELETE)
+ ]
+
+-- | Convert the HTTP.Response to a CGI response for stdout.
+respondCGI :: Response -> IO ()
+respondCGI r = do let message = (unlines $ drop 1 $ lines $ show r) ++ "\n\n" ++ rspBody r -- need to drop the first line from the response for CGI
+ hPutStr stdout message
+ hFlush stdout
+
+-- | Convert from HTTP_SOME_FLAG to Some-Flag for HTTP.parseHeaders
+extractHTTPHeaders :: [(String, String)] -> [String]
+extractHTTPHeaders [] = []
+extractHTTPHeaders (('H':'T':'T':'P':'_':k,v):hs) = (convertUnderscores k ++ ": " ++ v) : extractHTTPHeaders hs
+ where convertUnderscores [] = []
+ convertUnderscores ('_':ss) = '-' : convertUnderscores ss
+ convertUnderscores (s :ss) = s : convertUnderscores ss
+extractHTTPHeaders ((k,v) : hs) = extractHTTPHeaders hs
+
+
+-- | Lifted from Network.HTTP
+rqMethodMap :: [(String, RequestMethod)]
+rqMethodMap = [("HEAD", HEAD),
+ ("PUT", PUT),
+ ("GET", GET),
+ ("POST", POST),
+ ("DELETE", DELETE),
+ ("OPTIONS", OPTIONS),
+ ("TRACE", TRACE)]
+
+
View
12 Turbinado/Server/Handlers/RequestHandler.hs → Turbinado/Server/RequestProcess.hs 100644 → 100755
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
-- |
--- Module : Turbinado.Server.Handlers.RequestHandler
+-- Module : Turbinado.Server.RequestProcess
-- Copyright : (c) Alson Kemp 2008, Niklas Broberg 2004,
-- License : BSD-style (see the file LICENSE)
--
@@ -12,8 +12,8 @@
-- a response.
--
-----------------------------------------------------------------------------
-module Turbinado.Server.Handlers.RequestHandler (
- requestHandler
+module Turbinado.Server.RequestProcess (
+ processRequest
) where
import qualified Network.HTTP as HTTP
@@ -27,6 +27,7 @@ import Data.List
import Data.Dynamic
import Config.Master
+import Turbinado.Controller.Routes
import Turbinado.Environment.Types
import Turbinado.Environment.CodeStore
import Turbinado.Environment.Logger
@@ -58,13 +59,14 @@ postFilters = []
-- | The main request handler. This runs standard and custom preFilters
-- then runs the Controller and View.
-requestHandler :: Controller ()
-requestHandler = do
+processRequest :: Controller ()
+processRequest = do
debugM $ " requestHandler : running pre and main filters"
-- Run the Pre filters, the page
sequence_ $ preFilters ++
customPreFilters ++
[ retrieveAndRunController
+ , checkFormats
, retrieveAndRunLayout
]
debugM $ " requestHandler : running post filters"
View
63 Turbinado/Server/StandardResponse.hs 100644 → 100755
@@ -13,6 +13,7 @@
module Turbinado.Server.StandardResponse where
import Data.List
+import Data.Maybe
import Network.HTTP
import Network.HTTP.Headers
import System.Locale
@@ -21,69 +22,73 @@ import System.Time
import Turbinado.Environment.Types
import Turbinado.Environment.Response
import Turbinado.Controller.Monad
+import Turbinado.Utility.Data
-- import HSP.Data
instance Eq Header where
(==) (Header hn1 _) (Header hn2 _) = hn1 == hn2
+addEmptyResponse :: (HasEnvironment m) => m ()
+addEmptyResponse =
+ do t <- liftIO $ getClockTime
+ setResponse (Response (0,0,0)
+ ""
+ (startingHeaders t)
+ ""
+ )
+
fileNotFoundResponse :: (HasEnvironment m) => FilePath -> m ()
fileNotFoundResponse fp =
do t <- liftIO $ getClockTime
- setResponse (Response (4,0,0)
- "File Not Found"
- (buildHeaders (Just $ length body) t [])
- (body))
- where body = "<html><body>\n <p><big>404 File Not Found</big></p>\n <p>Requested resource: "++ fp ++ "</p>\n </body></html>"
+ setResponse (Response (4,0,4)
+ "File Not Found"
+ (startingHeaders t ++ [Header HdrContentLength $ show $ length body])
+ (body))
+ where body = "<html><body>\n <p><big>404 File Not Found</big></p>\n <p>Requested resource: "++ fp ++ "</p>\n </body></html>"
cachedContentResponse :: (HasEnvironment m) => Int -> String -> String -> m ()
cachedContentResponse age ct body =
- do t <- liftIO $ getClockTime
- pageResponse (buildHeaders
- Nothing t
- [Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
- , Header HdrContentType ct])
+ do pageResponse [ Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
+ , Header HdrContentType ct]
body
pageResponse :: (HasEnvironment m) => [Header] -> String -> m ()
pageResponse hds body =
do t <- liftIO $ getClockTime
- setResponse (Response stSuccess "OK"
- (buildHeaders (Just $ length body) t hds) (body))
+ r <- getEnvironment >>= (return . fromJust' "StandardResponse : pageResponse" . getResponse)
+ setResponse $ foldl
+ (\rs (Header hn s) -> replaceHeader hn s rs)
+ (Response
+ (2,0,0)
+ "OK"
+ (rspHeaders r ++ [Header HdrContentLength $ show $ length body])
+ body
+ )
+ hds
redirectResponse :: (HasEnvironment m) => String -> m ()
redirectResponse l =
do t <- liftIO $ getClockTime
- setResponse (Response (3,0,2) "OK" (buildHeaders Nothing t [Header HdrLocation l]) "")
+ r <- getEnvironment >>= (return . fromJust' "StandardResponse : redirectResponse" . getResponse)
+ setResponse (Response (3,0,2) "OK" (rspHeaders r ++ [Header HdrLocation l]) "")
errorResponse :: (HasEnvironment m) => String -> m ()
errorResponse err =
do t <- liftIO $ getClockTime
- setResponse (Response stError "Internal Server Error"
- (buildHeaders (Just $ length body) t []) (body))
+ setResponse (Response (5,0,0) "Internal Server Error"
+ (startingHeaders t ++ [Header HdrContentLength $ show $ length body]) body)
where body = "<html><body>\n <p><big>500 Internal Server Error</big></p>\n <p>Error specification:<br/>\n" ++ err ++ "</p>\n </body></html>"
badReqResponse :: (HasEnvironment m) => m ()
badReqResponse =
do t <- liftIO $ getClockTime
- setResponse (Response stBadReq "Bad Request"
- (buildHeaders (Just $ length body) t []) body)
+ setResponse (Response (4,0,0) "Bad Request"
+ (startingHeaders t ++ [Header HdrContentLength $ show $ length body]) body)
where body = "<html><body>\n <p><big>400 Bad Request</big></p>\n </body></html>"
-buildHeaders :: Maybe Int -> ClockTime -> [Header] -> [Header]
-buildHeaders Nothing t hdrs = union hdrs ( startingHeaders t)
-buildHeaders (Just l) t hdrs = union hdrs ((startingHeaders t) ++
- [Header HdrContentLength $ show l])
-
-
startingHeaders t = [ Header HdrServer "Turbinado www.turbinado.org"
, Header HdrContentType "text/html; charset=UTF-8"
, Header HdrDate $ formatCalendarTime defaultTimeLocale rfc822DateFormat $ toUTCTime t
]
-stSuccess, stFNF :: ResponseCode
-stSuccess = (2,0,0)
-stFNF = (4,0,4)
-stError = (5,0,0)
-stBadReq = (4,0,0)
-
View
9 Turbinado/Utility/Data.hs
@@ -0,0 +1,9 @@
+module Turbinado.Utility.Data where
+
+import Data.Maybe
+
+fromJust' :: String -> Maybe a -> a
+fromJust' s m = maybe
+ (error $ "fromJust' called with Nothing : " ++ s)
+ id
+ m
View
35 Turbinado/Utility/Naming.hs
@@ -0,0 +1,35 @@
+module Turbinado.Utility.Naming where
+
+import Data.Char
+import Data.List
+
+--
+-- * Turbinado Utility functions for Naming
+--
+
+-- | Lowercases the first letter to make a valid function.
+underscoreToFunction [] = error "toFunction passed an empty string"
+underscoreToFunction (firstL:ls) = (Data.Char.toLower firstL) : fromUnderscore ls
+
+
+-- | Uppercases the first letter to make a valid type.
+underscoreToType [] = error "toType passed an empty string"
+underscoreToType l = fromUnderscore l
+
+-- | Convert AbbaDing to abba_ding
+toUnderscore [] = error "toUnderscore passed an empty string"
+toUnderscore (l:ls) = toLower l : worker ls
+ where worker [] = []
+ worker "_" = "_" -- end with "_", then end with "_"
+ worker (c:cs) | isUpper c = '_' : toLower c : worker cs
+ | otherwise = c : worker cs
+
+-- | Convert abba_ding to AbbaDing
+fromUnderscore [] = error "fromUnderscore passed an empty string"
+fromUnderscore (l:ls) = toUpper l : worker ls
+ where worker [] = []
+ worker "_" = "_" -- end with "_", then end with "_"
+ worker ('_':c:cs) | isLetter c = toUpper c : worker cs
+ | otherwise = '_' : c : worker cs
+ worker (c:cs) = c : worker cs
+
View
2  Turbinado/View.hs
@@ -11,6 +11,7 @@ module Turbinado.View (
insertComponent,
-- Module Exports
+ module Turbinado.View.Helpers,
module Turbinado.View.HTML,
module Turbinado.View.XML,
module Turbinado.View.XML.PCDATA,
@@ -47,6 +48,7 @@ import Turbinado.Environment.Types
import Turbinado.Environment.ViewData
import Turbinado.Server.StandardResponse
import Turbinado.View.Exception
+import Turbinado.View.Helpers
import Turbinado.View.HTML
import Turbinado.View.Monad hiding (liftIO)
import Turbinado.View.XML hiding (Name)
View
8 Turbinado/View/Helpers/Misc.hs 100644 → 100755
@@ -8,9 +8,11 @@ import qualified Network.URI as URI
import qualified Network.HTTP as HTTP
import System.FilePath
-
-import Turbinado.View
-
+import Turbinado.Environment.Types
+import Turbinado.Environment.Request
+import Turbinado.View.Monad
+import Turbinado.View.XML
+import Turbinado.View.XMLGenerator
breadCrumbs :: View XML
breadCrumbs = do e <- getEnvironment
View
16 Turbinado/View/Helpers/Tags.hs 100644 → 100755
@@ -1,10 +1,22 @@
module Turbinado.View.Helpers.Tags (
- anchorTag
+ anchorTag,
+ javaScriptFile,
+ javaScriptBlock
) where
-import Turbinado.View
+import Turbinado.View.Monad
+import Turbinado.View.XML
+import Turbinado.View.XMLGenerator
anchorTag :: String -> String -> View XML
anchorTag l t = <a href=l><% t %></a>
+javaScriptFile :: String -> View XML
+javaScriptFile f = return $ cdata $ "<script type=\"text/javascript\" src=\"/js/" ++ f ++ ".js\"></script>"
+
+javaScriptBlock :: String -> View XML
+javaScriptBlock s = return $ cdata $ "<script type=\"text/javascript\">" ++ s ++ "</script>"
+
+
+
View
4 static/dispatch.cgi
@@ -0,0 +1,4 @@
+#!/bin/sh
+
+cd ..
+dist/build/turbinado/turbinado -c
View
6 turbinado.cabal 100644 → 100755
@@ -1,5 +1,5 @@
Name: turbinado
-Version: 0.4.9
+Version: 0.6.0
Synopsis: Haskell web application server
Description: The Haskell web application server
License: BSD3
@@ -14,6 +14,8 @@ Executable turbinado
Main-is: Turbinado/Server.hs
Build-Depends: base >= 4,
containers,
+ Crypto > 4.1.0,
+ dataenc,
directory,
harp == 0.4,
filepath,
@@ -32,7 +34,7 @@ Executable turbinado
pretty,
regex-compat,
time
- ghc-options: -F -pgmFtrhsx -O
+ ghc-options: -F -pgmFtrhsx
Extensions: MultiParamTypeClasses,
FunctionalDependencies,
TypeFamilies,