diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 218a939..b7a68e6 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -9,6 +9,7 @@ import Framework.Types import Framework.API import Framework.SQL import Framework.Http.Response +import Framework.Http.Vars import Framework.TEngine.TemplateUtil import Framework.Urls import Framework.Utils @@ -28,8 +29,18 @@ urlconf = "blog" // "new" --> newpost <|> "blog" // "post" // number ~> onepost <|> "blog" // "edit" // number ~> editpost <|> "blog" --> allposts + <|> "form" --> testform <|> RawFunction serveStatic +testform :: HttpAction +testform conf = do + case rqMethod $ request conf of + GET -> return $ renderToResponse "testform.html" [] + POST -> do + print $ request conf + print $ rqBody $ request conf + return $ redirect "/blog/" + allposts :: HttpAction allposts conf = do result <- cGet (cacheBackend conf) key @@ -38,7 +49,7 @@ allposts conf = do Nothing -> do (posts,pagerHtml) <- pager conf 5 (countChildren postModel commentModel "dt") [] postModel lastComments <- querySQL' conf ((table commentModel) `order` (Desceding "dt") `limit` (0,10)) [] commentModel - let code = httpGetVar' (request conf) "code" "" + let code = getString' getvars "code" "" let message = maybe "" id $ lookup code messagecodes let html = render "blogposts.html" $ M.fromList [("posts", C posts), @@ -47,7 +58,8 @@ allposts conf = do ("pager", C pagerHtml)] cPut (cacheBackend conf) key html return $ ok html - where key = "allposts" ++ (httpGetVar' (request conf) "page" "1") + where key = "allposts" ++ (getString' getvars "page" "1") + getvars = _GET (request conf) invalidatePostsCache :: ActionConfig -> IO () invalidatePostsCache conf = do diff --git a/Blog/blog.conf b/Blog/blog.conf index 2ad4618..5811316 100644 --- a/Blog/blog.conf +++ b/Blog/blog.conf @@ -2,7 +2,7 @@ port = 8080 [static] -staticPath = static/ +staticdir = static/ [database] path = host=rtfm-server password=31415 diff --git a/Blog/templates/testform.html b/Blog/templates/testform.html new file mode 100644 index 0000000..52fdac7 --- /dev/null +++ b/Blog/templates/testform.html @@ -0,0 +1,20 @@ +<!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>Test form</title> + <meta name='author' content='Portnov'> + </head> + <body> + <h1>Just a test</h1> + + <form method='POST' enctype='multipart/form-data' action='/form'> + <table> + <tr><td>Name:</td><td><input name='name'/></td></tr> + <tr><td>Value:</td><td><input name='value'/></td></tr> + <tr><td>File:</td><td><input type='file' name='file'/></td></tr> + <tr><td></td><td><input type='submit'/></td></tr> + </table> + </form> + + </body> +</html> diff --git a/Framework/Cache.hs b/Framework/Cache.hs index be9ff14..ff0fffc 100644 --- a/Framework/Cache.hs +++ b/Framework/Cache.hs @@ -49,7 +49,7 @@ instance CacheBackend FilesystemBackend where cget (FB path) name = do b <- doesFileExist file if b - then do s <- readFile' file + then do s <- readFile file return $ fromString s else return Nothing where file = path </> name diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index c472074..218718c 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -19,10 +19,11 @@ import qualified Database.HDBC as D import Framework.Types import Framework.Utils -import Framework.Urls +import Framework.Urls (myUrl) import Framework.API import Framework.Models import Framework.Http.Response (redirectG) +import Framework.Http.Vars import Framework.Forms.Types import Framework.Forms.HTML diff --git a/Framework/Http/Httpd.hs b/Framework/Http/Httpd.hs index 20e57d0..73c8b82 100644 --- a/Framework/Http/Httpd.hs +++ b/Framework/Http/Httpd.hs @@ -126,14 +126,14 @@ initServerMain processBody ps callOut = do ) `finally` sClose sock where - readHeaders h mode uri = do + readHeaders h mode uri = {-# SCC "readHeaders" #-} do lns <- readUntilEmptyLine h -- print lns case parseHeaders lns of Right hdrs -> readPOST h mode uri hdrs Left err -> hClose h -- strange format -- FIXME: arguable answer? - readPOST h mode uri hds = + readPOST h mode uri hds = {-# SCC "readPOST" #-} if mode `elem` [POST,PUT] then case read `fmap` (lookupHeader HdrContentLength hds) of Just n -> do postbody <- hGetChars h n @@ -146,7 +146,8 @@ initServerMain processBody ps callOut = do case lookup code longMessages of Just msg -> msg Nothing -> "-" - sendRequest h mode uri hds rbody = do + + sendRequest h mode uri hds rbody = {-# SCC "sendRequest" #-} do let req = Request { rqMethod = mode , rqURI = uri , rqHeaders = hds diff --git a/Framework/Http/PostParser.hs b/Framework/Http/PostParser.hs new file mode 100644 index 0000000..c6969b2 --- /dev/null +++ b/Framework/Http/PostParser.hs @@ -0,0 +1,102 @@ +module Framework.Http.PostParser + (_POST) + 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 + +import Framework.Types +import Framework.Utils + +data FormDataItem = Single String HttpVar + | Multiple String FormData + deriving (Show) + +type FormData = [FormDataItem] + +urlencoded = "application/x-www-form-urlencoded" +multipart = "multipart/form-data" + +_POST :: HttpRequest -> HttpVarsMap +_POST rq = + if hdr == multipart + then let bound = getBoundary ctype + in M.fromList $ flattenFormData $ parse bound $ rqBody rq + else getUrlEncodedVars rq + where ctype = fromMaybe urlencoded $ lookupHeader HdrContentType $ rqHeaders rq + hdr = getHeader ctype + +getUrlEncodedVars rq = M.fromList $ map (second Str) $ decodePairs (rqBody rq) + +flattenFormData :: FormData -> [(String,HttpVar)] +flattenFormData d = concatMap flatten' d + where + flatten' (Single name val) = [(name,val)] + flatten' (Multiple name xs) = map (first ((name++).("/"++))) $ flattenFormData xs + +base :: Show a => [a] -> [a] +base s = if (length s)>=2 + then (tail.init) s + else (trace (show s) []) + +parseHeaderAttrs v = map parse' lst + where + lst = tail $ split "; " v + parse' s = second (tail.base) $ break (=='=') s + +getHeader :: String -> String +getHeader s = head $ split "; " s + +getValue :: String -> String -> String -> String +getValue a s d = + case lookup a (parseHeaderAttrs s) of + Just v -> v + Nothing -> d + +getName = \s -> getValue "name" s "" +getBoundary = \s -> getValue "boundary" s "" +getFilename = \s -> getValue "filename" s "" + +parseP :: String -> FormDataItem +parseP part = + let (h,oth) = cutAt "\r\n\r\n" part + in case parseHeaders $ map strip $ lines h of + Right hdrs -> + let disposition = lookupHeader (HdrCustom "Content-Disposition") hdrs + name = maybe "" getName disposition + fname = maybe "" getFilename disposition + in case lookupHeader HdrContentType hdrs of + Just v -> let b = getBoundary v + in if null b + then Single name $ POSTfile { + filename = fname, + mimetype = v, + filebody = (init.init) oth } + else Multiple name $ parse b oth + Nothing -> Single name $ Str $ (init.init) oth + Left err -> error "Could not parse headers!" + +cutAt sp str = cutAt' "" str + where + cutAt' acc [] = (acc, "") + cutAt' acc s@(x:xs) = if sp `isPrefixOf` s + then (acc, drop (length sp) s) + else cutAt' (acc++[x]) xs + +parse :: String -> String -> FormData +parse b str = map parseP $ map (drop 2) $ base $ split ("--"++b) str + +-- s = "-----------------------------14004705096106365022051874893\r\nContent-Disposition: form-data; name=\"name\"\r\n\r\nX\r\n-----------------------------14004705096106365022051874893\r\nContent-Disposition: form-data; name=\"value\"\r\n\r\nY\r\n-----------------------------14004705096106365022051874893\r\nContent-Disposition: form-data; name=\"file\"; filename=\"missfont.log\"\r\nContent-Type: text/x-log\r\n\r\nmktextfm cmr\n\r\n-----------------------------14004705096106365022051874893--\r\n" + +-- bound = "---------------------------14004705096106365022051874893" + +-- main = print $ flattenFormData $ parse bound s diff --git a/Framework/Http/Vars.hs b/Framework/Http/Vars.hs new file mode 100644 index 0000000..c9b81e1 --- /dev/null +++ b/Framework/Http/Vars.hs @@ -0,0 +1,63 @@ +module Framework.Http.Vars + (_GET, _POST, + getVar, getVar', + getFile, + getString, getString', + httpGetVar', + httpPostVar, httpPostVar', + httpAddGetVar + ) where + +import Control.Arrow +import qualified Data.Map as M +import Data.Maybe +import Network.URI +import Network.HTTP + +import Framework.Types +import Framework.Utils +import Framework.Http.Httpd +import Framework.Http.PostParser + +_GET :: HttpRequest -> HttpVarsMap +_GET rq = M.fromList $ map (second Str) $ queryToArguments $ uriQuery $ rqURI rq + +varToString :: HttpVar -> String +varToString (Str s) = s +varToString (POSTfile {filebody=body}) = body + +getVar :: HttpVarsMap -> String -> Maybe HttpVar +getVar = flip M.lookup + +getFile :: HttpVarsMap -> String -> Maybe HttpVar +getFile mm name = toFile =<< (M.lookup name mm) + where toFile f@(POSTfile {}) = Just f + toFile (Str _) = Nothing + +getVar' :: HttpVarsMap -> String -> String -> HttpVar +getVar' mm name def = fromMaybe (Str def) $ M.lookup name mm + +getString :: HttpVarsMap -> String -> Maybe String +getString mm name = varToString `fmap` (M.lookup name mm) + +getString' :: HttpVarsMap -> String -> String -> String +getString' mm name def = fromMaybe def $ getString mm name + +httpGetVar' :: HttpRequest -> String -> String -> String +httpGetVar' rq name def = getString' (_GET rq) name def + +httpPostVar :: HttpRequest -> String -> Maybe String +httpPostVar rq name = getString (_POST rq) name + +httpPostVar' :: HttpRequest -> String -> String -> String +httpPostVar' rq name def = getString' (_POST rq) name def + +-- | Add GET var to given Request and return resulting URL +httpAddGetVar :: HttpRequest + -> String -- ^ Var name + -> String -- ^ Var value + -> String +httpAddGetVar rq name value = urlencode (map packParam pairs') + where pairs' = update name value pairs + pairs = decodePairs (uriQuery $ rqURI rq) + diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 98a08a6..2327b1e 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -12,9 +12,9 @@ import Framework.Forms.HTML import Framework.Models import Framework.SQL import Framework.API -import Framework.Urls +-- import Framework.Urls import Framework.Types - +import Framework.Http.Vars -- | Represents pager HTML generator type Pager = HttpRequest -> Int -> Int -> String diff --git a/Framework/Types.hs b/Framework/Types.hs index 687f6c5..7223341 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -28,6 +28,15 @@ instance Show DBConnection where type HttpRequest = Request String type HttpResponse = Response String +data HttpVar = Str String + | POSTfile { + filename :: String, + mimetype :: String, + filebody :: String } + deriving (Show) + +type HttpVarsMap = M.Map String HttpVar + ------------------------------------------------------------------------------------------- -- | This object contains config which is common for all requests diff --git a/Framework/Urls.hs b/Framework/Urls.hs index 73fef6d..7cb37ec 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -7,9 +7,6 @@ module Framework.Urls ManyStrAction, HttpAction, (-->), (//), (-\>), (~>), (~/), (~>>), (<|>), - httpGetVar, httpGetVar', - httpPostVar, httpPostVar', - httpAddGetVar, myUrl ) where @@ -28,7 +25,6 @@ import Framework.Wrapper import Framework.Logger import qualified Framework.Http.Sessions as Sessions import Framework.Http.Response ((<+>)) -import Framework.Http.Httpd (queryToArguments) type URLParts = [String] -- | Function which get one String argument and (maybe) returns Response @@ -175,43 +171,6 @@ infixr 6 <|> ------------------------------------------------------------------------------------------------ -- --- | Get HTTP GET var value -httpGetVar :: HttpRequest -- ^ HTTP Request - -> String -- ^ Var name - -> Maybe String -httpGetVar rq name = lookup name pairs - where pairs = queryToArguments $ uriQuery $ rqURI rq - --- | Same, but with default value -httpGetVar' :: HttpRequest - -> String -- ^ Var name - -> String -- ^ Default value - -> String -httpGetVar' rq name def = maybe def id $ lookup name pairs - where pairs = queryToArguments $ uriQuery $ rqURI rq - --- | Get HTTP POST var value -httpPostVar :: HttpRequest -> String -> Maybe String -httpPostVar rq name = lookup name pairs - where pairs = decodePairs (rqBody rq) - --- | Same, but with default value -httpPostVar' :: HttpRequest - -> String -- ^ Var name - -> String -- ^ Default value - -> String -httpPostVar' rq name def = maybe def id $ lookup name pairs - where pairs = decodePairs (rqBody rq) - --- | Add GET var to given Request and return resulting URL -httpAddGetVar :: HttpRequest - -> String -- ^ Var name - -> String -- ^ Var value - -> String -httpAddGetVar rq name value = urlencode (map packParam pairs') - where pairs' = update name value pairs - pairs = decodePairs (uriQuery $ rqURI rq) - -- | Get URL from Request myUrl :: HttpRequest -> String myUrl rq = uriPath $ rqURI rq