diff --git a/API.hs b/API.hs deleted file mode 100644 index 4b92447..0000000 --- a/API.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# 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 qualified Urls -import qualified Cache -import HTTPServer ((<+>)) - -data ActionConfig = ActionConfig { - request :: Httpd.Request, - httpParams :: HttpActionParams, - dbconnection :: Storage.DBConnection, - sessionID :: Sessions.SessionID, - sessionMap :: Sessions.SessionMap, - sessionsBackend :: Sessions.SessionsConnection, - cacheBackend :: Cache.CacheConnection, - 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 (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, - dbconnection = conn, - sessionID = sid, - sessionMap = mm, - sessionsBackend = sb, - cacheBackend = cc, - cookiesExp = ed - } - resp <- f conf - Storage.disconnect conn - Cache.cFree cc - Sessions.sFree sb - return $ resp <+> Sessions.sessionCookie ed sid - diff --git a/Cache.hs b/Cache.hs deleted file mode 100644 index 24784e7..0000000 --- a/Cache.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Cache - ( -- $doc - initCache, - cGet,cPut, - cached, - cFree, - Serializable (..), - CacheConnection - ) where - -import System.Directory(doesFileExist) -import System.FilePath ((</>)) -import Control.Exception(handle,IOException) - -import Network.Memcache (Memcache) -import qualified Network.Memcache as MC -import qualified Network.Memcache.Protocol as SMC -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 -- ^ 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 -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 () - --- | 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/Cookies.hs b/Cookies.hs deleted file mode 100644 index 11db2e8..0000000 --- a/Cookies.hs +++ /dev/null @@ -1,35 +0,0 @@ -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 deleted file mode 100644 index 9c4234c..0000000 --- a/Forms.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} -module Forms - ( -- $doc - Inputbox, Textarea, - inputbox, textarea, - tag, - createform, editform, - retryForm, returnInvalidForm, - Form (..), - FormField (..), - formVars, formVarsNames, formVarsValues, - notEmpty, noValidate, - defValidate, - getAnyForm, getForm - ) where - -import qualified Data.Map as M -import Data.Maybe - -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 -- ^ 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 - then [] - else ["class" =: cls] - itemlabel = if null label - then (capitalize name)++":" - else label - itemname = fname++fid++"-"++name - -submit :: String -submit = "<tr><td></td><td><input type='submit'/></td></tr>\n" - --- | 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 - --- | 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 - names = map fName (fFields form) - 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)++"'" - -tag :: String -> [FormVar] -> String -> String -tag name attrs value = "<"++name++(concat $ map htmlAttr attrs)++content++">" - where content = if null value - then " /" - else ">"++value++"</"++name - -tag' :: String -> [FormVar] -> String -> String -tag' name attrs value = "<"++name++(concat $ map 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 - type WContent Inputbox = String - html (Inputbox w) name value = tag "input" ["size" =: w, "name" =: name, "value" =: value] "" - wRead = id - -instance Widget Textarea where - type WContent Textarea = String - html (Textarea c r) name value = tag "textarea" ["cols" =: c, "rows" =: r, "name" =: 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 :: FieldValidator - } - -data Form = Form { - formName :: String, - 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 -> String -> FormValidator a -defValidate form fid rq = - if all isRight maybes - then Right $ record $ map (D.toSql . fromRight) maybes - else Left $ map fromLeft $ filter isLeft maybes - where maybes :: [Either String String] - maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) (fFields form)) vars - vars :: [String] - vars = formVarsValues form fid rq - -formVarsValues :: Form -> String -> Request -> [String] -formVarsValues form fid rq = map (\name -> httpPostVar' rq name "") (formVarsNames form fid) - -formVarsNames :: Form -> String -> [String] -formVarsNames form fid = map ((formName form)++) $ map (fid++) $ map ("-"++) $ map fName $ fFields form - -formVars :: Form -> String -> Request -> [(String,String)] -formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) - -notEmpty :: String -> FieldValidator -notEmpty msg s = if null s - then Left msg - else Right s - -noValidate :: FieldValidator -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/Framework/API.hs b/Framework/API.hs new file mode 100644 index 0000000..8c64203 --- /dev/null +++ b/Framework/API.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes, NamedFieldPuns #-} +module Framework.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 Framework.Types +import qualified Framework.Utils as Utils +import qualified Framework.Cookies as Cookies +import qualified Framework.Sessions as Sessions +import qualified Framework.Storage as Storage +import qualified Framework.Urls as Urls +import qualified Framework.Cache as Cache +import Framework.HTTPServer ((<+>)) + +data ActionConfig = ActionConfig { + request :: Httpd.Request, + httpParams :: HttpActionParams, + dbconnection :: Storage.DBConnection, + sessionID :: Sessions.SessionID, + sessionMap :: Sessions.SessionMap, + sessionsBackend :: Sessions.SessionsConnection, + cacheBackend :: Cache.CacheConnection, + 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 (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, + dbconnection = conn, + sessionID = sid, + sessionMap = mm, + sessionsBackend = sb, + cacheBackend = cc, + cookiesExp = ed + } + resp <- f conf + Storage.disconnect conn + Cache.cFree cc + Sessions.sFree sb + return $ resp <+> Sessions.sessionCookie ed sid + diff --git a/Framework/Cache.hs b/Framework/Cache.hs new file mode 100644 index 0000000..cb85d20 --- /dev/null +++ b/Framework/Cache.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Framework.Cache + ( -- $doc + initCache, + cGet,cPut, + cached, + cFree, + Serializable (..), + CacheConnection + ) where + +import System.Directory(doesFileExist) +import System.FilePath ((</>)) +import Control.Exception(handle,IOException) + +import Network.Memcache (Memcache) +import qualified Network.Memcache as MC +import qualified Network.Memcache.Protocol as SMC +import Network.Memcache.Serializable (Serializable(..)) + +import Framework.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 -- ^ 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 +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 () + +-- | 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/Framework/Cookies.hs b/Framework/Cookies.hs new file mode 100644 index 0000000..29d9ecc --- /dev/null +++ b/Framework/Cookies.hs @@ -0,0 +1,35 @@ +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 (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/Framework/Forms.hs b/Framework/Forms.hs new file mode 100644 index 0000000..837a403 --- /dev/null +++ b/Framework/Forms.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} +module Framework.Forms + ( -- $doc + Inputbox, Textarea, + inputbox, textarea, + tag, + createform, editform, + retryForm, returnInvalidForm, + Form (..), + FormField (..), + formVars, formVarsNames, formVarsValues, + notEmpty, noValidate, + defValidate, + getAnyForm, getForm + ) where + +import qualified Data.Map as M +import Data.Maybe + +import Network.Shed.Httpd (Request,Response) +import qualified Database.HDBC as D + +import Framework.Types +import Framework.Utils +import Framework.Urls +import Framework.API +import Framework.HTTPServer (redirectG, packHeader) + +-- $doc +-- HTML forms generation and validation. + +-- | Types of this class represent HTML widgets +class Widget w where + -- | Type of widget content; not used at the moment. + type WContent w + -- | Generate HTML for widget + html :: w -- ^ A 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 + then [] + else ["class" =: cls] + itemlabel = if null label + then (capitalize name)++":" + else label + itemname = fname++fid++"-"++name + +submit :: String +submit = "<tr><td></td><td><input type='submit'/></td></tr>\n" + +-- | 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 + +-- | 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 + names = map fName (fFields form) + 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 + -> 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 = 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 -> 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)++"'" + +tag :: String -> [FormVar] -> String -> String +tag name attrs value = "<"++name++(concat $ map htmlAttr attrs)++content++">" + where content = if null value + then " /" + else ">"++value++"</"++name + +tag' :: String -> [FormVar] -> String -> String +tag' name attrs value = "<"++name++(concat $ map 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 + type WContent Inputbox = String + html (Inputbox w) name value = tag "input" ["size" =: w, "name" =: name, "value" =: value] "" + wRead = id + +instance Widget Textarea where + type WContent Textarea = String + html (Textarea c r) name value = tag "textarea" ["cols" =: c, "rows" =: r, "name" =: 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 :: FieldValidator + } + +data Form = Form { + formName :: String, + 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 -> String -> FormValidator a +defValidate form fid rq = + if all isRight maybes + then Right $ record $ map (D.toSql . fromRight) maybes + else Left $ map fromLeft $ filter isLeft maybes + where maybes :: [Either String String] + maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) (fFields form)) vars + vars :: [String] + vars = formVarsValues form fid rq + +formVarsValues :: Form -> String -> Request -> [String] +formVarsValues form fid rq = map (\name -> httpPostVar' rq name "") (formVarsNames form fid) + +formVarsNames :: Form -> String -> [String] +formVarsNames form fid = map ((formName form)++) $ map (fid++) $ map ("-"++) $ map fName $ fFields form + +formVars :: Form -> String -> Request -> [(String,String)] +formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) + +notEmpty :: String -> FieldValidator +notEmpty msg s = if null s + then Left msg + else Right s + +noValidate :: FieldValidator +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/Framework/HTTPServer.hs b/Framework/HTTPServer.hs new file mode 100644 index 0000000..ef767b2 --- /dev/null +++ b/Framework/HTTPServer.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Framework.HTTPServer where + +import Prelude hiding (catch) +import System.IO +import System.Directory +import Control.Exception +import Network.Shed.Httpd +import Network.URI + +import Framework.Types +import Framework.Urls +import Framework.Utils + +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" =: mime] body + where mime = "text/html" + +redirect :: String -> Response +redirect url = response 302 ["Location" =: url] "" + +redirectP :: String -> Response +redirectP url = response 301 ["Location" =: url] "" + +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" =: 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 +-- putStrLn $ "Request: "++show req +-- putStrLn $ "Serving "++uriPath + runURLConf hap req (tail uriPath) conf + +defaultURLConf :: URLConf +defaultURLConf = Function serveStatic + +serveHttp :: Int -> HttpActionParams -> URLConf -> IO () +serveHttp port hap conf = initServer port (httpWorker hap conf) + diff --git a/Framework/Makefile b/Framework/Makefile new file mode 100644 index 0000000..94d36e5 --- /dev/null +++ b/Framework/Makefile @@ -0,0 +1,10 @@ +GHC=ghc --make -O2 -i. -i../ + +all: API.o + +API.o: *.hs + $(GHC) API.hs + +clean: + rm *.o *.hi + diff --git a/Framework/Middlewares.hs b/Framework/Middlewares.hs new file mode 100644 index 0000000..a000ebf --- /dev/null +++ b/Framework/Middlewares.hs @@ -0,0 +1,6 @@ +module Framework.Middlewares where + +import Network.Shed.Httpd (Request,Response) + +type RequestMiddleware = Request -> IO Request +type ResponseMiddleware = Response -> IO Response diff --git a/Framework/Models.hs b/Framework/Models.hs new file mode 100644 index 0000000..3acdf72 --- /dev/null +++ b/Framework/Models.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleInstances,NoMonomorphismRestriction, ExistentialQuantification #-} +module Framework.Models where + +import qualified Data.Map as M +import Database.HDBC (fromSql) + +import Framework.Types +import Framework.Storage +import Framework.Forms + +data User = User { + _userId :: Int, + _username :: String, + _password :: String } + +userId :: (TemplateOne a) => a -> Int +userId = transformInt 1 id +username :: (TemplateItem a) => a -> String +username = transformString 1 id +password :: (TemplateOne a) => a -> String +password = transformString 2 id + +instance Table User where + record [uId, uName, uPass] = User (fromSql uId) (fromSql uName) (fromSql uPass) + record [uName,uPass] = User 0 (fromSql uName) (fromSql uPass) + +instance TemplateOne User where + showO (User uId uName uPass) = "#"++(show uId)++". "++(show uName)++" -- "++(show uPass) + intField _ = _userId + stringField 1 = _username + stringField 2 = _password + boolField _ = error "undefined boolField for User" + +userForm = Form { + formName = "userform", + 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/Framework/Sessions.hs b/Framework/Sessions.hs new file mode 100644 index 0000000..e903b7c --- /dev/null +++ b/Framework/Sessions.hs @@ -0,0 +1,91 @@ +{-# 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 + 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 (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 :: String -> String -> HttpHeader +sessionCookie exp sid = setcookie exp "SessionID" sid diff --git a/Framework/Storage.hs b/Framework/Storage.hs new file mode 100644 index 0000000..7f8e89e --- /dev/null +++ b/Framework/Storage.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, EmptyDataDecls, TypeFamilies, NoMonomorphismRestriction, NamedFieldPuns #-} +module Framework.Storage + (DBConnection, Table (..), + connect, connect', + commit, + disconnect, + query, query', queryR, queryR', + getTable + ) + where + +import qualified Database.HDBC.Sqlite3 as Sqlite3 +import qualified Database.HDBC as D + +import Framework.Types + +data DBConnection = forall c. D.IConnection c => DBC c + +connect :: String -> String -> IO DBConnection +connect "sqlite3" file = DBC `fmap` (Sqlite3.connectSqlite3 file) + +connect' :: HttpActionParams -> IO DBConnection +connect' (HP {dbDriver, dbPath}) = connect dbDriver dbPath + +disconnect :: DBConnection -> IO () +disconnect (DBC conn) = D.disconnect conn + +query :: DBConnection -> String -> [D.SqlValue] -> IO [[D.SqlValue]] +query (DBC conn) sql params = D.quickQuery conn sql params + +query' :: DBConnection -> String -> [D.SqlValue] -> IO [[D.SqlValue]] +query' (DBC conn) sql params = D.quickQuery' conn sql params + +commit :: DBConnection -> IO () +commit (DBC conn) = D.commit conn + +getTable :: forall t. (Table t) => DBConnection -> String -> IO [t] +getTable (DBC conn) name = do + res <- D.quickQuery conn ("SELECT * FROM "++name) [] + return (map record res :: [t]) + +queryR :: forall t. (Table t) => DBConnection -> String -> [D.SqlValue] -> IO [t] +queryR (DBC conn) sql params = do + res <- D.quickQuery conn sql params + return (map record res :: [t]) + +queryR' :: forall t. (Table t) => DBConnection -> String -> [D.SqlValue] -> IO [t] +queryR' (DBC conn) sql params = do + res <- D.quickQuery' conn sql params + return (map record res :: [t]) + diff --git a/Framework/TEngine/Makefile b/Framework/TEngine/Makefile new file mode 100644 index 0000000..dc717a6 --- /dev/null +++ b/Framework/TEngine/Makefile @@ -0,0 +1,3 @@ + +clean: + rm *.hi *.o diff --git a/Framework/TEngine/TemplateFuncs.hs b/Framework/TEngine/TemplateFuncs.hs new file mode 100644 index 0000000..9ffdaa6 --- /dev/null +++ b/Framework/TEngine/TemplateFuncs.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Framework.TEngine.TemplateFuncs + (bold, + uppercase,lowercase, + evenP,oddP, + list + ) where + +import Data.Char +import Data.List + +import Framework.Types + +_bold s = "<strong>"++s++"</strong>" +bold = transformString 1 _bold + +uppercase = transformString 1 $ map toUpper +lowercase = transformString 1 $ map toLower + +evenP = transformInt 1 even +oddP = transformInt 1 odd + +list :: String -> (String -> String) -> SFunction +list sep f lst = concat $ intersperse sep $ map (transform f) (mkList lst) + where transform f = \(C x) -> f (stringField 1 x) + +separateWith :: String -> SFunction +separateWith s = list s id diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs new file mode 100644 index 0000000..f730db9 --- /dev/null +++ b/Framework/TEngine/TemplateUtil.hs @@ -0,0 +1,27 @@ +module Framework.TEngine.TemplateUtil + (render, + renderToResponse, + renderToResponseC + ) + where + +import qualified Data.Map as M +import Network.Shed.Httpd + +import Framework.HTTPServer (ok) +import Framework.TEngine.Templates (render) +import Framework.Types +import Framework.API +import Framework.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/Framework/TGenerator/Makefile b/Framework/TGenerator/Makefile new file mode 100644 index 0000000..b06fb39 --- /dev/null +++ b/Framework/TGenerator/Makefile @@ -0,0 +1,9 @@ +GHC=ghc --make -O2 -i. -i../../ + +all: TemplateGen + +TemplateGen: TemplateGen.hs TemplateParser.hs + $(GHC) TemplateGen.hs + +clean: + rm TemplateGen diff --git a/Framework/TGenerator/TemplateGen.hs b/Framework/TGenerator/TemplateGen.hs new file mode 100644 index 0000000..ea41494 --- /dev/null +++ b/Framework/TGenerator/TemplateGen.hs @@ -0,0 +1,134 @@ +import System.IO +import System.Environment +import Data.List +import Data.Char +import Data.String.Utils +import System.Directory +import System.FilePath ((</>)) +import Control.Monad +import qualified Data.Map as M + +import Framework.Utils +import TemplateParser + +-------------------------------------------------------------------------------------------------- +-- Code generator +-------------------------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------------------------- +-- Generator's utilites +-------------------------------------------------------------------------------------------------- + +quote s = "\""++s++"\"" +getvar v = "maybe \"\" showC (M.lookup "++quote v++" pairs)" + +getlist n = "maybe (C ([]::[Int])) id (M.lookup "++quote n++" pairs)" + +hash t = sum $ map hashF t +hash' = show.hash + +hashF (Verbatim s) = hashS s +hashF (Quote ss) = sum (map hashS ss) +hashF (ForTag ss t) = sum (map hashS ss) + hash t +hashF (IfTag ss t p) = sum (map hashS ss) + hash t + hash p + +hashS s = length s + (sum $ map ord s) + +nl = "\n" + +mapS start f [] = ([], start) +mapS start f (x:xs) = (z:zs, res) + where y = f start x + z = fst y + t = mapS (snd y) f xs + zs = fst t + res = snd t + +joinMap f lst = (concat $ intersperse ", \n" $ (fst m), snd m) + where m = mapS M.empty f lst + +genTemplate :: String -> Template -> String +genTemplate name tpl = if name=="0" + then "" + else "render \""++name++"\" pairs = concat [\n" ++ (fst j) ++ "]" ++ nl ++ renderSubs ++ nl + where j = joinMap genFormat tpl + renderSubs = case M.assocs $ snd j of + [] -> "" + lst -> concat $ map (uncurry genTemplate) lst + +joinList lst = concat $ intersperse ",\n" $ map (" "++) $ map quote lst +quoteLines s = joinList $ map (replace "\"" "\\\"") $ lines s + +undollars = unwords + +genquote xs = + if null fs + then getvar x + else "("++(undollars fs)++") `tmap` (M.lookup "++(quote x)++" pairs)" + where + fs = init xs + x = last xs + +genquoteB xs = + if null fs + then "isTrue `bmap` (M.lookup "++(quote x)++" pairs)" + else "("++(undollars fs)++") `bmap` (M.lookup "++(quote x)++" pairs)" + where + fs = init xs + x = last xs + +genFormat m (Verbatim s) = (quoteLines s, m) +genFormat m (Quote v) = (" "++genquote v, m) +genFormat m (ForTag [v,lst] tpl) = (" mapF "++(quote v)++" (render \""++ h ++"\") pairs $ "++(getlist lst), M.insert h tpl m) + where h = hash' tpl +genFormat m (IfTag v tpl1 tpl2) = (" render (if "++(genquoteB v)++" then "++(quote h1)++" else "++(quote h2)++") pairs", + M.insert h1 tpl1 $ M.insert h2 tpl2 m) + where h1 = hash' tpl1 + h2 = hash' tpl2 +genFormat m (Include s) = (" render "++(quote s)++" pairs", m) +genFormat m (IncludeVar v) = (" render ("++(getvar v)++") pairs", m) + +preamble h = do +-- hPutStrLn h "{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, OverlappingInstances #-}" + hPutStrLn h "module Framework.TEngine.Templates where" + hPutStrLn h "import qualified Data.Map as M" + hPutStrLn h "import Data.List" + hPutStrLn h "import Framework.Types" + hPutStrLn h "import Framework.Models" + hPutStrLn h "import Framework.Utils" + hPutStrLn h "import Framework.TEngine.TemplateFuncs" + hPutStrLn h "" + hPutStrLn h "render :: String -> M.Map String TContainer -> String" + +endrender h = do + hPutStrLn h "render \"0\" _ = \"\"" + hPutStrLn h "render _ _ = \"<h1>No such template!</h1>\"" + +------------------------------------------------------------------------------------------------------------------------------------ +-- +searchTemplates dir f = do + names <- getDirectoryContents dir + let properNames = filter (`notElem` [".", ".."]) names + forM properNames $ \name -> do + let path = dir </> name + isDirectory <- doesDirectoryExist path + if (not isDirectory) && (".html" `isSuffixOf` name) + then f path name + else return () + +workTemplate h path name = do + hPutStrLn stderr $ "Parsing "++name++"..." + contents <- readFile path + let res = parseTemplate name contents + + case res of + Left e -> hPutStrLn stderr (show e) + Right tpl -> do -- hPutStrLn stderr $ show res + hPutStr h $ genTemplate name tpl + +main = do args <- getArgs + tpls <- openFile (args!!1) WriteMode + preamble tpls + searchTemplates (head args) (workTemplate tpls) + endrender tpls + hClose tpls diff --git a/Framework/TGenerator/TemplateParser.hs b/Framework/TGenerator/TemplateParser.hs new file mode 100644 index 0000000..2670e56 --- /dev/null +++ b/Framework/TGenerator/TemplateParser.hs @@ -0,0 +1,109 @@ +module TemplateParser + (Format (..), Template, + parseTemplate) + where + +import Data.Char +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language (haskellDef) + +import Framework.Utils + +-------------------------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------------------------- + +data Format = Verbatim String + | Quote [String] + | ForTag [String] Template + | IfTag [String] Template Template + | Include String + | IncludeVar String + deriving (Show) + +type Template = [Format] + +-------------------------------------------------------------------------------------------------- +-- Parser +-------------------------------------------------------------------------------------------------- + +lexer = P.makeTokenParser haskellDef + +-- identifier = P.identifier lexer +symbol = P.symbol lexer + +parseTemplate = parse pTemplate + +pTemplate :: GenParser Char st Template +pTemplate = many1 (pVerbatim <|> (try pForTag) <|> (try pIfTag) <|> (try pIncludeVar) <|> (try pInclude) <|> (try pQuote)) + +pVerbatim :: GenParser Char st Format +pVerbatim = do + s <- many1 (noneOf "{}%") + return $ Verbatim s + +pQuote :: GenParser Char st Format +pQuote = do + string "{{" + name <- many1 (noneOf "}") + string "}}" + return $ Quote (words name) + +pForTag :: GenParser Char st Format +pForTag = do + symbol "{%for" + s <- many1 (noneOf "%") + symbol "%}" + tpl <- pTemplate + let ws = words s +-- if (ws!!1)/="in" +-- then fail "incorrect `for` syntax!" +-- else do symbol "{%endfor%}" -- <?> "tag 'for' end" +-- return $ ForTag [(ws!!0),(ws!!2)] tpl + symbol "{%endfor%}" -- <?> "tag 'for' end" + return $ ForTag [(ws!!0),(ws!!2)] tpl + +pIfTag :: GenParser Char st Format +pIfTag = do + s <- between (symbol "{%if") (symbol "%}") $ many1 (noneOf "%") + let ws = words s + (try (pIf1 ws)) <|> (pIf2 ws []) + +pIf1 :: [String] -> GenParser Char st Format +pIf1 ws = do + t <- between (return []) (symbol "{%else%}") pTemplate + pIf2 ws t + +pIf2 :: [String] -> Template -> GenParser Char st Format +pIf2 ws t = do + e <- between (return []) (symbol "{%endif%}") pTemplate + if null t + then return $ IfTag ws e [] + else return $ IfTag ws t e + +pElsePart :: GenParser Char st Template +pElsePart = do + symbol "{%else%}" + pTemplate + +pInclude :: GenParser Char st Format +pInclude = do + symbol "{%include" + s <- many1 (noneOf " %") + symbol "%}" + return $ Include (trim s) + +pIncludeVar :: GenParser Char st Format +pIncludeVar = do + symbol "{%includevar" + v <- many1 (noneOf " %") + symbol "%}" + return $ IncludeVar (trim v) + +----------------------------------------------------------------------------------- +-- Parser utilites + +words' x = init ws ++ [v,t] + where ws = words x + [v,t] = splitWith (==':') (last ws) diff --git a/Framework/Types.hs b/Framework/Types.hs new file mode 100644 index 0000000..0fb59d6 --- /dev/null +++ b/Framework/Types.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, OverlappingInstances, IncoherentInstances, FlexibleContexts, UndecidableInstances, RankNTypes, ImpredicativeTypes #-} +module Framework.Types where + +import System.IO +import Network.Shed.Httpd +import Data.List +import qualified Data.Map as M +import qualified Database.HDBC as D + +---------------------------------------------------------------- +--Types +-- +type Channel = Handle +type S = String +type URLParts = [String] +type StrAction = HttpActionParams -> Request -> String -> Maybe (IO Response) +type ManyStrAction = HttpActionParams -> Request -> URLParts -> Maybe (IO Response) +type HttpAction = HttpActionParams -> Request -> IO Response + +data URLConf = Action HttpAction + | OneOf URLConf URLConf + | Function StrAction + | Prefix String URLConf + | Regexp String URLConf + | RegexpFun String StrAction + | ManyRegexpFun URLParts URLParts ManyStrAction + | After URLConf URLConf + +instance Show URLConf where + show (Action _) = "Some action" + show (OneOf x y) = (show x)++"\n| "++(show y) + show (Function _) = "Some function" + show (Prefix s u) = s++" --> "++(show u) + show (Regexp s u) = s++" --> "++(show u) + show (RegexpFun s _) = s++" --> Some function" + show (ManyRegexpFun _ rs _) = (concat $ intersperse "/" rs)++" --> Some function" + show (After u v) = (show u)++", then "++(show v) + +------------------------------------------------------------------------------------------- + +data HttpActionParams = HP { + docdir :: String, + hLog :: Channel, + dbDriver :: String, + dbPath :: String, + cacheDriver :: String, + cachePath :: String, + sessionsDriver :: String, + sessionsPath :: String + } + +class HttpValue v where + httpEmpty :: v -> Bool + httpShow :: v -> S + +data HttpBox = forall a. HttpValue a => HB a + +instance HttpValue (Maybe S) where + httpEmpty Nothing = True + httpEmpty (Just _) = False + + httpShow Nothing = "" + httpShow (Just x) = x + +instance (Show a) => HttpValue (Maybe a) where + httpEmpty Nothing = True + httpEmpty (Just _) = False + + httpShow Nothing = "" + httpShow (Just x) = show x + +instance HttpValue Int where + httpEmpty _ = False + httpShow = show + +instance HttpValue S where + httpEmpty "" = True + httpEmpty _ = False + + httpShow x = x + +instance HttpValue HttpBox where + httpEmpty (HB x) = httpEmpty x + httpShow (HB x) = httpShow x + +data HttpHeader = String := HttpBox +type UrlParam = HttpHeader +type FormVar = 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 + stringField :: Int -> a -> String + boolField :: Int -> a -> Bool + +class (TemplateOne a) => TemplateItem a where + showT :: a -> String + intFields :: Int -> a -> [Int] + stringFields :: Int -> a -> [String] + boolFields :: Int -> a -> [Bool] + mkList :: a -> [TContainer] + isTrue :: a -> Bool + +showC :: TContainer -> String +showC (C x) = showT x + +instance TemplateOne String where + showO = id + intField _ = read + stringField _ = id + boolField _ = not.null + +instance TemplateOne Int where + showO = show + intField _ = id + stringField _ = show + boolField _ = (/=0) + +instance TemplateOne Bool where + showO = show + intField _ x = if x then 1 else 0 + stringField _ = show + boolField _ = id + +instance (TemplateOne a) => TemplateOne [a] where + showO l = concat $ intersperse ", " (map showO l) + intField _ = length + stringField _ x = showO x + boolField _ = not.null + +instance (TemplateOne a) => TemplateItem a where + showT = showO + intFields n x = [intField n x] + stringFields n x = [stringField n x] + boolFields n x = [boolField n x] + mkList = error "undefined mkList for a" + isTrue = error "undefined isTrue for a" + +instance (TemplateOne a) => TemplateItem [a] where + showT l = concat $ intersperse ", " (map showO l) + intFields n = map (intField n) + stringFields n = map (stringField n) + boolFields n = map (boolField n) + mkList x = map C x + isTrue = not.null + +instance TemplateItem String where + showT s = s + intFields _ s = [read s] + stringFields _ s = [s] + boolFields _ s = [not $ null s] + mkList = error "undefined mkList for String" + isTrue = not.null + +data TContainer = forall a. (TemplateItem a) => C a +type SFunction = forall a. (TemplateItem a) => a -> String +type BFunction = forall a. (TemplateItem a) => a -> Bool + +mapF :: String -> (M.Map String TContainer -> String) -> M.Map String TContainer -> TContainer -> String +mapF k f s (C lst) = concat $ map f [M.insert "it" (C it) $ M.insert k v s | (it,v) <- zip ([1..]::[Int]) (mkList lst)] + +tmap' :: SFunction -> TContainer -> String +tmap' f (C x) = f x + +tmap :: SFunction -> Maybe TContainer -> String +tmap f x = maybe "" id $ (tmap' f) `fmap` x + +bmap' :: BFunction -> TContainer -> Bool +bmap' f (C x) = f x + +bmap :: BFunction -> Maybe TContainer -> Bool +bmap f x = maybe False id $ (bmap' f) `fmap` x + +transformInts n f = \x -> f `map` (intFields n x) +transformStrings n f = \x -> f `map` (stringFields n x) +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/Framework/Urls.hs b/Framework/Urls.hs new file mode 100644 index 0000000..94b6de3 --- /dev/null +++ b/Framework/Urls.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Framework.Urls where + +import Text.Regex.PCRE +import Network.URI +import Network.Shed.Httpd(reqBody,Response,reqURI,Request,queryToArguments) +import Data.List + +import Framework.Utils +import Framework.Types + +urlSplit :: URI -> URLParts +urlSplit uri = splitWith (=='/') (uriPath uri) + +urlJoin :: URLParts -> String +urlJoin us = concat $ intersperse "/" us + +runURLConf :: HttpActionParams -> Request -> String -> URLConf -> IO Response +runURLConf ps rq s conf = let murl = parseURIReference s + in case murl of + Nothing -> error "Couldn't parse URL!" + Just url -> case runURLConf' conf (urlSplit url) ps rq of + Nothing -> return $ noSuchUrl True conf + Just act -> act + +runURLConf' :: URLConf -> URLParts -> HttpActionParams -> Request -> Maybe (IO Response) +-- runURLConf' _ [] _ = Nothing +runURLConf' (Prefix p conf) (x:xs) ps rq | p==x = runURLConf' conf xs ps rq + | otherwise = Nothing +runURLConf' (Regexp r conf) (x:xs) ps rq = let b = x =~ r :: Bool + in if b then runURLConf' conf xs ps rq else Nothing +runURLConf' (RegexpFun r f) (x:_) ps rq = let part = x =~ r :: String + in if null part then Nothing else f ps rq part +runURLConf' (ManyRegexpFun _ _ _) [] _ _ = Nothing +runURLConf' (ManyRegexpFun u [] f) _ ps rq = f ps rq (reverse u) +runURLConf' (ManyRegexpFun u (r:rs) f) (x:xs) ps rq = let part = x =~ r :: String + in runURLConf' (ManyRegexpFun (part:u) rs f) xs ps rq +runURLConf' (Action act) _ ps rq = Just (act ps rq) +runURLConf' (Function f) x ps rq = f ps rq (urlJoin x) +runURLConf' (OneOf c d) url ps rq = case runURLConf' c url ps rq of + Nothing -> runURLConf' d url ps rq + Just act -> Just act +runURLConf' (After c d) (x:xs) ps rq = case runURLConf' c [x] ps rq of + Nothing -> runURLConf' d xs ps rq + Just act -> Just (maybe act (act>>) (runURLConf' d xs ps rq)) + +(-->) :: String -> HttpAction -> URLConf +s --> act = Prefix s (Action act) + +(//) :: String -> URLConf -> URLConf +(//) = Prefix +infixr 7 // + +(-\>) :: String -> StrAction -> URLConf +s -\> f = s // Function f + +(~>) :: String -> StrAction -> URLConf +(~>) = RegexpFun +infixl 8 ~> + +(~/) :: String -> URLConf -> URLConf +r ~/ c = case c of + ManyRegexpFun u rs f -> ManyRegexpFun u (r:rs) f + _ -> error "~>> works only with ManyRegexpFun at right side!" +infixr 8 ~/ + +(~>>) :: String -> ManyStrAction -> URLConf +r ~>> f = r ~/ mrf f + +mrf f = ManyRegexpFun [] [] f + +(<|>) :: URLConf -> URLConf -> URLConf +(<|>) = OneOf +infixr 6 <|> + +(>=>) :: URLConf -> URLConf -> URLConf +(>=>) = After +infixr 6 >=> + +----------------------------------------------------------------------------------------------- + +(?) :: 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 + +httpGetVar' :: Request -> String -> String -> String +httpGetVar' rq name def = maybe def id $ lookup name pairs + where pairs = queryToArguments $ uriQuery $ reqURI rq + +httpPostVar :: Request -> String -> Maybe String +httpPostVar rq name = lookup name pairs + where pairs = decodePairs (reqBody rq) + +httpPostVar' :: Request -> String -> String -> String +httpPostVar' rq name def = maybe def id $ lookup name pairs + 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 + +myUrl :: Request -> String +myUrl rq = uriPath $ reqURI rq + diff --git a/Framework/Utils.hs b/Framework/Utils.hs new file mode 100644 index 0000000..71c307d --- /dev/null +++ b/Framework/Utils.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Framework.Utils where + +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 Framework.Types + +mimes = M.fromList [ + ("css", "text/css"), + ("htm", "text/html"), + ("gif", "image/gif"), + ("html", "text/html"), + ("jpeg", "image/jpeg"), + ("jpg", "image/jpeg"), + ("js", "text/javascript"), + ("png", "image/png"), + ("xml", "text/xml") + ] + +----------------------------------------------------------------------------------- +-- Utility functions + +splitWith :: (a -> Bool) -> [a] -> [[a]] +splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + +getExt str = reverse (takeWhile (/= '.') (reverse str)) + +emptyLine = "\r\n\r\n" +endl = "\r\n" + +chooseMime :: S -> Maybe S +chooseMime filename = M.lookup ext mimes + where + ext = getExt filename + +emptyResponse = Response 200 [] "" +noSuchUrl debug conf = Response 404 [] ("<p>No such URL!</p>"++d) + where d = if debug then "<p>URLConf was:"++(show conf)++"</p>" else "" + +number = "[0-9]+" +year = "[0-9]{4}" +month = "[0-9]{2}" +day = month + +------------------------------ + +capitalize "" = "" +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 + +------------------------------------------------------------------------------------------ + +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/Framework/test.db b/Framework/test.db new file mode 100644 index 0000000..f9e9c62 Binary files /dev/null and b/Framework/test.db differ diff --git a/Framework/www/index.html b/Framework/www/index.html new file mode 100644 index 0000000..a3a798e --- /dev/null +++ b/Framework/www/index.html @@ -0,0 +1,12 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> + <head> + <title>A test</title> + <meta name='author' content='Portnov'> + </head> + + <body> + <h1>Hello world!</h1> + <p>Just a test.</p> + </body> +</html> diff --git a/HTTPServer.hs b/HTTPServer.hs deleted file mode 100644 index 0842b1c..0000000 --- a/HTTPServer.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module HTTPServer where - -import Prelude hiding (catch) -import System.IO -import System.Directory -import Control.Exception -import Network.Shed.Httpd -import Network.URI - -import Types -import Urls -import Utils - -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" =: mime] body - where mime = "text/html" - -redirect :: String -> Response -redirect url = response 302 ["Location" =: url] "" - -redirectP :: String -> Response -redirectP url = response 301 ["Location" =: url] "" - -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" =: 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 --- putStrLn $ "Request: "++show req --- putStrLn $ "Serving "++uriPath - runURLConf hap req (tail uriPath) conf - -defaultURLConf :: URLConf -defaultURLConf = Function serveStatic - -serveHttp :: Int -> HttpActionParams -> URLConf -> IO () -serveHttp port hap conf = initServer port (httpWorker hap conf) - diff --git a/Makefile b/Makefile index 19eab00..a8c03a4 100644 --- a/Makefile +++ b/Makefile @@ -1,16 +1,20 @@ -GHC=ghc -O2 -Wall --make +GHC=ghc -O2 --make +TEMPLATES=Framework/TEngine/Templates.hs all: TemplateGen Templates.hs test -TemplateGen: TemplateGen.hs - $(GHC) $< +TemplateGen: + make -C Framework/TGenerator/ Templates.hs: - ./TemplateGen + Framework/TGenerator/TemplateGen templates/ $(TEMPLATES) -test: *.hs - $(GHC) test.hs +test: test.hs $(TEMPLATES) + $(GHC) $< clean: - rm TemplateGen Templates.hs test *.hi *.o + rm test *.hi *.o + make -C Framework/ clean + make -C Framework/TEngine clean + make -C Framework/TGenerator clean diff --git a/Middlewares.hs b/Middlewares.hs deleted file mode 100644 index fef5819..0000000 --- a/Middlewares.hs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 0402c05..0000000 --- a/Models.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE FlexibleInstances,NoMonomorphismRestriction, ExistentialQuantification #-} -module Models where - -import qualified Data.Map as M - -import Types -import Storage -import Database.HDBC (fromSql) -import Forms - -data User = User { - _userId :: Int, - _username :: String, - _password :: String } - -userId :: (TemplateOne a) => a -> Int -userId = transformInt 1 id -username :: (TemplateItem a) => a -> String -username = transformString 1 id -password :: (TemplateOne a) => a -> String -password = transformString 2 id - -instance Table User where - record [uId, uName, uPass] = User (fromSql uId) (fromSql uName) (fromSql uPass) - record [uName,uPass] = User 0 (fromSql uName) (fromSql uPass) - -instance TemplateOne User where - showO (User uId uName uPass) = "#"++(show uId)++". "++(show uName)++" -- "++(show uPass) - intField _ = _userId - stringField 1 = _username - stringField 2 = _password - boolField _ = error "undefined boolField for User" - -userForm = Form { - formName = "userform", - 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 deleted file mode 100644 index 6a4a30c..0000000 --- a/Sessions.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module 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 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 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 - 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 (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 :: String -> String -> HttpHeader -sessionCookie exp sid = setcookie exp "SessionID" sid diff --git a/Storage.hs b/Storage.hs deleted file mode 100644 index 3973116..0000000 --- a/Storage.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, EmptyDataDecls, TypeFamilies, NoMonomorphismRestriction, NamedFieldPuns #-} -module Storage - (DBConnection, Table (..), - connect, connect', - commit, - disconnect, - query, query', queryR, queryR', - getTable - ) - where - -import qualified Database.HDBC.Sqlite3 as Sqlite3 -import qualified Database.HDBC as D - -import Types - -data DBConnection = forall c. D.IConnection c => DBC c - -connect :: String -> String -> IO DBConnection -connect "sqlite3" file = DBC `fmap` (Sqlite3.connectSqlite3 file) - -connect' :: HttpActionParams -> IO DBConnection -connect' (HP {dbDriver, dbPath}) = connect dbDriver dbPath - -disconnect :: DBConnection -> IO () -disconnect (DBC conn) = D.disconnect conn - -query :: DBConnection -> String -> [D.SqlValue] -> IO [[D.SqlValue]] -query (DBC conn) sql params = D.quickQuery conn sql params - -query' :: DBConnection -> String -> [D.SqlValue] -> IO [[D.SqlValue]] -query' (DBC conn) sql params = D.quickQuery' conn sql params - -commit :: DBConnection -> IO () -commit (DBC conn) = D.commit conn - -getTable :: forall t. (Table t) => DBConnection -> String -> IO [t] -getTable (DBC conn) name = do - res <- D.quickQuery conn ("SELECT * FROM "++name) [] - return (map record res :: [t]) - -queryR :: forall t. (Table t) => DBConnection -> String -> [D.SqlValue] -> IO [t] -queryR (DBC conn) sql params = do - res <- D.quickQuery conn sql params - return (map record res :: [t]) - -queryR' :: forall t. (Table t) => DBConnection -> String -> [D.SqlValue] -> IO [t] -queryR' (DBC conn) sql params = do - res <- D.quickQuery' conn sql params - return (map record res :: [t]) - diff --git a/TemplateFuncs.hs b/TemplateFuncs.hs deleted file mode 100644 index e941187..0000000 --- a/TemplateFuncs.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -module TemplateFuncs - (bold, - uppercase,lowercase, - evenP,oddP, - list - ) where - -import Data.Char -import Data.List - -import Types - -_bold s = "<strong>"++s++"</strong>" -bold = transformString 1 _bold - -uppercase = transformString 1 $ map toUpper -lowercase = transformString 1 $ map toLower - -evenP = transformInt 1 even -oddP = transformInt 1 odd - -list :: String -> (String -> String) -> SFunction -list sep f lst = concat $ intersperse sep $ map (transform f) (mkList lst) - where transform f = \(C x) -> f (stringField 1 x) - -separateWith :: String -> SFunction -separateWith s = list s id diff --git a/TemplateGen.hs b/TemplateGen.hs deleted file mode 100644 index 681e379..0000000 --- a/TemplateGen.hs +++ /dev/null @@ -1,132 +0,0 @@ -import System.IO -import Data.List -import Data.Char -import Data.String.Utils -import System.Directory -import System.FilePath ((</>)) -import Control.Monad -import qualified Data.Map as M - -import Utils -import TemplateParser - --------------------------------------------------------------------------------------------------- --- Code generator --------------------------------------------------------------------------------------------------- - --------------------------------------------------------------------------------------------------- --- Generator's utilites --------------------------------------------------------------------------------------------------- - -quote s = "\""++s++"\"" -getvar v = "maybe \"\" showC (M.lookup "++quote v++" pairs)" - -getlist n = "maybe (C ([]::[Int])) id (M.lookup "++quote n++" pairs)" - -hash t = sum $ map hashF t -hash' = show.hash - -hashF (Verbatim s) = hashS s -hashF (Quote ss) = sum (map hashS ss) -hashF (ForTag ss t) = sum (map hashS ss) + hash t -hashF (IfTag ss t p) = sum (map hashS ss) + hash t + hash p - -hashS s = length s + (sum $ map ord s) - -nl = "\n" - -mapS start f [] = ([], start) -mapS start f (x:xs) = (z:zs, res) - where y = f start x - z = fst y - t = mapS (snd y) f xs - zs = fst t - res = snd t - -joinMap f lst = (concat $ intersperse ", \n" $ (fst m), snd m) - where m = mapS M.empty f lst - -genTemplate :: String -> Template -> String -genTemplate name tpl = if name=="0" - then "" - else "render \""++name++"\" pairs = concat [\n" ++ (fst j) ++ "]" ++ nl ++ renderSubs ++ nl - where j = joinMap genFormat tpl - renderSubs = case M.assocs $ snd j of - [] -> "" - lst -> concat $ map (uncurry genTemplate) lst - -joinList lst = concat $ intersperse ",\n" $ map (" "++) $ map quote lst -quoteLines s = joinList $ map (replace "\"" "\\\"") $ lines s - -undollars = unwords - -genquote xs = - if null fs - then getvar x - else "("++(undollars fs)++") `tmap` (M.lookup "++(quote x)++" pairs)" - where - fs = init xs - x = last xs - -genquoteB xs = - if null fs - then "isTrue `bmap` (M.lookup "++(quote x)++" pairs)" - else "("++(undollars fs)++") `bmap` (M.lookup "++(quote x)++" pairs)" - where - fs = init xs - x = last xs - -genFormat m (Verbatim s) = (quoteLines s, m) -genFormat m (Quote v) = (" "++genquote v, m) -genFormat m (ForTag [v,lst] tpl) = (" mapF "++(quote v)++" (render \""++ h ++"\") pairs $ "++(getlist lst), M.insert h tpl m) - where h = hash' tpl -genFormat m (IfTag v tpl1 tpl2) = (" render (if "++(genquoteB v)++" then "++(quote h1)++" else "++(quote h2)++") pairs", - M.insert h1 tpl1 $ M.insert h2 tpl2 m) - where h1 = hash' tpl1 - h2 = hash' tpl2 -genFormat m (Include s) = (" render "++(quote s)++" pairs", m) -genFormat m (IncludeVar v) = (" render ("++(getvar v)++") pairs", m) - -preamble h = do --- hPutStrLn h "{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, OverlappingInstances #-}" - hPutStrLn h "module Templates where" - hPutStrLn h "import qualified Data.Map as M" - hPutStrLn h "import Data.List" - hPutStrLn h "import Types" - hPutStrLn h "import Models" - hPutStrLn h "import Utils" - hPutStrLn h "import TemplateFuncs" - hPutStrLn h "" - hPutStrLn h "render :: String -> M.Map String TContainer -> String" - -endrender h = do - hPutStrLn h "render \"0\" _ = \"\"" - hPutStrLn h "render _ _ = \"<h1>No such template!</h1>\"" - ------------------------------------------------------------------------------------------------------------------------------------- --- -searchTemplates dir f = do - names <- getDirectoryContents dir - let properNames = filter (`notElem` [".", ".."]) names - forM properNames $ \name -> do - let path = dir </> name - isDirectory <- doesDirectoryExist path - if (not isDirectory) && (".html" `isSuffixOf` name) - then f path name - else return () - -workTemplate h path name = do - hPutStrLn stderr $ "Parsing "++name++"..." - contents <- readFile path - let res = parseTemplate name contents - - case res of - Left e -> hPutStrLn stderr (show e) - Right tpl -> do hPutStrLn stderr $ show res - hPutStr h $ genTemplate name tpl - -main = do tpls <- openFile "Templates.hs" WriteMode - preamble tpls - searchTemplates "templates" (workTemplate tpls) - endrender tpls - hClose tpls diff --git a/TemplateParser.hs b/TemplateParser.hs deleted file mode 100644 index 30f7978..0000000 --- a/TemplateParser.hs +++ /dev/null @@ -1,109 +0,0 @@ -module TemplateParser - (Format (..), Template, - parseTemplate) - where - -import Data.Char -import Text.ParserCombinators.Parsec -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language (haskellDef) - -import Utils - --------------------------------------------------------------------------------------------------- --- Types --------------------------------------------------------------------------------------------------- - -data Format = Verbatim String - | Quote [String] - | ForTag [String] Template - | IfTag [String] Template Template - | Include String - | IncludeVar String - deriving (Show) - -type Template = [Format] - --------------------------------------------------------------------------------------------------- --- Parser --------------------------------------------------------------------------------------------------- - -lexer = P.makeTokenParser haskellDef - --- identifier = P.identifier lexer -symbol = P.symbol lexer - -parseTemplate = parse pTemplate - -pTemplate :: GenParser Char st Template -pTemplate = many1 (pVerbatim <|> (try pForTag) <|> (try pIfTag) <|> (try pIncludeVar) <|> (try pInclude) <|> (try pQuote)) - -pVerbatim :: GenParser Char st Format -pVerbatim = do - s <- many1 (noneOf "{}%") - return $ Verbatim s - -pQuote :: GenParser Char st Format -pQuote = do - string "{{" - name <- many1 (noneOf "}") - string "}}" - return $ Quote (words name) - -pForTag :: GenParser Char st Format -pForTag = do - symbol "{%for" - s <- many1 (noneOf "%") - symbol "%}" - tpl <- pTemplate - let ws = words s --- if (ws!!1)/="in" --- then fail "incorrect `for` syntax!" --- else do symbol "{%endfor%}" -- <?> "tag 'for' end" --- return $ ForTag [(ws!!0),(ws!!2)] tpl - symbol "{%endfor%}" -- <?> "tag 'for' end" - return $ ForTag [(ws!!0),(ws!!2)] tpl - -pIfTag :: GenParser Char st Format -pIfTag = do - s <- between (symbol "{%if") (symbol "%}") $ many1 (noneOf "%") - let ws = words s - (try (pIf1 ws)) <|> (pIf2 ws []) - -pIf1 :: [String] -> GenParser Char st Format -pIf1 ws = do - t <- between (return []) (symbol "{%else%}") pTemplate - pIf2 ws t - -pIf2 :: [String] -> Template -> GenParser Char st Format -pIf2 ws t = do - e <- between (return []) (symbol "{%endif%}") pTemplate - if null t - then return $ IfTag ws e [] - else return $ IfTag ws t e - -pElsePart :: GenParser Char st Template -pElsePart = do - symbol "{%else%}" - pTemplate - -pInclude :: GenParser Char st Format -pInclude = do - symbol "{%include" - s <- many1 (noneOf " %") - symbol "%}" - return $ Include (trim s) - -pIncludeVar :: GenParser Char st Format -pIncludeVar = do - symbol "{%includevar" - v <- many1 (noneOf " %") - symbol "%}" - return $ IncludeVar (trim v) - ------------------------------------------------------------------------------------ --- Parser utilites - -words' x = init ws ++ [v,t] - where ws = words x - [v,t] = splitWith (==':') (last ws) diff --git a/TemplateUtil.hs b/TemplateUtil.hs deleted file mode 100644 index 16f1a95..0000000 --- a/TemplateUtil.hs +++ /dev/null @@ -1,27 +0,0 @@ -module TemplateUtil - (render, - renderToResponse, - renderToResponseC - ) - where - -import qualified Data.Map as M -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 deleted file mode 100644 index 35ab569..0000000 --- a/Types.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, OverlappingInstances, IncoherentInstances, FlexibleContexts, UndecidableInstances, RankNTypes, ImpredicativeTypes #-} -module Types where - -import System.IO -import Network.Shed.Httpd -import Data.List -import qualified Data.Map as M -import qualified Database.HDBC as D - ----------------------------------------------------------------- ---Types --- -type Channel = Handle -type S = String -type URLParts = [String] -type StrAction = HttpActionParams -> Request -> String -> Maybe (IO Response) -type ManyStrAction = HttpActionParams -> Request -> URLParts -> Maybe (IO Response) -type HttpAction = HttpActionParams -> Request -> IO Response - -data URLConf = Action HttpAction - | OneOf URLConf URLConf - | Function StrAction - | Prefix String URLConf - | Regexp String URLConf - | RegexpFun String StrAction - | ManyRegexpFun URLParts URLParts ManyStrAction - | After URLConf URLConf - -instance Show URLConf where - show (Action _) = "Some action" - show (OneOf x y) = (show x)++"\n| "++(show y) - show (Function _) = "Some function" - show (Prefix s u) = s++" --> "++(show u) - show (Regexp s u) = s++" --> "++(show u) - show (RegexpFun s _) = s++" --> Some function" - show (ManyRegexpFun _ rs _) = (concat $ intersperse "/" rs)++" --> Some function" - show (After u v) = (show u)++", then "++(show v) - -------------------------------------------------------------------------------------------- - -data HttpActionParams = HP { - docdir :: String, - hLog :: Channel, - dbDriver :: String, - dbPath :: String, - cacheDriver :: String, - cachePath :: String, - sessionsDriver :: String, - sessionsPath :: String - } - -class HttpValue v where - httpEmpty :: v -> Bool - httpShow :: v -> S - -data HttpBox = forall a. HttpValue a => HB a - -instance HttpValue (Maybe S) where - httpEmpty Nothing = True - httpEmpty (Just _) = False - - httpShow Nothing = "" - httpShow (Just x) = x - -instance (Show a) => HttpValue (Maybe a) where - httpEmpty Nothing = True - httpEmpty (Just _) = False - - httpShow Nothing = "" - httpShow (Just x) = show x - -instance HttpValue Int where - httpEmpty _ = False - httpShow = show - -instance HttpValue S where - httpEmpty "" = True - httpEmpty _ = False - - httpShow x = x - -instance HttpValue HttpBox where - httpEmpty (HB x) = httpEmpty x - httpShow (HB x) = httpShow x - -data HttpHeader = String := HttpBox -type UrlParam = HttpHeader -type FormVar = 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 - stringField :: Int -> a -> String - boolField :: Int -> a -> Bool - -class (TemplateOne a) => TemplateItem a where - showT :: a -> String - intFields :: Int -> a -> [Int] - stringFields :: Int -> a -> [String] - boolFields :: Int -> a -> [Bool] - mkList :: a -> [TContainer] - isTrue :: a -> Bool - -showC :: TContainer -> String -showC (C x) = showT x - -instance TemplateOne String where - showO = id - intField _ = read - stringField _ = id - boolField _ = not.null - -instance TemplateOne Int where - showO = show - intField _ = id - stringField _ = show - boolField _ = (/=0) - -instance TemplateOne Bool where - showO = show - intField _ x = if x then 1 else 0 - stringField _ = show - boolField _ = id - -instance (TemplateOne a) => TemplateOne [a] where - showO l = concat $ intersperse ", " (map showO l) - intField _ = length - stringField _ x = showO x - boolField _ = not.null - -instance (TemplateOne a) => TemplateItem a where - showT = showO - intFields n x = [intField n x] - stringFields n x = [stringField n x] - boolFields n x = [boolField n x] - mkList = error "undefined mkList for a" - isTrue = error "undefined isTrue for a" - -instance (TemplateOne a) => TemplateItem [a] where - showT l = concat $ intersperse ", " (map showO l) - intFields n = map (intField n) - stringFields n = map (stringField n) - boolFields n = map (boolField n) - mkList x = map C x - isTrue = not.null - -instance TemplateItem String where - showT s = s - intFields _ s = [read s] - stringFields _ s = [s] - boolFields _ s = [not $ null s] - mkList = error "undefined mkList for String" - isTrue = not.null - -data TContainer = forall a. (TemplateItem a) => C a -type SFunction = forall a. (TemplateItem a) => a -> String -type BFunction = forall a. (TemplateItem a) => a -> Bool - -mapF :: String -> (M.Map String TContainer -> String) -> M.Map String TContainer -> TContainer -> String -mapF k f s (C lst) = concat $ map f [M.insert "it" (C it) $ M.insert k v s | (it,v) <- zip ([1..]::[Int]) (mkList lst)] - -tmap' :: SFunction -> TContainer -> String -tmap' f (C x) = f x - -tmap :: SFunction -> Maybe TContainer -> String -tmap f x = maybe "" id $ (tmap' f) `fmap` x - -bmap' :: BFunction -> TContainer -> Bool -bmap' f (C x) = f x - -bmap :: BFunction -> Maybe TContainer -> Bool -bmap f x = maybe False id $ (bmap' f) `fmap` x - -transformInts n f = \x -> f `map` (intFields n x) -transformStrings n f = \x -> f `map` (stringFields n x) -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 deleted file mode 100644 index 7380435..0000000 --- a/Urls.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module Urls where - -import Text.Regex.PCRE -import Network.URI -import Network.Shed.Httpd(reqBody,Response,reqURI,Request,queryToArguments) -import Data.List - -import Utils -import Types - -urlSplit :: URI -> URLParts -urlSplit uri = splitWith (=='/') (uriPath uri) - -urlJoin :: URLParts -> String -urlJoin us = concat $ intersperse "/" us - -runURLConf :: HttpActionParams -> Request -> String -> URLConf -> IO Response -runURLConf ps rq s conf = let murl = parseURIReference s - in case murl of - Nothing -> error "Couldn't parse URL!" - Just url -> case runURLConf' conf (urlSplit url) ps rq of - Nothing -> return $ noSuchUrl True conf - Just act -> act - -runURLConf' :: URLConf -> URLParts -> HttpActionParams -> Request -> Maybe (IO Response) --- runURLConf' _ [] _ = Nothing -runURLConf' (Prefix p conf) (x:xs) ps rq | p==x = runURLConf' conf xs ps rq - | otherwise = Nothing -runURLConf' (Regexp r conf) (x:xs) ps rq = let b = x =~ r :: Bool - in if b then runURLConf' conf xs ps rq else Nothing -runURLConf' (RegexpFun r f) (x:_) ps rq = let part = x =~ r :: String - in if null part then Nothing else f ps rq part -runURLConf' (ManyRegexpFun _ _ _) [] _ _ = Nothing -runURLConf' (ManyRegexpFun u [] f) _ ps rq = f ps rq (reverse u) -runURLConf' (ManyRegexpFun u (r:rs) f) (x:xs) ps rq = let part = x =~ r :: String - in runURLConf' (ManyRegexpFun (part:u) rs f) xs ps rq -runURLConf' (Action act) _ ps rq = Just (act ps rq) -runURLConf' (Function f) x ps rq = f ps rq (urlJoin x) -runURLConf' (OneOf c d) url ps rq = case runURLConf' c url ps rq of - Nothing -> runURLConf' d url ps rq - Just act -> Just act -runURLConf' (After c d) (x:xs) ps rq = case runURLConf' c [x] ps rq of - Nothing -> runURLConf' d xs ps rq - Just act -> Just (maybe act (act>>) (runURLConf' d xs ps rq)) - -(-->) :: String -> HttpAction -> URLConf -s --> act = Prefix s (Action act) - -(//) :: String -> URLConf -> URLConf -(//) = Prefix -infixr 7 // - -(-\>) :: String -> StrAction -> URLConf -s -\> f = s // Function f - -(~>) :: String -> StrAction -> URLConf -(~>) = RegexpFun -infixl 8 ~> - -(~/) :: String -> URLConf -> URLConf -r ~/ c = case c of - ManyRegexpFun u rs f -> ManyRegexpFun u (r:rs) f - _ -> error "~>> works only with ManyRegexpFun at right side!" -infixr 8 ~/ - -(~>>) :: String -> ManyStrAction -> URLConf -r ~>> f = r ~/ mrf f - -mrf f = ManyRegexpFun [] [] f - -(<|>) :: URLConf -> URLConf -> URLConf -(<|>) = OneOf -infixr 6 <|> - -(>=>) :: URLConf -> URLConf -> URLConf -(>=>) = After -infixr 6 >=> - ------------------------------------------------------------------------------------------------ - -(?) :: 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 - -httpGetVar' :: Request -> String -> String -> String -httpGetVar' rq name def = maybe def id $ lookup name pairs - where pairs = queryToArguments $ uriQuery $ reqURI rq - -httpPostVar :: Request -> String -> Maybe String -httpPostVar rq name = lookup name pairs - where pairs = decodePairs (reqBody rq) - -httpPostVar' :: Request -> String -> String -> String -httpPostVar' rq name def = maybe def id $ lookup name pairs - 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 - -myUrl :: Request -> String -myUrl rq = uriPath $ reqURI rq - diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 index d5b0ff2..0000000 --- a/Utils.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -module Utils where - -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 - -mimes = M.fromList [ - ("css", "text/css"), - ("htm", "text/html"), - ("gif", "image/gif"), - ("html", "text/html"), - ("jpeg", "image/jpeg"), - ("jpg", "image/jpeg"), - ("js", "text/javascript"), - ("png", "image/png"), - ("xml", "text/xml") - ] - ------------------------------------------------------------------------------------ --- Utility functions - -splitWith :: (a -> Bool) -> [a] -> [[a]] -splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs - -getExt str = reverse (takeWhile (/= '.') (reverse str)) - -emptyLine = "\r\n\r\n" -endl = "\r\n" - -chooseMime :: S -> Maybe S -chooseMime filename = M.lookup ext mimes - where - ext = getExt filename - -emptyResponse = Response 200 [] "" -noSuchUrl debug conf = Response 404 [] ("<p>No such URL!</p>"++d) - where d = if debug then "<p>URLConf was:"++(show conf)++"</p>" else "" - -number = "[0-9]+" -year = "[0-9]{4}" -month = "[0-9]{2}" -day = month - ------------------------------- - -capitalize "" = "" -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 - ------------------------------------------------------------------------------------------- - -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.db b/test.db deleted file mode 100644 index f9e9c62..0000000 Binary files a/test.db and /dev/null differ diff --git a/test.hs b/test.hs index 11e7b4f..66b8835 100644 --- a/test.hs +++ b/test.hs @@ -7,14 +7,14 @@ 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 Models -import Forms -import API +import Framework.Types +import Framework.Urls +import Framework.Utils +import Framework.HTTPServer +import Framework.TEngine.TemplateUtil +import Framework.Models +import Framework.Forms +import Framework.API -- testing _ _ = return $ ok "Happy new year!" diff --git a/www/index.html b/www/index.html deleted file mode 100644 index a3a798e..0000000 --- a/www/index.html +++ /dev/null @@ -1,12 +0,0 @@ -<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> - <head> - <title>A test</title> - <meta name='author' content='Portnov'> - </head> - - <body> - <h1>Hello world!</h1> - <p>Just a test.</p> - </body> -</html>