diff --git a/Blog/Blog b/Blog/Blog index 3bd8293..c3266a6 100755 Binary files a/Blog/Blog and b/Blog/Blog differ diff --git a/Blog/Blog.hs b/Blog/Blog.hs index f59d95c..c558a93 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -33,14 +33,14 @@ urlconf = "blog" // "new" --> newpost <|> Function serveStatic allposts :: HttpAction -allposts hp rq = withConfig hp rq $ \conf -> do +allposts conf = do result <- cGet (cacheBackend conf) key case result of Just html -> return $ ok html 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' rq "code" "" + let code = httpGetVar' (request conf) "code" "" let message = maybe "" id $ lookup code messagecodes let html = render "blogposts.html" $ M.fromList [("posts", C posts), ("comments", C lastComments), @@ -48,7 +48,7 @@ allposts hp rq = withConfig hp rq $ \conf -> do ("pager", C pagerHtml)] cPut (cacheBackend conf) key html return $ ok html - where key = "allposts" ++ (httpGetVar' rq "page" "1") + where key = "allposts" ++ (httpGetVar' (request conf) "page" "1") invalidatePostsCache :: ActionConfig -> IO () invalidatePostsCache conf = do @@ -59,14 +59,14 @@ invalidatePostsCache conf = do return () newpost :: HttpAction -newpost hp rq = withConfig hp rq $ \conf -> - case reqMethod rq of +newpost conf = do + case reqMethod (request conf) of "GET" -> do (form,err) <- retryForm conf postForm "1" [] url return $ renderToResponse "newpost.html" [("form", C form), ("invalid", C err)] "POST" -> do - let (d,_) = getForm allForms rq "postform" + let (d,_) = getForm allForms (request conf) "postform" case d of Right post -> let ptitle = post -:> "title" pbody = post -:> "body" @@ -75,11 +75,11 @@ newpost hp rq = withConfig hp rq $ \conf -> invalidatePostsCache conf return $ redirectG "/blog/" ["code" =: "1"] Left e -> returnInvalidForm conf postForm "1" e - where url = myUrl rq + where url = myUrl (request conf) editpost :: StrAction -editpost hp rq sid = Just $ withConfig hp rq $ \conf -> - case reqMethod rq of +editpost conf sid = Just $ + case reqMethod (request conf) of "GET" -> do posts <- querySQL' conf ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel let post = head posts @@ -89,7 +89,7 @@ editpost hp rq sid = Just $ withConfig hp rq $ \conf -> return $ renderToResponse "editpost.html" [("form", C form), ("invalid", C err)] "POST" -> do - let (d,_) = getForm allForms rq "postform" + let (d,_) = getForm allForms (request conf) "postform" case d of Right post -> let ptitle = post -:> "title" pbody = post -:> "body" @@ -98,24 +98,24 @@ editpost hp rq sid = Just $ withConfig hp rq $ \conf -> return $ redirectG "/blog/" ["code" =: "3"] Left e -> do cont <- returnInvalidForm conf postForm "1" e return cont - where url = myUrl rq + where url = myUrl (request conf) pid = read sid onepost :: StrAction -onepost hp rq sid = Just $ withConfig hp rq $ \conf -> do +onepost conf sid = Just $ do (form,err) <- retryForm conf commentForm "1" [] url - case reqMethod rq of + case reqMethod (request conf) of "GET" -> do post <- querySQL' conf ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel comments <- querySQL' conf ((table commentModel) `restrict` ("pid" :==: "?") `order` (Asceding "dt")) [SqlInt32 pid] commentModel - let code = httpGetVar' rq "code" "" + let code = httpGetVar' (request conf) "code" "" let message = maybe "" id $ lookup code messagecodes return $ renderToResponse "onepost.html" [("post", C (head post)), ("comments", C comments), ("message", C message), ("form", C form)] "POST" -> do - let (d,_) = getForm allForms rq "comment" + let (d,_) = getForm allForms (request conf) "comment" case d of Right comment -> do print $ mFields comment @@ -125,7 +125,7 @@ onepost hp rq sid = Just $ withConfig hp rq $ \conf -> do commit conf return $ redirectG url ["code" =: "2"] Left e -> returnInvalidForm conf commentForm "1" e - where url = myUrl rq + where url = myUrl (request conf) pid = read sid diff --git a/Framework/API.hs b/Framework/API.hs index fea71ca..6291ca7 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -8,8 +8,7 @@ module Framework.API queryList, queryList', query, query', commit, queryListSQL, queryListSQL', querySQL, querySQL', - getcookie, setcookie, - withConfig + getcookie, setcookie )where import Debug.Trace @@ -99,39 +98,3 @@ getcookie ac name = Cookies.getcookie (request ac) name setcookie :: ActionConfig -> String -> String -> HttpHeader setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value ----------------------------------------------------------------------------------------------------------- --- --- * Main wrapper - --- | Main API wrapper. Connects to DB etc, then calls given function, then disconnects. -withConfig :: StaticConfig -- ^ Static (global) server configuration - -> Httpd.Request -- ^ HTTP request - -> (ActionConfig -> IO Httpd.Response) -- ^ Worker function - -> IO Httpd.Response -withConfig hp rq f = do - ed <- Cookies.expirationDate - conn <- Storage.connect' hp - sb <- Sessions.initSessions (sessionsDriver hp) (sessionsPath hp) - sess <- Sessions.session sb rq - let (sid,mm,addSession) = case sess of - Sessions.NewSession sid' -> (sid', M.empty, True) - Sessions.ExistingSession sid' mm' -> (sid', mm', False) - cc <- Cache.initCache (cacheDriver hp) (cachePath hp) - let conf = ActionConfig { - request = rq, - httpParams = hp, - dbconnection = conn, - sessionID = sid, - sessionMap = mm, - sessionsBackend = sb, - cacheBackend = cc, - cookiesExp = ed - } - resp <- f conf - Storage.disconnect conn - Cache.cFree cc - Sessions.sFree sb - if addSession - then return $ resp <+> Sessions.sessionCookie ed sid - else return resp - diff --git a/Framework/CacheTypes.hs b/Framework/CacheTypes.hs index 5c562d0..72c6d06 100644 --- a/Framework/CacheTypes.hs +++ b/Framework/CacheTypes.hs @@ -12,4 +12,7 @@ class CacheBackend b where -- | Type to incapsulate connection to any cache backend. data CacheConnection = forall b. (CacheBackend b) => CConnection b + +instance Show CacheConnection where + show _ = "<Cache connection>" diff --git a/Framework/Http/Cookies.hs b/Framework/Http/Cookies.hs index bd3e47d..0839485 100644 --- a/Framework/Http/Cookies.hs +++ b/Framework/Http/Cookies.hs @@ -1,17 +1,14 @@ module Framework.Http.Cookies - (setcookie,getcookie, - expirationDate) where + (setcookie,getcookie) where import Debug.Trace -import System.Time -import System.Locale import Data.Char import Network.Shed.Httpd import Framework.Types import Framework.Utils -import Framework.Urls +-- import Framework.Urls setcookie :: String -> String -> String -> HttpHeader setcookie exp name value = "Set-Cookie" =: ((esc (name++"="++value))++"; expires="++exp) @@ -24,13 +21,3 @@ allcookies :: Request -> [(String,String)] allcookies rq = map spliteq $ map trim $ concat $ map (splitWith (==';')) $ map snd $ filter cookiehdr $ reqHeaders rq where cookiehdr (n,_) = n=="Cookie" -days :: Int -> TimeDiff -days n = TimeDiff 0 0 n 0 0 0 0 -addDays n = addToClockTime (days n) - -expirationDate :: IO String -expirationDate = do - time <- getClockTime - ctime <- toCalendarTime (addDays 14 time) - return $ formatCalendarTime defaultTimeLocale "%c" ctime - diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index 7d4bb3b..1074da6 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -27,10 +27,10 @@ sendfile filename = do where mime = chooseMime filename serveStatic :: StrAction -serveStatic ps rq s = Just $ serveStatic' ps rq s +serveStatic ac s = Just $ serveStatic' ac s -serveStatic' (HP {docdir,hLog}) (Request {reqMethod}) resource = - if reqMethod == "GET" +serveStatic' ac resource = + if (reqMethod $ request ac) == "GET" then do -- putStrLn $ "Sending "++filepath exists <- doesFileExist filepath @@ -40,16 +40,17 @@ serveStatic' (HP {docdir,hLog}) (Request {reqMethod}) resource = where handleError :: SomeException -> IO Response handleError e = do - hPutStr hLog $ show e + hPutStr (hLog $ httpParams ac) $ show e return $ response 500 [] (show e ++ emptyLine) toResponse False = return $ response 404 [] $ "File "++filepath++" not found!" toResponse True = sendfile filepath filepath = choose resource - choose "/" = docdir++"/index.html" - choose "" = docdir++"/index.html" - choose x = docdir ++"/"++x + basedir = docdir $ httpParams ac + choose "/" = basedir++"/index.html" + choose "" = basedir++"/index.html" + choose x = basedir ++"/"++x httpWorker :: StaticConfig -> URLConf -> Request -> IO Response httpWorker hap conf req@(Request {reqURI = URI {uriPath}}) = do diff --git a/Framework/Http/Response.hs b/Framework/Http/Response.hs index e6d0af0..9892d27 100644 --- a/Framework/Http/Response.hs +++ b/Framework/Http/Response.hs @@ -7,7 +7,11 @@ import qualified Network.Shed.Httpd as Httpd import Framework.Types import Framework.Utils -import Framework.Urls ((?)) + +----------------------------------------------------------------------------------------------- + +(?) :: String -> [UrlParam] -> String +url ? pairs = url++(urlencode pairs) ------------------------------------------------------------------------------------------------------- -- * Make a Response diff --git a/Framework/Http/SessionTypes.hs b/Framework/Http/SessionTypes.hs index 1c000ef..8ea7583 100644 --- a/Framework/Http/SessionTypes.hs +++ b/Framework/Http/SessionTypes.hs @@ -17,3 +17,6 @@ class SessionBackend b where sfree :: b -> IO () data SessionsConnection = forall b. (SessionBackend b) => SConnection b + +instance Show SessionsConnection where + show _ = "<Sessions connection>" diff --git a/Framework/Types.hs b/Framework/Types.hs index 0192d92..a3a386e 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -19,6 +19,9 @@ type S = String -- | Container type for any database connection data DBConnection = forall c. D.IConnection c => DBC c +instance Show DBConnection where + show _ = "<DB connection>" + ------------------------------------------------------------------------------------------- data StaticConfig = HP { @@ -44,6 +47,7 @@ data ActionConfig = ActionConfig { cacheBackend :: CacheConnection, -- ^ Connection to cache backend cookiesExp :: String -- ^ Cookies expiration date } + deriving (Show) class HttpValue v where httpEmpty :: v -> Bool diff --git a/Framework/Urls.hs b/Framework/Urls.hs index 8769e2e..ff1c8a9 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -12,11 +12,14 @@ import Data.List import Framework.Utils import Framework.Types +import Framework.Wrapper +import qualified Framework.Http.Sessions as Sessions +import Framework.Http.Response ((<+>)) type URLParts = [String] -type StrAction = StaticConfig -> Request -> String -> Maybe (IO Response) -type ManyStrAction = StaticConfig -> Request -> URLParts -> Maybe (IO Response) -type HttpAction = StaticConfig -> Request -> IO Response +type StrAction = ActionConfig -> String -> Maybe (IO Response) +type ManyStrAction = ActionConfig -> URLParts -> Maybe (IO Response) +type HttpAction = ActionConfig -> IO Response data URLConf = Action HttpAction | OneOf URLConf URLConf @@ -51,32 +54,38 @@ runURLConf :: StaticConfig -> Request -> String -> URLConf -> IO Response runURLConf ps rq s conf = let murl = parseURIReference s in case murl of Nothing -> error "Couldn't parse URL!" - Just url -> case runURLConf' conf (urlSplit url) ps rq of - Nothing -> return $ noSuchUrl True conf - Just act -> act - -runURLConf' :: URLConf -> URLParts -> StaticConfig -> Request -> Maybe (IO Response) + Just url -> do + (ac,addSession) <- mkActionConfig ps rq + resp <- case runURLConf' conf (urlSplit url) ac of + Nothing -> return $ noSuchUrl True conf + Just act -> act + acFree ac + if addSession + then return $ resp <+> Sessions.sessionCookie (cookiesExp ac) (sessionID ac) + else return resp + +runURLConf' :: URLConf -> URLParts -> ActionConfig -> Maybe (IO Response) -- runURLConf' _ [] _ = Nothing -runURLConf' (Prefix p conf) (x:xs) ps rq | p==x = runURLConf' conf xs ps rq - | otherwise = Nothing -runURLConf' (Prefix p conf) [] ps rq = Nothing -runURLConf' (Regexp r conf) (x:xs) ps rq = let b = x =~ r :: Bool - in if b then runURLConf' conf xs ps rq else Nothing -runURLConf' (RegexpFun r f) (x:_) ps rq = let part = x =~ r :: String - in if null part then Nothing else f ps rq part -runURLConf' (ManyRegexpFun _ _ _) [] _ _ = Nothing -runURLConf' (ManyRegexpFun u [] f) _ ps rq = f ps rq (reverse u) -runURLConf' (ManyRegexpFun u (r:rs) f) (x:xs) ps rq = let part = x =~ r :: String - in runURLConf' (ManyRegexpFun (part:u) rs f) xs ps rq -runURLConf' (Action act) _ ps rq = Just (act ps rq) -runURLConf' (Function f) x ps rq = f ps rq (urlJoin x) -runURLConf' (OneOf c d) url ps rq = case runURLConf' c url ps rq of - Nothing -> runURLConf' d url ps rq +runURLConf' (Prefix p conf) (x:xs) ac | p==x = runURLConf' conf xs ac + | otherwise = Nothing +runURLConf' (Prefix p conf) [] ac = Nothing +runURLConf' (Regexp r conf) (x:xs) ac = let b = x =~ r :: Bool + in if b then runURLConf' conf xs ac else Nothing +runURLConf' (RegexpFun r f) (x:_) ac = let part = x =~ r :: String + in if null part then Nothing else f ac part +runURLConf' (ManyRegexpFun _ _ _) [] _ = Nothing +runURLConf' (ManyRegexpFun u [] f) _ ac = f ac (reverse u) +runURLConf' (ManyRegexpFun u (r:rs) f) (x:xs) ac = let part = x =~ r :: String + in runURLConf' (ManyRegexpFun (part:u) rs f) xs ac +runURLConf' (Action act) _ ac = Just (act ac) +runURLConf' (Function f) x ac = f ac (urlJoin x) +runURLConf' (OneOf c d) url ac = case runURLConf' c url ac of + Nothing -> runURLConf' d url ac Just act -> Just act -runURLConf' (After c d) (x:xs) ps rq = case runURLConf' c [x] ps rq of - Nothing -> runURLConf' d xs ps rq - Just act -> Just (maybe act (act>>) (runURLConf' d xs ps rq)) -runURLConf' cc xs ps rq = error $ unlines ["URLConf error",show cc,show xs,show ps,show rq] +runURLConf' (After c d) (x:xs) ac = case runURLConf' c [x] ac of + Nothing -> runURLConf' d xs ac + Just act -> Just (maybe act (act>>) (runURLConf' d xs ac)) +runURLConf' cc xs ac = error $ unlines ["URLConf error",show cc,show xs,show ac] (-->) :: String -> HttpAction -> URLConf s --> act = Prefix s (Action act) @@ -111,11 +120,6 @@ infixr 6 <|> (>=>) = After infixr 6 >=> ------------------------------------------------------------------------------------------------ - -(?) :: String -> [UrlParam] -> String -url ? pairs = url++(urlencode pairs) - ------------------------------------------------------------------------------------------------ -- httpGetVar :: Request -> String -> Maybe String @@ -139,19 +143,6 @@ httpAddGetVar rq name value = urlencode (map packHeader pairs') where pairs' = update name value pairs pairs = decodePairs (uriQuery $ reqURI rq) -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 -decodePair = head.decodePairs - -urlencode pairs = '?':(concat $ intersperse "&" $ map escapePair pairs) - -escapePair (n:=v) = (esc n)++"="++(esc $ httpShow v) - -esc = (escapeURIString isAllowedInURI).encodeString - myUrl :: Request -> String myUrl rq = uriPath $ reqURI rq diff --git a/Framework/Utils.hs b/Framework/Utils.hs index 765af35..0e67ee3 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -8,6 +8,10 @@ import Data.Char import System.IO import System.IO.Unsafe import Foreign +import System.Time +import System.Locale +import Codec.Binary.UTF8.String +import Network.URI import Framework.Types @@ -71,6 +75,19 @@ spliteq s = let n = takeWhile (/='=') s trim = trimR . trimR where trimR = reverse . dropWhile isSpace +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 +decodePair = head.decodePairs + +urlencode pairs = '?':(concat $ intersperse "&" $ map escapePair pairs) + +escapePair (n:=v) = (esc n)++"="++(esc $ httpShow v) + +esc = (escapeURIString isAllowedInURI).encodeString + ------------------------------------------------------------------------------------------ readFile' :: String -> IO String @@ -109,3 +126,13 @@ update k v [] = [(k,v)] update k v ((x,y):ps) | k==x = (k,v):ps | otherwise = (x,y):(update k v ps) +days :: Int -> TimeDiff +days n = TimeDiff 0 0 n 0 0 0 0 +addDays n = addToClockTime (days n) + +expirationDate :: IO String +expirationDate = do + time <- getClockTime + ctime <- toCalendarTime (addDays 14 time) + return $ formatCalendarTime defaultTimeLocale "%c" ctime + diff --git a/Framework/Wrapper.hs b/Framework/Wrapper.hs new file mode 100644 index 0000000..cb36b93 --- /dev/null +++ b/Framework/Wrapper.hs @@ -0,0 +1,58 @@ +module Framework.Wrapper where + +import Network.Shed.Httpd(reqBody,Response,reqURI,Request,queryToArguments) +import qualified Data.Map as M + +import qualified Framework.Http.Cookies as Cookies +import qualified Framework.Http.Sessions as Sessions +import qualified Framework.Storage as Storage +import Framework.Http.Response ((<+>)) +import qualified Framework.Cache as Cache +import Framework.Types +import Framework.Utils + +mkActionConfig :: StaticConfig -> Request -> IO (ActionConfig,Bool) +mkActionConfig hp rq = do + ed <- expirationDate + conn <- Storage.connect' hp + sb <- Sessions.initSessions (sessionsDriver hp) (sessionsPath hp) + sess <- Sessions.session sb rq + let (sid,mm,addSession) = case sess of + Sessions.NewSession sid' -> (sid', M.empty, True) + Sessions.ExistingSession sid' mm' -> (sid', mm', False) + cc <- Cache.initCache (cacheDriver hp) (cachePath hp) + let conf = ActionConfig { + request = rq, + httpParams = hp, + dbconnection = conn, + sessionID = sid, + sessionMap = mm, + sessionsBackend = sb, + cacheBackend = cc, + cookiesExp = ed + } + return (conf,addSession) + +acFree :: ActionConfig -> IO () +acFree ac = do + Storage.disconnect (dbconnection ac) + Cache.cFree (cacheBackend ac) + Sessions.sFree (sessionsBackend ac) + +---------------------------------------------------------------------------------------------------------- +-- +-- * Main wrapper + +-- | Main API wrapper. Connects to DB etc, then calls given function, then disconnects. +withConfig :: StaticConfig -- ^ Static (global) server configuration + -> Request -- ^ HTTP request + -> (ActionConfig -> IO Response) -- ^ Worker function + -> IO Response +withConfig hp rq f = do + (conf,addSession) <- mkActionConfig hp rq + resp <- f conf + acFree conf + if addSession + then return $ resp <+> Sessions.sessionCookie (cookiesExp conf) (sessionID conf) + else return resp +