diff --git a/Blog/Blog.hs b/Blog/Blog.hs index e2cdd84..8325043 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -5,8 +5,6 @@ import qualified Data.Map as M import Control.Monad(forM) import Framework.API -import Framework.SQL -import Framework.Http.Response(redirect) import Framework.Utils import Models @@ -24,7 +22,7 @@ testform = do case rqMethod rq of GET -> return $ renderToResponse "testform.html" [] POST -> do - liftC $ print $ _POST rq + liftIO $ print $ _POST rq return $ redirect "/blog/" allposts :: HttpAction diff --git a/Blog/Plugins.hs b/Blog/Plugins.hs deleted file mode 100644 index 32a2363..0000000 --- a/Blog/Plugins.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Plugins where - -import Framework.Forms.Types - -simple :: Form -> Form -simple = id diff --git a/Blog/Settings.hs b/Blog/Settings.hs new file mode 100644 index 0000000..a89b249 --- /dev/null +++ b/Blog/Settings.hs @@ -0,0 +1,15 @@ +module Settings where + +import Framework.Controller +import Framework.Forms.Types + +requestExcHandler :: ExcHandler +requestExcHandler rq code msg = return () + +controllerExcHandler :: ExcHandler +controllerExcHandler rq code msg = return () + +formProcessors = [simple] + +simple :: Form -> Form +simple = id diff --git a/Framework/API.hs b/Framework/API.hs index 1b3e602..02679c4 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -13,6 +13,7 @@ module Framework.API -- ** Common modules module Framework.Types, module Framework.Controller, + module Framework.Exceptions, -- ** API modules module Framework.API.Cache, module Framework.API.Sessions, @@ -25,7 +26,9 @@ module Framework.API module Framework.Forms.Validation, module Framework.Pager, module Framework.Http.Vars, - module Framework.Urls + module Framework.Urls, + module Framework.SQL, + module Framework.Http.Response ) where import Control.Monad.Reader.Class @@ -33,6 +36,7 @@ import Network.HTTP import Framework.Types import Framework.Controller +import Framework.Exceptions import qualified Framework.Http.Cookies as Cookies import Framework.Http.HTTPServer (serveStatic, serveHttp) @@ -48,6 +52,8 @@ import Framework.Forms.Validation import Framework.Pager import Framework.Http.Vars import Framework.Urls hiding (runURLConf) +import Framework.SQL +import Framework.Http.Response ---------------------------------------------------------------------------------------------------------- -- * Cookies API diff --git a/Framework/API/Cache.hs b/Framework/API/Cache.hs index c2389ba..d927a36 100644 --- a/Framework/API/Cache.hs +++ b/Framework/API/Cache.hs @@ -15,7 +15,7 @@ cacheGet :: String -- ^ Key -> AController (Maybe String) cacheGet key = do cb <- asks cacheBackend - liftC $ cGet cb key + liftIO $ cGet cb key -- | Put a value to cache cachePut :: String -- ^ Key @@ -23,7 +23,7 @@ cachePut :: String -- ^ Key -> AController Bool cachePut key value = do cb <- asks cacheBackend - liftC $ {-do + liftIO $ {-do print $ length value -} cPut cb key value @@ -32,7 +32,7 @@ cacheUnset :: String -- ^ Key -> AController Bool cacheUnset key = do cb <- asks cacheBackend - liftC $ cUnset cb key + liftIO $ cUnset cb key -- | If named item is in cache, return its value. Otherwise, do nothing. tryReturnFromCache :: String -- ^ Key diff --git a/Framework/API/Logger.hs b/Framework/API/Logger.hs index b865abc..f8c64d0 100644 --- a/Framework/API/Logger.hs +++ b/Framework/API/Logger.hs @@ -11,17 +11,17 @@ import qualified Framework.Logger as Logger -- | Write a message to access log accessLog :: String -- ^ Log message - -> AController () + -> Controller ActionConfig r () accessLog msg = do chan <- asks (logChan.httpParams) rq <- asks request - liftC $ Logger.writeLog chan rq msg + liftIO $ Logger.writeLog chan rq msg -- | Write a message to errors log errorLog :: String -- ^ Log message - -> AController () + -> Controller ActionConfig r () errorLog msg = do chan <- asks (errChan.httpParams) rq <- asks request - liftC $ Logger.writeLog chan rq msg + liftIO $ Logger.writeLog chan rq msg diff --git a/Framework/API/SQL.hs b/Framework/API/SQL.hs index 4627355..b387545 100644 --- a/Framework/API/SQL.hs +++ b/Framework/API/SQL.hs @@ -6,6 +6,7 @@ import qualified Data.Map as M import Framework.Types import Framework.Controller +import Framework.Exceptions import qualified Framework.Storage as Storage import Framework.SQL import Framework.Models @@ -21,25 +22,25 @@ import Framework.API.Storage queryListSQL :: Query -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]] queryListSQL q params = do conn <- asks dbconnection - liftC $ Storage.query conn (sql q) params + liftIO $ Storage.query conn (sql q) params -- | Same, but strict. queryListSQL' :: Query -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]] queryListSQL' q params = do conn <- asks dbconnection - liftC $ Storage.query' conn (sql q) params + liftIO $ Storage.query' conn (sql q) params -- | Same as "query", but gets Query object instead of plain SQL querySQL :: Query -> [HDBC.SqlValue] -> Model -> AController [Model] querySQL q params model = do conn <- asks dbconnection - liftC $ Storage.queryR conn (sql q) params model + liftIO $ Storage.queryR conn (sql q) params model -- | Same, but strict. querySQL' :: Query -> [HDBC.SqlValue] -> Model -> AController [Model] querySQL' q params model = do conn <- asks dbconnection - liftC $ Storage.queryR' conn (sql q) params model + liftIO $ Storage.queryR' conn (sql q) params model -- | Get an object from DB specified by Model and object ID. -- Fail if count(such objects)=!1. diff --git a/Framework/API/Sessions.hs b/Framework/API/Sessions.hs index 91c48a8..18c41d0 100644 --- a/Framework/API/Sessions.hs +++ b/Framework/API/Sessions.hs @@ -21,11 +21,11 @@ sessionLookup name = do sessionSet :: String -> String -> Controller ActionConfig r () sessionSet name value = do ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask - liftC $ sPush sessionsBackend sessionID $ M.insert name value sessionMap + liftIO $ sPush sessionsBackend sessionID $ M.insert name value sessionMap -- | Unset value in the session sessionUnset :: String -> Controller ActionConfig r () sessionUnset name = do ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask - liftC $ sPush sessionsBackend sessionID $ M.delete name sessionMap + liftIO $ sPush sessionsBackend sessionID $ M.delete name sessionMap diff --git a/Framework/API/Storage.hs b/Framework/API/Storage.hs index 61a8224..136e3e9 100644 --- a/Framework/API/Storage.hs +++ b/Framework/API/Storage.hs @@ -15,13 +15,13 @@ import qualified Framework.Storage as Storage queryList :: String -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]] queryList sql params = do conn <- asks dbconnection - liftC $ Storage.query conn sql params + liftIO $ Storage.query conn sql params -- | Just as "queryList", but strict. queryList' :: String -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]] queryList' sql params = do conn <- asks dbconnection - liftC $ Storage.query' conn sql params + liftIO $ Storage.query' conn sql params -- | DB query. Returns list of Models. query :: String -- ^ SQL @@ -30,7 +30,7 @@ query :: String -- ^ SQL -> AController [Model] query sql params model = do conn <- asks dbconnection - liftC $ Storage.queryR conn sql params model + liftIO $ Storage.queryR conn sql params model -- | Same as "query", but strict. query' :: String -- ^ SQL @@ -39,11 +39,11 @@ query' :: String -- ^ SQL -> AController [Model] query' sql params model = do conn <- asks dbconnection - liftC $ Storage.queryR' conn sql params model + liftIO $ Storage.queryR' conn sql params model commit :: AController () commit = do conn <- asks dbconnection - liftC $ Storage.commit conn + liftIO $ Storage.commit conn diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 0950610..9a7bf9b 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -16,18 +16,18 @@ module Framework.Controller Controller, AController, HttpController, StaticController, ContextProcessor, + ExcHandler, -- * Controller-monad specific functions - liftC, + MonadIO (..), returnNow, reject, concatC, changeR, assertC, evalController, - -- * Functions that are specific to application-level controllers - internalError, - errorIf, forceMaybe + evalRightNow ) where import Control.Monad.Reader.Class +import Control.Monad.Trans import Framework.Types import Framework.Http.Response @@ -57,6 +57,8 @@ type AController a = Controller ActionConfig HttpResponse a type ContextProcessor = Controller ActionConfig Context Context +type ExcHandler = HttpRequest -> Int -> String -> Controller StaticConfig HttpResponse () + ------------------------------------------------------------------------------------------- instance Monad (Controller s r) where @@ -76,6 +78,11 @@ instance MonadReader s (Controller s r) where ask = Controller $ \s -> return (Result s) local f m = Controller $ runController m . f +instance MonadIO (Controller s r) where + -- liftIO :: IO a -> Controller s r a + -- | `Lift' an IO action into Controller + liftIO act = Controller $ \_ -> Result `fmap` act + --------------------------------------------------------------------------------------------- -- * Controller-monad specific functions @@ -84,7 +91,7 @@ concatC :: [Controller b [a] [a]] -- ^ List of controllers -> Controller b r [a] concatC cs = do s <- ask - rs <- liftC $ mapM (flip runController s) cs + rs <- liftIO $ mapM (flip runController s) cs return $ process rs where process [] = [] @@ -96,16 +103,12 @@ concatC cs = do changeR :: Controller s r a -> Controller s q a changeR m = do s <- ask - r <- liftC $ runController m s + r <- liftIO $ runController m s case r of Reject -> reject RightNow t -> reject Result x -> return x --- | `Lift' an IO action into Controller -liftC :: IO a -> Controller s r a -liftC act = Controller $ \_ -> Result `fmap` act - -- | Assert that condition is satisfied. Otherwise, reject URL. assertC :: Bool -> Controller s r () assertC b = @@ -126,36 +129,21 @@ evalController :: Controller s a a -- ^ Controller -> s -- ^ Configuration for controller -> IO (Maybe a) evalController m s = anyResult `fmap` (runController m s) - ------------------------------------------------------------------------------------------ --- * Functions that are specific to application-level controllers - --- | Return HTTP 500 error with given message -internalError :: String -> Controller s HttpResponse a -internalError msg = returnNow $ response 500 [] msg - --- | Return HTTP error with given code, if condition is satisfied -errorIf :: Int -- ^ HTTP status code - -> String -- ^ Error message - -> Bool -- ^ Value of condition - -> Controller s HttpResponse () -errorIf code msg b = - if b - then returnNow $ response code [] msg - else return () - --- | If value is supplied, return it. Otherwise, raise HTTP 500 error. -forceMaybe :: String -- ^ Error message - -> Maybe a -- ^ Maybe value - -> Controller s HttpResponse a -- -forceMaybe msg x = - case x of - Just v -> return v - Nothing -> internalError msg - --- | Convert any result to Maybe HttpResponse -anyResult :: ControllerResult a a -> Maybe a -anyResult Reject = Nothing -anyResult (RightNow r) = Just r -anyResult (Result r) = Just r + where + -- | Convert any result to Maybe HttpResponse + anyResult :: ControllerResult a a -> Maybe a + anyResult Reject = Nothing + anyResult (RightNow r) = Just r + anyResult (Result r) = Just r + + +evalRightNow :: Controller s r a + -> s + -> IO (Maybe r) +evalRightNow m s = anyResult `fmap` (runController m s) + where + anyResult :: ControllerResult r a -> Maybe r + anyResult Reject = Nothing + anyResult (RightNow r) = Just r + anyResult (Result _) = Nothing diff --git a/Framework/Exceptions.hs b/Framework/Exceptions.hs new file mode 100644 index 0000000..469ee78 --- /dev/null +++ b/Framework/Exceptions.hs @@ -0,0 +1,75 @@ +module Framework.Exceptions + (raiseC, + raiseIO, + -- * Functions that are specific to application-level controllers + internalError, + errorIf, forceMaybe + ) where + +import Control.Monad.Reader.Class + +import Framework.Types +import Framework.Controller +import Framework.Logger +import Framework.Http.Response + +import Settings (requestExcHandler, controllerExcHandler) + +raiseAny :: ExcHandler -> HttpRequest -> Int -> String -> Controller StaticConfig HttpResponse a +raiseAny handler rq code msg = do + ps <- ask + handler rq code msg + liftIO $ writeLog (errChan ps) rq $ (show code)++" "++msg + returnNow $ response code [] msg + +-- | Raise an exception in controller +raiseC :: Int -- ^ HTTP error code + -> String -- ^ Message + -> AController a +raiseC code msg = do + rq <- asks request + ps <- asks httpParams + let handler = raiseAny controllerExcHandler rq code msg + val <- liftIO $ evalRightNow handler ps + case val of + Just resp -> returnNow resp + Nothing -> returnNow $ response 500 [] "Impossible: Exception handler returned Nothing!" + +-- | Raise an exception in IO monad +raiseIO :: StaticConfig -- ^ Static (global) config + -> HttpRequest + -> Int -- ^ HTTP error code + -> String -- ^ Message + -> IO HttpResponse +raiseIO ps rq code msg = do + val <- evalController (raiseAny requestExcHandler rq code msg) ps + case val of + Just resp -> return resp + Nothing -> return $ response 500 [] "Impossible: Exception handler returned Nothing!" + +----------------------------------------------------------------------------------------- +-- * Functions that are specific to application-level controllers + +-- | Return HTTP 500 error with given message +internalError :: String -> AController a +internalError msg = raiseC 500 msg + +-- | Return HTTP error with given code, if condition is satisfied +errorIf :: Int -- ^ HTTP status code + -> String -- ^ Error message + -> Bool -- ^ Value of condition + -> Controller s HttpResponse () +errorIf code msg b = + if b + then returnNow $ response code [] msg + else return () + +-- | If value is supplied, return it. Otherwise, raise HTTP 500 error. +forceMaybe :: String -- ^ Error message + -> Maybe a -- ^ Maybe value + -> AController a -- +forceMaybe msg x = + case x of + Just v -> return v + Nothing -> internalError msg + diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index 0edd24d..f4b6867 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -16,13 +16,13 @@ import Control.Monad.Reader.Class import qualified Data.Map as M import Data.Maybe -import Network.HTTP (Request,Response) +import Network.URI +import Network.HTTP import qualified Database.HDBC as D import Framework.Types import Framework.Utils import Framework.Controller -import Framework.Urls (myUrl) import Framework.API.Sessions import Framework.Models import Framework.Http.Response (redirectG) @@ -31,7 +31,7 @@ import Framework.Http.Vars import Framework.Forms.Types import Framework.Forms.HTML -import Plugins +import Settings (formProcessors) -- | Generate a \"to-edit\" form (as "createform", but mark erroneus fields and -- fill with previous values @@ -119,7 +119,7 @@ returnInvalidForm form fid errs = do let values = tail $ urlencode $ map packParam vars vars = formVars form fid rq sessionSet "filled" values - returnNow $ redirectG (myUrl rq) ["invalid" := (unwords errs)] + returnNow $ redirectG (uriPath $ rqURI rq) ["invalid" := (unwords errs)] isRight :: Either t1 t -> Bool isRight (Right _) = True diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index c070c36..8f12a3a 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -11,8 +11,8 @@ import System.Exit import System.IO hiding (print,hPutStr,hPutStrLn,readFile,putStrLn) import System.IO.UTF8 import Control.Monad.Reader.Class +import Control.Monad.Trans (liftIO) import Control.Concurrent.Chan -import Codec.Binary.UTF8.String import System.Directory import Control.Exception import Network.URI @@ -20,14 +20,13 @@ import Network.HTTP import Data.Maybe import Framework.Config -import Framework.Cache -import Framework.Storage +import Framework.Cache(cDisconnect) +import Framework.Storage(disconnect') import Framework.Pool import Framework.Logger import Framework.Types import Framework.Urls import Framework.Utils -import Framework.Controller import Framework.Http.Response import Framework.Http.Middlewares import Framework.Http.Httpd @@ -43,9 +42,10 @@ sendfile filename = do serveStatic :: StaticAction serveStatic rq s = do ps <- ask - resp <- liftC $ serveStatic' ps rq s + resp <- liftIO $ serveStatic' ps rq s return resp +serveStatic' :: StaticConfig -> HttpRequest -> String -> IO HttpResponse serveStatic' ps rq resource = if (rqMethod rq) == GET then do diff --git a/Framework/Urls.hs b/Framework/Urls.hs index f737f77..8f49a60 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -24,6 +24,7 @@ import Framework.Types import Framework.Wrapper import Framework.Logger import Framework.Controller +import Framework.Exceptions import qualified Framework.Http.Sessions as Sessions import Framework.Http.Response ((<+>)) @@ -72,9 +73,8 @@ urlSplit uri = filter (/="") $ splitWith (=='/') url -- (url++slash) urlJoin :: URLParts -> String urlJoin us = concat $ intersperse "/" us -return404 ps rq conf url = do - writeLog (errChan ps) rq $ "Not found: "++uriPath url - return $ noSuchUrl True conf +return404 :: (Show a) =>StaticConfig -> HttpRequest -> a -> URI -> IO HttpResponse +return404 ps rq conf url = raiseIO ps rq 404 $ "Not found: "++uriPath url data URLResult = NoResult | AC HttpController diff --git a/graph.dot b/graph.dot index 0eb40f0..74dec88 100644 --- a/graph.dot +++ b/graph.dot @@ -1,76 +1,86 @@ digraph G { - subgraph cluster_Blog { - graph [label=Application]; - u28 [color="#ccffcc", - label=Plugins, - style=filled]; - u26 [color="#ccffcc", - label=Models, - style=filled]; - u0 [color="#ccffcc", - label=Main, - style=filled]; - } - subgraph cluster_DB { - graph [label=DB]; - u15 [color="#99ff99", - label=SQL, - style=filled]; - u10 [color="#99ff99", - label=Models, - style=filled]; - u9 [color="#99ff99", - label=Storage, - style=filled]; - } - forms [color="#66ff66", - label=Forms, - shape=box, - style=filled]; - u28 -> forms; - u27 [color="#99ff99", - label=Markdown, - style=filled]; - u26 -> u27; - u26 -> forms; - u24 [color="#99ff99", - label=Pager, - style=filled]; - u0 -> u24; - tengine [color="#66ff66", - label=TEngine, - shape=box, - style=filled]; - u0 -> tengine; - u24 -> forms; - u15 -> u10; - u9 -> u10; - u4 [color="#99ff99", - label=Pool, - style=filled]; - u9 -> u4; - u11 [color="#99ff99", - label=Urls, - style=filled]; - http [color="#99cc99", - label=Http, - shape=box, - style=filled]; - u11 -> http; - u5 [color="#99ff99", - label=API, - style=filled]; - u5 -> u15; - u5 -> u11; - http -> u9; - http -> u11; - cache [color="#66ff66", - label=Cache, - shape=box, - style=filled]; - http -> cache; - forms -> u28; - forms -> u5; - tengine -> u26; - cache -> u4; +u43[label="TemplateParser"]; +u42[label="Plugins"]; +u40[label="Models"]; +u0[label="Main"]; +subgraph cluster_0 { +label="Framework"; +color="#ccffcc"; +style="filled"; +u41[label="Markdown"]; +u39[label="Pager"]; +u38[label="ContextProcessors"]; +u27[label="SQL"]; +u20[label="Wrapper"]; +u19[label="Urls"]; +u18[label="Models"]; +u17[label="Storage"]; +u14[label="Cache",shape=box]; +u13[label="Config"]; +u10[label="Logger"]; +u6[label="Controller"]; +u5[label="Pool"]; +u1[label="API", shape=box]; +forms[label="Forms", shape=box]; +http[label="HTTP", shape=box]; +tengine[label="TEngine",shape=box]; } + +forms -> http; +forms -> u1; +forms -> u18; +forms -> u42; +forms -> u6; +http -> u10; +http -> u13; +http -> u14; +http -> u17; +http -> u19; +http -> u5; +http -> u6; +tengine -> http; +tengine -> u1; +tengine -> u14; +tengine -> u38; +tengine -> u40; +tengine -> u6; +u0 -> u1; +u0 -> u40; +u14 -> u5; +u17 -> u18; +u17 -> u5; +u19 -> http; +u19 -> u10; +u19 -> u20; +u19 -> u6; +u1 -> forms; +u1 -> http; +u1 -> tengine; +u1 -> u10; +u1 -> u14; +u1 -> u17; +u1 -> u18; +u1 -> u19; +u1 -> u27; +u1 -> u39; +u1 -> u6; +u20 -> http; +u20 -> u14; +u20 -> u17; +u27 -> u18; +u38 -> u1; +u38 -> u6; +u39 -> forms; +u39 -> http; +u39 -> u1; +u39 -> u18; +u39 -> u27; +u39 -> u6; +u40 -> forms; +u40 -> u17; +u40 -> u18; +u40 -> u41; +u42 -> forms; +u6 -> http; +} +