Do not connect to DB/whatever when sending static files
Do not connect to DB/whatever when sending static files
diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 6178910..cd648fe 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -29,7 +29,7 @@ urlconf = "blog" // "new" --> newpost
<|> "blog" // "post" // number ~> onepost
<|> "blog" // "edit" // number ~> editpost
<|> "blog" --> allposts
- <|> Function serveStatic
+ <|> RawFunction serveStatic
allposts :: HttpAction
allposts conf = do
diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs
index 2b0d760..d26a1f1 100644
--- a/Framework/Http/HTTPServer.hs
+++ b/Framework/Http/HTTPServer.hs
@@ -38,13 +38,13 @@ sendfile filename = do
where mime = fromMaybe "application/octet-stream" $ chooseMime filename
-- | Just serve static files
-serveStatic :: StrAction
-serveStatic ac s = Just $ serveStatic' ac s
+serveStatic :: StaticAction
+serveStatic ps rq s = serveStatic' ps rq s
-serveStatic' ac resource =
- if (rqMethod $ request ac) == GET
+serveStatic' ps rq resource =
+ if (rqMethod rq) == GET
then do
- writeLog (logChan $ httpParams ac) (request ac) $ "Sending "++filepath
+ writeLog (logChan ps) rq $ "Sending "++filepath
exists <- doesFileExist filepath
(toResponse exists) `catch` handleError
else return $ response 400 [] "Invalid request method"
@@ -52,14 +52,14 @@ serveStatic' ac resource =
where
handleError :: SomeException -> IO (Response String)
handleError e = do
- writeLog (errChan $ httpParams ac) (request ac) $ show e
+ writeLog (errChan ps) rq $ show e
return $ response 500 [] (show e ++ emptyLine)
toResponse False = return $ response 404 [] $ "File "++filepath++" not found!"
toResponse True = sendfile filepath
filepath = choose resource
- basedir = docdir $ httpParams ac
+ basedir = docdir ps
choose "/" = basedir++"/index.html"
choose "" = basedir++"/index.html"
choose x = basedir ++"/"++x
@@ -75,7 +75,7 @@ httpWorker hap conf req@(Request {rqURI = URI {uriPath}}) = do
responseMiddlewares resp
defaultURLConf :: URLConf
-defaultURLConf = Function serveStatic
+defaultURLConf = RawFunction serveStatic
-- freePools :: MPool DBConnection -> MPool CacheConnection -> IO ()
cleanup dbPool cPool hacc herr = do
diff --git a/Framework/Urls.hs b/Framework/Urls.hs
index ca4502e..b61b1a4 100644
--- a/Framework/Urls.hs
+++ b/Framework/Urls.hs
@@ -21,6 +21,8 @@ import Framework.Http.Httpd (queryToArguments)
type URLParts = [String]
-- | Function which get one String argument and (maybe) returns Response
type StrAction = ActionConfig -> String -> Maybe (IO (Response String))
+-- | Function which get one String argument and returns Response
+type StaticAction = StaticConfig -> Request String -> String -> IO (Response String)
-- | Function which get many String arguments and (maybe) returns Response
type ManyStrAction = ActionConfig -> URLParts -> Maybe (IO (Response String))
-- | Function which just returns Response
@@ -34,7 +36,8 @@ data URLConf = Action HttpAction -- ^ Simple answer
| Regexp String URLConf -- ^ URLConf is executed only when current part of URL matches regexp
| RegexpFun String StrAction -- ^ Same, but answer depends on URL part
| ManyRegexpFun URLParts URLParts ManyStrAction -- ^ Answer depends on many URL parts (which should match regexps)
- | After URLConf URLConf -- ^ Execute first URLConf, then second.
+-- | After URLConf URLConf -- ^ Execute first URLConf, then second.
+ | RawFunction StaticAction -- ^ Execute StaticAction without connecting to DB or anything else
instance Show URLConf where
show (Action _) = "Some action"
@@ -44,7 +47,7 @@ instance Show URLConf where
show (Regexp s u) = s++" --> "++(show u)
show (RegexpFun s _) = s++" --> Some function"
show (ManyRegexpFun _ rs _) = (concat $ intersperse "/" rs)++" --> Some function"
- show (After u v) = (show u)++", then "++(show v)
+-- show (After u v) = (show u)++", then "++(show v)
-- | Split URL into parts:
-- /usr/local/bin --> [usr,local,bin]
@@ -59,6 +62,10 @@ urlSplit uri = filter (/="") $ splitWith (=='/') url -- (url++slash)
urlJoin :: URLParts -> String
urlJoin us = concat $ intersperse "/" us
+data URLResult = NoResult
+ | AC (ActionConfig -> Maybe (IO (Response String)))
+ | SC (StaticConfig -> Request String -> IO (Response String))
+
-- | Main dispatcher function
runURLConf :: StaticConfig -- ^ Static (global) config
-> Request String -- ^ HTTP request
@@ -69,37 +76,48 @@ runURLConf ps rq s conf = let murl = parseURIReference s
in case murl of
Nothing -> error "Couldn't parse URL!"
Just url -> do
- (ac,addSession) <- mkActionConfig ps rq
- resp <- case runURLConf' conf (urlSplit url) ac of
+ case runURLConf' conf (urlSplit url) of
+ NoResult -> return $ noSuchUrl True conf
+ AC fun -> do
+ (ac,addSession) <- mkActionConfig ps rq
+ resp <- case fun 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 String))
+ acFree ac
+ if addSession
+ then return $ resp <+> Sessions.sessionCookie (cookiesExp ac) (sessionID ac)
+ else return resp
+ SC fun -> do
+ resp <- fun ps rq
+ return resp
+
+runURLConf' :: URLConf -> URLParts -> URLResult
-- runURLConf' _ [] _ = Nothing
-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) 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]
+runURLConf' (Prefix p conf) (x:xs) | p==x = runURLConf' conf xs
+ | otherwise = NoResult
+runURLConf' (Prefix p conf) [] = NoResult
+runURLConf' (Regexp r conf) (x:xs) = let b = x =~ r :: Bool
+ in if b
+ then runURLConf' conf xs
+ else NoResult
+runURLConf' (RegexpFun r f) (x:_) = let part = x =~ r :: String
+ in if null part
+ then NoResult
+ else AC $ \ac -> f ac part
+runURLConf' (ManyRegexpFun _ _ _) [] = NoResult
+runURLConf' (ManyRegexpFun u [] f) _ = AC $ \ac -> f ac (reverse u)
+runURLConf' (ManyRegexpFun u (r:rs) f) (x:xs) = let part = x =~ r :: String
+ in runURLConf' (ManyRegexpFun (part:u) rs f) xs
+runURLConf' (Action act) _ = AC $ \ac -> Just (act ac)
+runURLConf' (RawFunction f) x = SC $ \ps rq -> f ps rq (urlJoin x)
+runURLConf' (Function f) x = AC $ \ac -> f ac (urlJoin x)
+runURLConf' (OneOf c d) url = case runURLConf' c url of
+ NoResult -> runURLConf' d url
+ x -> x
+-- runURLConf' (After c d) (x:xs) = case runURLConf' c [x] of
+-- 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]
-- | If current part of URL is equal to given string, then call given function
(-->) :: String -> HttpAction -> URLConf
@@ -132,9 +150,9 @@ mrf f = ManyRegexpFun [] [] f
(<|>) = OneOf
infixr 6 <|>
-(>=>) :: URLConf -> URLConf -> URLConf
-(>=>) = After
-infixr 6 >=>
+-- (>=>) :: URLConf -> URLConf -> URLConf
+-- (>=>) = After
+-- infixr 6 >=>
------------------------------------------------------------------------------------------------
--