diff --git a/Framework/Cache.hs b/Framework/Cache.hs index 46e1388..6d46733 100644 --- a/Framework/Cache.hs +++ b/Framework/Cache.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} +-- | This module manages caching of any data. Caching is implemented by several backends, +-- such as Memcache and Filesystem. module Framework.Cache ( -- $doc module Framework.Cache.Types, @@ -10,7 +12,3 @@ import Framework.Cache.Types import Framework.Cache.Cache import Network.Memcache.Serializable (Serializable(..)) --- $doc --- This module manages caching of any data. Caching is implemented by several backends, --- such as Memcache and Filesystem. - diff --git a/Framework/Cache/Instances.hs b/Framework/Cache/Instances.hs index c4a51b3..fe5e40d 100644 --- a/Framework/Cache/Instances.hs +++ b/Framework/Cache/Instances.hs @@ -67,4 +67,5 @@ initCache' :: String -- ^ Cache backend initCache' "memcached" s = CConnection `fmap` (cinit s :: IO MemcacheBackend) initCache' "filesystem" s = CConnection `fmap` (cinit s :: IO FilesystemBackend) initCache' "fake" s = CConnection `fmap` (cinit s :: IO FakeBackend) +initCache' _ _ = error "Don't know given cache backend" diff --git a/Framework/Controller.hs b/Framework/Controller.hs index e927463..0cfcee8 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -112,7 +112,7 @@ changeR m = do r <- liftIO $ runController m s case fst r of Reject -> reject - RightNow t -> reject + RightNow _ -> reject Result x -> return x -- | Assert that condition is satisfied. Otherwise, reject URL. diff --git a/Framework/GetText/Controller.hs b/Framework/GetText/Controller.hs index e136e25..48d261e 100644 --- a/Framework/GetText/Controller.hs +++ b/Framework/GetText/Controller.hs @@ -2,9 +2,6 @@ module Framework.GetText.Controller (__ ) where -import Text.I18N.GetText -import Codec.Binary.UTF8.String - import Framework.Controller import qualified Framework.GetText.IO as IO diff --git a/Framework/GetText/Init.hs b/Framework/GetText/Init.hs index f53daba..22ddd94 100644 --- a/Framework/GetText/Init.hs +++ b/Framework/GetText/Init.hs @@ -6,6 +6,7 @@ import Data.Char import System.Locale.SetLocale import Text.I18N.GetText +countries :: [([Char], [Char])] countries = [ ("en", "GB"), ("ru", "RU")] diff --git a/Framework/Http/Cookies.hs b/Framework/Http/Cookies.hs index 6c6f00f..e7b4c1a 100644 --- a/Framework/Http/Cookies.hs +++ b/Framework/Http/Cookies.hs @@ -13,7 +13,7 @@ setcookie :: String -- ^ Expiration date -> String -- ^ Cookie name -> String -- ^ Cookie value -> Header -setcookie exp name value = mkHeader HdrSetCookie ((esc (name++"="++value))++"; expires="++exp) +setcookie expd name value = mkHeader HdrSetCookie ((esc (name++"="++value))++"; expires="++expd) getcookie :: HttpRequest -- ^ HTTP request -> String -- ^ Cookie name diff --git a/Framework/Http/Httpd.hs b/Framework/Http/Httpd.hs index 9e40769..fa1196d 100644 --- a/Framework/Http/Httpd.hs +++ b/Framework/Http/Httpd.hs @@ -55,11 +55,13 @@ import Framework.Logger type Server = () -- later, you might have a handle for shutting down a server. +showRC :: (Int, Int, Int) -> String showRC (a,b,c) = x:y:z:[] where x = Char.intToDigit a y = Char.intToDigit b z = Char.intToDigit c +addContentLength :: String -> ([Header], String) addContentLength body = {-# SCC "addContentLength" #-} ([mkHeader HdrContentLength (show $ lengthUTF8 body)], body) @@ -135,7 +137,7 @@ initServerMain processBody ps callOut = do -- print lns case parseHeaders lns of Right hdrs -> readPOST h mode uri hdrs - Left err -> hClose h -- strange format -- FIXME: arguable answer? + Left _ -> hClose h -- strange format -- FIXME: arguable answer? readPOST h mode uri hds = {-# SCC "readPOST" #-} if mode `elem` [POST,PUT] diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index d531535..22c4445 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -7,13 +7,11 @@ module Framework.Http.Middlewares -- import Debug.Trace -import Control.Monad (ap) import Data.Char import Data.Maybe import Data.String.Utils import Network.HTTP --- import Framework.Utils import Framework.Types import Framework.Utils import Framework.GetText.Init @@ -24,6 +22,7 @@ import qualified Extensions.Middlewares as Settings (requestMiddlewares, respons type RequestMiddleware = StaticConfig -> HttpRequest -> IO HttpRequest type ResponseMiddleware = StaticConfig -> HttpResponse -> IO HttpResponse +addEncoding :: (Monad m) => t -> Response a -> m (Response a) addEncoding _ resp = return $ case lookupHeader HdrContentType (rspHeaders resp) of Nothing -> replaceHeader HdrContentType ("text/html; charset="++enc) resp @@ -32,7 +31,8 @@ addEncoding _ resp = return $ Just x -> tail x Nothing -> "UTF-8" -readLanguage ps rq = do +readLanguage :: (Monad m) => t -> Request a -> m (Request a) +readLanguage _ rq = do let h = insertHeader (HdrCustom "X-UserLanguage") lang rq let h' = insertHeader (HdrCustom "X-UserCharset") enc h return h' @@ -41,6 +41,7 @@ readLanguage ps rq = do lang = parseLang hdrs enc = parseEnc hdrs +initI18N :: StaticConfig -> Request a -> IO (Request a) initI18N ps rq = do gettextInit (lang++enc) domain dir return rq diff --git a/Framework/Http/PostParser.hs b/Framework/Http/PostParser.hs index 24e0991..8393a92 100644 --- a/Framework/Http/PostParser.hs +++ b/Framework/Http/PostParser.hs @@ -20,7 +20,9 @@ data FormDataItem = Single String HttpVar type FormData = [FormDataItem] +urlencoded :: String urlencoded = "application/x-www-form-urlencoded" +multipart :: String multipart = "multipart/form-data" -- | Get map of POST variables from request @@ -62,8 +64,11 @@ getValue a s d = Just v -> v Nothing -> d +getName :: String -> String getName = \s -> getValue "name" s "" +getBoundary :: String -> String getBoundary = \s -> getValue "boundary" s "" +getFilename :: String -> String getFilename = \s -> getValue "filename" s "" parseP :: String -> FormDataItem @@ -83,7 +88,7 @@ parseP part = filebody = (init.init) oth } else Multiple name $ parse b oth Nothing -> Single name $ Str $ (init.init.init) oth - Left err -> error "Could not parse headers!" + Left _ -> error "Could not parse headers!" cutAt :: String -> String -> (String, String) cutAt sp str = cutAt' "" str diff --git a/Framework/Http/Sessions.hs b/Framework/Http/Sessions.hs index 832e615..8dfa14b 100644 --- a/Framework/Http/Sessions.hs +++ b/Framework/Http/Sessions.hs @@ -59,6 +59,7 @@ initSessions :: String -- ^ Backend name (currently only `files`) -> String -- ^ Config of backend (path where to store sessions files) -> IO SessionsConnection initSessions "files" s = SConnection `fmap` (sinit s :: IO FilesBackend) +initSessions _ _ = error "Don't know given session backend" -- | Fetch session data from backend sFetch :: SessionsConnection -> SessionID -> IO SessionMap diff --git a/Framework/Modules/Auth/Handlers.hs b/Framework/Modules/Auth/Handlers.hs index d8ef738..a528bba 100644 --- a/Framework/Modules/Auth/Handlers.hs +++ b/Framework/Modules/Auth/Handlers.hs @@ -13,7 +13,6 @@ import Framework.Http.Response handle403 :: String -- ^ URL of login page -> ControllerExcHandler handle403 target rq code msg = do - rq <- asks request if code==403 then do message $ msg ++ ": Authenitication required" sessionSet "target" $ myUrl rq diff --git a/Framework/Modules/SHA1.hs b/Framework/Modules/SHA1.hs index ef1a77d..9124ada 100644 --- a/Framework/Modules/SHA1.hs +++ b/Framework/Modules/SHA1.hs @@ -4,5 +4,6 @@ import Codec.Binary.UTF8.String import qualified Data.Digest.SHA1 as SHA1 import Numeric +sha1 :: String -> String sha1 str = showHex (SHA1.toInteger $ SHA1.hash $ encode str) "" diff --git a/Framework/Modules/TextCaptcha/FormProcessors.hs b/Framework/Modules/TextCaptcha/FormProcessors.hs index a6f4035..8fba2bd 100644 --- a/Framework/Modules/TextCaptcha/FormProcessors.hs +++ b/Framework/Modules/TextCaptcha/FormProcessors.hs @@ -77,7 +77,6 @@ addCaptcha :: [String] -> Form -> FormController addCaptcha lst form = do if (formName form) `elem` lst then do --- liftIO $ print $ "Processing "++(formName form) captcha <- liftIO $ randomCaptcha let field = Field "textcaptcha" "Captcha" captcha validateCaptcha return $ form `addFields` [field] diff --git a/Framework/ORM/Types.hs b/Framework/ORM/Types.hs index 76dad7d..5c393b0 100644 --- a/Framework/ORM/Types.hs +++ b/Framework/ORM/Types.hs @@ -75,6 +75,7 @@ instance SQLFragment SQLCondition where sqlFPair :: (SQLFragment f) => String -> f -> f -> String sqlFPair op x y = (sqlFragment x)++op++(sqlFragment y) +sqlLift :: [a] -> [a] -> [a] -> [a] sqlLift op x y = x++op++y instance SQLFragment SQLField where diff --git a/Framework/Pool.hs b/Framework/Pool.hs index 58177e3..327c3a2 100644 --- a/Framework/Pool.hs +++ b/Framework/Pool.hs @@ -34,12 +34,12 @@ findConnection :: (c -> IO a) -> c -> Pool a -> IO (Pool a, (Int,a)) findConnection f x pool = findConnection' [] 0 x pool where findConnection' xs i _ ((Free res):ps) = return (xs++(Busy res):ps, (i,res)) - findConnection' xs i x (NotConnected:ps) = do - res <- f x + findConnection' xs i y (NotConnected:ps) = do + res <- f y return (xs++(Busy res):ps, (i,res)) - findConnection' xs i x (p:ps) = findConnection' (xs++[p]) (i+1) x ps - findConnection' xs i x [] = do - res <- f x + findConnection' xs i y (p:ps) = findConnection' (xs++[p]) (i+1) y ps + findConnection' xs i y [] = do + res <- f y return (xs++[Busy res], (i+1,res)) -- | Free connection @@ -56,10 +56,10 @@ freeConnection i res pool = return $ (take i pool)++[Free res]++(drop (i+1) pool freeAll :: MPool a -- ^ Pool -> (a -> IO ()) -- ^ Disconnect function -> IO () -freeAll mpool f = withMVar mpool (mapM_ $ free' f) - where free' _ NotConnected = return () - free' f (Busy res) = f res - free' f (Free res) = f res +freeAll mpool f = withMVar mpool (mapM_ free') + where free' NotConnected = return () + free' (Busy res) = f res + free' (Free res) = f res -- | Run GC thread, which closes unused connections garbageCollector :: MPool a -- ^ Pool diff --git a/Framework/TEngine/TemplateFuncs.hs b/Framework/TEngine/TemplateFuncs.hs index 9ffdaa6..a66e771 100644 --- a/Framework/TEngine/TemplateFuncs.hs +++ b/Framework/TEngine/TemplateFuncs.hs @@ -11,18 +11,25 @@ import Data.List import Framework.Types -_bold s = "<strong>"++s++"</strong>" -bold = transformString 1 _bold +bold :: (TemplateOne a) => a -> String +bold = transformString 1 $ \s -> "<strong>"++s++"</strong>" +italic :: (TemplateOne a) => a -> String +italic = transformString 1 $ \s -> "<em>"++s++"</em>" + +uppercase :: (TemplateOne a) => a -> String uppercase = transformString 1 $ map toUpper +lowercase :: (TemplateOne a) => a -> String lowercase = transformString 1 $ map toLower +evenP :: (TemplateOne a) => a -> Bool evenP = transformInt 1 even +oddP :: (TemplateOne a) => a -> Bool oddP = transformInt 1 odd list :: String -> (String -> String) -> SFunction -list sep f lst = concat $ intersperse sep $ map (transform f) (mkList lst) - where transform f = \(C x) -> f (stringField 1 x) +list sep f lst = concat $ intersperse sep $ map transform (mkList lst) + where transform = \(C x) -> f (stringField 1 x) separateWith :: String -> SFunction separateWith s = list s id diff --git a/Framework/Types.hs b/Framework/Types.hs index a55ebf2..040a280 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -219,15 +219,15 @@ mapF k f s (C lst) = concat $ map f [M.insert "it" (C it) $ M.insert k v s | (it -- | Apply "SFunction" to content of TContainer tmap :: SFunction -> Maybe TContainer -> String -tmap f x = maybe "" id $ (tmap' f) `fmap` x - where tmap' :: SFunction -> TContainer -> String - tmap' f (C x) = f x +tmap f x = maybe "" id $ tmap' `fmap` x + where tmap' :: TContainer -> String + tmap' (C y) = f y -- | Apply "BFunction" to content of TContainer bmap :: BFunction -> Maybe TContainer -> Bool -bmap f x = maybe False id $ (bmap' f) `fmap` x - where bmap' :: BFunction -> TContainer -> Bool - bmap' f (C x) = f x +bmap f x = maybe False id $ bmap' `fmap` x + where bmap' :: TContainer -> Bool + bmap' (C y) = f y transformInts :: (TemplateOne a) => Int -> (Int -> b) -> a -> [b] transformInts n f = \x -> f `map` (intFields n x) diff --git a/Framework/Utils.hs b/Framework/Utils.hs index 6c9057f..f631a04 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -18,6 +18,7 @@ import Control.Monad (ap) import Framework.Http.Httpd (queryToArguments) import Framework.Types +mimes :: M.Map String String mimes = M.fromList [ ("css", "text/css"), ("htm", "text/html"), @@ -39,27 +40,39 @@ splitWith p xs = ys : case zs of _:ws -> splitWith p ws where (ys,zs) = break p xs +getExt :: String -> String getExt str = reverse (takeWhile (/= '.') (reverse str)) +emptyLine :: String emptyLine = "\r\n\r\n" + +endl :: String endl = "\r\n" -chooseMime :: S -> Maybe S +chooseMime :: String -> Maybe String chooseMime filename = M.lookup ext mimes where ext = getExt filename +emptyResponse :: Response String emptyResponse = Response (2,0,0) "" [] "" + +noSuchUrl :: (Show a) => Bool -> a -> Response String noSuchUrl debug conf = Response (4,0,4) "" [] ("<p>No such URL!</p>"++d) where d = if debug then "<p>URLConf was:"++(show conf)++"</p>" else "" +number :: String number = "[0-9]+" +year :: String year = "[0-9]{4}" +month :: String month = "[0-9]{2}" +day :: String day = month ------------------------------ +capitalize :: String -> String capitalize "" = "" capitalize (x:xs) = (toUpper x):xs @@ -69,26 +82,35 @@ commas lst = concat $ intersperse ", " lst replaceChar :: (Eq a) => a -> a -> [a] -> [a] replaceChar ch1 ch2 = map (\c -> if c==ch1 then ch2 else c) +replaceplus :: String -> String replaceplus = replaceChar '+' ' ' +spliteq :: String -> (String, String) spliteq s = let n = takeWhile (/='=') s v = dropWhile (/='=') s in (n, tail v) +trim :: String -> String trim = trimR . trimR where trimR = reverse . dropWhile isSpace +decodePairs :: String -> [(String, String)] decodePairs s = map (both tryDecode) pairs where pairs = queryToArguments $ replaceplus s both f (x,y) = (f x, f y) - tryDecode s | isUTF8Encoded s = decodeString s - | otherwise = s + tryDecode t | isUTF8Encoded t = decodeString t + | otherwise = t + +decodePair :: String -> (String, String) decodePair = head.decodePairs +urlencode :: [UrlParam] -> String urlencode pairs = '?':(concat $ intersperse "&" $ map escapePair pairs) +escapePair :: UrlParam -> String escapePair (n:=v) = (esc n)++"="++(esc v) +esc :: String -> String esc = (escapeURIString isAllowedInURI).encodeString ------------------------------------------------------------------------------------------ @@ -133,6 +155,8 @@ update k v ((x,y):ps) | k==x = (k,v):ps days :: Int -> TimeDiff days n = TimeDiff 0 0 n 0 0 0 0 + +addDays :: Int -> ClockTime -> ClockTime addDays n = addToClockTime (days n) expirationDate :: IO String @@ -147,14 +171,22 @@ expirationDate = do myUrl :: HttpRequest -> String myUrl rq = uriPath $ rqURI rq +o :: (Monad m) => (t -> m a) -> (a -> m b) -> t -> m b f `o` g = \x -> f x >>= g + +ioPipe :: (Monad m) => [a -> b -> m b] -> a -> b -> m b ioPipe fs x = foldr o return $ ap fs [x] -ioPipe' fs = foldr o return fs +ioPipe' :: (Monad m) => [b -> m b] -> b -> m b +ioPipe' fs = foldr o return fs +normal :: String -> String normal url = if last url == '/' then init url else url +pipelist :: [String] -> String pipelist = intercalate "|" + +unpipelist :: String -> [String] unpipelist = split "|"