hack-contrib 2009.4.52 → 2009.4.52.1

raw patch · 22 files changed

+116/−93 lines, 22 filesdep +happstack-server

Dependencies added: happstack-server

Files

• changelog.md +12/−0
• hack-contrib.cabal +3/−2
• src/Hack/Contrib/Constants.hs +3/−3
• src/Hack/Contrib/Middleware/BounceFavicon.hs +1/−0
• src/Hack/Contrib/Middleware/Config.hs +3/−1
• src/Hack/Contrib/Middleware/ContentLength.hs +2/−1
• src/Hack/Contrib/Middleware/ContentType.hs +2/−1
• src/Hack/Contrib/Middleware/Debug.hs +11/−0
• src/Hack/Contrib/Middleware/ETag.hs +3/−1
• src/Hack/Contrib/Middleware/File.hs +3/−5
• src/Hack/Contrib/Middleware/Hub.hs +8/−8
• src/Hack/Contrib/Middleware/Inspect.hs +1/−0
• src/Hack/Contrib/Middleware/Lambda.hs +1/−0
• src/Hack/Contrib/Middleware/Lucky.hs +1/−0
• src/Hack/Contrib/Middleware/ShowExceptions.hs +1/−0
• src/Hack/Contrib/Middleware/ShowStatus.hs +8/−3
• src/Hack/Contrib/Middleware/SimpleAccessLogger.hs +3/−3
• src/Hack/Contrib/Middleware/SimpleRouter.hs +1/−0
• src/Hack/Contrib/Middleware/Static.hs +1/−0
• src/Hack/Contrib/Request.hs +35/−34
• src/Hack/Contrib/Response.hs +5/−8
• src/Hack/Contrib/Utils.hs +8/−23

@@ -1,3 +1,15 @@+2009.4.52.1++### Feature++* debug middleware allows inserting of function that inspect env and response+* inputs method from request is polymathic, handles both regular form and multi-part. File upload will have a (key, value) pair as ($input name, $file content), same for the rest of input fields. file name will be stored in (hack\_input\_file\_name\_"$input name", "$file\_name") pair.++### Fix++* logger use utf-8 encoding+* file-server use GMT time+ 2009.4.52 --------- 

@@ -1,5 +1,5 @@ Name:                 hack-contrib-Version:              2009.4.52+Version:              2009.4.52.1 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.52+  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, happstack-server >= 0.2   hs-source-dirs: src/   exposed-modules:                       Hack.Contrib.Utils@@ -42,6 +42,7 @@                     Hack.Contrib.Middleware.NotFound                     Hack.Contrib.Middleware.Config                     Hack.Contrib.Middleware.Inspect+                    Hack.Contrib.Middleware.Debug                                           

@@ -122,10 +122,10 @@ _TextPlainUTF8              :: String _TextHtmlUTF8               :: String -_TextPlain  = "text/plain"-_TextHtml   = "text/html"+_TextPlain     = "text/plain"+_TextHtml      = "text/html" _TextPlainUTF8 = "text/plain; charset=UTF-8"-_TextHtmlUTF8 = "text/html; charset=UTF-8"+_TextHtmlUTF8  = "text/html; charset=UTF-8"   -- status code

@@ -1,4 +1,5 @@ -- | Stolen from rack-contrib: Bounce those annoying favicon.ico requests+ module Hack.Contrib.Middleware.BounceFavicon (bounce_favicon) where  import Hack

@@ -1,4 +1,6 @@--- | Stolen from rack-contrib: modifies the environment using the block given during initialization.+-- | Stolen from rack-contrib: modifies the environment using the block given +--   during initialization.+ module Hack.Contrib.Middleware.Config (config) where  import Hack

@@ -1,4 +1,5 @@--- | Stolen from rack: Sets the Content-Length header on responses with fixed-length bodies.+-- | Stolen from rack: Sets the Content-Length header on responses with +--   fixed-length bodies.  module Hack.Contrib.Middleware.ContentLength (content_length) where 

