diff --git a/API.hs b/API.hs
new file mode 100644
index 0000000..60ddb77
--- /dev/null
+++ b/API.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE ExistentialQuantification, RankNTypes, NamedFieldPuns #-}
+module API where
+
+import Debug.Trace
+
+import qualified Network.Shed.Httpd as Httpd
+import qualified Database.HDBC as HDBC
+import qualified Data.Map as M
+
+import Types
+import qualified Utils
+import qualified Cookies
+import qualified Sessions
+import qualified Storage
+import HTTPServer ((<+>))
+
+data ActionConfig = forall b. (Sessions.SessionBackend b) => ActionConfig {
+ request :: Httpd.Request,
+ httpParams :: HttpActionParams,
+ dbconnection :: Storage.DBConnection,
+ sessionID :: Sessions.SessionID,
+ sessionMap :: Sessions.SessionMap,
+ sessionsBackend :: b,
+ cookiesExp :: String
+ }
+
+----------------------------------------------------------------------------------------------------------
+-- Sessions API
+
+sessionLookup :: ActionConfig -> String -> IO String
+sessionLookup (ActionConfig {sessionMap}) name = return $ maybe "" id $ M.lookup name sessionMap
+
+sessionSet :: ActionConfig -> String -> String -> IO ()
+sessionSet (ActionConfig {sessionsBackend,sessionID,sessionMap}) name value =
+ Sessions.spush sessionsBackend sessionID (trace ("Setting "++name++"="++value) mm)
+ where mm = M.insert name value sessionMap
+
+----------------------------------------------------------------------------------------------------------
+-- Storage API
+
+query :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]]
+query ac sql params = Storage.query (dbconnection ac) sql params
+
+query' :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]]
+query' ac sql params = Storage.query' (dbconnection ac) sql params
+
+queryR :: forall t. (Table t) => ActionConfig -> String -> [HDBC.SqlValue] -> IO [t]
+queryR ac sql params = Storage.queryR (dbconnection ac) sql params
+
+queryR' :: forall t. (Table t) => ActionConfig -> String -> [HDBC.SqlValue] -> IO [t]
+queryR' ac sql params = Storage.queryR' (dbconnection ac) sql params
+
+commit :: ActionConfig -> IO ()
+commit ac = Storage.commit (dbconnection ac)
+
+----------------------------------------------------------------------------------------------------------
+-- Cookies API
+
+getcookie :: ActionConfig -> String -> String
+getcookie ac name = Cookies.getcookie (request ac) name
+
+setcookie :: ActionConfig -> String -> String -> HttpHeader
+setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value
+
+----------------------------------------------------------------------------------------------------------
+
+withConfig :: HttpActionParams -> Httpd.Request -> (ActionConfig -> IO Httpd.Response) -> IO Httpd.Response
+withConfig hp rq f = do
+ ed <- Cookies.expirationDate
+ conn <- Storage.connect' hp
+ sb <- Sessions.initSessions hp
+ sess <- Sessions.session sb rq
+ let (sid,mm) = case sess of
+ Sessions.NewSession sid' -> (sid',M.empty)
+ Sessions.ExistingSession sid' mm' -> (sid',mm')
+ let conf = ActionConfig {
+ request = rq,
+ httpParams = hp,
+ dbconnection = conn,
+ sessionID = sid,
+ sessionMap = mm,
+ sessionsBackend = sb,
+ cookiesExp = ed
+ }
+ resp <- f conf
+ Storage.disconnect conn
+ Sessions.sfree sb
+ return $ resp <+> Sessions.sessionCookie ed sid
+
diff --git a/Sessions.hs b/Sessions.hs
index 1caadbf..6ab7259 100644
--- a/Sessions.hs
+++ b/Sessions.hs
@@ -3,9 +3,11 @@ module Sessions
(SessionID, SessionMap,
Session (..),
initSessions,
- sfetch,spush,sfree,
+ sfetch,spush,
+ sfree,
session,
- sessionCookie
+ sessionCookie,
+ SessionBackend
) where
import Debug.Trace
@@ -44,14 +46,19 @@ instance SessionBackend FilesBackend where
sfetch (FB path) sid = do
b <- doesFileExist file
if b
- then do s <- readFile file
+ then do putStrLn $ "Reading "++file
+ s <- readFile' file
+ putStrLn "File should be closed"
let ls = lines s
let pairs = map spliteq ls
return $ M.fromList pairs
else return M.empty
where file = path </> sid
- spush (FB path) sid mm = writeFile file content
+ 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
diff --git a/Storage.hs b/Storage.hs
index 98c4f44..3973116 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -5,14 +5,12 @@ module Storage
commit,
disconnect,
query, query', queryR, queryR',
- getTable,
- SqlValue (..)
+ getTable
)
where
import qualified Database.HDBC.Sqlite3 as Sqlite3
import qualified Database.HDBC as D
-import Database.HDBC (SqlValue(..))
import Types
@@ -36,14 +34,6 @@ query' (DBC conn) sql params = D.quickQuery' conn sql params
commit :: DBConnection -> IO ()
commit (DBC conn) = D.commit conn
--- queryRG :: forall c t. (D.IConnection c, Table t) => (c -> String -> [D.SqlValue] -> IO [[D.SqlValue]]) -> DBConnection -> String -> [D.SqlValue] -> IO [t]
--- queryRG qf (DBC conn) sql params = do
--- res <- qf conn sql params
--- return (map record res :: [t])
-
--- queryR = queryRG query
--- queryR' = queryRG query'
-
getTable :: forall t. (Table t) => DBConnection -> String -> IO [t]
getTable (DBC conn) name = do
res <- D.quickQuery conn ("SELECT * FROM "++name) []
diff --git a/Types.hs b/Types.hs
index 3c1238d..4ac9567 100644
--- a/Types.hs
+++ b/Types.hs
@@ -36,6 +36,8 @@ instance Show URLConf where
show (ManyRegexpFun _ rs _) = (concat $ intersperse "/" rs)++" --> Some function"
show (After u v) = (show u)++", then "++(show v)
+-------------------------------------------------------------------------------------------
+
data HttpActionParams = HP {
docdir :: String,
hLog :: Channel,
@@ -85,9 +87,13 @@ type UrlParam = HttpHeader
(=:) :: (HttpValue v) => String -> v -> HttpHeader
name =: value = name := (HB value)
+-------------------------------------------------------------------------------------------
+
class Table t where
record :: [D.SqlValue] -> t
+-------------------------------------------------------------------------------------------
+
class TemplateOne a where
showO :: a -> String
intField :: Int -> a -> Int
@@ -179,3 +185,5 @@ transformBools n f = \x -> f `map` (boolFields n x)
transformInt n f = \x -> f (intField n x)
transformString n f = \x -> f (stringField n x)
transformBool n f = \x -> f (boolField n x)
+-------------------------------------------------------------------------------------------
+
diff --git a/Urls.hs b/Urls.hs
index ecb3d5d..3acfef5 100644
--- a/Urls.hs
+++ b/Urls.hs
@@ -108,3 +108,6 @@ urlencode pairs = '?':(concat $ intersperse "&" $ map escapePair pairs)
esc = escapeURIString isAllowedInURI
+myUrl :: Request -> String
+myUrl rq = uriPath $ reqURI rq
+
diff --git a/Utils.hs b/Utils.hs
index e1af19f..d5b0ff2 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -5,6 +5,9 @@ import Network.Shed.Httpd
import qualified Data.Map as M
import Data.List
import Data.Char
+import System.IO
+import System.IO.Unsafe
+import Foreign
import Types
@@ -68,3 +71,34 @@ spliteq s = let n = takeWhile (/='=') s
trim = trimR . trimR
where trimR = reverse . dropWhile isSpace
+------------------------------------------------------------------------------------------
+
+readFile' :: String -> IO String
+readFile' f = do
+ h <- openFile f ReadMode
+ s <- hFileSize h
+ fp <- mallocForeignPtrBytes (fromIntegral s)
+ len <- withForeignPtr fp $ \buf -> hGetBuf h buf (fromIntegral s)
+ hClose h
+ lazySlurp fp 0 len
+
+buf_size = 4096 :: Int
+
+lazySlurp :: ForeignPtr Word8 -> Int -> Int -> IO String
+lazySlurp fp ix len
+ | fp `seq` False = undefined
+ | ix >= len = return []
+ | otherwise = do
+ cs <- unsafeInterleaveIO (lazySlurp fp (ix + buf_size) len)
+ ws <- withForeignPtr fp $ \p -> loop (min (len-ix) buf_size - 1)
+ ((p :: Ptr Word8) `plusPtr` ix) cs
+ return ws
+ where
+ loop :: Int -> Ptr Word8 -> String -> IO String
+ loop len p acc
+ | len `seq` p `seq` False = undefined
+ | len < 0 = return acc
+ | otherwise = do
+ w <- peekElemOff p len
+ loop (len-1) p (chr (fromIntegral w):acc)
+
diff --git a/test.hs b/test.hs
index 236dbe0..b259278 100644
--- a/test.hs
+++ b/test.hs
@@ -5,17 +5,16 @@ import Debug.Trace
import System.IO
import Network.Shed.Httpd
import qualified Data.Map as M
+import Database.HDBC (SqlValue(..))
import Types
import Urls
import Utils
import HTTPServer
import TemplateUtil
-import Storage
import Models
import Forms
-import Sessions
-import Cookies
+import API
-- testing _ _ = return $ ok "Happy new year!"
@@ -34,16 +33,8 @@ formfun _ rq@(Request {reqMethod}) =
where title = httpGetVar' rq "title" "Nothing"
testval = httpPostVar' rq "title" "Empty"
-printUsers hp rq@(Request {reqMethod}) = do
- sb <- initSessions hp
- sess <- session sb rq
- print sess
-
- ed <- expirationDate
-
- let (filled,sid) = case sess of
- NewSession sid' -> ("", sid')
- ExistingSession sid' mm -> (maybe "" id $ M.lookup "filled" mm, sid')
+printUsers hp rq@(Request {reqMethod}) = withConfig hp rq $ \conf -> do
+ filled <- sessionLookup conf "filled"
let defvals = decodePairs filled
@@ -53,28 +44,24 @@ printUsers hp rq@(Request {reqMethod}) = do
case reqMethod of
"GET" -> do
- conn <- connect' hp
- us <- queryR' conn "SELECT * FROM users" [] :: IO [User]
- disconnect conn
+ us <- queryR' conf "SELECT * FROM users" [] :: IO [User]
return $ renderToResponse "first.html" [("users", C us),
("title", C "Some title"),
("list", C ["first","second","third"]),
("include",C "inctest.html"),
("form", C form),
- ("invalid",C err)] <+> (sessionCookie ed sid)
+ ("invalid",C err)]
"POST" -> do
case defValidate userForm rq of
Right user -> let uname = _username user
upass = _password user
- in do conn <- connect' hp
- query conn "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname, SqlString upass]
- commit conn
- disconnect conn
+ in do query conf "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname, SqlString upass]
+ commit conf
return $ redirect url
- Left e -> do spush sb sid $ M.fromList [("filled",values)]
- return $ redirectG url ["invalid" =: (unwords e)] <+> (sessionCookie ed sid)
+ Left e -> do sessionSet conf "filled" values
+ return $ redirectG url ["invalid" =: (unwords e)]
- where url = "/users/"
+ where url = myUrl rq
err = httpGetVar' rq "invalid" ""
values = tail $ urlencode $ map packHeader vars
vars = formVars userForm rq