diff --git a/.gitignore b/.gitignore
index f7bef94..895fb45 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,3 +7,5 @@ Templates.hs
TypesI.hs
*.swp
.*.swp
+tmp
+tmp/*
diff --git a/Cache.hs b/Cache.hs
new file mode 100644
index 0000000..0414ace
--- /dev/null
+++ b/Cache.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Cache
+ (initCache,
+ cget,cput,
+ cfree
+ ) where
+
+import System.Directory
+import System.FilePath ((</>))
+import System.IO
+import Control.Exception
+
+import Network.Memcache (Memcache)
+import qualified Network.Memcache as MC
+import qualified Network.Memcache.Protocol as SMC
+import Network.Memcache.Serializable (Serializable(..))
+
+import Utils
+
+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 ()
+
+data MemcacheBackend = MB SMC.Server
+data FilesystemBackend = FB String
+data FakeBackend = Fake
+
+instance CacheBackend MemcacheBackend where
+ cinit str = do
+ s <- SMC.connect host (fromIntegral $ read port)
+ return $ MB s
+ where [host,port] = splitWith (==':') str
+
+ cget (MB s) name = MC.get s name
+ cput (MB s) name value = MC.set s name value
+ cfree (MB s) = SMC.disconnect s
+
+instance CacheBackend FilesystemBackend where
+ cinit str = return $ FB str
+
+ cget (FB path) name = do
+ b <- doesFileExist file
+ if b
+ then do s <- readFile file
+ return $ fromString s
+ else return Nothing
+ where file = path </> name
+
+ cput (FB path) name value = handle hndl $ do
+ writeFile (path </> name) (toString value)
+ return True
+ where hndl :: IOException -> IO Bool
+ hndl _ = return False
+
+ cfree _ = return ()
+
+instance CacheBackend FakeBackend where
+ cinit _ = return Fake
+ cget _ _ = return Nothing
+ cput _ _ _ = return True
+ cfree _ = return ()
+
+initCache :: String -> IO FilesystemBackend
+initCache s = cinit s
diff --git a/Cookies.hs b/Cookies.hs
new file mode 100644
index 0000000..11db2e8
--- /dev/null
+++ b/Cookies.hs
@@ -0,0 +1,35 @@
+module Cookies where
+
+import Debug.Trace
+
+import System.Time
+import System.Locale
+import Data.Char
+import Network.Shed.Httpd
+
+import Types
+import Utils
+import Urls
+import 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 (trace (show cc) 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/Forms.hs b/Forms.hs
index 5439b22..3343f92 100644
--- a/Forms.hs
+++ b/Forms.hs
@@ -1,11 +1,12 @@
-{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns #-}
+{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-}
module Forms
(Inputbox, Textarea,
inputbox, textarea,
tag,
- createform,
+ createform, editform,
Form (..),
FormField (..),
+ formVars, formVarsNames, formVarsValues,
notEmpty, noValidate,
defValidate
) where
@@ -19,19 +20,33 @@ import Types
import Urls
class Widget w where
- html :: w -> String -> String
-
-data Inputbox = Inputbox { ibWidth :: HttpBox, ibValue :: String }
-inputbox = Inputbox (HB (Nothing::Maybe Int))
-
-data Textarea = Textarea { tbCols :: HttpBox, tbRows :: HttpBox, tbValue :: String }
-textarea = Textarea (HB (Nothing::Maybe Int)) (HB (Nothing::Maybe Int))
-
-createform (Form {fFields}) action = tag "form" [("method", HB "POST"),("action", HB action)] content
- where formrow (Field name "" widget f) = formrow (Field name ((capitalize name)++":") widget f)
- formrow (Field name label widget _) = "<tr><td>"++label++"</td><td>"++(html widget name)++"</td>\n"
- submit = "<tr><td></td><td><input type='submit'/></td></tr>\n"
- content = "<table>\n"++(concat $ map formrow fFields)++submit++"</table>\n"
+ type WContent w
+ html :: w -> String -> String -> String
+ wRead :: String -> WContent w
+
+makeform :: (HttpValue a) => a -> String -> String
+makeform action = tag "form" [("method", HB "POST"),("action", HB action)]
+
+formrow :: (HttpValue [a]) => String -> [a] -> FormField -> String
+formrow def cls (Field name "" widget f) = formrow def cls (Field name ((capitalize name)++":") widget f)
+formrow def cls (Field name label widget _) = tag "tr" attrs $ (tag "td" [] label)++(tag "td" [] (html widget name def))
+ where attrs = if null cls
+ then []
+ else [("class", HB cls)]
+
+submit :: String
+submit = "<tr><td></td><td><input type='submit'/></td></tr>\n"
+
+createform :: (HttpValue a) => Form -> a -> String
+createform (Form {fFields}) action = makeform action content
+ where content = tag' "table" [] (concat $ map (formrow "" "") fFields)++submit
+
+editform :: (HttpValue a) => [String] -> Form -> [(String,String)] -> a -> String
+editform errfields (Form {fFields}) pairs action = makeform action content
+ where content = tag' "table" [] (concat $ zipWith3 formrow vals clss fFields)++submit
+ vals = map (\n -> maybe "" id $ lookup n pairs) names
+ names = map fName fFields
+ clss = map (\n -> if n `elem` errfields then "error" else "") names
htmlAttr :: String -> HttpBox -> String
htmlAttr name value | httpEmpty value = ""
@@ -43,46 +58,80 @@ tag name attrs value = "<"++name++(concat $ map (uncurry htmlAttr) attrs)++conte
then " /"
else ">"++value++"</"++name
+tag' :: String -> [(String,HttpBox)] -> String -> String
+tag' name attrs value = "<"++name++(concat $ map (uncurry htmlAttr) attrs)++content++">\n"
+ where content = if null value
+ then " /"
+ else ">\n"++value++"</"++name
+
+data Inputbox = Inputbox { ibWidth :: HttpBox }
+inputbox = Inputbox (HB (Nothing::Maybe Int))
+
+data Textarea = Textarea { tbCols :: HttpBox, tbRows :: HttpBox }
+textarea = Textarea (HB (Nothing::Maybe Int)) (HB (Nothing::Maybe Int))
+
instance Widget Inputbox where
- html (Inputbox w v) name = tag "input" [("size", HB w), ("name", HB name)] v
+ type WContent Inputbox = String
+ html (Inputbox w) name value = tag "input" [("size", HB w), ("name", HB name), ("value", HB value)] ""
+ wRead = id
instance Widget Textarea where
- html (Textarea c r v) name = tag "textarea" [("cols", HB c), ("rows", HB r), ("name", HB name)] v
+ type WContent Textarea = String
+ html (Textarea c r) name value = tag "textarea" [("cols", HB c), ("rows", HB r), ("name", HB name)] value
+ wRead = id
+
+type FormValidator a = Request -> Either [String] a
+type FieldValidator = String -> Either String String
data FormField = forall w. (Widget w) => Field {
fName :: String,
fLabel :: String,
fWidget :: w,
- fValidate :: String -> Either String String
+ fValidate :: FieldValidator
}
-data (Table a) => Form a = Form {
+data Form = Form {
fFields :: [FormField]
}
+isRight :: Either t1 t -> Bool
isRight (Right _) = True
isRight _ = False
+isLeft :: Either t1 t -> Bool
isLeft = not.isRight
+fromRight :: Either t1 t -> t
fromRight (Right x) = x
fromRight _ = error "fromRight applicable only to Right arguments!"
+fromLeft :: Either t t1 -> t
fromLeft (Left x) = x
fromLeft _ = error "fromLeft applicable only to Left arguments!"
-defValidate :: (Table a) => Form a -> Request -> Either String a
-defValidate (Form {fFields}) rq =
+defValidate :: (Table a) => Form -> FormValidator a
+defValidate form@(Form {fFields}) rq =
if all isRight maybes
then Right $ record $ map (D.toSql . fromRight) maybes
- else Left $ unwords $ map fromLeft $ filter isLeft maybes
+ else Left $ map fromLeft $ filter isLeft maybes
where maybes :: [Either String String]
maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) fFields) vars
vars :: [String]
- vars = map (\name -> httpPostVar' rq name "") $ map fName fFields
+ vars = formVarsValues form rq
+
+formVarsValues :: Form -> Request -> [String]
+formVarsValues form rq = map (\name -> httpPostVar' rq name "") (formVarsNames form)
+
+formVarsNames :: Form -> [String]
+formVarsNames form = map fName $ fFields form
+
+formVars :: Form -> Request -> [(String,String)]
+formVars form rq = zip (formVarsNames form) (formVarsValues form rq)
+notEmpty :: String -> FieldValidator
notEmpty msg s = if null s
then Left msg
else Right s
+noValidate :: FieldValidator
noValidate s = Right s
diff --git a/HTTPServer.hs b/HTTPServer.hs
index b251fad..0842b1c 100644
--- a/HTTPServer.hs
+++ b/HTTPServer.hs
@@ -12,26 +12,39 @@ import Types
import Urls
import Utils
-response :: Int -> [(String, HttpBox)] -> String -> Response
-response code pairs body = Response code [(n,httpShow v) | (n,v) <- pairs, not (httpEmpty v)] body
+repackHeader :: HttpHeader -> (String,String)
+repackHeader (n := v) = (n, httpShow v)
+
+packHeader :: (String,String) -> HttpHeader
+packHeader (n,v) = (n =: v)
+
+response :: Int -> [HttpHeader] -> String -> Response
+response code pairs body = Response code (map repackHeader $ filter notEmptyHeader pairs) body
+ where notEmptyHeader (_:=v) = not $ httpEmpty v
+
+(<+>) :: Response -> HttpHeader -> Response
+(Response c hdrs b) <+> hdr = Response c (hdrs++[repackHeader hdr]) b
+
+(<++>) :: Response -> [HttpHeader] -> Response
+(Response c old b) <++> new = Response c (old++(map repackHeader new)) b
ok :: String -> Response
-ok body = response 200 [("Content-Type", HB mime)] body
+ok body = response 200 ["Content-Type" =: mime] body
where mime = "text/html"
redirect :: String -> Response
-redirect url = response 302 [("Location", HB url)] ""
+redirect url = response 302 ["Location" =: url] ""
redirectP :: String -> Response
-redirectP url = response 301 [("Location", HB url)] ""
+redirectP url = response 301 ["Location" =: url] ""
-redirectG :: String -> [(String,HttpBox)] -> Response
-redirectG url pairs = redirect $ url++(urlencode pairs)
+redirectG :: String -> [UrlParam] -> Response
+redirectG url pairs = redirect $ url ? pairs
sendfile :: String -> IO Response
sendfile filename = do
body <- readFile filename
- return $ response 200 [("Content-Type", HB mime)] body
+ return $ response 200 ["Content-Type" =: mime] body
where mime = chooseMime filename
diff --git a/Makefile b/Makefile
index 737b73b..19eab00 100644
--- a/Makefile
+++ b/Makefile
@@ -8,7 +8,7 @@ TemplateGen: TemplateGen.hs
Templates.hs:
./TemplateGen
-test:
+test: *.hs
$(GHC) test.hs
clean:
diff --git a/Models.hs b/Models.hs
index 40d590d..baa5fce 100644
--- a/Models.hs
+++ b/Models.hs
@@ -28,6 +28,6 @@ instance TemplateOne User where
boolField _ = error "undefined boolField for User"
userForm = Form {
- fFields = [ Field "name" "Username:" (inputbox "") (notEmpty "name"),
- Field "password" "" (inputbox "") noValidate ]
+ fFields = [ Field "name" "Username:" inputbox (notEmpty "name"),
+ Field "password" "" inputbox noValidate ]
}
diff --git a/Sessions.hs b/Sessions.hs
new file mode 100644
index 0000000..1caadbf
--- /dev/null
+++ b/Sessions.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Sessions
+ (SessionID, SessionMap,
+ Session (..),
+ initSessions,
+ sfetch,spush,sfree,
+ session,
+ sessionCookie
+ ) 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
+
+import Types
+import Utils
+import Cookies
+import 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 FilesBackend = FB String
+
+instance SessionBackend FilesBackend where
+ sinit path = return $ FB path
+
+ sfetch (FB path) sid = do
+ b <- doesFileExist file
+ if b
+ then do s <- readFile file
+ 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
+ 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
+
+session :: SessionBackend b => b -> Request -> IO Session
+session b rq =
+ if null (trace sid 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 exp sid = setcookie exp "SessionID" sid
diff --git a/TemplateParser.hs b/TemplateParser.hs
index 85935b8..30f7978 100644
--- a/TemplateParser.hs
+++ b/TemplateParser.hs
@@ -104,9 +104,6 @@ pIncludeVar = do
-----------------------------------------------------------------------------------
-- Parser utilites
-trim = trimR . trimR
- where trimR = reverse . dropWhile isSpace
-
words' x = init ws ++ [v,t]
where ws = words x
[v,t] = splitWith (==':') (last ws)
diff --git a/Types.hs b/Types.hs
index 8aeade9..3c1238d 100644
--- a/Types.hs
+++ b/Types.hs
@@ -40,7 +40,9 @@ data HttpActionParams = HP {
docdir :: String,
hLog :: Channel,
dbDriver :: String,
- dbPath :: String
+ dbPath :: String,
+ cachePath :: String,
+ sessionsPath :: String
}
class HttpValue v where
@@ -77,6 +79,12 @@ instance HttpValue HttpBox where
httpEmpty (HB x) = httpEmpty x
httpShow (HB x) = httpShow x
+data HttpHeader = String := HttpBox
+type UrlParam = HttpHeader
+
+(=:) :: (HttpValue v) => String -> v -> HttpHeader
+name =: value = name := (HB value)
+
class Table t where
record :: [D.SqlValue] -> t
diff --git a/Urls.hs b/Urls.hs
index f153caf..ecb3d5d 100644
--- a/Urls.hs
+++ b/Urls.hs
@@ -77,13 +77,13 @@ infixr 6 <|>
(>=>) = After
infixr 6 >=>
-------------------------------------------------------------------------------------------------
---
-replace :: (Eq a) => a -> a -> [a] -> [a]
-replace ch1 ch2 = map (\c -> if c==ch1 then ch2 else c)
+-----------------------------------------------------------------------------------------------
-replaceplus = replace '+' ' '
+(?) :: String -> [UrlParam] -> String
+url ? pairs = url++(urlencode pairs)
+------------------------------------------------------------------------------------------------
+--
httpGetVar :: Request -> String -> Maybe String
httpGetVar rq name = lookup name pairs
where pairs = queryToArguments $ uriQuery $ reqURI rq
@@ -94,13 +94,17 @@ httpGetVar' rq name def = maybe def id $ lookup name pairs
httpPostVar :: Request -> String -> Maybe String
httpPostVar rq name = lookup name pairs
- where pairs = queryToArguments $ replaceplus ('?':(reqBody rq))
+ where pairs = decodePairs (reqBody rq)
httpPostVar' :: Request -> String -> String -> String
httpPostVar' rq name def = maybe def id $ lookup name pairs
- where pairs = queryToArguments $ replaceplus ('?':(reqBody rq))
+ where pairs = decodePairs (reqBody rq)
+
+decodePairs s = queryToArguments $ replaceplus ('?':s)
+decodePair = head.decodePairs
urlencode pairs = '?':(concat $ intersperse "&" $ map escapePair pairs)
- where escapePair (n,v) = (esc n)++"="++(esc $ httpShow v)
- esc = escapeURIString isAllowedInURI
+ where escapePair (n:=v) = (esc n)++"="++(esc $ httpShow v)
+
+esc = escapeURIString isAllowedInURI
diff --git a/Utils.hs b/Utils.hs
index f15654f..e1af19f 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -55,3 +55,16 @@ capitalize (x:xs) = (toUpper x):xs
commas :: [String] -> String
commas lst = concat $ intersperse ", " lst
+
+replaceChar :: (Eq a) => a -> a -> [a] -> [a]
+replaceChar ch1 ch2 = map (\c -> if c==ch1 then ch2 else c)
+
+replaceplus = replaceChar '+' ' '
+
+spliteq s = let n = takeWhile (/='=') s
+ v = dropWhile (/='=') s
+ in (n, tail v)
+
+trim = trimR . trimR
+ where trimR = reverse . dropWhile isSpace
+
diff --git a/templates/first.html b/templates/first.html
index e619ad9..8d10a2c 100644
--- a/templates/first.html
+++ b/templates/first.html
@@ -9,8 +9,8 @@
{%include gohome.html%}
{%includevar include%}
- {%if errormsg%}
- <p>Error: {{errormsg}}</p>
+ {%if invalid%}
+ <p>Error: These fields should be filled: {{invalid}}</p>
{%endif%}
<table>
diff --git a/test.db b/test.db
index c9bb6bb..f88f896 100644
Binary files a/test.db and b/test.db differ
diff --git a/test.hs b/test.hs
index 97031b6..236dbe0 100644
--- a/test.hs
+++ b/test.hs
@@ -1,6 +1,10 @@
{-# LANGUAGE NamedFieldPuns #-}
+
+import Debug.Trace
+
import System.IO
import Network.Shed.Httpd
+import qualified Data.Map as M
import Types
import Urls
@@ -10,6 +14,8 @@ import TemplateUtil
import Storage
import Models
import Forms
+import Sessions
+import Cookies
-- testing _ _ = return $ ok "Happy new year!"
@@ -24,11 +30,27 @@ formfun _ rq@(Request {reqMethod}) =
case reqMethod of
"GET" -> return $ renderToResponse "testform.html" [("title", C (title::String))]
"POST" -> do print (reqBody rq)
- return $ redirectG "/form/" [("title", HB testval)]
+ return $ redirectG "/form/" ["title" =: testval]
where title = httpGetVar' rq "title" "Nothing"
testval = httpPostVar' rq "title" "Empty"
-printUsers hp rq@(Request {reqMethod}) =
+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')
+
+ let defvals = decodePairs filled
+
+ let form = if null err
+ then createform userForm url
+ else editform (words err) userForm defvals url
+
case reqMethod of
"GET" -> do
conn <- connect' hp
@@ -39,7 +61,7 @@ printUsers hp rq@(Request {reqMethod}) =
("list", C ["first","second","third"]),
("include",C "inctest.html"),
("form", C form),
- ("errormsg", C err)]
+ ("invalid",C err)] <+> (sessionCookie ed sid)
"POST" -> do
case defValidate userForm rq of
Right user -> let uname = _username user
@@ -49,11 +71,14 @@ printUsers hp rq@(Request {reqMethod}) =
commit conn
disconnect conn
return $ redirect url
- Left e -> return $ redirectG url [("errormsg", HB ("This fields should be filled: "++e))]
+ Left e -> do spush sb sid $ M.fromList [("filled",values)]
+ return $ redirectG url ["invalid" =: (unwords e)] <+> (sessionCookie ed sid)
- where form = createform userForm url
- url = "/users/"
- err = httpGetVar' rq "errormsg" ""
+ where url = "/users/"
+ err = httpGetVar' rq "invalid" ""
+ values = tail $ urlencode $ map packHeader vars
+ vars = formVars userForm rq
+
urlconf = "blog" // year ~/ month ~>> manyfun
<|> "blog" // year ~> printyear
@@ -64,7 +89,9 @@ urlconf = "blog" // year ~/ month ~>> manyfun
params = HP { docdir = "www",
hLog = stdout,
dbDriver = "sqlite3",
- dbPath = "test.db"
+ dbPath = "test.db",
+ cachePath = "tmp/",
+ sessionsPath = "tmp/sessions/"
}
main = serveHttp 8080 params urlconf