@@ -1,4 +1,5 @@--- | Stolen from rack: Sets the Content-Type header on responses which don't have one.+-- | Stolen from rack: Sets the Content-Type header on responses which don't +--   have one.  module Hack.Contrib.Middleware.ContentType (content_type) where 

@@ -0,0 +1,11 @@+-- | print the env and response in the console++module Hack.Contrib.Middleware.Debug (debug) where++import Hack++debug :: (Env -> Response -> IO ()) -> Middleware+debug f app = \env -> do+  r <- app env+  f env r+  return r

@@ -1,4 +1,6 @@--- | Stolen from rack-contrib: Automatically sets the ETag header on all String bodies+-- | Stolen from rack-contrib: Automatically sets the ETag header on all +--   String bodies+ module Hack.Contrib.Middleware.ETag (etag) where  import Hack

@@ -1,4 +1,6 @@--- | Stolen from rack:serves files below the +root+ given, according to the path info of the Rack request.+-- | 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,10 +18,6 @@ import System.Directory 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

@@ -1,6 +1,8 @@ {-# LANGUAGE QuasiQuotes #-} --- the entire logging framework is stolen from [innate](http://github.com/manveru/innate/tree/master)+-- the entire logging module is stolen from+-- [innate](http://github.com/manveru/innate/tree/master)+ module Hack.Contrib.Middleware.Hub where  import Hack.Contrib.Utils@@ -46,14 +48,12 @@      where     line_format = "%s [%s $%d] %5s | %-25s: %s\n"-    -    h = severity.hint-    +    h           = severity.hint     time_format = "%Y-%m-%d %H:%M:%S"-    t = time.format_time time_format-    -    l = severity.show.upper-    s = colorize severity message+    t           = time.format_time time_format+    l           = severity.show.upper+    s           = colorize severity message+  colorize :: Severity -> String -> String colorize severity message = color severity (message.text) .show

@@ -1,4 +1,5 @@ -- | print the env and response in the console+ module Hack.Contrib.Middleware.Inspect (inspect) where  import Hack

@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-}  -- | Paste has a Pony, Rack has a Lobster, Hack has a Lambda ><+ module Hack.Contrib.Middleware.Lambda (lambda) where  import Hack

@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-}  -- | Paste has a Pony, Rack has a Lobster, Hack has a Lucky - -+ module Hack.Contrib.Middleware.Lucky (lucky) where  import Hack

@@ -1,4 +1,5 @@ -- | Stolen from rack: catches all exceptions raised from the app it wraps.+ module Hack.Contrib.Middleware.ShowExceptions (show_exceptions) where  import Hack

