diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 221f739..a37ad6d 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -1,7 +1,6 @@ import System.IO import Database.HDBC (SqlValue(..),fromSql) -import qualified Data.Map as M import Control.Monad(forM) import Framework.API diff --git a/Blog/Models.hs b/Blog/Models.hs index fb3e388..ee569d2 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -1,17 +1,14 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Models where -import Debug.Trace +-- import Debug.Trace import qualified Data.Map as M -import Database.HDBC (fromSql) -import Database.HDBC.ColTypes (SqlTypeId (..)) import Framework.Types -import Framework.Storage import Framework.Forms.Types import Framework.Forms.HTML -import Framework.Forms.Validation +import Framework.Forms.Validators import Framework.ORM import Framework.Markdown diff --git a/Blog/Settings.hs b/Blog/Settings.hs index a89b249..6633a5a 100644 --- a/Blog/Settings.hs +++ b/Blog/Settings.hs @@ -1,10 +1,18 @@ module Settings where +import Network.HTTP +import Network.URI + +import Framework.Types import Framework.Controller +import Framework.TEngine.TemplateUtil import Framework.Forms.Types requestExcHandler :: ExcHandler -requestExcHandler rq code msg = return () +requestExcHandler rq code msg = do + returnNow $ renderToResponse (show code++".html") [("error", C msg), + ("request", C $ show rq), + ("url", C $ uriPath $ rqURI rq)] controllerExcHandler :: ExcHandler controllerExcHandler rq code msg = return () diff --git a/Blog/templates/404.html b/Blog/templates/404.html new file mode 100644 index 0000000..4fd78cf --- /dev/null +++ b/Blog/templates/404.html @@ -0,0 +1,15 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> + <head> + <title>404 Error</title> + <meta name='author' content='Portnov'> + </head> + + <body> + <h1>{{error}}</h1> + <p>Requested URL: {{url}}</p> + <p> <code><pre> + Request: {{request}} + </pre></code> </p> + </body> +</html> diff --git a/Framework/API.hs b/Framework/API.hs index e6e8b95..2bdd8b5 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -38,7 +38,7 @@ import Framework.Types import Framework.Controller import Framework.Exceptions import qualified Framework.Http.Cookies as Cookies -import Framework.Http.HTTPServer (serveStatic, serveHttp) +import Framework.Http.HTTPServer (serveHttp,serveStatic) import Framework.API.Cache import Framework.API.Sessions @@ -70,3 +70,4 @@ setcookie name value = do expDate <- asks cookiesExp return $ Cookies.setcookie expDate name value +------------------------------------------------------------------------------------------------------------ diff --git a/Framework/Cache/Cache.hs b/Framework/Cache/Cache.hs index ab21b3c..ecaade5 100644 --- a/Framework/Cache/Cache.hs +++ b/Framework/Cache/Cache.hs @@ -3,7 +3,6 @@ module Framework.Cache.Cache where import Network.Memcache.Serializable (Serializable(..)) -import Framework.Types import Framework.Pool import Framework.Cache.Types import Framework.Cache.Instances diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 392f09c..3eaa0a0 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -30,7 +30,6 @@ import Control.Monad.Reader.Class import Control.Monad.Trans import Framework.Types -import Framework.Http.Response --------------------------------------------------------------------------------------- -- * Data types diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs index 323e895..0d485b0 100644 --- a/Framework/Forms/HTML.hs +++ b/Framework/Forms/HTML.hs @@ -9,7 +9,6 @@ module Framework.Forms.HTML ) where import Framework.Forms.Types -import Framework.Urls import Framework.Utils import Framework.Types diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index 3f77cbc..a9f937b 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -8,8 +8,6 @@ module Framework.Forms.Types FormValidator, FieldValidator ) where -import Network.HTTP - import Framework.Types import Framework.ORM diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index 42f8191..f46179f 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -5,12 +5,11 @@ module Framework.Forms.Validation editModelForm, returnInvalidForm, formVars, formVarsNames, formVarsValues, - notEmpty, noValidate, defValidate, getAnyForm, getForm ) where -import Debug.Trace +-- import Debug.Trace import Control.Monad.Reader.Class import qualified Data.Map as M @@ -167,16 +166,6 @@ formVarsNames form fid = map (mangleName (formName form) fid) $ map fName $ fFie formVars :: Form -> String -> HttpRequest -> [(String,String)] formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) --- | Check that field is not empty -notEmpty :: String -> FieldValidator -notEmpty msg s = if null s - then Left msg - else Right s - --- | Do not validate at all, consider all values are valid. -noValidate :: FieldValidator -noValidate s = Right s - ---------------------------------------------------------------------------------------------------- -- | Get any present form from HttpRequest diff --git a/Framework/Forms/Validators.hs b/Framework/Forms/Validators.hs new file mode 100644 index 0000000..30d3fd2 --- /dev/null +++ b/Framework/Forms/Validators.hs @@ -0,0 +1,13 @@ +module Framework.Forms.Validators where + +import Framework.Forms.Types + +-- | Check that field is not empty +notEmpty :: String -> FieldValidator +notEmpty msg s = if null s + then Left msg + else Right s + +-- | Do not validate at all, consider all values are valid. +noValidate :: FieldValidator +noValidate s = Right s diff --git a/Framework/Http/Cookies.hs b/Framework/Http/Cookies.hs index ab3ffcf..6c6f00f 100644 --- a/Framework/Http/Cookies.hs +++ b/Framework/Http/Cookies.hs @@ -1,7 +1,7 @@ module Framework.Http.Cookies (setcookie,getcookie) where -import Debug.Trace +-- import Debug.Trace import Data.Char import Network.HTTP diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index 8f12a3a..ff57e94 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -2,8 +2,8 @@ -- | This module wraps Httpd module Framework.Http.HTTPServer (defaultURLConf, - serveHttp, - serveStatic) where + serveHttp, serveStatic + ) where import Prelude hiding (catch,print,putStr,putStrLn,readFile) import System.Posix.Signals @@ -25,18 +25,13 @@ import Framework.Storage(disconnect') import Framework.Pool import Framework.Logger import Framework.Types +import Framework.Exceptions import Framework.Urls import Framework.Utils import Framework.Http.Response import Framework.Http.Middlewares import Framework.Http.Httpd - --- | Send a file -sendfile :: String -> IO HttpResponse -sendfile filename = do - body <- readFile filename - return $ response 200 [mkHeader HdrContentType mime] body - where mime = fromMaybe "application/octet-stream" $ chooseMime filename +import Framework.Http.Static -- | Just serve static files serveStatic :: StaticAction @@ -60,8 +55,7 @@ serveStatic' ps rq resource = return $ response 500 [] (show e ++ emptyLine) toResponse False = do - writeLog (errChan ps) rq $ "Not found: "++filepath - return $ response 404 [] $ "File "++filepath++" not found!" + raiseIO ps rq 404 $ "Not found: "++filepath toResponse True = do writeLog (logChan ps) rq $ "Sending "++filepath sendfile filepath diff --git a/Framework/Http/Httpd.hs b/Framework/Http/Httpd.hs index 986142e..9e40769 100644 --- a/Framework/Http/Httpd.hs +++ b/Framework/Http/Httpd.hs @@ -35,10 +35,10 @@ import Prelude hiding (print) import Network import Network.URI import Network.HTTP -import Network.Stream +-- import Network.Stream import System.IO hiding (hPutStr,hPutStrLn,print,hGetLine) import System.IO.UTF8 -import Codec.Binary.UTF8.String +-- import Codec.Binary.UTF8.String import Control.Monad import Control.Monad import Control.Concurrent diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index 6c799d1..4a47acc 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -5,7 +5,7 @@ module Framework.Http.Middlewares responseMiddlewares) where import Network.HTTP -import Framework.Utils +-- import Framework.Utils import Framework.Types type RequestMiddleware = HttpRequest -> IO HttpRequest diff --git a/Framework/Http/PostParser.hs b/Framework/Http/PostParser.hs index 07c6532..24e0991 100644 --- a/Framework/Http/PostParser.hs +++ b/Framework/Http/PostParser.hs @@ -3,13 +3,10 @@ module Framework.Http.PostParser where import Data.List -import Data.List.Utils import Data.String.Utils import qualified Data.Map as M import Data.Maybe import Network.HTTP -import Control.Monad -import Control.Monad.State import Control.Arrow import Debug.Trace diff --git a/Framework/Http/Response.hs b/Framework/Http/Response.hs index c829483..375e0ce 100644 --- a/Framework/Http/Response.hs +++ b/Framework/Http/Response.hs @@ -4,7 +4,7 @@ module Framework.Http.Response redirect, redirectG, redirectP, (<+>), (<++>) ) where -import System.IO.UTF8 +-- import System.IO.UTF8 import Network.HTTP import Framework.Types diff --git a/Framework/Http/Sessions.hs b/Framework/Http/Sessions.hs index 43c806b..832e615 100644 --- a/Framework/Http/Sessions.hs +++ b/Framework/Http/Sessions.hs @@ -10,7 +10,7 @@ module Framework.Http.Sessions SessionsConnection ) where -import Debug.Trace +-- import Debug.Trace import Prelude hiding (readFile,writeFile) import System.IO hiding (readFile,writeFile) diff --git a/Framework/Http/Static.hs b/Framework/Http/Static.hs new file mode 100644 index 0000000..56643a0 --- /dev/null +++ b/Framework/Http/Static.hs @@ -0,0 +1,20 @@ +module Framework.Http.Static + (sendfile + ) where + +import Prelude hiding (readFile) +import Data.Maybe +import System.IO.UTF8 +import Network.HTTP + +import Framework.Types +import Framework.Utils +import Framework.Http.Response + +-- | Send a file +sendfile :: String -> IO HttpResponse +sendfile filename = do + body <- readFile filename + return $ response 200 [mkHeader HdrContentType mime] body + where mime = fromMaybe "application/octet-stream" $ chooseMime filename + diff --git a/Framework/Logger.hs b/Framework/Logger.hs index cfe25a9..1de56be 100644 --- a/Framework/Logger.hs +++ b/Framework/Logger.hs @@ -13,7 +13,6 @@ import Control.Monad import Control.Concurrent import Control.Concurrent.Chan import Text.Printf -import Network.HTTP import Framework.Types diff --git a/Framework/Makefile b/Framework/Makefile index fb4ad9a..95c6d0b 100644 --- a/Framework/Makefile +++ b/Framework/Makefile @@ -6,5 +6,6 @@ API.o: *.hs $(GHC) API.hs clean: - rm *.o *.hi + find . -name \*.hi -delete + find . -name \*.o -delete diff --git a/Framework/ORM/SQL.hs b/Framework/ORM/SQL.hs index b321459..0ec7d08 100644 --- a/Framework/ORM/SQL.hs +++ b/Framework/ORM/SQL.hs @@ -12,11 +12,9 @@ module Framework.ORM.SQL aggregate, count ) where -import Debug.Trace +-- import Debug.Trace import Data.List -import Database.HDBC -import qualified Data.Convertible.Base as CD import Framework.ORM.Types import Framework.ORM.Models diff --git a/Framework/ORM/Types.hs b/Framework/ORM/Types.hs index 369c411..2708a7b 100644 --- a/Framework/ORM/Types.hs +++ b/Framework/ORM/Types.hs @@ -1,6 +1,6 @@ module Framework.ORM.Types where -import Database.HDBC (SqlValue(..), fromSql) +import Database.HDBC (SqlValue(..)) ---------------------------------------------------------------------------------- -- * SQL query ADT diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 8b7ccb6..3dc3b82 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -6,7 +6,6 @@ module Framework.Pager import Control.Monad.Reader.Class import Database.HDBC (SqlValue (..), fromSql) -import Network.HTTP import Framework.Forms.Types import Framework.Forms.HTML diff --git a/Framework/Storage.hs b/Framework/Storage.hs index 30e86f6..2efe6ae 100644 --- a/Framework/Storage.hs +++ b/Framework/Storage.hs @@ -11,7 +11,7 @@ module Framework.Storage import qualified Database.HDBC.Sqlite3 as Sqlite3 -import qualified Database.HDBC.MySQL as MySQL +-- import qualified Database.HDBC.MySQL as MySQL import qualified Database.HDBC.PostgreSQL as PostgreSQL import qualified Database.HDBC as D diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs index 7f358a5..c90cb64 100644 --- a/Framework/TEngine/TemplateUtil.hs +++ b/Framework/TEngine/TemplateUtil.hs @@ -7,9 +7,7 @@ module Framework.TEngine.TemplateUtil ) where import Control.Monad (when) -import Control.Monad.Reader.Class import qualified Data.Map as M -import Network.HTTP import Framework.Http.Response (ok) import Framework.TEngine.Templates (render) diff --git a/Framework/TGenerator/TemplateGen.hs b/Framework/TGenerator/TemplateGen.hs index 6951544..6efff64 100644 --- a/Framework/TGenerator/TemplateGen.hs +++ b/Framework/TGenerator/TemplateGen.hs @@ -93,9 +93,6 @@ genFormat m (IncludeVar v) = (" render ("++(getvar v)++") pairs", m) preamble h = do -- hPutStrLn h "{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, OverlappingInstances #-}" hPutStrLn h "module Framework.TEngine.Templates where" - hPutStrLn h "import Prelude hiding (readFile)" - hPutStrLn h "import System.IO hiding (readFile,hPutStrLn,hPutStr)" - hPutStrLn h "import System.IO.UTF8" hPutStrLn h "import qualified Data.Map as M" hPutStrLn h "import Data.List" hPutStrLn h "import Framework.Types" diff --git a/Framework/Types.hs b/Framework/Types.hs index 0c92294..0a30661 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, OverlappingInstances, IncoherentInstances, FlexibleContexts, UndecidableInstances, RankNTypes, ImpredicativeTypes #-} module Framework.Types where -import System.IO import Control.Concurrent.Chan import Data.List import qualified Data.Map as M diff --git a/Framework/Urls.hs b/Framework/Urls.hs index 8f49a60..ab421e3 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -10,10 +10,9 @@ module Framework.Urls myUrl ) where -import Debug.Trace +-- import Debug.Trace import Data.Char -import Codec.Binary.UTF8.String import Text.Regex.PCRE import Network.URI import Network.HTTP @@ -22,7 +21,6 @@ import Data.List import Framework.Utils import Framework.Types import Framework.Wrapper -import Framework.Logger import Framework.Controller import Framework.Exceptions import qualified Framework.Http.Sessions as Sessions diff --git a/Framework/Wrapper.hs b/Framework/Wrapper.hs index caa4e2a..a1c41e6 100644 --- a/Framework/Wrapper.hs +++ b/Framework/Wrapper.hs @@ -1,9 +1,7 @@ module Framework.Wrapper where import qualified Data.Map as M -import Network.HTTP -import qualified Framework.Http.Cookies as Cookies import qualified Framework.Http.Sessions as Sessions import qualified Framework.Storage as Storage import Framework.Http.Response ((<+>))