diff --git a/Framework/API.hs b/Framework/API.hs index b764c52..340a336 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -14,9 +14,10 @@ module Framework.API import Debug.Trace -import qualified Network.Shed.Httpd as Httpd +-- import qualified Network.Shed.Httpd as Httpd import qualified Database.HDBC as HDBC import qualified Data.Map as M +import Network.HTTP import Framework.Types import qualified Framework.Utils as Utils @@ -99,7 +100,7 @@ getcookie :: ActionConfig -> String -> String getcookie ac name = Cookies.getcookie (request ac) name -- | Return HttpHeader, which sets specified cookie. -setcookie :: ActionConfig -> String -> String -> HttpHeader +setcookie :: ActionConfig -> String -> String -> Header setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value ---------------------------------------------------------------------------------------------------------- diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index a012aa6..e462d54 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -8,7 +8,7 @@ module Framework.Forms.Types FormValidator, FieldValidator ) where -import Network.Shed.Httpd (Request) +import Network.HTTP import Framework.Types import Framework.Models @@ -47,7 +47,7 @@ data HTMLForm = HTMLForm { formId :: String, formAction :: String } -type FormValidator = Request -> Either [String] Model +type FormValidator = Request String -> 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 c57db0d..b67c119 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -14,7 +14,7 @@ import Debug.Trace import qualified Data.Map as M import Data.Maybe -import Network.Shed.Httpd (Request,Response) +import Network.HTTP (Request,Response) import qualified Database.HDBC as D import Framework.Types @@ -83,11 +83,11 @@ 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 +returnInvalidForm :: ActionConfig -> Form -> String -> [String] -> IO (Response String) 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 + where values = tail $ urlencode $ map packParam vars vars = formVars form fid (request conf) isRight :: Either t1 t -> Bool isRight (Right _) = True @@ -115,13 +115,13 @@ defValidate form fid rq = vars :: [String] vars = formVarsValues form fid rq -formVarsValues :: Form -> String -> Request -> [String] +formVarsValues :: Form -> String -> Request String -> [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)] +formVars :: Form -> String -> Request String -> [(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 -> (Either [String] Model, String, String) +getAnyForm :: M.Map String Form -> Request String -> (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 -> (Either [String] Model, String) +getForm :: M.Map String Form -> Request String -> 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 1733072..99aa390 100644 --- a/Framework/Http/Cookies.hs +++ b/Framework/Http/Cookies.hs @@ -4,7 +4,7 @@ module Framework.Http.Cookies import Debug.Trace import Data.Char -import Network.Shed.Httpd +import Network.HTTP import Framework.Types import Framework.Utils @@ -12,16 +12,17 @@ import Framework.Utils setcookie :: String -- ^ Expiration date -> String -- ^ Cookie name -> String -- ^ Cookie value - -> HttpHeader -setcookie exp name value = "Set-Cookie" =: ((esc (name++"="++value))++"; expires="++exp) + -> Header +setcookie exp name value = mkHeader HdrSetCookie ((esc (name++"="++value))++"; expires="++exp) -getcookie :: Request -- ^ HTTP request +getcookie :: Request String -- ^ HTTP request -> String -- ^ Cookie name -> String getcookie rq name = maybe "" id $ lookup name 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" +allcookies :: Request String -> [(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 061a9de..2b0d760 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -13,8 +13,10 @@ import Control.Concurrent.Chan import Codec.Binary.UTF8.String import System.Directory import Control.Exception -import Network.Shed.Httpd +-- import Network.Shed.Httpd import Network.URI +import Network.HTTP +import Data.Maybe import Framework.Cache import Framework.Storage @@ -25,21 +27,22 @@ import Framework.Urls import Framework.Utils import Framework.Http.Response import Framework.Http.Middlewares +import Framework.Http.Httpd -- | Send a file -sendfile :: String -> IO Response +sendfile :: String -> IO (Response String) sendfile filename = do body <- readFile filename - return $ response 200 ["Content-Type" =: mime] body + return $ response 200 [mkHeader HdrContentType mime] body - where mime = chooseMime filename + where mime = fromMaybe "application/octet-stream" $ chooseMime filename -- | Just serve static files serveStatic :: StrAction serveStatic ac s = Just $ serveStatic' ac s serveStatic' ac resource = - if (reqMethod $ request ac) == "GET" + if (rqMethod $ request ac) == GET then do writeLog (logChan $ httpParams ac) (request ac) $ "Sending "++filepath exists <- doesFileExist filepath @@ -47,7 +50,7 @@ serveStatic' ac resource = else return $ response 400 [] "Invalid request method" where - handleError :: SomeException -> IO Response + handleError :: SomeException -> IO (Response String) handleError e = do writeLog (errChan $ httpParams ac) (request ac) $ show e return $ response 500 [] (show e ++ emptyLine) @@ -62,9 +65,9 @@ serveStatic' ac resource = choose x = basedir ++"/"++x -- | This function is called on each HTTP request -httpWorker :: StaticConfig -> URLConf -> Request -> IO Response -httpWorker hap conf req@(Request {reqURI = URI {uriPath}}) = do - let s = unEscapeString $ reqBody req +httpWorker :: StaticConfig -> URLConf -> Request String -> IO (Response String) +httpWorker hap conf req@(Request {rqURI = URI {uriPath}}) = do + let s = unEscapeString $ rqBody req -- putStrLn $ "Request body: "++show s -- putStrLn $ "deUTF:"++(decodeString s) -- putStrLn $ "Serving "++uriPath diff --git a/Framework/Http/Httpd.hs b/Framework/Http/Httpd.hs new file mode 100644 index 0000000..30ae4ae --- /dev/null +++ b/Framework/Http/Httpd.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE PatternGuards,ViewPatterns #-} +-- | +-- Module: Httpd +-- Copyright: Andy Gill, Ilya Portnov +-- License: BSD3 +-- +-- Maintainer: Ilya Portnov +-- Stability: unstable +-- Portability: GHC +-- +-- +-- A trivial web server. +-- +-- This web server promotes a Request to IO Response function +-- into a local web server. The user can decide how to interpret +-- the requests, and the library is intended for implementing Ajax APIs. +-- +-- initServerLazy (and assocated refactorings) was written by Henning Thielemann. +-- + +module Framework.Http.Httpd + ( Server + , initServer + , initServerLazy + , queryToArguments + , addCache + , noCache + , contentType + , int2respCode + ) where + +--import System.Posix +--import System.Posix.Signals +import Prelude hiding (print) +import Network +import Network.URI +import Network.HTTP +import Network.Stream +import System.IO hiding (hPutStr,hPutStrLn,print,hGetLine) +import System.IO.UTF8 +import Control.Monad +import Control.Monad +import Control.Concurrent +import Control.Exception as Exc +import qualified Data.List as List +import qualified Data.Char as Char +import qualified Data.ByteString.Lazy.Char8 as L +import Numeric (showHex) + +type Server = () -- later, you might have a handle for shutting down a server. +type S = String + +{- | +This server transfers documents as one parcel, using the content-length header. +-} + +initServer + :: Int -- ^ The port number + -> (Request S -> IO (Response S)) -- ^ The functionality of the Sever + -> IO Server -- ^ A token for the Server +initServer = + initServerMain + (\body -> ([mkHeader HdrContentLength (show $ length body)], body)) + +{- | +This server transfers documents in chunked mode +and without content-length header. +This way you can ship infinitely big documents. +It inserts the transfer encoding header for you. +-} +initServerLazy + :: Int -- ^ Chunk size + -> Int -- ^ The port number + -> (Request S -> IO (Response S)) -- ^ The functionality of the Sever + -> IO Server -- ^ A token for the Server +initServerLazy chunkSize = + initServerMain + (\body -> + ([mkHeader HdrTransferEncoding "chunked"], + concatMap (\str -> showHex (length str) $ showString "\r\n" $ str) $ + slice chunkSize body ++ [[]])) + +-- cf. Data.List.HT.sliceVertical +slice :: Int -> [a] -> [[a]] +slice n = + map (take n) . takeWhile (not . null) . iterate (drop n) + +parseStartLine :: String -> Maybe (RequestMethod,String,String) +parseStartLine (words -> [mode, uri, proto]) = Just (method, uri, proto) + where + method | mode=="GET" = GET + | mode=="PUT" = PUT + | mode=="POST" = POST + | otherwise = Custom mode +parseStartLine _ = Nothing + +initServerMain + :: (String -> ([Header], String)) + -> Int + -> (Request S -> IO (Response S)) + -> IO Server +initServerMain processBody portNo callOut = do +-- installHandler sigPIPE Ignore Nothing + sock <- listenOn (PortNumber $ fromIntegral portNo) + forever + (do (h,_nm,_port) <- accept sock + forkIO $ do + ln <- hGetLine h + case parseStartLine ln of + Just (mode,uri,proto) -> + if (mode `elem` [GET,POST,PUT]) && ((proto=="HTTP/1.1")||(proto=="HTTP/1.0")) + then case parseURIReference uri of + Just uri' -> readHeaders h mode uri' + _ -> do print uri + hClose h + else hClose h + _ -> hClose h + return () + ) `finally` sClose sock + + where + readHeaders h mode uri = do + lns <- readUntilEmptyLine h + case parseHeaders lns of + Right hdrs -> readPOST h mode uri hdrs + Left err -> hClose h -- strange format -- FIXME: arguable answer? + + readPOST h mode uri hds = + if mode `elem` [POST,PUT] + then case read `fmap` (lookupHeader HdrContentLength hds) of + Just n -> do postbody <- hGetChars h n + work postbody + _ -> work "" + else work "" + where work = sendRequest h mode uri hds + + message code = show code ++ " " ++ + case lookup code longMessages of + Just msg -> msg + Nothing -> "-" + sendRequest h mode uri hds rbody = do + resp <- callOut $ Request { rqMethod = mode + , rqURI = uri + , rqHeaders = hds + , rqBody = rbody + } + let (additionalHeaders, body) = + processBody $ rspBody resp + writeLines h $ + ("HTTP/1.1 " ++ message (rspCode resp)) : + ("Connection: close") : + (concatMap show (rspHeaders resp ++ additionalHeaders)): [] + hPutStr h body + hClose h + +readUntilEmptyLine :: Handle -> IO [String] +readUntilEmptyLine h = read' [] + where + read' acc = do + line <- hGetLine h + if null line + then return acc + else read' (acc++[line]) + +int2respCode :: Int -> ResponseCode +int2respCode n = + let c = n `mod` 10 + b = (n-c) `mod` 100 + a = (n-10*b-c) `mod` 1000 + in (a,b,c) + +-- | Read the given number of bytes from a Handle +hGetChars :: Handle -> Int -> IO String +hGetChars h n = fmap L.unpack $ L.hGet h n + +writeLines :: Handle -> [String] -> IO () +writeLines h = + hPutStr h . concatMap (++"\r\n") + +-- | Takes an escaped query, optionally starting with '?', and returns an unescaped index-value list. +queryToArguments :: String -> [(String,String)] +queryToArguments ('?':rest) = queryToArguments rest +queryToArguments input = findIx input + where + findIx = findIx' . span (/= '=') + findIx' (index,'=':rest) = findVal (unEscapeString index) rest + findIx' _ = [] + + findVal index = findVal' index . span (/= '&') + findVal' index (value,'&':rest) = (index,unEscapeString value) : findIx rest + findVal' index (value,[]) = [(index,unEscapeString value)] + findVal' _ _ = [] + +-- data Request = Request +-- { reqMethod :: String +-- , reqURI :: URI +-- , reqHeaders :: [(String,String)] +-- , reqBody :: String +-- } +-- deriving Show +-- +-- data Response = Response +-- { resCode :: Int +-- , resHeaders :: [(String,String)] +-- , resBody :: String +-- } +-- deriving Show + +addCache :: Int -> (String,String) +addCache n = ("Cache-Control","max-age=" ++ show n) + +noCache :: (String,String) +noCache = ("Cache-Control","no-cache") + +-- examples include "text/html" and "text/plain" + +contentType :: String -> (String,String) +contentType msg = ("Content-Type",msg) + +------------------------------------------------------------------------------ +longMessages :: [(ResponseCode ,String)] +longMessages = + [ ((2,0,0),"OK") + , ((2,0,1),"Created") + , ((2,0,4),"No content") + , ((3,0,1),"Moved permanently") + , ((3,0,2),"Moved temporarly") + , ((4,0,0),"Invalid request") + , ((4,0,3),"Forbidden") + , ((4,0,4),"Not Found") + , ((5,0,0),"Internal server error") + , ((5,0,1),"Not implemented") + ] diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index bcfccf0..5c88d76 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -4,17 +4,16 @@ module Framework.Http.Middlewares ResponseMiddleware, responseMiddlewares) where -import Network.Shed.Httpd -- (Request,Response) +-- import Network.Shed.Httpd -- (Request,Response) +import Network.HTTP import Framework.Utils -type RequestMiddleware = Request -> IO Request -type ResponseMiddleware = Response -> IO Response +type RequestMiddleware = Request String -> IO (Request String) +type ResponseMiddleware = Response String -> IO (Response String) -ctype = "Content-Type" - -addEncoding enc (Response c hdrs b) = - case lookup ctype hdrs of - Nothing -> Response c ((ctype ,"text/html; charset="++enc):hdrs) b - Just s -> Response c (update ctype (s++"; charset="++enc) hdrs) b +addEncoding enc resp = + case lookupHeader HdrContentType (rspHeaders resp) of + Nothing -> replaceHeader HdrContentType ("text/html; charset="++enc) resp + Just ctype -> insertHeader HdrContentType (ctype++"; charset="++enc) resp responseMiddlewares = return . (addEncoding "UTF-8") diff --git a/Framework/Http/Response.hs b/Framework/Http/Response.hs index a04404d..a849f1d 100644 --- a/Framework/Http/Response.hs +++ b/Framework/Http/Response.hs @@ -4,10 +4,11 @@ module Framework.Http.Response redirect, redirectG, redirectP, (<+>), (<++>) ) where -import qualified Network.Shed.Httpd as Httpd +import Network.HTTP import Framework.Types import Framework.Utils +import Framework.Http.Httpd ----------------------------------------------------------------------------------------------- @@ -18,36 +19,36 @@ url ? pairs = url++(urlencode pairs) -- * Make a Response -- | Generic response response :: Int -- ^ HTTP status code - -> [HttpHeader] -- ^ HTTP headers + -> [Header] -- ^ HTTP headers -> String -- ^ Response body - -> Httpd.Response -response code pairs body = Httpd.Response code (map repackHeader $ filter notEmptyHeader pairs) body - where notEmptyHeader (_:=v) = not $ httpEmpty v + -> Response String +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 -> Httpd.Response -ok body = response 200 ["Content-Type" =: mime] body +ok :: String -> Response String +ok body = response 200 [mkHeader HdrContentType mime] body where mime = "text/html" -- | HTTP 302 redirect response with given text -redirect :: String -> Httpd.Response -redirect url = response 302 ["Location" =: url] "" +redirect :: String -> Response String +redirect url = response 302 [mkHeader HdrLocation url] "" -- | HTTP 301 redirect response with given text -redirectP :: String -> Httpd.Response -redirectP url = response 301 ["Location" =: url] "" +redirectP :: String -> Response String +redirectP url = response 301 [mkHeader HdrLocation url] "" -- | Generic 302 redirect redirectG :: String -- ^ Response body -> [UrlParam] -- ^ Parameters for URL - -> Httpd.Response + -> Response String redirectG url pairs = redirect $ url ? pairs -- | Add HTTP header to response -(<+>) :: Httpd.Response -> HttpHeader -> Httpd.Response -(Httpd.Response c hdrs b) <+> hdr = Httpd.Response c (hdrs++[repackHeader hdr]) b +(<+>) :: Response String -> Header -> Response String +(Response c m hdrs b) <+> hdr = Response c m (hdrs++[hdr]) b -- | Add list of HTTP headers to response -(<++>) :: Httpd.Response -> [HttpHeader] -> Httpd.Response -(Httpd.Response c old b) <++> new = Httpd.Response c (old++(map repackHeader new)) b +(<++>) :: Response String -> [Header] -> Response String +(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 b9f2c30..a7a12e7 100644 --- a/Framework/Http/Sessions.hs +++ b/Framework/Http/Sessions.hs @@ -17,8 +17,8 @@ import System.Directory import System.FilePath ((</>)) import System.Random import qualified Data.Map as M +import Network.HTTP -import Network.Shed.Httpd(Request) import Framework.Types import Framework.Utils @@ -71,7 +71,7 @@ sFree :: SessionsConnection -> IO () sFree (SConnection b) = sfree b -- | Acquire session (create new or use existing SessionID) -session :: SessionsConnection -> Request -> IO Session +session :: SessionsConnection -> Request String -> IO Session session (SConnection b) rq = if null sid then do n <- getStdRandom (randomR (100,maxBound::Int)) @@ -83,5 +83,5 @@ session (SConnection b) rq = -- | Form SessionID cookie header sessionCookie :: String -- ^ Cookie expiration date -> SessionID -- ^ Session ID - -> HttpHeader + -> Header sessionCookie exp sid = setcookie exp "SessionID" sid diff --git a/Framework/Logger.hs b/Framework/Logger.hs index 695955e..ba4108f 100644 --- a/Framework/Logger.hs +++ b/Framework/Logger.hs @@ -14,11 +14,10 @@ import Control.Monad import Control.Concurrent import Control.Concurrent.Chan import Text.Printf - -import Network.Shed.Httpd (Request) +import Network.HTTP data LogItem = LogItem { - logRequest :: Request, + logRequest :: Request String, logTime :: String, logMessage :: String } @@ -36,7 +35,7 @@ currentTime = do formatMsg :: LogItem -> String formatMsg item = printf "%s: %s" (logTime item) (logMessage item) -writeLog :: Log -> Request -> String -> IO () +writeLog :: Log -> Request String -> String -> IO () writeLog chan rq msg = do time <- currentTime writeChan chan $ LogItem rq time msg diff --git a/Framework/Types.hs b/Framework/Types.hs index 02cb49a..5cce8ab 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -2,10 +2,10 @@ 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 +import Network.HTTP import Framework.Http.SessionTypes import Framework.CacheTypes @@ -42,7 +42,7 @@ data StaticConfig = HP { -- | Runtime controller action configuration data ActionConfig = ActionConfig { - request :: Request, -- ^ HTTP request + request :: Request String, -- ^ HTTP request httpParams :: StaticConfig, -- ^ Static (global) configuration dbconnection :: DBConnection, -- ^ DB connection sessionID :: SessionID, -- ^ Current HTTP session ID @@ -55,52 +55,18 @@ data ActionConfig = ActionConfig { } deriving (Show) -class HttpValue v where - httpEmpty :: v -> Bool - httpShow :: v -> String +data UrlParam = String := String +type FormVar = UrlParam -data HttpBox = forall a. HttpValue a => HB a +-- FIXME: remove this doubt operator :) +(=:) :: String -> String -> UrlParam +name =: value = name := value -instance HttpValue (Maybe String) where - httpEmpty Nothing = True - httpEmpty (Just _) = False +repackHeader :: Header -> (String,String) +repackHeader hdr = (show $ hdrName hdr, hdrValue hdr) - 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 String 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) - -repackHeader :: HttpHeader -> (String,String) -repackHeader (n := v) = (n, httpShow v) - -packHeader :: (String,String) -> HttpHeader -packHeader (n,v) = (n =: v) +packParam :: (String,String) -> UrlParam +packParam (n,v) = (n =: v) ------------------------------------------------------------------------------------------- diff --git a/Framework/Urls.hs b/Framework/Urls.hs index c5ffecd..acd9242 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -8,7 +8,9 @@ import Data.Char import Codec.Binary.UTF8.String import Text.Regex.PCRE import Network.URI -import Network.Shed.Httpd(reqBody,Response,reqURI,Request,queryToArguments) +-- FIXME! +import Network.Shed.Httpd(queryToArguments) +import Network.HTTP import Data.List import Framework.Utils @@ -19,11 +21,11 @@ import Framework.Http.Response ((<+>)) type URLParts = [String] -- | Function which get one String argument and (maybe) returns Response -type StrAction = ActionConfig -> String -> Maybe (IO Response) +type StrAction = ActionConfig -> String -> Maybe (IO (Response String)) -- | Function which get many String arguments and (maybe) returns Response -type ManyStrAction = ActionConfig -> URLParts -> Maybe (IO Response) +type ManyStrAction = ActionConfig -> URLParts -> Maybe (IO (Response String)) -- | Function which just returns Response -type HttpAction = ActionConfig -> IO Response +type HttpAction = ActionConfig -> IO (Response String) -- | URL dispatcher config data URLConf = Action HttpAction -- ^ Simple answer, not depending on URL @@ -60,10 +62,10 @@ urlJoin us = concat $ intersperse "/" us -- | Main dispatcher function runURLConf :: StaticConfig -- ^ Static (global) config - -> Request -- ^ HTTP request + -> Request String -- ^ HTTP request -> String -- ^ URL itself -> URLConf -- ^ Dispatcher configuration - -> IO Response + -> IO (Response String) runURLConf ps rq s conf = let murl = parseURIReference s in case murl of Nothing -> error "Couldn't parse URL!" @@ -77,7 +79,7 @@ runURLConf ps rq s conf = let murl = parseURIReference s then return $ resp <+> Sessions.sessionCookie (cookiesExp ac) (sessionID ac) else return resp -runURLConf' :: URLConf -> URLParts -> ActionConfig -> Maybe (IO Response) +runURLConf' :: URLConf -> URLParts -> ActionConfig -> Maybe (IO (Response String)) -- runURLConf' _ [] _ = Nothing runURLConf' (Prefix p conf) (x:xs) ac | p==x = runURLConf' conf xs ac | otherwise = Nothing @@ -138,43 +140,43 @@ infixr 6 >=> ------------------------------------------------------------------------------------------------ -- -- | Get HTTP GET var value -httpGetVar :: Request -- ^ HTTP Request +httpGetVar :: Request String -- ^ HTTP Request -> String -- ^ Var name -> Maybe String httpGetVar rq name = lookup name pairs - where pairs = queryToArguments $ uriQuery $ reqURI rq + where pairs = queryToArguments $ uriQuery $ rqURI rq -- | Same, but with default value -httpGetVar' :: Request +httpGetVar' :: Request String -> String -- ^ Var name -> String -- ^ Default value -> String httpGetVar' rq name def = maybe def id $ lookup name pairs - where pairs = queryToArguments $ uriQuery $ reqURI rq + where pairs = queryToArguments $ uriQuery $ rqURI rq -- | Get HTTP POST var value -httpPostVar :: Request -> String -> Maybe String +httpPostVar :: Request String -> String -> Maybe String httpPostVar rq name = lookup name pairs - where pairs = decodePairs (reqBody rq) + where pairs = decodePairs (rqBody rq) -- | Same, but with default value -httpPostVar' :: Request +httpPostVar' :: Request String -> String -- ^ Var name -> String -- ^ Default value -> String httpPostVar' rq name def = maybe def id $ lookup name pairs - where pairs = decodePairs (reqBody rq) + where pairs = decodePairs (rqBody rq) -- | Add GET var to given Request and return resulting URL -httpAddGetVar :: Request +httpAddGetVar :: Request String -> String -- ^ Var name -> String -- ^ Var value -> String -httpAddGetVar rq name value = urlencode (map packHeader pairs') +httpAddGetVar rq name value = urlencode (map packParam pairs') where pairs' = update name value pairs - pairs = decodePairs (uriQuery $ reqURI rq) + pairs = decodePairs (uriQuery $ rqURI rq) -- | Get URL from Request -myUrl :: Request -> String -myUrl rq = uriPath $ reqURI rq +myUrl :: Request String -> String +myUrl rq = uriPath $ rqURI rq diff --git a/Framework/Utils.hs b/Framework/Utils.hs index 9670e1a..c8dd190 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Framework.Utils where -import Network.Shed.Httpd import qualified Data.Map as M import Data.List import Data.Char @@ -12,6 +11,9 @@ import System.Time import System.Locale import Codec.Binary.UTF8.String import Network.URI +import Network.HTTP +-- ! FIXME +import Network.Shed.Httpd (queryToArguments) import Framework.Types @@ -46,8 +48,8 @@ chooseMime filename = M.lookup ext mimes where ext = getExt filename -emptyResponse = Response 200 [] "" -noSuchUrl debug conf = Response 404 [] ("<p>No such URL!</p>"++d) +emptyResponse = Response (2,0,0) "" [] "" +noSuchUrl debug conf = Response (4,0,4) "" [] ("<p>No such URL!</p>"++d) where d = if debug then "<p>URLConf was:"++(show conf)++"</p>" else "" number = "[0-9]+" @@ -84,7 +86,7 @@ decodePair = head.decodePairs urlencode pairs = '?':(concat $ intersperse "&" $ map escapePair pairs) -escapePair (n:=v) = (esc n)++"="++(esc $ httpShow v) +escapePair (n:=v) = (esc n)++"="++(esc v) esc = (escapeURIString isAllowedInURI).encodeString diff --git a/Framework/Wrapper.hs b/Framework/Wrapper.hs index 6cc268b..8eec1cb 100644 --- a/Framework/Wrapper.hs +++ b/Framework/Wrapper.hs @@ -1,7 +1,7 @@ module Framework.Wrapper where -import Network.Shed.Httpd(reqBody,Response,reqURI,Request,queryToArguments) import qualified Data.Map as M +import Network.HTTP import qualified Framework.Http.Cookies as Cookies import qualified Framework.Http.Sessions as Sessions @@ -13,7 +13,7 @@ import Framework.Utils -- | Prepare ActionConfig for controller. This connects to DB etc. -- Returns (ActionConfig, WhetherToAddSessionCookie) -mkActionConfig :: StaticConfig -> Request -> IO (ActionConfig,Bool) +mkActionConfig :: StaticConfig -> Request String -> 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 -- ^ HTTP request - -> (ActionConfig -> IO Response) -- ^ Worker function - -> IO Response + -> Request String -- ^ HTTP request + -> (ActionConfig -> IO (Response String)) -- ^ Worker function + -> IO (Response String) withConfig hp rq f = do (conf,addSession) <- mkActionConfig hp rq resp <- f conf