@@ -1,10 +1,15 @@ {-# LANGUAGE QuasiQuotes #-}  -- | Stolen from rack:---   catches all empty responses the app it wraps and replaces them with a site explaining the error. +--   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.+--+--   Note: it appears that only when content is empty will this+--         message be shown.+ module Hack.Contrib.Middleware.ShowStatus (show_status) where  import Hack@@ -52,7 +57,7 @@ <html lang="en"> <head>   <meta http-equiv="content-type" content="text/html; charset=utf-8" />-  <title>#{h message } at #{h (env.path.url2unicode) }</title>+  <title>#{h message } at #{h (env.path.unescape_uri.b2u) }</title>   <meta name="robots" content="NONE,NOARCHIVE" />   <style type="text/css">     html * { padding:0; margin:0; }@@ -82,7 +87,7 @@       </tr>       <tr>         <th>Request URL:</th>-      <td>#{h (env.url.url2unicode) }</td>+      <td>#{h (env.url.unescape_uri.b2u) }</td>       </tr>     </table>   </div>

@@ -15,8 +15,8 @@ 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-  -  Info .log (env.url.url2unicode)+  let log       = simple_logger my_stream program++  Info .log (env.url.unescape_uri)      app env

@@ -11,6 +11,7 @@ --    --   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

@@ -3,6 +3,7 @@ --   (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

@@ -2,7 +2,7 @@  module Hack.Contrib.Request where -import Hack+import Hack hiding (body) import Hack.Contrib.Constants  import Prelude hiding ((.), (^), (>), (+))@@ -11,7 +11,11 @@ import Data.Maybe import Network.CGI.Protocol import Network.CGI.Cookie+import Data.ByteString.Lazy.Char8 (pack, unpack) +import qualified Happstack.Server.MessageWrap as HM+import qualified Happstack.Server.HTTP.Types as HT+ body :: Env -> String body = hack_input @@ -38,7 +42,8 @@         .content_type         .split "\\s*[;,]\\s"         .drop 1-        .map (split "=" > take 2)+        .map (split "=")+        .select (length > is 2)         .map tuple2         .map_fst lower @@ -46,23 +51,33 @@ 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" ""+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+params env =+  if env.query_string.empty +    then []+    else env.query_string.formDecode  inputs :: Env -> [(String, String)]-inputs env-  | env.media_type.is "application/x-www-form-urlencoded" =+inputs env = +  case env.media_type of +    "application/x-www-form-urlencoded" -> env.body.formDecode+    "multipart/form-data" ->        env-        .hack_input-        .formDecode-  | otherwise = [] -- multipart wait - -+        .body+        .pack+        .HM.multipartDecode (env.media_type_params)+        .concatMap to_headers+    otherwise -> []+  +  where+    to_headers (k, input) = case input.HT.inputFilename of+      Nothing -> [(k, input.HT.inputValue.unpack)]+      Just name -> +        [  (k, input.HT.inputValue.unpack)+        ,  ("hack_input_file_name_" ++ k, name)+        ]  referer :: Env -> String referer = http_ _Referer > fromMaybe "/"@@ -81,9 +96,15 @@ http_ :: String -> Env -> Maybe String http_ s env = env.http.get s +set_http :: String -> String -> Env -> Env+set_http k v env = env {http = env.http.put k v}+ custom_ :: String -> Env -> Maybe String custom_ s env = env.custom.get s +set_custom :: String -> String -> Env -> Env+set_custom k v env = env {custom = env.custom.put k v}+ url :: Env -> String url env =   [  env.scheme@@ -99,23 +120,3 @@           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

@@ -13,15 +13,14 @@   redirect :: String -> Maybe Int -> Response -> Response-redirect target status_code = -    set_status (status_code.fromMaybe 302)+redirect target code = +    set_status (code.fromMaybe 302)   > set_header _Location target  finish :: Response -> Response finish r    | r.status.belongs_to [204, 304]-      = r-          .delete_header _ContentType+      = r .delete_header _ContentType           .set_body ""   | otherwise = r         @@ -33,12 +32,10 @@ has_header s r = r.header s .isJust  set_header :: String -> String -> Response -> Response-set_header k v r = r -  { headers = r.headers.put k v }+set_header k v r = r { headers = r.headers.put k v }  delete_header :: String -> Response -> Response-delete_header k r = r-  { headers = r.headers.reject (fst > is k) }+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

@@ -15,7 +15,6 @@ import Control.Arrow ((>>>), (<<<)) import qualified Data.Map as M import Data.Time-import qualified Data.ByteString.Lazy.Char8 as B import Control.Monad (mplus, MonadPlus) import Data.Maybe import System.IO@@ -25,11 +24,6 @@ import Data.List (lookup)  --- 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 >@@ -69,13 +63,13 @@  escape_html :: String -> String escape_html = concatMap fixChar-    where-      fixChar '&' = "&amp;"-      fixChar '<' = "&lt;"-      fixChar '>' = "&gt;"-      fixChar '\'' = "&#39;"-      fixChar '"' = "&quot;"-      fixChar x = [x]+  where+    fixChar '&'   = "&amp;"+    fixChar '<'  = "&lt;"+    fixChar '>'  = "&gt;"+    fixChar '\'' = "&#39;"+    fixChar '"'  = "&quot;"+    fixChar x    = [x]  escape_uri :: String -> String escape_uri = escapeURIString isAllowedInURI@@ -87,13 +81,4 @@ show_status_message x = status_code.M.lookup x  httpdate :: UTCTime -> String-httpdate x = x.format_time rfc822DateFormat where--url2unicode :: String -> String-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---- MPS candidate-+httpdate x = x.format_time "%a, %d %b %Y %X GMT"