diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index e462d54..c4d5b3b 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -47,7 +47,7 @@ data HTMLForm = HTMLForm { formId :: String, formAction :: String } -type FormValidator = Request String -> Either [String] Model +type FormValidator = HttpRequest -> Either [String] Model type FieldValidator = String -> Either String String data FormField = forall w. (Widget w) => Field { diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index a459a6f..80f2d69 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -83,7 +83,7 @@ retryEditForm conf form fid defvals hidden action = do then return (formToHtml $ refillFormU [] form fid hidden defvals action, "") else return (formToHtml $ refillForm (words err) form fid hidden filledVals action, err) -returnInvalidForm :: ActionConfig -> Form -> String -> [String] -> IO (Response String) +returnInvalidForm :: ActionConfig -> Form -> String -> [String] -> IO HttpResponse returnInvalidForm conf form fid errs = do sessionSet conf "filled" values return $ redirectG (myUrl $ request conf) ["invalid" := (unwords errs)] @@ -115,13 +115,13 @@ defValidate form fid rq = vars :: [String] vars = formVarsValues form fid rq -formVarsValues :: Form -> String -> Request String -> [String] +formVarsValues :: Form -> String -> HttpRequest -> [String] formVarsValues form fid rq = map (\name -> httpPostVar' rq name "") (formVarsNames form fid) formVarsNames :: Form -> String -> [String] formVarsNames form fid = map (mangleName (formName form) fid) $ map fName $ fFields form -formVars :: Form -> String -> Request String -> [(String,String)] +formVars :: Form -> String -> HttpRequest -> [(String,String)] formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) notEmpty :: String -> FieldValidator @@ -134,7 +134,7 @@ noValidate s = Right s ---------------------------------------------------------------------------------------------------- -getAnyForm :: M.Map String Form -> Request String -> (Either [String] Model, String, String) +getAnyForm :: M.Map String Form -> HttpRequest -> (Either [String] Model, String, String) getAnyForm mm rq = case form of Nothing -> (Left [], "","") Just form' -> (defValidate form' fid rq, formname, fid) @@ -142,7 +142,7 @@ getAnyForm mm rq = case form of form = M.lookup formname mm fid = httpPostVar' rq "formid" "" -getForm :: M.Map String Form -> Request String -> String -> (Either [String] Model, String) +getForm :: M.Map String Form -> HttpRequest -> String -> (Either [String] Model, String) getForm mm rq name = if name==formname then (e,fid) else (Left [], "") diff --git a/Framework/Http/Cookies.hs b/Framework/Http/Cookies.hs index 99aa390..ab3ffcf 100644 --- a/Framework/Http/Cookies.hs +++ b/Framework/Http/Cookies.hs @@ -15,13 +15,13 @@ setcookie :: String -- ^ Expiration date -> Header setcookie exp name value = mkHeader HdrSetCookie ((esc (name++"="++value))++"; expires="++exp) -getcookie :: Request String -- ^ HTTP request +getcookie :: HttpRequest -- ^ HTTP request -> String -- ^ Cookie name -> String getcookie rq name = maybe "" id $ lookup name cc where cc = allcookies rq -allcookies :: Request String -> [(String,String)] +allcookies :: HttpRequest -> [(String,String)] allcookies rq = map (spliteq.trim) $ concatMap (splitWith (==';')) $ map hdrValue $ filter cookiehdr $ rqHeaders rq where cookiehdr (Header HdrCookie _) = True cookiehdr _ = False diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index 6b69e9a..322e58c 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -30,7 +30,7 @@ import Framework.Http.Middlewares import Framework.Http.Httpd -- | Send a file -sendfile :: String -> IO (Response String) +sendfile :: String -> IO HttpResponse sendfile filename = do body <- readFile filename return $ response 200 [mkHeader HdrContentType mime] body @@ -49,7 +49,7 @@ serveStatic' ps rq resource = else return $ response 400 [] "Invalid request method" where - handleError :: SomeException -> IO (Response String) + handleError :: SomeException -> IO HttpResponse handleError e = do writeLog (errChan ps) rq $ show e return $ response 500 [] (show e ++ emptyLine) @@ -64,7 +64,7 @@ serveStatic' ps rq resource = choose x = basedir ++"/"++x -- | This function is called on each HTTP request -httpWorker :: StaticConfig -> URLConf -> Request String -> IO (Response String) +httpWorker :: StaticConfig -> URLConf -> HttpRequest -> IO HttpResponse httpWorker hap conf req@(Request {rqURI = URI {uriPath}}) = do let s = unEscapeString $ rqBody req -- putStrLn $ "Request body: "++show s diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index 7a1f3b4..6c799d1 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -6,9 +6,10 @@ module Framework.Http.Middlewares import Network.HTTP import Framework.Utils +import Framework.Types -type RequestMiddleware = Request String -> IO (Request String) -type ResponseMiddleware = Response String -> IO (Response String) +type RequestMiddleware = HttpRequest -> IO HttpRequest +type ResponseMiddleware = HttpResponse -> IO HttpResponse addEncoding enc resp = case lookupHeader HdrContentType (rspHeaders resp) of diff --git a/Framework/Http/Response.hs b/Framework/Http/Response.hs index 7016439..d52e30b 100644 --- a/Framework/Http/Response.hs +++ b/Framework/Http/Response.hs @@ -21,34 +21,34 @@ url ? pairs = url++(urlencode pairs) response :: Int -- ^ HTTP status code -> [Header] -- ^ HTTP headers -> String -- ^ Response body - -> Response String + -> HttpResponse response code pairs body = Response (int2respCode code) "" (filter notEmptyHeader pairs) body -- FIXME: fix Httpd to allow response message here where notEmptyHeader hdr = not $ null $ hdrValue hdr -- | HTTP 200 OK response with given body (text/html) -ok :: String -> Response String +ok :: String -> HttpResponse ok body = response 200 [mkHeader HdrContentType mime] body where mime = "text/html" -- | HTTP 302 redirect response with given text -redirect :: String -> Response String +redirect :: String -> HttpResponse redirect url = response 302 [mkHeader HdrLocation url] "" -- | HTTP 301 redirect response with given text -redirectP :: String -> Response String +redirectP :: String -> HttpResponse redirectP url = response 301 [mkHeader HdrLocation url] "" -- | Generic 302 redirect redirectG :: String -- ^ Response body -> [UrlParam] -- ^ Parameters for URL - -> Response String + -> HttpResponse redirectG url pairs = redirect $ url ? pairs -- | Add HTTP header to response -(<+>) :: Response String -> Header -> Response String +(<+>) :: HttpResponse -> Header -> HttpResponse (Response c m hdrs b) <+> hdr = Response c m (hdrs++[hdr]) b -- | Add list of HTTP headers to response -(<++>) :: Response String -> [Header] -> Response String +(<++>) :: HttpResponse -> [Header] -> HttpResponse (Response c m old b) <++> new = Response c m (old++new) b diff --git a/Framework/Http/Sessions.hs b/Framework/Http/Sessions.hs index a7a12e7..a229b87 100644 --- a/Framework/Http/Sessions.hs +++ b/Framework/Http/Sessions.hs @@ -71,7 +71,7 @@ sFree :: SessionsConnection -> IO () sFree (SConnection b) = sfree b -- | Acquire session (create new or use existing SessionID) -session :: SessionsConnection -> Request String -> IO Session +session :: SessionsConnection -> HttpRequest -> IO Session session (SConnection b) rq = if null sid then do n <- getStdRandom (randomR (100,maxBound::Int)) diff --git a/Framework/Logger.hs b/Framework/Logger.hs index b32be8a..83366a3 100644 --- a/Framework/Logger.hs +++ b/Framework/Logger.hs @@ -27,7 +27,7 @@ currentTime = do formatMsg :: LogItem -> String formatMsg item = printf "%s: %s" (logTime item) (logMessage item) -writeLog :: Log -> Request String -> String -> IO () +writeLog :: Log -> HttpRequest -> String -> IO () writeLog chan rq msg = do time <- currentTime writeChan chan $ LogItem rq time msg diff --git a/Framework/Pager.hs b/Framework/Pager.hs index c0bf638..98a08a6 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -17,7 +17,7 @@ import Framework.Types -- | Represents pager HTML generator -type Pager = Request String -> Int -> Int -> String +type Pager = HttpRequest -> Int -> Int -> String -- | Simple pager pager :: ActionConfig-> Int-> Query-> [SqlValue]-> Model-> IO ([Model], String) diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs index fb69e89..e6dd151 100644 --- a/Framework/TEngine/TemplateUtil.hs +++ b/Framework/TEngine/TemplateUtil.hs @@ -18,10 +18,10 @@ instance (Ord k, Show k,Show v, Read k, Read v) => Serializable (M.Map k v) wher toString = show fromString = read -renderToResponse :: String -> [(String,TContainer)] -> Response String +renderToResponse :: String -> [(String,TContainer)] -> HttpResponse renderToResponse name pairs = ok $! render name (M.fromList pairs) -renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> [(String,TContainer)] -> IO (Response String) +renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> [(String,TContainer)] -> IO HttpResponse 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/Types.hs b/Framework/Types.hs index c43b5aa..f6f7ac5 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -25,6 +25,11 @@ instance Show DBConnection where ------------------------------------------------------------------------------------------- +type HttpRequest = Request String +type HttpResponse = Response String + +------------------------------------------------------------------------------------------- + data StaticConfig = HP { docdir :: String, -- ^ Static content directory dbDriver :: String, -- ^ DB backend name @@ -42,7 +47,7 @@ data StaticConfig = HP { -- | Runtime controller action configuration data ActionConfig = ActionConfig { - request :: Request String, -- ^ HTTP request + request :: HttpRequest, -- ^ HTTP request httpParams :: StaticConfig, -- ^ Static (global) configuration dbconnection :: DBConnection, -- ^ DB connection sessionID :: SessionID, -- ^ Current HTTP session ID @@ -67,7 +72,7 @@ packParam (n,v) = (n := v) -------------------------------------------------------------------------------------------- data LogItem = LogItem { - logRequest :: Request String, + logRequest :: HttpRequest, logTime :: String, logMessage :: String } diff --git a/Framework/Urls.hs b/Framework/Urls.hs index 9c6e3bc..d727d30 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -20,13 +20,13 @@ import Framework.Http.Httpd (queryToArguments) type URLParts = [String] -- | Function which get one String argument and (maybe) returns Response -type StrAction = ActionConfig -> String -> Maybe (IO (Response String)) +type StrAction = ActionConfig -> String -> Maybe (IO HttpResponse) -- | Function which get one String argument and returns Response -type StaticAction = StaticConfig -> Request String -> String -> IO (Response String) +type StaticAction = StaticConfig -> HttpRequest -> String -> IO HttpResponse -- | Function which get many String arguments and (maybe) returns Response -type ManyStrAction = ActionConfig -> URLParts -> Maybe (IO (Response String)) +type ManyStrAction = ActionConfig -> URLParts -> Maybe (IO HttpResponse) -- | Function which just returns Response -type HttpAction = ActionConfig -> IO (Response String) +type HttpAction = ActionConfig -> IO HttpResponse -- | URL dispatcher config data URLConf = Action HttpAction -- ^ Simple answer, not depending on URL @@ -63,15 +63,15 @@ urlJoin :: URLParts -> String urlJoin us = concat $ intersperse "/" us data URLResult = NoResult - | AC (ActionConfig -> Maybe (IO (Response String))) - | SC (StaticConfig -> Request String -> IO (Response String)) + | AC (ActionConfig -> Maybe (IO HttpResponse)) + | SC (StaticConfig -> HttpRequest -> IO HttpResponse) -- | Main dispatcher function runURLConf :: StaticConfig -- ^ Static (global) config - -> Request String -- ^ HTTP request + -> HttpRequest -- ^ HTTP request -> String -- ^ URL itself -> URLConf -- ^ Dispatcher configuration - -> IO (Response String) + -> IO HttpResponse runURLConf ps rq s conf = let murl = parseURIReference s in case murl of @@ -158,14 +158,14 @@ infixr 6 <|> ------------------------------------------------------------------------------------------------ -- -- | Get HTTP GET var value -httpGetVar :: Request String -- ^ HTTP Request +httpGetVar :: HttpRequest -- ^ HTTP Request -> String -- ^ Var name -> Maybe String httpGetVar rq name = lookup name pairs where pairs = queryToArguments $ uriQuery $ rqURI rq -- | Same, but with default value -httpGetVar' :: Request String +httpGetVar' :: HttpRequest -> String -- ^ Var name -> String -- ^ Default value -> String @@ -173,12 +173,12 @@ httpGetVar' rq name def = maybe def id $ lookup name pairs where pairs = queryToArguments $ uriQuery $ rqURI rq -- | Get HTTP POST var value -httpPostVar :: Request String -> String -> Maybe String +httpPostVar :: HttpRequest -> String -> Maybe String httpPostVar rq name = lookup name pairs where pairs = decodePairs (rqBody rq) -- | Same, but with default value -httpPostVar' :: Request String +httpPostVar' :: HttpRequest -> String -- ^ Var name -> String -- ^ Default value -> String @@ -186,7 +186,7 @@ httpPostVar' rq name def = maybe def id $ lookup name pairs where pairs = decodePairs (rqBody rq) -- | Add GET var to given Request and return resulting URL -httpAddGetVar :: Request String +httpAddGetVar :: HttpRequest -> String -- ^ Var name -> String -- ^ Var value -> String @@ -195,6 +195,6 @@ httpAddGetVar rq name value = urlencode (map packParam pairs') pairs = decodePairs (uriQuery $ rqURI rq) -- | Get URL from Request -myUrl :: Request String -> String +myUrl :: HttpRequest -> String myUrl rq = uriPath $ rqURI rq diff --git a/Framework/Wrapper.hs b/Framework/Wrapper.hs index e0d28b9..caa4e2a 100644 --- a/Framework/Wrapper.hs +++ b/Framework/Wrapper.hs @@ -13,7 +13,7 @@ import Framework.Utils -- | Prepare ActionConfig for controller. This connects to DB etc. -- Returns (ActionConfig, WhetherToAddSessionCookie) -mkActionConfig :: StaticConfig -> Request String -> IO (ActionConfig,Bool) +mkActionConfig :: StaticConfig -> HttpRequest -> IO (ActionConfig,Bool) mkActionConfig hp rq = do ed <- expirationDate (i,conn) <- Storage.connect (dbpool hp) hp @@ -50,9 +50,9 @@ acFree ac = do -- | Main API wrapper. Connects to DB etc, then calls given function, then disconnects. withConfig :: StaticConfig -- ^ Static (global) server configuration - -> Request String -- ^ HTTP request - -> (ActionConfig -> IO (Response String)) -- ^ Worker function - -> IO (Response String) + -> HttpRequest -- ^ HTTP request + -> (ActionConfig -> IO HttpResponse) -- ^ Worker function + -> IO HttpResponse withConfig hp rq f = do (conf,addSession) <- mkActionConfig hp rq resp <- f conf