diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index cd648fe..8d3b23c 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -130,4 +130,4 @@ onepost conf sid = Just $ do
pid = read sid
-main = serveHttp 8080 params urlconf
+main = serveHttp params urlconf
diff --git a/Blog/Config.hs b/Blog/Config.hs
index f1bac60..b779189 100644
--- a/Blog/Config.hs
+++ b/Blog/Config.hs
@@ -3,7 +3,8 @@ module Config where
import System.IO
import Framework.Types
-params = HP { docdir = "static",
+params = HP { portNumber = 8080,
+ docdir = "static",
-- dbDriver = "sqlite3",
dbDriver = "psql",
-- dbPath = "blog.db",
diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs
index fa364f8..4e6db48 100644
--- a/Framework/Http/HTTPServer.hs
+++ b/Framework/Http/HTTPServer.hs
@@ -42,7 +42,6 @@ serveStatic ps rq s = serveStatic' ps rq s
serveStatic' ps rq resource =
if (rqMethod rq) == GET
then do
- writeLog (logChan ps) rq $ "Sending "++filepath
exists <- doesFileExist filepath
(toResponse exists) `catch` handleError
else return $ response 400 [] "Invalid request method"
@@ -53,8 +52,12 @@ serveStatic' ps rq resource =
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
+ toResponse False = do
+ writeLog (errChan ps) rq $ "Not found: "++filepath
+ return $ response 404 [] $ "File "++filepath++" not found!"
+ toResponse True = do
+ writeLog (logChan ps) rq $ "Sending "++filepath
+ sendfile filepath
filepath = choose resource
basedir = docdir ps
@@ -85,11 +88,10 @@ cleanup dbPool cPool hacc herr = do
exitWith ExitSuccess
-- | Start HTTP server
-serveHttp :: Int -- ^ TCP port number
- -> StaticConfig -- ^ Server config
+serveHttp :: StaticConfig -- ^ Server config
-> URLConf -- ^ URL dispatcher config
-> IO ()
-serveHttp port hap conf = do
+serveHttp hap conf = do
dbPool <- emptyPool 10
cPool <- emptyPool 10
garbageCollector dbPool disconnect'
@@ -99,9 +101,10 @@ serveHttp port hap conf = do
hAccess <- openFile "access.log" WriteMode
hErrors <- openFile "errors.log" WriteMode
runLogWriter aLog eLog hAccess hErrors
+ let hap' = hap {dbpool = dbPool,
+ cpool = cPool,
+ logChan = aLog,
+ errChan = eLog }
installHandler sigINT (CatchOnce (cleanup dbPool cPool hAccess hErrors)) Nothing
- initServer port (httpWorker (hap {dbpool = dbPool,
- cpool = cPool,
- logChan = aLog,
- errChan = eLog }) conf)
+ initServer hap' (httpWorker hap' conf)
diff --git a/Framework/Http/Httpd.hs b/Framework/Http/Httpd.hs
index d04d46a..20e57d0 100644
--- a/Framework/Http/Httpd.hs
+++ b/Framework/Http/Httpd.hs
@@ -47,8 +47,10 @@ import qualified Data.Char as Char
import qualified Data.ByteString.Lazy.Char8 as L
import Numeric (showHex)
+import Framework.Types
+import Framework.Logger
+
type Server = () -- later, you might have a handle for shutting down a server.
-type S = String
showRC (a,b,c) = x:y:z:[]
where x = Char.intToDigit a
@@ -60,9 +62,9 @@ This server transfers documents as one parcel, using the content-length header.
-}
initServer
- :: Int -- ^ The port number
- -> (Request S -> IO (Response S)) -- ^ The functionality of the Sever
- -> IO Server -- ^ A token for the Server
+ :: StaticConfig
+ -> (HttpRequest -> IO HttpResponse) -- ^ The functionality of the Sever
+ -> IO Server -- ^ A token for the Server
initServer =
initServerMain
(\body -> ([mkHeader HdrContentLength (show $ length body)], body))
@@ -75,7 +77,7 @@ It inserts the transfer encoding header for you.
-}
initServerLazy
:: Int -- ^ Chunk size
- -> Int -- ^ The port number
+ -> StaticConfig
-> (Request S -> IO (Response S)) -- ^ The functionality of the Sever
-> IO Server -- ^ A token for the Server
initServerLazy chunkSize =
@@ -101,12 +103,12 @@ parseStartLine _ = Nothing
initServerMain
:: (String -> ([Header], String))
- -> Int
+ -> StaticConfig
-> (Request S -> IO (Response S))
-> IO Server
-initServerMain processBody portNo callOut = do
+initServerMain processBody ps callOut = do
-- installHandler sigPIPE Ignore Nothing
- sock <- listenOn (PortNumber $ fromIntegral portNo)
+ sock <- listenOn (PortNumber $ fromIntegral $ portNumber ps)
forever
(do (h,_nm,_port) <- accept sock
forkIO $ do
@@ -145,12 +147,13 @@ initServerMain processBody portNo callOut = do
Just msg -> msg
Nothing -> "-"
sendRequest h mode uri hds rbody = do
- resp <- callOut $ Request { rqMethod = mode
- , rqURI = uri
- , rqHeaders = hds
- , rqBody = rbody
- }
--- print resp
+ let req = Request { rqMethod = mode
+ , rqURI = uri
+ , rqHeaders = hds
+ , rqBody = rbody
+ }
+ writeLog (logChan ps) req $ "Serving for "++uriPath uri
+ resp <- callOut req
let (additionalHeaders, body) =
processBody $ rspBody resp
writeLines h $
diff --git a/Framework/Logger.hs b/Framework/Logger.hs
index 83366a3..05c39b6 100644
--- a/Framework/Logger.hs
+++ b/Framework/Logger.hs
@@ -33,10 +33,9 @@ writeLog chan rq msg = do
writeChan chan $ LogItem rq time msg
runLogWriter :: Log -> Log -> Handle -> Handle -> IO ThreadId
-runLogWriter aLog eLog afile efile = forkIO $ do
- every 3000000 $ do
- flushLog aLog afile
- flushLog eLog efile
+runLogWriter aLog eLog afile efile = do
+ forkIO $ flushLog eLog efile
+ forkIO $ flushLog aLog afile
flushLog :: Log -> Handle -> IO ()
flushLog chan hndl = do
@@ -45,9 +44,3 @@ flushLog chan hndl = do
-- putStrLn $ formatMsg item
hPutStrLn hndl $ formatMsg item
hFlush hndl
-
-every :: Int -> IO a -> IO b -- FIXME: code duplication - same as in Pool.hs
-every ms action = do
- action
- threadDelay ms
- every ms action
diff --git a/Framework/Types.hs b/Framework/Types.hs
index f6f7ac5..15e05a0 100644
--- a/Framework/Types.hs
+++ b/Framework/Types.hs
@@ -31,6 +31,7 @@ type HttpResponse = Response String
-------------------------------------------------------------------------------------------
data StaticConfig = HP {
+ portNumber :: Int, -- ^ Port number to listen
docdir :: String, -- ^ Static content directory
dbDriver :: String, -- ^ DB backend name
dbPath :: String, -- ^ Info for DB backend
diff --git a/Framework/Urls.hs b/Framework/Urls.hs
index 7a524b1..5dc822a 100644
--- a/Framework/Urls.hs
+++ b/Framework/Urls.hs
@@ -14,6 +14,7 @@ import Data.List
import Framework.Utils
import Framework.Types
import Framework.Wrapper
+import Framework.Logger
import qualified Framework.Http.Sessions as Sessions
import Framework.Http.Response ((<+>))
import Framework.Http.Httpd (queryToArguments)
@@ -82,7 +83,9 @@ runURLConf ps rq s conf =
AC fun -> do
(ac,addSession) <- mkActionConfig ps rq
resp <- case fun ac of
- Nothing -> return $ noSuchUrl True conf
+ Nothing -> do
+ writeLog (errChan ps) rq $ "Not found: "++uriPath url
+ return $ noSuchUrl True conf
Just act -> act
acFree ac
if addSession