Permalink
Browse files

Updating to HTTP 4k and adding better form handling (including files)

  • Loading branch information...
1 parent 30ff4a0 commit e8c1bd489c1cae3e3950972760ce1aa69a7d68fc @alsonkemp committed Jun 3, 2009
View
@@ -24,6 +24,7 @@ module Turbinado.Controller (
module Turbinado.Controller.Routes,
module Turbinado.Environment.CodeStore,
module Turbinado.Environment.Cookie,
+ module Turbinado.Environment.Files,
module Turbinado.Environment.Header,
module Turbinado.Environment.Logger,
module Turbinado.Environment.Params,
@@ -47,6 +48,7 @@ import Config.Master
import Turbinado.Environment.CodeStore
import Turbinado.Environment.Cookie
import Turbinado.Environment.Database
+import Turbinado.Environment.Files
import Turbinado.Environment.Header
import Turbinado.Environment.Logger
import Turbinado.Environment.Params
@@ -21,6 +21,6 @@ addDatabaseToEnvironment :: (HasEnvironment m) => m ()
addDatabaseToEnvironment = do e <- getEnvironment
case databaseConnection of
Nothing -> return ()
- Just conn -> do c <- liftIO $ conn
+ Just conn -> do c <- liftIO $ (conn :: IO Connection)
setEnvironment $ e {getDatabase = Just (ConnWrapper c)}
@@ -0,0 +1,45 @@
+module Turbinado.Environment.Files(
+ getFile,
+ getFile_u,
+ getFileContent,
+ getFileDecode
+ ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.Map as M
+import Data.Maybe
+import Network.HTTP
+import Network.HTTP.Headers
+import Network.URI
+import Codec.MIME.Type
+import Codec.MIME.Decode
+
+import Turbinado.Environment.Params
+import Turbinado.Environment.Types
+import Turbinado.Utility.Data
+
+-- | Attempt to get a File from the POST
+getFile :: (HasEnvironment m) => String -> m (Maybe MIMEValue)
+getFile f = do populateParamsAndFiles
+ e <- getEnvironment
+ let Files fs = fromJust' "Turbinado.Environment.Files.getFile: Files is Nothing" $ getFiles e
+ return $ M.lookup f fs
+
+-- | An unsafe version of getFile. Errors if the key does not exist.
+getFile_u :: (HasEnvironment m) => String -> m MIMEValue
+getFile_u f = do r <- getFile f
+ maybe (error $ "getFile_u : key does not exist - \"" ++ f ++ "\"")
+ return
+ r
+
+getFileContent :: MIMEValue -> String
+getFileContent mv = case (mime_val_content mv) of
+ Single c -> c
+ _ -> error "Turbinado.Environment.Params.getContent: called with a Multi Content"
+
+getFileDecode :: MIMEValue -> String
+getFileDecode mv =
+ case (mime_val_content mv) of
+ --Single c -> decodeBody "base64" c
+ Single c -> decodeWords c
+ _ -> error "Turbinado.Environment.Params.getContent: called with a Multi Content"
@@ -4,7 +4,7 @@ module Turbinado.Environment.Header (
) where
import Data.Maybe
-import Network.HTTP
+import qualified Network.HTTP as HTTP
import Network.HTTP.Headers
import Turbinado.Controller.Monad
@@ -1,55 +1,128 @@
module Turbinado.Environment.Params(
- getParam,
- getParam_u
- ) where
+getParam,
+getParam_u,
+populateParamsAndFiles
+) where
+import Control.Monad
+import qualified Data.ByteString.Lazy.Char8 as BS
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.Map as M
+import Data.Int (Int64)
+import Data.List
import Data.Maybe
import Network.HTTP
import Network.HTTP.Headers
import Network.URI
import Turbinado.Environment.Header
+import Turbinado.Environment.Logger
import Turbinado.Environment.Request
import Turbinado.Environment.Types
import Turbinado.Utility.Data
+import Codec.MIME.Parse
+import Codec.MIME.Type
+
-- | Attempt to get a Parameter from the Request query string
-- or POST body.
getParam :: (HasEnvironment m) => String -> m (Maybe String)
-getParam p = do r <- getParamFromQueryString p
- case r of
- Just r' -> return r
- Nothing -> getParamFromBody p
-
+getParam p = do (Params ps) <- populateParamsAndFiles -- lazy population
+ return $ M.lookup p ps
+
-- | An unsafe version of getParam. Errors if the key does not exist.
getParam_u :: (HasEnvironment m) => String -> m String
getParam_u p = do r <- getParam p
maybe (error $ "getParam_u : key does not exist - \"" ++ p ++ "\"")
- return
- r
+ return
+ r
+
+populateParamsAndFiles :: (HasEnvironment m) => m Params
+populateParamsAndFiles = do e <- getEnvironment
+ case (getParams e) of
+ Just ps' -> return ps'
+ Nothing -> do ct <- getHeader HdrContentType
+ let rm = rqMethod (fromJust' "Params : getParamsFromBody" $ Turbinado.Environment.Types.getRequest e)
+ rb = rqBody (fromJust' "Params : getParamsFromBody" $ Turbinado.Environment.Types.getRequest e)
+ qsPs <- setParamsFromQueryString -- always process the query string
+ case rm of
+ POST -> case ct of
+ Just "application/x-www-form-urlencoded" -> setParamsFromBody rb qsPs
+ _ -> setParamsFromForm rb qsPs
+ _ -> return qsPs
-- Functions used by getParam. Not exported.
-getParamFromQueryString :: (HasEnvironment m) => String -> m (Maybe String)
-getParamFromQueryString s = do e <- getEnvironment
- let qs = uriQuery $ rqURI (fromJust' "Params : getParamFromQueryString" $ getRequest e)
- return $ lookup s $ formDecode qs
-
-getParamFromBody :: (HasEnvironment m) => String -> m (Maybe String)
-getParamFromBody s = do e <- getEnvironment
- ct <- getHeader HdrContentType
- let rm = rqMethod (fromJust' "Params : getParamsFromBody" $ getRequest e)
- rb = rqBody (fromJust' "Params : getParamsFromBody" $ getRequest e)
- case rm of
- POST -> -- TODO: ADD MULTIPART
- return $ lookup s $ formDecode rb
- _ -> return Nothing
+setParamsFromQueryString :: (HasEnvironment m) => m Params
+setParamsFromQueryString = do e <- getEnvironment
+ let qs = dropWhile (=='?') $ uriQuery $ rqURI (fromJust' "Params : getParamFromQueryString" $ Turbinado.Environment.Types.getRequest e)
+ ps = Params $ M.fromList $ qsDecode qs
+ setEnvironment $ e {getParams = Just ps}
+ return ps
+
+setParamsFromBody :: (HasEnvironment m) => String -> Params -> m Params
+setParamsFromBody s (Params qsps) = do e <- getEnvironment
+ let ps = Params $ M.union (M.fromList $ qsDecode s) qsps
+ setEnvironment $ e {getParams = Just ps}
+ return ps
+
+setParamsFromForm :: (HasEnvironment m) => String -> Params -> m Params
+setParamsFromForm s qsps = multipartDecode s qsps
-- LIFTED FROM THE CGI PACKAGE
--- | Gets the name-value pairs from application\/x-www-form-urlencoded data.
-formDecode :: String -> [(String,String)]
-formDecode "" = []
-formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs)
- where (nv,rs) = break (=='&') s
- (n,v) = break (=='=') nv
+-- | Gets the name-value pairs from urlencoded data.
+qsDecode :: String -> [(String,String)]
+qsDecode "" = []
+qsDecode s = (urlDecode n, urlDecode (drop 1 v)) : qsDecode (drop 1 rs)
+ where (nv,rs) = break (=='&') s
+ (n,v) = break (=='=') nv
+
+multipartDecode :: (HasEnvironment m) => String -> Params -> m Params
+multipartDecode s qsps = do hd <- getHeader_u HdrContentType
+ errorM $ "hd: " ++ hd
+ let ms = parseMIMEBody [("content-type", hd)] s
+ (fs, ps) = extractParamsAndFiles ms
+ (Params qsps') = qsps
+ ps' = Params $ M.union ps qsps'
+ errorM $ "qsps: " ++ show qsps'
+ errorM $ "ps: " ++ show ps
+ errorM $ "ps': " ++ show (M.union ps qsps')
+ e <- getEnvironment
+ setEnvironment $ e { getFiles = Just $ Files fs, getParams = Just ps'}
+ return ps'
+
+
+{-
+First draft:
+
+If there is a disposition we could have a file, and we look at the content, if there is one single content we add it into the Files Map.
+If there are more than one Files we run the function for each file.
+-}
+extractParamsAndFiles :: MIMEValue -> (M.Map String MIMEValue, M.Map String String)
+extractParamsAndFiles mi = worker (M.empty, M.empty) mi
+ where worker :: (M.Map String MIMEValue, M.Map String String) -> MIMEValue -> (M.Map String MIMEValue, M.Map String String)
+ worker (fs,ps) mv = if (isSingle mv)
+ then case (getFileAndName $ dispParams $ fromJust' "MIMEValue has no Dispositions" $ mime_val_disp mv) of
+ (True, nm) -> (M.insert nm mv fs,ps)
+ (False, nm) -> (fs, M.insert nm (_getContent mv) ps)
+ else foldl worker (fs, ps) (_getContents mv)
+
+_getContent mv = case (mime_val_content mv) of
+ Single c -> c
+ _ -> error "Turbinado.Environment.Params.getContent: called with a Multi Content"
+
+_getContents mv = case (mime_val_content mv) of
+ Multi c -> c
+ _ -> error "Turbinado.Environment.Params.getContents: called with a Single Content"
+
+isSingle :: MIMEValue -> Bool
+isSingle mv = case (mime_val_content mv) of
+ Single _ -> True
+ _ -> False
+
+getFileAndName :: [DispParam] -> (Bool, String)
+getFileAndName ds = worker (False, "no-name-found") ds
+ where worker (b, n) [] = (b, n)
+ worker (_, n) ((Filename _):ds') = worker (True, n) ds'
+ worker (b, _) ((Name n'):ds') = worker (b, n') ds'
View
2 Turbinado/Environment/Request.hs 100644 → 100755
@@ -12,7 +12,7 @@ import Control.Monad.State
import Data.Maybe
import Turbinado.Environment.Types
-addRequestToEnvironment :: (HasEnvironment m) => HTTP.Request -> m ()
+addRequestToEnvironment :: (HasEnvironment m) => HTTP.Request String -> m ()
addRequestToEnvironment req = do e <- getEnvironment
setEnvironment $ e {getRequest = Just $ req}
@@ -20,7 +20,7 @@ import System.Locale
--getResponse = do e <- getEnvironment
-- return $ getResponse e
-setResponse :: (HasEnvironment m) => HTTP.Response -> m ()
+setResponse :: (HasEnvironment m) => HTTP.Response String -> m ()
setResponse resp = do e <- getEnvironment
setEnvironment $ e {getResponse = Just resp}
@@ -5,6 +5,7 @@ module Turbinado.Environment.Settings (
setSetting,
getController,
clearLayout,
+ setLayout,
getView
)where
@@ -14,7 +14,7 @@ import qualified Network.HTTP as HTTP
import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)
import Turbinado.View.XML
import Database.HDBC
-
+import Codec.MIME.Type (MIMEValue)
-- | The class of types which hold an 'Environment'.
-- 'View' and 'Controller' are both instances of this class.
@@ -27,10 +27,12 @@ class (MonadIO m) => HasEnvironment m where
-- Environment can be partially constructed.
data Environment = Environment { getCodeStore :: Maybe CodeStore
, getDatabase :: Maybe ConnWrapper
+ , getFiles :: Maybe Files
, getLoggerLock :: Maybe LoggerLock
, getMimeTypes :: Maybe MimeTypes
- , getRequest :: Maybe HTTP.Request
- , getResponse :: Maybe HTTP.Response
+ , getParams :: Maybe Params
+ , getRequest :: Maybe (HTTP.Request String)
+ , getResponse :: Maybe (HTTP.Response String)
, getRoutes :: Maybe Routes
, getSession :: Maybe Session
, getSettings :: Maybe Settings
@@ -42,8 +44,10 @@ data Environment = Environment { getCodeStore :: Maybe CodeStore
newEnvironment :: Environment
newEnvironment = Environment { getCodeStore = Nothing
, getDatabase = Nothing
+ , getFiles = Nothing
, getLoggerLock = Nothing
, getMimeTypes = Nothing
+ , getParams = Nothing
, getRequest = Nothing
, getResponse = Nothing
, getRoutes = Nothing
@@ -95,6 +99,12 @@ data Cookie = Cookie {
deriving (Show, Read, Eq, Ord)
--
+-- * Types for Files
+--
+
+data Files = Files (M.Map String MIMEValue)
+
+--
-- * Types for Logger
--
@@ -112,6 +122,12 @@ instance Show MimeType where
showsPrec _ (MimeType part1 part2) = showString (part1 ++ '/':part2)
--
+-- * Types for Files
+--
+
+data Params = Params (M.Map String String)
+
+--
-- * Types for Request
--
@@ -5,7 +5,9 @@ module Turbinado.Server.Network (
import Data.Maybe
import Network.Socket
-import Network.HTTP
+import Network.HTTP hiding (receiveHTTP, respondHTTP)
+import Network.HTTP.Stream
+import Network.StreamSocket
import Network.URI
import qualified System.Environment as Env
import System.IO
@@ -30,13 +32,14 @@ receiveRequest (Just sock) = do
case req of
Left e -> throwTurbinado $ BadRequest $ "In receiveRequest : " ++ show e
Right r -> do e <- get
- put $ e {getRequest = Just r}
+ put $ e {Turbinado.Environment.Types.getRequest = Just r}
-- | Get the 'Response' from the 'Environment' and send
-- it back to the client.
sendResponse :: Maybe Socket -> Environment -> IO ()
-sendResponse Nothing e = respondCGI $ fromJust' "Network : sendResponse" $ getResponse e
-sendResponse (Just sock) e = respondHTTP sock $ fromJust' "Network : sendResponse" $ getResponse e
+sendResponse Nothing e = respondCGI $ fromJust' "Network : sendResponse" $ Turbinado.Environment.Types.getResponse e
+sendResponse (Just sock) e = do
+ respondHTTP sock $ fromJust' "Network : sendResponse" $ Turbinado.Environment.Types.getResponse e
-- | Pull a CGI request from stdin
acceptCGI :: Controller ()
@@ -51,7 +54,8 @@ acceptCGI = do body <- liftIO $ hGetContents stdin
Left err -> errorResponse $ show err
Right r -> do e' <- getEnvironment
setEnvironment $ e' {
- getRequest = Just Request { rqURI = rquri
+ Turbinado.Environment.Types.getRequest =
+ Just Request { rqURI = rquri
, rqMethod = rqmethod
, rqHeaders = r
, rqBody = body
@@ -68,7 +72,7 @@ matchRqMethod m = fromJust' "Turbinado.Server.Network:matchRqMethod" $
]
-- | Convert the HTTP.Response to a CGI response for stdout.
-respondCGI :: Response -> IO ()
+respondCGI :: Response String -> IO ()
respondCGI r = do let message = (unlines $ drop 1 $ lines $ show r) ++ "\n\n" ++ rspBody r -- need to drop the first line from the response for CGI
hPutStr stdout message
hFlush stdout
View
@@ -14,7 +14,8 @@ module Turbinado.Server.StandardResponse where
import Data.List
import Data.Maybe
-import Network.HTTP
+import Network.HTTP (Response(..), rspHeaders)
+import Network.HTTP.Stream
import Network.HTTP.Headers
import System.Locale
import System.Time
@@ -27,7 +27,7 @@ tryStaticContent =
do e <- get
cDir <- liftIO $ getCurrentDirectory
let mt = fromJust $ getMimeTypes e
- rq = fromJust $ getRequest e
+ rq = fromJust $ Turbinado.Environment.Types.getRequest e
f = drop 1 $ uriPath $ rqURI rq
trydirs = case (length f) of
0 -> map (\s -> joinPath $ map normalise [cDir, s, "index.html"]) staticDirs
Oops, something went wrong.

0 comments on commit e8c1bd4

Please sign in to comment.