diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 176374d..227023d 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -1,14 +1,12 @@ import System.IO -import Database.HDBC (SqlValue(..),fromSql) -import Control.Monad(forM) +import Database.HDBC (SqlValue(..)) import Framework.API import Framework.Utils import Framework.Modules.Auth.Controllers import Framework.Modules.Auth.Utils -import Framework.Modules.TextCaptcha.FormProcessors import Framework.Modules.Registration.Forms import Models hiding (__) @@ -113,4 +111,5 @@ onepost sid = do message "Комментарий добавлен." return $ redirect url +main :: IO () main = serveHttp "blog.conf" urlconf diff --git a/Blog/Extensions/FormProcessors.hs b/Blog/Extensions/FormProcessors.hs index 975a7f0..c8bf562 100644 --- a/Blog/Extensions/FormProcessors.hs +++ b/Blog/Extensions/FormProcessors.hs @@ -1,6 +1,5 @@ module Extensions.FormProcessors where -import Framework.Controller import Framework.Forms.Types import Framework.GetText.HTML @@ -10,5 +9,6 @@ import Framework.Modules.TextCaptcha.FormProcessors formProcessors :: FormProcessors formProcessors = [addCaptcha ["commentform"]] +htmlProcessors :: HTMLProcessors htmlProcessors = [translateHTML] diff --git a/Blog/Invalidation.hs b/Blog/Invalidation.hs index 7770bfb..253ddf1 100644 --- a/Blog/Invalidation.hs +++ b/Blog/Invalidation.hs @@ -12,7 +12,7 @@ import Framework.API.SQL import Models invalidatePostsCache :: SignalHandler -invalidatePostsCache _ model = do +invalidatePostsCache _ _ = do [[r]] <- queryListSQL (count (table postModel)) [] let n = fromSql r :: Int let perpage = fromMaybe 5 $ perPage postModel diff --git a/Blog/Models.hs b/Blog/Models.hs index ab8cbd6..943ee58 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -13,8 +13,10 @@ import Framework.Forms.ModelForm import Framework.ORM import Framework.Modules.Formatters.Markdown +__ :: String -> String __ = id +postModel :: Model postModel = emptyModel { mName = "post", mTable = "posts", @@ -28,29 +30,29 @@ postModel = emptyModel { } +postid :: (TemplateOne a) => a -> String postid = show.(transformInt 1 id) +nComments :: (TemplateOne a) => a -> String nComments = show.(transformInt 2 id) +bComments :: (TemplateOne a) => a -> Bool bComments = (/=0).(transformInt 2 id) +postDate :: (TemplateOne a) => a -> String postDate = transformString 1 id +title :: (TemplateOne a) => a -> String title = transformString 2 id +postbody :: (TemplateOne a) => a -> String postbody = transformString 3 id +postmarkdown :: (TemplateOne a) => a -> String postmarkdown = markdown2html . (transformString 3 id) --- tracelines x = unlines $ zipWith trace (map (("^"++).(++"$")) $ lines x) (lines x) - --- postForm = Form { --- formName = "postform", --- formModel = postModel, --- fFields = [ Field "title" "" inputbox noValidate, --- Field "body" "" textarea notEmpty] --- } - +postForm :: Form postForm = modelForm postModel addNComments post n = setCached postModel "ncomments" IntegerColumn n ------------------------------------------------------------------------------- +commentModel :: Model commentModel = emptyModel { mName = "comment", mTable = "comments", @@ -63,21 +65,23 @@ commentModel = emptyModel { defaultOrdering = [Asceding "dt"] } +commentForm :: Form +commentForm = modelForm commentModel + +commentId :: (TemplateOne a) => a -> String commentId = show.(transformInt 1 id) +commendPID :: (TemplateOne a) => a -> String commendPID = show.(transformInt 2 id) +commentDate :: (TemplateOne a) => a -> String commentDate = transformString 1 id +author :: (TemplateOne a) => a -> String author = transformString 2 id +commentBody :: (TemplateOne a) => a -> String commentBody = transformString 3 id --- commentForm = Form { --- formName = "comment", --- formModel = commentModel, --- fFields = [ Field "author" "" inputbox noValidate, --- Field "body" "" textarea notEmpty] --- } -commentForm = modelForm commentModel - ------------------------------------------------------------------------------- +formsList :: [Form] formsList = [postForm, commentForm] +allForms :: M.Map String Form allForms = M.fromList [(formName form, form) | form <- formsList] diff --git a/Framework/API/SQL.hs b/Framework/API/SQL.hs index 78e71b7..9adb554 100644 --- a/Framework/API/SQL.hs +++ b/Framework/API/SQL.hs @@ -2,18 +2,12 @@ module Framework.API.SQL where import Control.Monad.Reader.Class import qualified Database.HDBC as HDBC -import qualified Data.Map as M import Framework.Types import Framework.Controller --- import Framework.Exceptions import qualified Framework.Storage as Storage import Framework.ORM.Types import Framework.ORM.SQL --- import Framework.Forms.Types --- import Framework.Forms.Validation - -import Framework.API.Storage ---------------------------------------------------------------------------------------------------------- -- * Storage/SQL API diff --git a/Framework/API/SQLUtils.hs b/Framework/API/SQLUtils.hs index ad83c93..a8a7de8 100644 --- a/Framework/API/SQLUtils.hs +++ b/Framework/API/SQLUtils.hs @@ -2,7 +2,6 @@ module Framework.API.SQLUtils where import Control.Monad.Reader.Class import qualified Database.HDBC as HDBC -import qualified Data.Map as M import Framework.Types import Framework.Controller diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 0cfcee8..34bb95b 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -102,7 +102,7 @@ concatC cs = do where process [] = [] process (Reject:_) = [] - process ((RightNow x):xs) = x + process ((RightNow x):_) = x process ((Result x):xs) = x++process xs -- | Run a controller, but reject if it returns RightNow t. @@ -135,7 +135,7 @@ evalController :: Controller s a a -- ^ Controller -> s -- ^ Configuration for controller -> IO (Maybe a) evalController m s = do - (res, s') <- (runController m s) + (res, _) <- (runController m s) return $ anyResult res where -- | Convert any result to Maybe HttpResponse diff --git a/Framework/Forms/ModelForm.hs b/Framework/Forms/ModelForm.hs index 75789b5..e92fce0 100644 --- a/Framework/Forms/ModelForm.hs +++ b/Framework/Forms/ModelForm.hs @@ -18,8 +18,8 @@ modelForm model = Form { } mf2ff :: ModelField -> FormField -mf2ff f@(ValidateBy fld fn) = chgValidator (mf2ff fld) fn -mf2ff f@(UsingWidget fld w) = chgWidget (mf2ff fld) w +mf2ff (ValidateBy fld fn) = chgValidator (mf2ff fld) fn +mf2ff (UsingWidget fld w) = chgWidget (mf2ff fld) w mf2ff fld = mf2ff' (mfName fld) (mfType fld) chgValidator :: FormField -> FieldValidator -> FormField diff --git a/Framework/Forms/Rendering.hs b/Framework/Forms/Rendering.hs index a13707b..fa5960b 100644 --- a/Framework/Forms/Rendering.hs +++ b/Framework/Forms/Rendering.hs @@ -78,7 +78,7 @@ renderEditForm :: Model -> AController (String, String) renderEditForm model form fid action = do form' <- processForm form - renderCreateForm' form fid (zip fields values) [] action + renderCreateForm' form' fid (zip fields values) [] action where fields = map fieldName $ filter (not . isExternalField) $ mFields model values = map (D.fromSql.(model -:>)) fields diff --git a/Framework/Forms/Validators.hs b/Framework/Forms/Validators.hs index 1bbf892..5b191ef 100644 --- a/Framework/Forms/Validators.hs +++ b/Framework/Forms/Validators.hs @@ -5,7 +5,7 @@ import Framework.Forms.Types -- | Check that field is not empty notEmpty :: FieldValidator -notEmpty _ name s = if null s +notEmpty _ _ s = if null s then Left "This field should not be empty!" else Right s @@ -14,7 +14,7 @@ noValidate :: FieldValidator noValidate _ _ s = Right s regexp :: String -> FieldValidator -regexp re _ name s = if s =~ ("^"++re++"$") +regexp re _ _ s = if s =~ ("^"++re++"$") then Right s else Left $ "This field should be of form "++re diff --git a/Framework/GetText/HTML.hs b/Framework/GetText/HTML.hs index 7423a24..d812b69 100644 --- a/Framework/GetText/HTML.hs +++ b/Framework/GetText/HTML.hs @@ -5,6 +5,7 @@ import Framework.Forms.HTMLTypes import Framework.Forms.Types import qualified Framework.GetText.Controller as C +__ :: String -> String __ = id translateHTML :: HTML -> HTMLController diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index d7c3287..3ce82d9 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -19,15 +19,16 @@ import Network.URI import Network.HTTP import Data.Maybe -import Framework.Config +import Framework.Config(openConfig,readConfig) +import Framework.Cache.Types(CacheConnection) import Framework.Cache(cDisconnect) import Framework.Storage(disconnect') -import Framework.Pool +import Framework.Pool(garbageCollector,freeAll,emptyPool,MPool) import Framework.Logger import Framework.Types import Framework.Exceptions -import Framework.Urls -import Framework.Utils +import Framework.Urls(runURLConf,URLConf(RawFunction),StaticAction) +import Framework.Utils(emptyLine) import Framework.Http.Response import Framework.Http.Middlewares import Framework.Http.Httpd @@ -70,7 +71,7 @@ serveStatic' ps rq resource = httpWorker :: StaticConfig -> URLConf -> HttpRequest -> IO HttpResponse httpWorker hap conf req@(Request {rqURI = URI {uriPath}}) = do req' <- requestMiddlewares hap req - let s = unEscapeString $ rqBody req' +-- let s = unEscapeString $ rqBody req' -- putStrLn $ "Request body: "++show s -- putStrLn $ "deUTF:"++(decodeString s) -- putStrLn $ "Serving "++uriPath @@ -80,6 +81,7 @@ httpWorker hap conf req@(Request {rqURI = URI {uriPath}}) = do defaultURLConf :: URLConf defaultURLConf = RawFunction serveStatic +cleanup :: MPool DBConnection-> MPool CacheConnection-> Handle-> Handle-> IO () cleanup dbPool cPool hacc herr = do print "Disconnecting from DB and cache" freeAll dbPool disconnect' diff --git a/Framework/Modules/Auth/Context.hs b/Framework/Modules/Auth/Context.hs index 604f4bc..b67f5ac 100644 --- a/Framework/Modules/Auth/Context.hs +++ b/Framework/Modules/Auth/Context.hs @@ -1,6 +1,6 @@ module Framework.Modules.Auth.Context where -import Debug.Trace +-- import Debug.Trace import Control.Monad.Reader.Class diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs index 80f6143..c695c14 100644 --- a/Framework/Modules/Auth/Controllers.hs +++ b/Framework/Modules/Auth/Controllers.hs @@ -1,8 +1,6 @@ module Framework.Modules.Auth.Controllers where -import Control.Monad.Reader.Class import Database.HDBC -import qualified Data.Map as M import Framework.Forms.Types import Framework.Forms.Validation @@ -80,6 +78,8 @@ loginPage' form target retry = do resp <- checkAuth' target' retry form' returnNow resp +-- | Same, but with default login form +loginPage :: String -> String -> AController () loginPage = loginPage' defaultLoginForm -- | Log out current user diff --git a/Framework/Modules/Auth/Models.hs b/Framework/Modules/Auth/Models.hs index ddb93f7..a18802e 100644 --- a/Framework/Modules/Auth/Models.hs +++ b/Framework/Modules/Auth/Models.hs @@ -1,14 +1,13 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Framework.Modules.Auth.Models where --- module Models where import Framework.Types import Framework.Forms.Types import Framework.Forms.HTML import Framework.Forms.Validators import Framework.ORM -import qualified Data.Map as M +defaultUserModel :: Model defaultUserModel = emptyModel { mName = "user", mTable = "users", @@ -17,14 +16,15 @@ defaultUserModel = emptyModel { "password" ::: StringColumn ] } +uid :: (TemplateOne a) => a -> String uid = show.(transformInt 1 id) +username :: (TemplateOne a) => a -> String username = transformString 1 id +defaultLoginForm :: Form defaultLoginForm = Form { formName = "loginform", formModel = defaultUserModel, fFields = [ Field "name" "" inputbox notEmpty, Field "password" "" passwordbox notEmpty ] } - -onlyLogin = M.fromList [("loginform", defaultLoginForm)] diff --git a/Framework/Modules/Auth/ShowForm.hs b/Framework/Modules/Auth/ShowForm.hs index 2014a55..1e6d100 100644 --- a/Framework/Modules/Auth/ShowForm.hs +++ b/Framework/Modules/Auth/ShowForm.hs @@ -1,6 +1,5 @@ module Framework.Modules.Auth.ShowForm where -import Framework.Types import Framework.Controller import Framework.Forms.Types import Framework.Forms.Rendering diff --git a/Framework/Modules/Registration/Forms.hs b/Framework/Modules/Registration/Forms.hs index d3312ec..a984a50 100644 --- a/Framework/Modules/Registration/Forms.hs +++ b/Framework/Modules/Registration/Forms.hs @@ -32,6 +32,7 @@ instance Widget TwoPasswordBoxes where wRead = id +twoPasswordBoxes :: TwoPasswordBoxes twoPasswordBoxes = TwoPasswordBoxes Nothing validatePasswords :: FieldValidator @@ -42,6 +43,7 @@ validatePasswords rq name str = where str' = httpPostVar' rq (name++"check") "" +registrationForm :: Form registrationForm = Form { formName = "register", formModel = defaultUserModel, @@ -78,6 +80,7 @@ doRegister' form target = do doRegister :: String -> HttpController doRegister = doRegister' registrationForm +registrationPage' :: Form -> String -> AController () registrationPage' form target = do rq <- asks request case rqMethod rq of @@ -90,5 +93,6 @@ registrationPage' form target = do resp <- doRegister' form target returnNow resp +registrationPage :: String -> AController () registrationPage = registrationPage' registrationForm diff --git a/Framework/Modules/TextCaptcha/FormProcessors.hs b/Framework/Modules/TextCaptcha/FormProcessors.hs index e3fcb98..a4a4e81 100644 --- a/Framework/Modules/TextCaptcha/FormProcessors.hs +++ b/Framework/Modules/TextCaptcha/FormProcessors.hs @@ -32,6 +32,8 @@ readCaptcha str | [s,xs,ys] <- words str = "+" -> TCAdd x y "-" -> TCSub x y "*" -> TCMul x y + _ -> TCAdd 0 0 + | otherwise = TCAdd 0 0 evalCaptcha :: TextCaptcha -> Int evalCaptcha (TCAdd x y) = x+y @@ -62,12 +64,13 @@ randomCaptcha = do 0 -> TCAdd x y 1 -> TCSub x y 2 -> TCMul x y + _ -> error "Impossible!" isNum :: String -> Bool isNum s = (not $ null s) && ((head s) `elem` "-0123456789") && (all isDigit (tail s)) validateCaptcha :: FieldValidator -validateCaptcha rq name str = +validateCaptcha rq _ str = if val == targetval then Right str else Left "Invalid captcha!" diff --git a/Framework/ORM/Models.hs b/Framework/ORM/Models.hs index 7c9917f..279029a 100644 --- a/Framework/ORM/Models.hs +++ b/Framework/ORM/Models.hs @@ -88,7 +88,7 @@ record :: Model -- ^ Empty model (with unfilled fi record m lst = m { mFields = combine (mFields m) lst} where combine (_:_) [] = [] - combine [] lst = [] + combine [] _ = [] combine ((FilledField name tp _):fs) (x:xs) = (FilledField name tp x):(combine fs xs) combine ((ValidateBy fld _):fs) (x:xs) = combine (fld:fs) (x:xs) combine ((UsingWidget fld _):fs) (x:xs) = combine (fld:fs) (x:xs) @@ -104,18 +104,18 @@ record' m lst = m { mFields = filledFields } filledFields = combine (mFields m) lst combine _ [] = [] - combine [] lst = combine' (mCached m) lst + combine [] l = combine' (mCached m) l combine ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine fs xs) combine ((FilledField name tp _):fs) (x:xs) = (FilledField name tp x):(combine fs xs) combine ((ValidateBy fld _):fs) (x:xs) = combine (fld:fs) (x:xs) combine ((UsingWidget fld _):fs) (x:xs) = combine (fld:fs) (x:xs) combine' [] _ = [] - combine' lst [] = lst + combine' l [] = l combine' ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine' fs xs) combine' ((FilledField name tp _):fs) (x:xs) = (FilledField name tp x):(combine' fs xs) - combine' ((ValidateBy fld _):fs) lst = combine' (fld:fs) lst - combine' ((UsingWidget fld _):fs) lst = combine' (fld:fs) lst + combine' ((ValidateBy fld _):fs) l = combine' (fld:fs) l + combine' ((UsingWidget fld _):fs) l = combine' (fld:fs) l -- | Get name of field fieldName :: ModelField -> String diff --git a/Framework/ORM/SQL.hs b/Framework/ORM/SQL.hs index b3f48f6..744a3af 100644 --- a/Framework/ORM/SQL.hs +++ b/Framework/ORM/SQL.hs @@ -12,7 +12,7 @@ module Framework.ORM.SQL aggregate, count ) where -import Debug.Trace +-- import Debug.Trace import Data.List @@ -26,6 +26,7 @@ fieldname (QFn _ n) = n -- sql q = let s = sql' q -- in trace s s +sql :: Query -> String sql = sql' -- | Generate SQL query from its Query description @@ -76,7 +77,7 @@ liftF fn (QFn _ name) = QFn fn name -- | Get `count` function of query count :: Query -> Query -count q@(Query flds tbls conds ordr grp lim) | TableJoin lst <- tbls = Query [liftF "count" $ head flds] (TableList [head lst]) NoCondition [] [] Nothing +count q@(Query flds tbls _ _ _ _) | TableJoin lst <- tbls = Query [liftF "count" $ head flds] (TableList [head lst]) NoCondition [] [] Nothing | otherwise = aggregate q "count" allFields :: [SQLField] diff --git a/Framework/Signals.hs b/Framework/Signals.hs index 32fcda5..5a58789 100644 --- a/Framework/Signals.hs +++ b/Framework/Signals.hs @@ -16,6 +16,7 @@ import Extensions.Signals (connectSignals) signals :: M.Map Signal [SignalHandler] signals = defaultSignals `M.union` connectSignals +defaultSignals :: M.Map Signal [SignalHandler] defaultSignals = M.fromList [] -- | Send a signal. diff --git a/Framework/Storage.hs b/Framework/Storage.hs index 597fbcc..234f61a 100644 --- a/Framework/Storage.hs +++ b/Framework/Storage.hs @@ -36,6 +36,7 @@ connect' "mysql" str = DBC `fmap` (MySQL.connectMySQL $ parsedMySQL) [user,x] = split ":" str [pass,x'] = split "@" x [server,db] = split "/" x' +connect' _ _ = error "Unknown DB driver!" -- | Connect to DB, get parameters from "StaticConfig" connect :: MPool DBConnection -- ^ Pool of connections diff --git a/Framework/Urls.hs b/Framework/Urls.hs index fce3a14..c00dfb0 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -15,7 +15,6 @@ module Framework.Urls import Data.Char import Text.Regex.PCRE import Network.URI -import Network.HTTP import Data.List import Framework.Utils @@ -72,7 +71,7 @@ urlJoin :: URLParts -> String urlJoin us = concat $ intersperse "/" us return404 :: (Show a) =>StaticConfig -> HttpRequest -> a -> URI -> IO HttpResponse -return404 ps rq conf url = raiseIO ps rq 404 $ "Not found: "++uriPath url +return404 ps rq _ url = raiseIO ps rq 404 $ "Not found: "++uriPath url data URLResult = NoResult | AC HttpController @@ -112,7 +111,7 @@ runURLConf' :: URLConf -> URLParts -> URLResult -- runURLConf' _ [] _ = Nothing runURLConf' (Prefix p conf) (x:xs) | p==x = runURLConf' conf xs | otherwise = NoResult -runURLConf' (Prefix p conf) [] = NoResult +runURLConf' (Prefix _ _) [] = NoResult runURLConf' (Regexp r conf) (x:xs) = let b = x =~ r :: Bool in if b then runURLConf' conf xs @@ -135,7 +134,7 @@ runURLConf' (OneOf c d) url = case runURLConf' c u -- NoResult -> runURLConf' d xs -- Just act -> Just (maybe act (act>>) (runURLConf' d xs ac)) -- runURLConf' cc xs = error $ unlines ["URLConf error",show cc,show xs] -runURLConf' cc xs = NoResult +runURLConf' _ _ = NoResult -- | If current part of URL is equal to given string, then call given function (-->) :: String -> HttpAction -> URLConf @@ -164,8 +163,8 @@ infixr 8 ~/ -- | Ends form "ManyRegexpFun" (~>>) :: String -> ManyStrAction -> URLConf -r ~>> f = r ~/ mrf f - where mrf f = ManyRegexpFun [] [] f +r ~>> f = r ~/ mrf + where mrf = ManyRegexpFun [] [] f -- | Same as "OneOf" (<|>) :: URLConf -> URLConf -> URLConf diff --git a/Framework/Utils.hs b/Framework/Utils.hs index f631a04..ea50ea4 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -125,7 +125,8 @@ readFile' f = do hClose h lazySlurp fp 0 len -buf_size = 4096 :: Int +buf_size :: Int +buf_size = 4096 lazySlurp :: ForeignPtr Word8 -> Int -> Int -> IO String lazySlurp fp ix len