diff --git a/Blog/Blog b/Blog/Blog index a8f62cb..7fdb4d2 100755 Binary files a/Blog/Blog and b/Blog/Blog differ diff --git a/Blog/Blog.hs b/Blog/Blog.hs index cdef9b4..f59d95c 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -8,8 +8,8 @@ import Control.Monad import Framework.Types import Framework.API import Framework.SQL -import Framework.HTTPServer -import Framework.Response +-- import Framework.HTTPServer +import Framework.Http.Response import Framework.TEngine.TemplateUtil import Framework.Urls import Framework.Utils diff --git a/Blog/Config.hs b/Blog/Config.hs index 6a94e22..a1d6d89 100644 --- a/Blog/Config.hs +++ b/Blog/Config.hs @@ -11,8 +11,8 @@ params = HP { docdir = "static", dbPath = "host=rtfm-server password=31415", -- cacheDriver = "memcached", -- cachePath = "localhost:11211", - cacheDriver = "fake", --- cacheDriver = "filesystem", +-- cacheDriver = "fake", + cacheDriver = "filesystem", cachePath = "tmp/", sessionsDriver = "files", sessionsPath = "tmp/sessions/" diff --git a/Blog/Makefile b/Blog/Makefile index 3399fe3..c417379 100644 --- a/Blog/Makefile +++ b/Blog/Makefile @@ -1,4 +1,4 @@ -GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../ +GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -threaded -i. -i../ TEMPLATES=../Framework/TEngine/Templates.hs all: Templates Blog diff --git a/Framework/API.hs b/Framework/API.hs index c875db0..0fb498d 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -1,7 +1,16 @@ {-# LANGUAGE ExistentialQuantification, RankNTypes, NamedFieldPuns #-} -- | Contains `userland` API. Wraps functions from many other modules. -- API functions get ActionConfig parameter, which contains all data about current job. -module Framework.API where +module Framework.API + (ActionConfig (..), + serveHttp, serveStatic, + sessionLookup, sessionSet, + queryList, queryList', query, query', + commit, + queryListSQL, queryListSQL', querySQL, querySQL', + getcookie, setcookie, + withConfig + )where import Debug.Trace @@ -11,14 +20,15 @@ import qualified Data.Map as M import Framework.Types import qualified Framework.Utils as Utils -import qualified Framework.Cookies as Cookies -import qualified Framework.Sessions as Sessions +import qualified Framework.Http.Cookies as Cookies +import qualified Framework.Http.Sessions as Sessions import qualified Framework.Storage as Storage import qualified Framework.Urls as Urls import qualified Framework.Cache as Cache import qualified Framework.SQL as SQL import Framework.Models (Model) -import Framework.Response ((<+>)) +import Framework.Http.Response ((<+>)) +import Framework.Http.HTTPServer (serveHttp,serveStatic) -- | Runtime controller action configuration data ActionConfig = ActionConfig { diff --git a/Framework/Cookies.hs b/Framework/Cookies.hs deleted file mode 100644 index 3b11e81..0000000 --- a/Framework/Cookies.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Framework.Cookies 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.HTTPServer - -setcookie :: String -> String -> String -> HttpHeader -setcookie exp name value = "Set-Cookie" =: ((esc (name++"="++value))++"; expires="++exp) - -getcookie :: Request -> String -> String -getcookie rq name = maybe "" id $ lookup name cc - where cc = allcookies rq - -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/Forms/Validation.hs b/Framework/Forms/Validation.hs index c7e50f6..c57db0d 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -22,7 +22,7 @@ import Framework.Utils import Framework.Urls import Framework.API import Framework.Models -import Framework.Response (redirectG) +import Framework.Http.Response (redirectG) import Framework.Forms.Types import Framework.Forms.HTML diff --git a/Framework/HTTPServer.hs b/Framework/HTTPServer.hs deleted file mode 100644 index 8e3b2ba..0000000 --- a/Framework/HTTPServer.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module Framework.HTTPServer where - -import Prelude hiding (catch,print,putStr,putStrLn,readFile) -import System.IO hiding (print,hPutStr,hPutStrLn,readFile,putStrLn) -import System.IO.UTF8 -import Codec.Binary.UTF8.String -import System.Directory -import Control.Exception -import Network.Shed.Httpd -import Network.URI - -import Framework.Types -import Framework.Urls -import Framework.Utils -import Framework.Response -import Framework.Middlewares --- import Framework.Forms (Form,FormsPlugins) - -sendfile :: String -> IO Response -sendfile filename = do - body <- readFile filename - return $ response 200 ["Content-Type" =: mime] body - - where mime = chooseMime filename - -serveStatic :: StrAction -serveStatic ps rq s = Just $ serveStatic' ps rq s - -serveStatic' (HP {docdir,hLog}) (Request {reqMethod}) resource = - if reqMethod == "GET" - then do --- putStrLn $ "Sending "++filepath - exists <- doesFileExist filepath - (toResponse exists) `catch` handleError - else return $ response 400 [] "Invalid request method" - - where - handleError :: SomeException -> IO Response - handleError e = do - hPutStr hLog $ 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 - -httpWorker :: HttpActionParams -> URLConf -> Request -> IO Response -httpWorker hap conf req@(Request {reqURI = URI {uriPath}}) = do - let s = unEscapeString $ reqBody req --- putStrLn $ "Request body: "++show s --- putStrLn $ "deUTF:"++(decodeString s) --- putStrLn $ "Serving "++uriPath - resp <- runURLConf hap req (tail uriPath) conf - responseMiddlewares resp - -defaultURLConf :: URLConf -defaultURLConf = Function serveStatic - -serveHttp :: Int -> HttpActionParams -> URLConf -> IO () -serveHttp port hap conf = initServer port (httpWorker hap conf) - diff --git a/Framework/Http/Cookies.hs b/Framework/Http/Cookies.hs new file mode 100644 index 0000000..bd3e47d --- /dev/null +++ b/Framework/Http/Cookies.hs @@ -0,0 +1,36 @@ +module Framework.Http.Cookies + (setcookie,getcookie, + expirationDate) 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 + +setcookie :: String -> String -> String -> HttpHeader +setcookie exp name value = "Set-Cookie" =: ((esc (name++"="++value))++"; expires="++exp) + +getcookie :: Request -> String -> String +getcookie rq name = maybe "" id $ lookup name cc + where cc = allcookies rq + +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 new file mode 100644 index 0000000..dc9ef00 --- /dev/null +++ b/Framework/Http/HTTPServer.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Framework.Http.HTTPServer + (defaultURLConf, + serveHttp, + serveStatic) where + +import Prelude hiding (catch,print,putStr,putStrLn,readFile) +import System.IO hiding (print,hPutStr,hPutStrLn,readFile,putStrLn) +import System.IO.UTF8 +import Codec.Binary.UTF8.String +import System.Directory +import Control.Exception +import Network.Shed.Httpd +import Network.URI + +import Framework.Types +import Framework.Urls +import Framework.Utils +import Framework.Http.Response +import Framework.Http.Middlewares + +sendfile :: String -> IO Response +sendfile filename = do + body <- readFile filename + return $ response 200 ["Content-Type" =: mime] body + + where mime = chooseMime filename + +serveStatic :: StrAction +serveStatic ps rq s = Just $ serveStatic' ps rq s + +serveStatic' (HP {docdir,hLog}) (Request {reqMethod}) resource = + if reqMethod == "GET" + then do +-- putStrLn $ "Sending "++filepath + exists <- doesFileExist filepath + (toResponse exists) `catch` handleError + else return $ response 400 [] "Invalid request method" + + where + handleError :: SomeException -> IO Response + handleError e = do + hPutStr hLog $ 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 + +httpWorker :: HttpActionParams -> URLConf -> Request -> IO Response +httpWorker hap conf req@(Request {reqURI = URI {uriPath}}) = do + let s = unEscapeString $ reqBody req +-- putStrLn $ "Request body: "++show s +-- putStrLn $ "deUTF:"++(decodeString s) +-- putStrLn $ "Serving "++uriPath + resp <- runURLConf hap req (tail uriPath) conf + responseMiddlewares resp + +defaultURLConf :: URLConf +defaultURLConf = Function serveStatic + +serveHttp :: Int -> HttpActionParams -> URLConf -> IO () +serveHttp port hap conf = initServer port (httpWorker hap conf) + diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs new file mode 100644 index 0000000..bcfccf0 --- /dev/null +++ b/Framework/Http/Middlewares.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Framework.Http.Middlewares + (RequestMiddleware, + ResponseMiddleware, + responseMiddlewares) where + +import Network.Shed.Httpd -- (Request,Response) +import Framework.Utils + +type RequestMiddleware = Request -> IO Request +type ResponseMiddleware = Response -> IO Response + +ctype = "Content-Type" + +addEncoding enc (Response c hdrs b) = + case lookup ctype hdrs of + Nothing -> Response c ((ctype ,"text/html; charset="++enc):hdrs) b + Just s -> Response c (update ctype (s++"; charset="++enc) hdrs) b + +responseMiddlewares = return . (addEncoding "UTF-8") diff --git a/Framework/Http/Response.hs b/Framework/Http/Response.hs new file mode 100644 index 0000000..e6d0af0 --- /dev/null +++ b/Framework/Http/Response.hs @@ -0,0 +1,37 @@ +module Framework.Http.Response + (response, ok, + redirect, redirectG, redirectP, + (<+>), (<++>) ) where + +import qualified Network.Shed.Httpd as Httpd + +import Framework.Types +import Framework.Utils +import Framework.Urls ((?)) + +------------------------------------------------------------------------------------------------------- +-- * Make a Response +-- +response :: Int -> [HttpHeader] -> String -> Httpd.Response +response code pairs body = Httpd.Response code (map repackHeader $ filter notEmptyHeader pairs) body + where notEmptyHeader (_:=v) = not $ httpEmpty v + +ok :: String -> Httpd.Response +ok body = response 200 ["Content-Type" =: mime] body + where mime = "text/html" + +redirect :: String -> Httpd.Response +redirect url = response 302 ["Location" =: url] "" + +redirectP :: String -> Httpd.Response +redirectP url = response 301 ["Location" =: url] "" + +redirectG :: String -> [UrlParam] -> Httpd.Response +redirectG url pairs = redirect $ url ? pairs + +(<+>) :: Httpd.Response -> HttpHeader -> Httpd.Response +(Httpd.Response c hdrs b) <+> hdr = Httpd.Response c (hdrs++[repackHeader hdr]) b + +(<++>) :: Httpd.Response -> [HttpHeader] -> Httpd.Response +(Httpd.Response c old b) <++> new = Httpd.Response c (old++(map repackHeader new)) b + diff --git a/Framework/Http/Sessions.hs b/Framework/Http/Sessions.hs new file mode 100644 index 0000000..26fd6b7 --- /dev/null +++ b/Framework/Http/Sessions.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Framework.Http.Sessions + (SessionID, SessionMap, + Session (..), + initSessions, + sFetch,sPush, + sFree, + session, + sessionCookie, + SessionsConnection + ) where + +import Debug.Trace + +import System.IO +import System.Directory +import System.FilePath ((</>)) +import System.Random +import qualified Data.Map as M + +import Network.Shed.Httpd(Request) + +import Framework.Types +import Framework.Utils +import Framework.Http.Cookies + +type SessionID = String +type SessionMap = M.Map String String + +data Session = NewSession SessionID + | ExistingSession SessionID SessionMap + deriving (Show) + +class SessionBackend b where + sinit :: String -> IO b + sfetch :: b -> SessionID -> IO SessionMap + spush :: b -> SessionID -> SessionMap -> IO () + sfree :: b -> IO () + +data SessionsConnection = forall b. (SessionBackend b) => SConnection b + +data FilesBackend = FB String + +instance SessionBackend FilesBackend where + sinit path = return $ FB path + + sfetch (FB path) sid = do + b <- doesFileExist file + if b + then do -- putStrLn $ "Reading "++file + s <- readFile' file +-- putStrLn "File should be closed" + let ls = lines s + let pairs = map spliteq ls +-- putStrLn $ "Session read: "++(show pairs) + return $ M.fromList pairs + else return M.empty + where file = path </> sid + + spush (FB path) sid mm = do +-- putStrLn $ "Writing "++file + writeFile file content +-- putStrLn "File should be closed by writer" + where content = unlines $ map (\(n,v) -> n++"="++v) $ M.assocs mm + file = path </> sid + + sfree _ = return () + +initSessions :: String -> String -> IO SessionsConnection +initSessions "files" s = SConnection `fmap` (sinit s :: IO FilesBackend) + +sFetch :: SessionsConnection -> SessionID -> IO SessionMap +sFetch (SConnection b) sid = sfetch b sid + +sPush :: SessionsConnection -> SessionID -> SessionMap -> IO () +sPush (SConnection b) sid mm = spush b sid mm + +sFree :: SessionsConnection -> IO () +sFree (SConnection b) = sfree b + +session :: SessionsConnection -> Request -> IO Session +session (SConnection b) rq = + if null sid + then do n <- getStdRandom (randomR (100,maxBound::Int)) + return $ NewSession (show n) + else do mm <- sfetch b sid + return $ ExistingSession sid mm + where sid = getcookie rq "SessionID" + +sessionCookie :: String -> String -> HttpHeader +sessionCookie exp sid = setcookie exp "SessionID" sid diff --git a/Framework/Makefile b/Framework/Makefile index 8ff3645..f319f5e 100644 --- a/Framework/Makefile +++ b/Framework/Makefile @@ -1,4 +1,4 @@ -GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../ +GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -threaded -i. -i../ all: API.o diff --git a/Framework/Middlewares.hs b/Framework/Middlewares.hs deleted file mode 100644 index 8fbc4c2..0000000 --- a/Framework/Middlewares.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -module Framework.Middlewares where - -import Network.Shed.Httpd -- (Request,Response) -import Framework.Utils - -type RequestMiddleware = Request -> IO Request -type ResponseMiddleware = Response -> IO Response - -ctype = "Content-Type" - -addEncoding enc (Response c hdrs b) = - case lookup ctype hdrs of - Nothing -> Response c ((ctype ,"text/html; charset="++enc):hdrs) b - Just s -> Response c (update ctype (s++"; charset="++enc) hdrs) b - -responseMiddlewares = return . (addEncoding "UTF-8") diff --git a/Framework/Response.hs b/Framework/Response.hs deleted file mode 100644 index 53974c9..0000000 --- a/Framework/Response.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Framework.Response where - -import qualified Network.Shed.Httpd as Httpd - -import Framework.Types -import Framework.Utils -import Framework.Urls ((?)) - -------------------------------------------------------------------------------------------------------- --- * Make a Response --- -response :: Int -> [HttpHeader] -> String -> Httpd.Response -response code pairs body = Httpd.Response code (map repackHeader $ filter notEmptyHeader pairs) body - where notEmptyHeader (_:=v) = not $ httpEmpty v - -ok :: String -> Httpd.Response -ok body = response 200 ["Content-Type" =: mime] body - where mime = "text/html" - -redirect :: String -> Httpd.Response -redirect url = response 302 ["Location" =: url] "" - -redirectP :: String -> Httpd.Response -redirectP url = response 301 ["Location" =: url] "" - -redirectG :: String -> [UrlParam] -> Httpd.Response -redirectG url pairs = redirect $ url ? pairs - -(<+>) :: Httpd.Response -> HttpHeader -> Httpd.Response -(Httpd.Response c hdrs b) <+> hdr = Httpd.Response c (hdrs++[repackHeader hdr]) b - -(<++>) :: Httpd.Response -> [HttpHeader] -> Httpd.Response -(Httpd.Response c old b) <++> new = Httpd.Response c (old++(map repackHeader new)) b - diff --git a/Framework/Sessions.hs b/Framework/Sessions.hs deleted file mode 100644 index a97d926..0000000 --- a/Framework/Sessions.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Framework.Sessions - (SessionID, SessionMap, - Session (..), - initSessions, - sFetch,sPush, - sFree, - session, - sessionCookie, - SessionsConnection - ) where - -import Debug.Trace - -import System.IO -import System.Directory -import System.FilePath ((</>)) -import System.Random -import qualified Data.Map as M - -import Network.Shed.Httpd(Request) - -import Framework.Types -import Framework.Utils -import Framework.Cookies --- import Framework.HTTPServer - -type SessionID = String -type SessionMap = M.Map String String - -data Session = NewSession SessionID - | ExistingSession SessionID SessionMap - deriving (Show) - -class SessionBackend b where - sinit :: String -> IO b - sfetch :: b -> SessionID -> IO SessionMap - spush :: b -> SessionID -> SessionMap -> IO () - sfree :: b -> IO () - -data SessionsConnection = forall b. (SessionBackend b) => SConnection b - -data FilesBackend = FB String - -instance SessionBackend FilesBackend where - sinit path = return $ FB path - - sfetch (FB path) sid = do - b <- doesFileExist file - if b - then do -- putStrLn $ "Reading "++file - s <- readFile' file --- putStrLn "File should be closed" - let ls = lines s - let pairs = map spliteq ls --- putStrLn $ "Session read: "++(show pairs) - return $ M.fromList pairs - else return M.empty - where file = path </> sid - - spush (FB path) sid mm = do --- putStrLn $ "Writing "++file - writeFile file content --- putStrLn "File should be closed by writer" - where content = unlines $ map (\(n,v) -> n++"="++v) $ M.assocs mm - file = path </> sid - - sfree _ = return () - -initSessions :: String -> String -> IO SessionsConnection -initSessions "files" s = SConnection `fmap` (sinit s :: IO FilesBackend) - -sFetch :: SessionsConnection -> SessionID -> IO SessionMap -sFetch (SConnection b) sid = sfetch b sid - -sPush :: SessionsConnection -> SessionID -> SessionMap -> IO () -sPush (SConnection b) sid mm = spush b sid mm - -sFree :: SessionsConnection -> IO () -sFree (SConnection b) = sfree b - -session :: SessionsConnection -> Request -> IO Session -session (SConnection b) rq = - if null sid - then do n <- getStdRandom (randomR (100,maxBound::Int)) - return $ NewSession (show n) - else do mm <- sfetch b sid - return $ ExistingSession sid mm - where sid = getcookie rq "SessionID" - -sessionCookie :: String -> String -> HttpHeader -sessionCookie exp sid = setcookie exp "SessionID" sid diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs index 38c4f2b..acdabd2 100644 --- a/Framework/TEngine/TemplateUtil.hs +++ b/Framework/TEngine/TemplateUtil.hs @@ -8,7 +8,7 @@ module Framework.TEngine.TemplateUtil import qualified Data.Map as M import Network.Shed.Httpd -import Framework.Response (ok) +import Framework.Http.Response (ok) import Framework.TEngine.Templates (render) import Framework.Types import Framework.API