diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,4 +1,25 @@ +2009.4.52 +--------- + +### Feature + +* request / response helper, able to get params / inputs data + +### Fix + +* uniform utf8 interface for string +* compatible with hack 4.52 + +2009.4.51.1 +----------- + +### Fix + +* enforce unicode asap policy +* rename ContnetSize to ContentLenght, since it was a typo + 2009.4.51 +--------- ### Feature @@ -9,6 +30,7 @@ * require MPS 4.50, hack 4.50 2009.4.50 +--------- ### Feature diff --git a/hack-contrib.cabal b/hack-contrib.cabal --- a/hack-contrib.cabal +++ b/hack-contrib.cabal @@ -1,5 +1,5 @@ Name: hack-contrib -Version: 2009.4.51 +Version: 2009.4.52 Build-type: Simple Synopsis: Hack contrib Description: Hack contrib @@ -15,7 +15,7 @@ library ghc-options: -Wall - build-depends: base, cgi, network, haskell98, old-locale, old-time, directory, filepath, containers, bytestring, ansi-wl-pprint, mps >= 2009.4.50, data-default >= 0.2, ansi-wl-pprint, unix, time, pureMD5, hack >= 2009.4.50 + build-depends: base, cgi, network, haskell98, old-locale, old-time, directory, filepath, containers, bytestring, ansi-wl-pprint, mps >= 2009.4.50, data-default >= 0.2, ansi-wl-pprint, unix, time, pureMD5, hack >= 2009.4.52 hs-source-dirs: src/ exposed-modules: Hack.Contrib.Utils @@ -23,7 +23,7 @@ Hack.Contrib.Response Hack.Contrib.Constants - Hack.Contrib.Middleware.ContentSize + Hack.Contrib.Middleware.ContentLength Hack.Contrib.Middleware.ContentType Hack.Contrib.Middleware.File Hack.Contrib.Middleware.Head diff --git a/src/Hack/Contrib/Middleware/BounceFavicon.hs b/src/Hack/Contrib/Middleware/BounceFavicon.hs --- a/src/Hack/Contrib/Middleware/BounceFavicon.hs +++ b/src/Hack/Contrib/Middleware/BounceFavicon.hs @@ -1,3 +1,4 @@ +-- | Stolen from rack-contrib: Bounce those annoying favicon.ico requests module Hack.Contrib.Middleware.BounceFavicon (bounce_favicon) where import Hack diff --git a/src/Hack/Contrib/Middleware/Config.hs b/src/Hack/Contrib/Middleware/Config.hs --- a/src/Hack/Contrib/Middleware/Config.hs +++ b/src/Hack/Contrib/Middleware/Config.hs @@ -1,3 +1,4 @@ +-- | Stolen from rack-contrib: modifies the environment using the block given during initialization. module Hack.Contrib.Middleware.Config (config) where import Hack diff --git a/src/Hack/Contrib/Middleware/ContentLength.hs b/src/Hack/Contrib/Middleware/ContentLength.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/Middleware/ContentLength.hs @@ -0,0 +1,27 @@ +-- | Stolen from rack: Sets the Content-Length header on responses with fixed-length bodies. + +module Hack.Contrib.Middleware.ContentLength (content_length) where + +import Hack +import Hack.Contrib.Utils +import Hack.Contrib.Response +import Hack.Contrib.Constants + +import MPSUTF8 +import Prelude hiding ((.), (^), (>)) + +content_length :: Middleware +content_length app = \env -> do + response <- app env + + if should_size response + then response + .set_header _ContentLength (response.body.bytesize.show) .return + else response .return + + where + should_size response = + [ not $ response.has_header _ContentLength + , not $ response.has_header _TransferEncoding + , not $ status_with_no_entity_body.has(response.status) + ] .and diff --git a/src/Hack/Contrib/Middleware/ContentSize.hs b/src/Hack/Contrib/Middleware/ContentSize.hs deleted file mode 100644 --- a/src/Hack/Contrib/Middleware/ContentSize.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Hack.Contrib.Middleware.ContentSize (content_size) where - -import Hack -import Hack.Contrib.Utils -import Hack.Contrib.Response -import Hack.Contrib.Constants - -import MPSUTF8 -import Prelude hiding ((.), (^), (>)) - -content_size :: Middleware -content_size app = \env -> do - response <- app env - - if should_size response - then response - .set_header _ContentLength (response.body.bytesize.show) .return - else response .return - - where - should_size response = - [ not $ response.has_header _ContentLength - , not $ response.has_header _TransferEncoding - , not $ status_with_no_entity_body.has(response.status) - ] .and diff --git a/src/Hack/Contrib/Middleware/ContentType.hs b/src/Hack/Contrib/Middleware/ContentType.hs --- a/src/Hack/Contrib/Middleware/ContentType.hs +++ b/src/Hack/Contrib/Middleware/ContentType.hs @@ -1,3 +1,5 @@ +-- | Stolen from rack: Sets the Content-Type header on responses which don't have one. + module Hack.Contrib.Middleware.ContentType (content_type) where import Hack diff --git a/src/Hack/Contrib/Middleware/ETag.hs b/src/Hack/Contrib/Middleware/ETag.hs --- a/src/Hack/Contrib/Middleware/ETag.hs +++ b/src/Hack/Contrib/Middleware/ETag.hs @@ -1,3 +1,4 @@ +-- | Stolen from rack-contrib: Automatically sets the ETag header on all String bodies module Hack.Contrib.Middleware.ETag (etag) where import Hack diff --git a/src/Hack/Contrib/Middleware/File.hs b/src/Hack/Contrib/Middleware/File.hs --- a/src/Hack/Contrib/Middleware/File.hs +++ b/src/Hack/Contrib/Middleware/File.hs @@ -1,3 +1,4 @@ +-- | Stolen from rack:serves files below the +root+ given, according to the path info of the Rack request. module Hack.Contrib.Middleware.File (file) where import Hack @@ -16,37 +17,41 @@ import System.FilePath +-- path name should be a unicode_string +-- so you can put unicode chars directly in your config +-- without encoding it + file :: Maybe String -> Middleware file root _ = \env -> do - let path = env.path_info .url2unicode + let path = env.path_info .unescape_uri - if ".." `isInfixOf` path + if ".." `isInfixOf` path then forbidden else path.serve root -serve :: Maybe String -> FilePath -> IO Response +serve :: Maybe String -> String -> IO Response serve root fname = do - cwd <- get_current_directory + cwd <- getCurrentDirectory let my_root = root.fromMaybe cwd let path = my_root / makeRelative "/" fname - exist <- file_exist path + exist <- doesFileExist path if not exist then path.not_found else do - can_read <- path.get_permissions ^ readable + can_read <- path.getPermissions ^ readable if not can_read then path.no_permission else path.serving where serving path = do - content <- path.read_binary_file - size <- path.file_size ^ from_i - mtime_str <- path.file_mtime ^ httpdate + content <- path.b2u.read_binary_file + size <- path.b2u.file_size ^ from_i + mtime_str <- path.b2u.file_mtime ^ httpdate let default_content_type = "application/octet-stream" let safe_lookup = lookup_mime_type > fromMaybe default_content_type diff --git a/src/Hack/Contrib/Middleware/Hub.hs b/src/Hack/Contrib/Middleware/Hub.hs --- a/src/Hack/Contrib/Middleware/Hub.hs +++ b/src/Hack/Contrib/Middleware/Hub.hs @@ -1,11 +1,8 @@ {-# LANGUAGE QuasiQuotes #-} -- the entire logging framework is stolen from [innate](http://github.com/manveru/innate/tree/master) - - module Hack.Contrib.Middleware.Hub where -import Hack import Hack.Contrib.Utils import MPSUTF8 @@ -33,14 +30,14 @@ type Logger = String -> Severity -> IO () -hub :: Stream -> Formatter -> String -> Logger +hub :: (String -> IO ()) -> Formatter -> String -> Logger hub stream formatter program = \message severity -> do time <- now pid <- getProcessID ^ from_i stream $ formatter severity time pid program message -simple_logger :: Stream -> String -> Logger +simple_logger :: (String -> IO ()) -> String -> Logger simple_logger = flip hub simple_formatter simple_formatter :: Formatter diff --git a/src/Hack/Contrib/Middleware/Inspect.hs b/src/Hack/Contrib/Middleware/Inspect.hs --- a/src/Hack/Contrib/Middleware/Inspect.hs +++ b/src/Hack/Contrib/Middleware/Inspect.hs @@ -1,25 +1,9 @@ +-- | print the env and response in the console module Hack.Contrib.Middleware.Inspect (inspect) where import Hack -import Hack.Contrib.Constants -import Hack.Contrib.Response - import MPSUTF8 -import Prelude hiding ((.), (^), (>), head) +import Prelude hiding ((.), (^)) inspect :: Middleware -inspect app = \env -> do - r <- app env - return $ - r - .set_body (output env r) - .set_content_type _TextPlainUTF8 - - where - output env r = - [ env.show - , 70.times '-' - , r.status.show - , r.headers.show - , r.body - ] .join "\n\n" +inspect app = \env -> env.trace'.app ^ trace' diff --git a/src/Hack/Contrib/Middleware/Lambda.hs b/src/Hack/Contrib/Middleware/Lambda.hs --- a/src/Hack/Contrib/Middleware/Lambda.hs +++ b/src/Hack/Contrib/Middleware/Lambda.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} +-- | Paste has a Pony, Rack has a Lobster, Hack has a Lambda >< module Hack.Contrib.Middleware.Lambda (lambda) where import Hack diff --git a/src/Hack/Contrib/Middleware/Lucky.hs b/src/Hack/Contrib/Middleware/Lucky.hs --- a/src/Hack/Contrib/Middleware/Lucky.hs +++ b/src/Hack/Contrib/Middleware/Lucky.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} +-- | Paste has a Pony, Rack has a Lobster, Hack has a Lucky - - module Hack.Contrib.Middleware.Lucky (lucky) where import Hack diff --git a/src/Hack/Contrib/Middleware/Mime.hs b/src/Hack/Contrib/Middleware/Mime.hs --- a/src/Hack/Contrib/Middleware/Mime.hs +++ b/src/Hack/Contrib/Middleware/Mime.hs @@ -4,6 +4,9 @@ import MPSUTF8 import Prelude hiding ((.)) +lookup_mime_type :: String -> Maybe String +lookup_mime_type = flip M.lookup mime_types + mime_types :: M.Map String String mime_types = [ x ".3gp" "video/3gpp" @@ -173,6 +176,3 @@ , x ".zip" "application/zip" ] .to_h where x a b = (a, b) - -lookup_mime_type :: String -> Maybe String -lookup_mime_type = flip M.lookup mime_types diff --git a/src/Hack/Contrib/Middleware/ShowExceptions.hs b/src/Hack/Contrib/Middleware/ShowExceptions.hs --- a/src/Hack/Contrib/Middleware/ShowExceptions.hs +++ b/src/Hack/Contrib/Middleware/ShowExceptions.hs @@ -1,3 +1,4 @@ +-- | Stolen from rack: catches all exceptions raised from the app it wraps. module Hack.Contrib.Middleware.ShowExceptions (show_exceptions) where import Hack @@ -16,7 +17,7 @@ program :: String program = "ShowExceptions" -show_exceptions :: Maybe Stream -> Middleware +show_exceptions :: Maybe (String -> IO ()) -> Middleware show_exceptions stream app = \env -> do let my_stream = stream.fromMaybe (env.hack_errors) let log = simple_logger my_stream program diff --git a/src/Hack/Contrib/Middleware/ShowStatus.hs b/src/Hack/Contrib/Middleware/ShowStatus.hs --- a/src/Hack/Contrib/Middleware/ShowStatus.hs +++ b/src/Hack/Contrib/Middleware/ShowStatus.hs @@ -1,5 +1,10 @@ {-# LANGUAGE QuasiQuotes #-} +-- | Stolen from rack: +-- catches all empty responses the app it wraps and replaces them with a site explaining the error. +-- Additional details can be put into hack.showstatus.detail. +-- and will be shown as HTML. If such details exist, the error page +-- is always rendered, even if the reply was not empty. module Hack.Contrib.Middleware.ShowStatus (show_status) where import Hack @@ -31,7 +36,7 @@ in return $ response - .set_body result + .set_body (result.unescape_unicode_xml.u2b) .set_content_type _TextHtml .set_content_length size @@ -40,7 +45,7 @@ template :: String -> String -> Env -> Response -> String template message detail env response = - let h = escape_html in [$here| + let h = escape_html > escape_unicode_xml in [$here| diff --git a/src/Hack/Contrib/Middleware/SimpleAccessLogger.hs b/src/Hack/Contrib/Middleware/SimpleAccessLogger.hs --- a/src/Hack/Contrib/Middleware/SimpleAccessLogger.hs +++ b/src/Hack/Contrib/Middleware/SimpleAccessLogger.hs @@ -12,7 +12,7 @@ program :: String program = "SimpleAccessLogger" -simple_access_logger :: Maybe Stream -> Middleware +simple_access_logger :: Maybe (String -> IO ()) -> Middleware simple_access_logger stream app = \env -> do let my_stream = stream.fromMaybe (env.hack_errors) let log = simple_logger my_stream program diff --git a/src/Hack/Contrib/Middleware/SimpleRouter.hs b/src/Hack/Contrib/Middleware/SimpleRouter.hs --- a/src/Hack/Contrib/Middleware/SimpleRouter.hs +++ b/src/Hack/Contrib/Middleware/SimpleRouter.hs @@ -1,5 +1,16 @@ {-# LANGUAGE QuasiQuotes #-} +-- | Stolen from rack: +-- Rack::URLMap takes a hash mapping urls or paths to apps, and +-- dispatches accordingly. +-- +-- URLMap modifies the SCRIPT_NAME and PATH_INFO such that the part +-- relevant for dispatch is in the SCRIPT_NAME, and the rest in the +-- PATH_INFO. This should be taken care of when you need to +-- reconstruct the URL in order to create links. +-- +-- URLMap dispatches in such a way that the longest paths are tried +-- first, since they are most specific. module Hack.Contrib.Middleware.SimpleRouter (route) where import Hack diff --git a/src/Hack/Contrib/Middleware/Static.hs b/src/Hack/Contrib/Middleware/Static.hs --- a/src/Hack/Contrib/Middleware/Static.hs +++ b/src/Hack/Contrib/Middleware/Static.hs @@ -1,3 +1,8 @@ +-- | Stolen from rack: +-- The Rack::Static middleware intercepts requests for static files +-- (javascript files, images, stylesheets, etc) based on the url prefixes +-- passed in the options, and serves them using a Rack::File object. This +-- allows a Rack stack to serve both static and dynamic content. module Hack.Contrib.Middleware.Static (static) where import Hack @@ -13,7 +18,7 @@ static root urls app = \env -> do let my_urls = if urls.null then ["/favicon.ico"] else urls - let path = env.path_info .url2unicode + let path = env.path_info .unescape_uri let can_serve = my_urls.find ( `isPrefixOf` path ) .isJust diff --git a/src/Hack/Contrib/Request.hs b/src/Hack/Contrib/Request.hs --- a/src/Hack/Contrib/Request.hs +++ b/src/Hack/Contrib/Request.hs @@ -3,11 +3,14 @@ module Hack.Contrib.Request where import Hack -import Prelude hiding ((.), (^), (>), lookup, (+)) +import Hack.Contrib.Constants + +import Prelude hiding ((.), (^), (>), (+)) import MPSUTF8 import Hack.Contrib.Utils -import List (lookup) import Data.Maybe +import Network.CGI.Protocol +import Network.CGI.Cookie body :: Env -> String body = hack_input @@ -21,6 +24,54 @@ path :: Env -> String path env = env.script_name ++ env.path_info +content_type :: Env -> String +content_type env = env.http_ _ContentType .fromMaybe "" + +media_type :: Env -> String +media_type env = env.content_type.split "\\s*[;,]\\s*" .first.lower + +media_type_params :: Env -> [(String, String)] +media_type_params env + | env.content_type.empty = [] + | otherwise = + env + .content_type + .split "\\s*[;,]\\s" + .drop 1 + .map (split "=" > take 2) + .map tuple2 + .map_fst lower + +content_charset :: Env -> String +content_charset env = env.media_type_params.lookup "charset" .fromMaybe "" + +host :: Env -> String +host env = env.http_"HOST" .fromMaybe (env.server_name) .gsub ":\\d+\\z" "" + +params :: Env -> [(String, String)] +params env + | env.query_string.empty = [] + | otherwise = + env + .query_string + .formDecode + +inputs :: Env -> [(String, String)] +inputs env + | env.media_type.is "application/x-www-form-urlencoded" = + env + .hack_input + .formDecode + | otherwise = [] -- multipart wait - - + +referer :: Env -> String +referer = http_ _Referer > fromMaybe "/" + +cookies :: Env -> [(String, String)] +cookies env = case env.http_ _Cookie of + Nothing -> [] + Just s -> s.readCookies + fullpath :: Env -> String fullpath env = if env.query_string.empty @@ -28,13 +79,10 @@ else env.path ++ "?" ++ env.query_string http_ :: String -> Env -> Maybe String -http_ s env = env.http.reverse.lookup s +http_ s env = env.http.get s custom_ :: String -> Env -> Maybe String -custom_ s env = env.custom.reverse.lookup s - -host :: Env -> String -host env = env.http_"HOST" .fromMaybe (env.server_name) .gsub ":\\d+\\z" "" +custom_ s env = env.custom.get s url :: Env -> String url env = @@ -51,3 +99,23 @@ env.scheme.is "http" && env.port.is_not 80 ) then ":" ++ env.server_port.show else "" + + +--form_data_media_types :: [String] +--form_data_media_types = +-- [ "" +-- , "application/x-www-form-urlencoded" +-- , "multipart/form-data" +-- ] +-- +--parseable_data_media_types :: [String] +--parseable_data_media_types = +-- [ "multipart/related" +-- , "multipart/mixed" +-- ] +-- +--is_form_data :: Env -> Bool +--is_form_data = media_type > belongs_to form_data_media_types +-- +--is_parseable_data :: Env -> Bool +--is_parseable_data = media_type > belongs_to parseable_data_media_types diff --git a/src/Hack/Contrib/Response.hs b/src/Hack/Contrib/Response.hs --- a/src/Hack/Contrib/Response.hs +++ b/src/Hack/Contrib/Response.hs @@ -3,25 +3,43 @@ module Hack.Contrib.Response where import Hack +import Hack.Contrib.Utils import Hack.Contrib.Constants import MPSUTF8 import Prelude hiding ((.), (^), (>), (+)) -import Data.Map (toList) import Data.Maybe +redirect :: String -> Maybe Int -> Response -> Response +redirect target status_code = + set_status (status_code.fromMaybe 302) + > set_header _Location target + +finish :: Response -> Response +finish r + | r.status.belongs_to [204, 304] + = r + .delete_header _ContentType + .set_body "" + | otherwise = r + + header :: String -> Response -> Maybe String -header s r = r.headers.reverse.lookup s +header s r = r.headers.get s has_header :: String -> Response -> Bool has_header s r = r.header s .isJust set_header :: String -> String -> Response -> Response set_header k v r = r - { headers = (r.headers ++ [(k,v)] ) .to_h .toList } + { headers = r.headers.put k v } +delete_header :: String -> Response -> Response +delete_header k r = r + { headers = r.headers.reject (fst > is k) } + set_content_type :: String -> Response -> Response set_content_type s r = r.set_header _ContentType s diff --git a/src/Hack/Contrib/Utils.hs b/src/Hack/Contrib/Utils.hs --- a/src/Hack/Contrib/Utils.hs +++ b/src/Hack/Contrib/Utils.hs @@ -22,9 +22,14 @@ import System.Locale import System.FilePath (()) import Control.Category (Category) +import Data.List (lookup) --- import Date.Time +-- hack input / output are all utf8 bytes +-- but sometimes we want to put unicode string directly +-- like when writing config and such +type UnicodeString = String + (>) :: (Control.Category.Category cat) => cat a b -> cat b c -> cat a c (>) = (>>>) infixl 8 > @@ -40,12 +45,21 @@ empty_app :: Application empty_app = return def --- usage: app.use [content_type, cache] +-- | usage: app.use [content_type, cache] use :: [Middleware] -> Middleware use = reduce (<<<) +-- use the get / put helper to deal with headers +put :: String -> String -> [(String, String)] -> [(String, String)] +put k v xs = (k,v) : xs.reject (fst > is k) + +get :: String -> [(String, String)] -> Maybe String +get = lookup + +-- | note when calling bytesize, you are sure that the string +-- is in [char8] format anyway. so just call length bytesize :: String -> Int -bytesize = B.pack > B.length > from_i +bytesize = length -- B.pack > B.length > from_i dummy_middleware :: Middleware dummy_middleware = id @@ -63,7 +77,12 @@ fixChar '"' = """ fixChar x = [x] +escape_uri :: String -> String +escape_uri = escapeURIString isAllowedInURI +unescape_uri :: String -> String +unescape_uri = unEscapeString + show_status_message :: Int -> Maybe String show_status_message x = status_code.M.lookup x @@ -71,7 +90,7 @@ httpdate x = x.format_time rfc822DateFormat where url2unicode :: String -> String -url2unicode s = s.unEscapeString.b2u +url2unicode s = s.unescape_uri.b2u just_lookup :: (Ord k) => k -> M.Map k a -> a just_lookup s xs = xs.M.lookup s .fromJust