diff --git a/.gitignore b/.gitignore
index 895fb45..cc8eab5 100644
--- a/.gitignore
+++ b/.gitignore
@@ -9,3 +9,7 @@ TypesI.hs
.*.swp
tmp
tmp/*
+html
+html/*
+tags
+
diff --git a/API.hs b/API.hs
index 60ddb77..4b92447 100644
--- a/API.hs
+++ b/API.hs
@@ -12,15 +12,18 @@ import qualified Utils
import qualified Cookies
import qualified Sessions
import qualified Storage
+import qualified Urls
+import qualified Cache
import HTTPServer ((<+>))
-data ActionConfig = forall b. (Sessions.SessionBackend b) => ActionConfig {
+data ActionConfig = ActionConfig {
request :: Httpd.Request,
httpParams :: HttpActionParams,
dbconnection :: Storage.DBConnection,
sessionID :: Sessions.SessionID,
sessionMap :: Sessions.SessionMap,
- sessionsBackend :: b,
+ sessionsBackend :: Sessions.SessionsConnection,
+ cacheBackend :: Cache.CacheConnection,
cookiesExp :: String
}
@@ -32,7 +35,7 @@ sessionLookup (ActionConfig {sessionMap}) name = return $ maybe "" id $ M.lookup
sessionSet :: ActionConfig -> String -> String -> IO ()
sessionSet (ActionConfig {sessionsBackend,sessionID,sessionMap}) name value =
- Sessions.spush sessionsBackend sessionID (trace ("Setting "++name++"="++value) mm)
+ Sessions.sPush sessionsBackend sessionID (trace ("Setting "++name++"="++value) mm)
where mm = M.insert name value sessionMap
----------------------------------------------------------------------------------------------------------
@@ -64,15 +67,18 @@ 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
+ sb <- Sessions.initSessions (sessionsDriver hp) (sessionsPath hp)
sess <- Sessions.session sb rq
let (sid,mm) = case sess of
Sessions.NewSession sid' -> (sid',M.empty)
Sessions.ExistingSession sid' mm' -> (sid',mm')
+ cc <- Cache.initCache (cacheDriver hp) (cachePath hp)
let conf = ActionConfig {
request = rq,
httpParams = hp,
@@ -80,10 +86,12 @@ withConfig hp rq f = do
sessionID = sid,
sessionMap = mm,
sessionsBackend = sb,
+ cacheBackend = cc,
cookiesExp = ed
}
resp <- f conf
Storage.disconnect conn
- Sessions.sfree sb
+ Cache.cFree cc
+ Sessions.sFree sb
return $ resp <+> Sessions.sessionCookie ed sid
diff --git a/Cache.hs b/Cache.hs
index 0414ace..24784e7 100644
--- a/Cache.hs
+++ b/Cache.hs
@@ -1,14 +1,17 @@
{-# LANGUAGE ExistentialQuantification #-}
module Cache
- (initCache,
- cget,cput,
- cfree
- ) where
+ ( -- $doc
+ initCache,
+ cGet,cPut,
+ cached,
+ cFree,
+ Serializable (..),
+ CacheConnection
+ ) where
-import System.Directory
+import System.Directory(doesFileExist)
import System.FilePath ((</>))
-import System.IO
-import Control.Exception
+import Control.Exception(handle,IOException)
import Network.Memcache (Memcache)
import qualified Network.Memcache as MC
@@ -17,11 +20,18 @@ import Network.Memcache.Serializable (Serializable(..))
import Utils
+-- $doc
+-- This module manages caching of any data. Caching is implemented by several backends,
+-- such as Memcache and Filesystem.
+
class CacheBackend b where
- cinit :: String -> IO b
- cget :: (Serializable v) => b -> String -> IO (Maybe v)
- cput :: (Serializable v) => b -> String -> v -> IO Bool
- cfree :: b -> IO ()
+ cinit :: String -> IO b -- ^ Init cache backend
+ cget :: (Serializable v) => b -> String -> IO (Maybe v) -- ^ Get data from cache
+ cput :: (Serializable v) => b -> String -> v -> IO Bool -- ^ Put data to cache
+ cfree :: b -> IO () -- ^ Free backend
+
+-- | Type to incapsulate connection to any cache backend.
+data CacheConnection = forall b. (CacheBackend b) => CConnection b
data MemcacheBackend = MB SMC.Server
data FilesystemBackend = FB String
@@ -62,5 +72,46 @@ instance CacheBackend FakeBackend where
cput _ _ _ = return True
cfree _ = return ()
-initCache :: String -> IO FilesystemBackend
-initCache s = cinit s
+-- | Init cache backend. Backend type is given in first argument,
+-- i.e. : initCache "memcached" "localhost:11211".
+initCache :: String -> String -> IO CacheConnection
+initCache "memcached" s = CConnection `fmap` (cinit s :: IO MemcacheBackend)
+initCache "filesystem" s = CConnection `fmap` (cinit s :: IO FilesystemBackend)
+initCache "fake" s = CConnection `fmap` (cinit s :: IO FakeBackend)
+
+-- | Get data from cache (from given connection)
+cGet :: (Serializable v) => CacheConnection -> String -> IO (Maybe v)
+cGet (CConnection b) name = cget b name
+
+-- | Put data to cache
+cPut :: (Serializable v) => CacheConnection -> String -> v -> IO Bool
+cPut (CConnection b) name value = cput b name value
+
+-- | Free cache backend
+cFree :: CacheConnection -> IO ()
+cFree (CConnection b) = cfree b
+
+showC Nothing = "Nothing"
+showC (Just x) = s++" ("++(show $ length s)++")"
+ where s = toString x
+
+-- | cached cConnection name key function argument
+-- Executes given function with given argument, caching the result
+-- (under given function name and item key)
+cached :: (Serializable k, Serializable v) => CacheConnection -> String -> k -> (a -> v) -> a -> IO v
+cached (CConnection b) name k f x =
+ do c <- cget b key
+-- putStrLn $ "Server answer: "++(showC c)
+ case c of
+ Nothing -> putcache
+ Just y -> if null (toString y)
+ then putcache
+ else {-do print (toString y) -}
+ return y
+ where key = name ++ ":" ++ (toString k)
+ putcache = let y = f x
+ in do cput b key y
+-- putStrLn $ "No "++key++" in cache"
+ return y
+
+
diff --git a/Forms.hs b/Forms.hs
index b509571..9c4234c 100644
--- a/Forms.hs
+++ b/Forms.hs
@@ -1,35 +1,52 @@
{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-}
module Forms
- (Inputbox, Textarea,
+ ( -- $doc
+ Inputbox, Textarea,
inputbox, textarea,
tag,
createform, editform,
+ retryForm, returnInvalidForm,
Form (..),
FormField (..),
formVars, formVarsNames, formVarsValues,
notEmpty, noValidate,
- defValidate
+ defValidate,
+ getAnyForm, getForm
) where
-import Types
-import Utils
+import qualified Data.Map as M
import Data.Maybe
-import Network.Shed.Httpd (Request)
+
+import Network.Shed.Httpd (Request,Response)
import qualified Database.HDBC as D
+
import Types
+import Utils
import Urls
import API
+import HTTPServer (redirectG, packHeader)
+
+-- $doc
+-- HTML forms generation and validation.
+-- | Types of this class represent HTML widgets
class Widget w where
- type WContent w
- html :: w -> String -> String -> String
+ type WContent w -- ^ Type of widget content; not used at the moment.
+ -- | Generate HTML for widget
+ html :: w -> -- ^ Widget
+ String -> -- ^ Widget's html \"name\" attribute
+ String -> -- ^ Value of widget
+ String
+ -- | Read widget's value from string. Not used yet.
wRead :: String -> WContent w
+-- | Generate <form> tag
makeform :: (HttpValue a) => String -> String -> a -> String -> String
makeform name fid action content = tag "form" ["method" =: "POST","action" =: action] (fidfield++namefield++content)
where fidfield = tag "input" ["name" =: "formid", "type" =: "hidden", "value" =: fid] ""
namefield = tag "input" ["name" =: "formname", "type" =: "hidden", "value" =: name] ""
+-- | Generate form row (widget with label)
formrow :: (HttpValue [a]) => String -> String -> String -> [a] -> FormField -> String
formrow fname fid def cls (Field name label widget _) = tag "tr" attrs $ (tag "td" [] itemlabel)++(tag "td" [] (html widget itemname def))
where attrs = if null cls
@@ -43,12 +60,22 @@ formrow fname fid def cls (Field name label widget _) = tag "tr" attrs $ (tag "t
submit :: String
submit = "<tr><td></td><td><input type='submit'/></td></tr>\n"
-createform :: (HttpValue a) => Form -> String -> a -> String
+-- | Generate an empty form
+createform :: (HttpValue a) => Form -> -- ^ A form to generate
+ String -> -- ^ Form ID
+ a -> -- ^ Form target url
+ String
createform form fid action = makeform name fid action content
where content = tag' "table" [] (concat $ map (formrow name fid "" "") (fFields form))++submit
name = formName form
-editform :: (HttpValue a) => [String] -> Form -> String -> [(String,String)] -> a -> String
+-- | Generate a \"to-edit\" form
+editform :: (HttpValue a) => [String] -> -- ^ List of erroneus filled fields names
+ Form -> -- ^ A form to generate
+ String -> -- ^ Form ID
+ [(String,String)] -> -- ^ (name,value) pairs
+ a -> -- ^ Form's target url
+ String
editform errfields form fid pairs action = makeform name fid action content
where content = tag' "table" [] (concat $ zipWith3 (formrow name fid) vals clss (fFields form))++submit
vals = map (\n -> maybe "" id $ lookup (name++fid++"-"++n) pairs) names
@@ -56,6 +83,27 @@ editform errfields form fid pairs action = makeform name fid action content
clss = map (\n -> if n `elem` errfields then "error" else "") names
name = formName form
+-- | Generate a form, maybe filled with already-entered data
+retryForm :: ActionConfig ->
+ Forms.Form -> -- ^ A form
+ String -> -- ^ Form ID
+ String -> -- ^ Target URL
+ IO (String, String) -- ^ (Form HTML, error message)
+retryForm conf form fid action = do
+ filled <- sessionLookup conf "filled"
+ let defvals = decodePairs filled
+ let err = Urls.httpGetVar' (request conf) "invalid" ""
+ if null err
+ then return (createform form fid action, "")
+ else return (editform (words err) form fid defvals action, err)
+
+returnInvalidForm :: ActionConfig -> Forms.Form -> String -> [String] -> IO Response
+returnInvalidForm conf form fid errs =
+ do sessionSet conf "filled" values
+ return $ redirectG (myUrl $ request conf) ["invalid" =: (unwords errs)]
+ where values = tail $ urlencode $ map packHeader vars
+ vars = formVars form fid (request conf)
+
htmlAttr :: FormVar -> String
htmlAttr (name := value) | httpEmpty value = ""
| otherwise = " "++name++"='"++(httpShow value)++"'"
@@ -147,4 +195,16 @@ noValidate s = Right s
----------------------------------------------------------------------------------------------------
-
+getAnyForm :: (Table a) => M.Map String Form -> Request -> (Either [String] a, String, String)
+getAnyForm mm rq = case form of
+ Nothing -> (Left [], "","")
+ Just form' -> (defValidate form' fid rq, formname, fid)
+ where formname = httpPostVar' rq "formname" ""
+ form = M.lookup formname mm
+ fid = httpPostVar' rq "formid" ""
+
+getForm :: (Table a) => M.Map String Form -> Request -> String -> (Either [String] a, String)
+getForm mm rq name = if name==formname
+ then (e,fid)
+ else (Left [], "")
+ where (e,formname,fid) = getAnyForm mm rq
diff --git a/Middlewares.hs b/Middlewares.hs
new file mode 100644
index 0000000..fef5819
--- /dev/null
+++ b/Middlewares.hs
@@ -0,0 +1,6 @@
+module Middlewares where
+
+import Network.Shed.Httpd (Request,Response)
+
+type RequestMiddleware = Request -> IO Request
+type ResponseMiddleware = Response -> IO Response
diff --git a/Models.hs b/Models.hs
index 73658b1..0402c05 100644
--- a/Models.hs
+++ b/Models.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE FlexibleInstances,NoMonomorphismRestriction, ExistentialQuantification #-}
module Models where
+import qualified Data.Map as M
+
import Types
import Storage
import Database.HDBC (fromSql)
@@ -11,9 +13,11 @@ data User = User {
_username :: String,
_password :: String }
+userId :: (TemplateOne a) => a -> Int
userId = transformInt 1 id
-username :: forall a. (TemplateItem a) => a -> String
+username :: (TemplateItem a) => a -> String
username = transformString 1 id
+password :: (TemplateOne a) => a -> String
password = transformString 2 id
instance Table User where
@@ -32,3 +36,9 @@ userForm = Form {
fFields = [ Field "name" "Username:" inputbox (notEmpty "name"),
Field "password" "" inputbox noValidate ]
}
+
+formsList :: [Form]
+formsList = [userForm]
+
+allForms :: M.Map String Form
+allForms = M.fromList [(formName form, form) | form <- formsList]
diff --git a/Sessions.hs b/Sessions.hs
index 6ab7259..6a4a30c 100644
--- a/Sessions.hs
+++ b/Sessions.hs
@@ -3,11 +3,11 @@ module Sessions
(SessionID, SessionMap,
Session (..),
initSessions,
- sfetch,spush,
- sfree,
+ sFetch,sPush,
+ sFree,
session,
sessionCookie,
- SessionBackend
+ SessionsConnection
) where
import Debug.Trace
@@ -18,7 +18,7 @@ import System.FilePath ((</>))
import System.Random
import qualified Data.Map as M
-import Network.Shed.Httpd
+import Network.Shed.Httpd(Request)
import Types
import Utils
@@ -38,6 +38,8 @@ class SessionBackend b where
spush :: b -> SessionID -> SessionMap -> IO ()
sfree :: b -> IO ()
+data SessionsConnection = forall b. (SessionBackend b) => SConnection b
+
data FilesBackend = FB String
instance SessionBackend FilesBackend where
@@ -46,9 +48,9 @@ instance SessionBackend FilesBackend where
sfetch (FB path) sid = do
b <- doesFileExist file
if b
- then do putStrLn $ "Reading "++file
+ then do -- putStrLn $ "Reading "++file
s <- readFile' file
- putStrLn "File should be closed"
+-- putStrLn "File should be closed"
let ls = lines s
let pairs = map spliteq ls
return $ M.fromList pairs
@@ -56,19 +58,28 @@ instance SessionBackend FilesBackend where
where file = path </> sid
spush (FB path) sid mm = do
- putStrLn $ "Writing "++file
+-- putStrLn $ "Writing "++file
writeFile file content
- putStrLn "File should be closed by writer"
+-- putStrLn "File should be closed by writer"
where content = unlines $ map (\(n,v) -> n++"="++v) $ M.assocs mm
file = path </> sid
sfree _ = return ()
-initSessions :: HttpActionParams -> IO FilesBackend
-initSessions hp = sinit $ sessionsPath hp
+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 :: SessionBackend b => b -> Request -> IO Session
-session b rq =
+session :: SessionsConnection -> Request -> IO Session
+session (SConnection b) rq =
if null (trace sid sid)
then do n <- getStdRandom (randomR (100,maxBound::Int))
return $ NewSession (show n)
@@ -76,4 +87,5 @@ session b rq =
return $ ExistingSession sid mm
where sid = getcookie rq "SessionID"
+sessionCookie :: String -> String -> HttpHeader
sessionCookie exp sid = setcookie exp "SessionID" sid
diff --git a/TemplateUtil.hs b/TemplateUtil.hs
index 3fa9dbe..16f1a95 100644
--- a/TemplateUtil.hs
+++ b/TemplateUtil.hs
@@ -1,6 +1,8 @@
module TemplateUtil
(render,
- renderToResponse)
+ renderToResponse,
+ renderToResponseC
+ )
where
import qualified Data.Map as M
@@ -9,6 +11,17 @@ import Network.Shed.Httpd
import HTTPServer (ok)
import Templates (render)
import Types
+import API
+import Cache
+
+instance (Ord k, Show k,Show v, Read k, Read v) => Serializable (M.Map k v) where
+ toString = show
+ fromString = read
renderToResponse :: String -> [(String,TContainer)] -> Response
renderToResponse name pairs = ok $! render name (M.fromList pairs)
+
+renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> [(String,TContainer)] -> IO Response
+renderToResponseC (ActionConfig{cacheBackend=b}) key name pairs = do
+ v <- cached b ("render:"++name) key (render name) (M.fromList pairs)
+ return $ ok v
diff --git a/Types.hs b/Types.hs
index 70b0503..35ab569 100644
--- a/Types.hs
+++ b/Types.hs
@@ -43,7 +43,9 @@ data HttpActionParams = HP {
hLog :: Channel,
dbDriver :: String,
dbPath :: String,
+ cacheDriver :: String,
cachePath :: String,
+ sessionsDriver :: String,
sessionsPath :: String
}
diff --git a/Urls.hs b/Urls.hs
index 3acfef5..7380435 100644
--- a/Urls.hs
+++ b/Urls.hs
@@ -3,14 +3,14 @@ module Urls where
import Text.Regex.PCRE
import Network.URI
-import Network.Shed.Httpd
+import Network.Shed.Httpd(reqBody,Response,reqURI,Request,queryToArguments)
import Data.List
import Utils
import Types
urlSplit :: URI -> URLParts
-urlSplit (URI {uriPath}) = splitWith (=='/') uriPath
+urlSplit uri = splitWith (=='/') (uriPath uri)
urlJoin :: URLParts -> String
urlJoin us = concat $ intersperse "/" us
diff --git a/test.db b/test.db
index f88f896..f9e9c62 100644
Binary files a/test.db and b/test.db differ
diff --git a/test.hs b/test.hs
index 72815ff..11e7b4f 100644
--- a/test.hs
+++ b/test.hs
@@ -18,13 +18,16 @@ import API
-- testing _ _ = return $ ok "Happy new year!"
+printyear :: StrAction
printyear _ _ s = let year = read s :: Int
in if year < 2010
then Just $ return $ ok $ "<p>Blog posts for year "++s++":</p>"
else Just $ return $ ok $ "<h1>Year in the future</h1>"
+manyfun :: ManyStrAction
manyfun _ _ [y,m] = Just $ return $ ok $ "<p> Blog posts for "++y++"/"++m++": </p>"
+formfun :: HttpAction
formfun _ rq@(Request {reqMethod}) =
case reqMethod of
"GET" -> return $ renderToResponse "testform.html" [("title", C (title::String))]
@@ -33,53 +36,49 @@ formfun _ rq@(Request {reqMethod}) =
where title = httpGetVar' rq "title" "Nothing"
testval = httpPostVar' rq "title" "Empty"
-printUsers hp rq@(Request {reqMethod}) = withConfig hp rq $ \conf -> do
- filled <- sessionLookup conf "filled"
+printUsers :: HttpActionParams -> Request -> IO Response
+printUsers hp rq = withConfig hp rq $ \conf -> do
- let defvals = decodePairs filled
-
- let form = if null err
- then createform userForm "1" url
- else editform (words err) userForm "1" defvals url
-
- case reqMethod of
+ (form, err) <- retryForm conf userForm "1" url
+ case reqMethod rq of
"GET" -> do
- 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)]
+ us <- queryR' conf "SELECT * FROM users" [] :: IO [User]
+ let key = (show $ length us)++(show err)++(show $ length form)
+ renderToResponseC conf key "first.html" [("users", C us),
+ ("title", C "Some title"),
+ ("list", C ["first","second","third"]),
+ ("include",C "inctest.html"),
+ ("form", C form),
+ ("invalid",C err)]
"POST" -> do
- case defValidate userForm "1" rq of
- Right user -> let uname = _username user
- upass = _password user
- in do query conf "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname, SqlString upass]
- commit conf
- return $ redirect url
- Left e -> do sessionSet conf "filled" values
- return $ redirectG url ["invalid" =: (unwords e)]
-
+ let (d,_) = getForm allForms rq "userform"
+ case d of
+ Right user -> let uname = _username user
+ upass = _password user
+ in do query conf "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname, SqlString upass]
+ commit conf
+ return $ redirect url
+ Left e -> returnInvalidForm conf userForm "1" e
where url = myUrl rq
- err = httpGetVar' rq "invalid" ""
- values = tail $ urlencode $ map packHeader vars
- vars = formVars userForm "1" rq
-
+urlconf :: URLConf
urlconf = "blog" // year ~/ month ~>> manyfun
<|> "blog" // year ~> printyear
<|> "users" --> printUsers
<|> "form" --> formfun
<|> Function serveStatic
+params :: HttpActionParams
params = HP { docdir = "www",
hLog = stdout,
dbDriver = "sqlite3",
dbPath = "test.db",
- cachePath = "tmp/",
+ cacheDriver = "memcached",
+ cachePath = "localhost:11211",
+ sessionsDriver = "files",
sessionsPath = "tmp/sessions/"
}
+main :: IO ()
main = serveHttp 8080 params urlconf