diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,13 @@ +2009.4.50 + +### Feature + +* more useful middlewares ported from rack-contrib + +### Fix + +* name change, show_status_message + 2009.4.30 ---------- 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.30 +Version: 2009.4.50 Build-type: Simple Synopsis: Hack contrib Description: @@ -15,7 +15,7 @@ library ghc-options: -Wall - build-depends: base, cgi, network, haskell98, old-locale, old-time, directory, filepath, containers, bytestring, template, base64-string, zlib, ansi-wl-pprint, mps >= 2009.4.21, data-default >= 0.2, ansi-wl-pprint, unix, time, hack >= 2009.4.30 + build-depends: base, cgi, network, haskell98, old-locale, old-time, directory, filepath, containers, bytestring, ansi-wl-pprint, mps >= 2009.4.27, data-default >= 0.2, ansi-wl-pprint, unix, time, pureMD5, hack >= 2009.4.30 hs-source-dirs: src/ exposed-modules: Hack.Contrib.Utils @@ -37,6 +37,10 @@ Hack.Contrib.Middleware.SimpleAccessLogger Hack.Contrib.Middleware.SimpleRouter Hack.Contrib.Middleware.Static + Hack.Contrib.Middleware.ETag + Hack.Contrib.Middleware.BounceFavicon + Hack.Contrib.Middleware.NotFound + diff --git a/src/Hack/Contrib/Constants.hs b/src/Hack/Contrib/Constants.hs --- a/src/Hack/Contrib/Constants.hs +++ b/src/Hack/Contrib/Constants.hs @@ -117,11 +117,15 @@ -- mime type -_TextPlain :: String -_TextHtml :: String +_TextPlain :: String +_TextHtml :: String +_TextPlainUTF8 :: String +_TextHtmlUTF8 :: String _TextPlain = "text/plain" _TextHtml = "text/html" +_TextPlainUTF8 = "text/plain; charset=UTF-8" +_TextHtmlUTF8 = "text/html; charset=UTF-8" -- status code diff --git a/src/Hack/Contrib/Middleware/BounceFavicon.hs b/src/Hack/Contrib/Middleware/BounceFavicon.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/Middleware/BounceFavicon.hs @@ -0,0 +1,15 @@ +module Hack.Contrib.Middleware.BounceFavicon (bounce_favicon) where + +import Hack +import Hack.Contrib.Utils +import Hack.Contrib.Middleware.NotFound + +import MPSUTF8 +import Prelude hiding ((.), (^), (>), head) + + +bounce_favicon :: Middleware +bounce_favicon app = \env -> do + if env.path_info.is "/favicon.ico" + then not_found dummy_app env + else app env 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 @@ -12,6 +12,6 @@ content_type s app = \env -> do response <- app env - case response.header _ContentType of - Nothing -> response.set_header _ContentType s .return - Just _ -> response .return + return $ case response.header _ContentType of + Nothing -> response.set_header _ContentType s + Just _ -> response diff --git a/src/Hack/Contrib/Middleware/ETag.hs b/src/Hack/Contrib/Middleware/ETag.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/Middleware/ETag.hs @@ -0,0 +1,28 @@ +module Hack.Contrib.Middleware.ETag (etag) where + +import Hack +import Hack.Contrib.Utils +import Hack.Contrib.Response +import Hack.Contrib.Constants + +import MPSUTF8 +import Prelude hiding ((.), (^), (>)) + +import Data.Digest.Pure.MD5 +import Data.ByteString.Lazy.Char8 as C + + +etag :: Middleware +etag app = \env -> do + r <- app env + + if r.has_header _ETag + then r.return + else r.set_header _ETag (r.tag) .return + + where + tag = + body + > C.pack + > md5 + > show 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 @@ -22,11 +22,11 @@ if ".." `isInfixOf` path then forbidden - else serve root path env + else path.serve root -serve :: Maybe String -> FilePath -> Env -> IO Response -serve root fname _ = do +serve :: Maybe String -> FilePath -> IO Response +serve root fname = do cwd <- get_current_directory let my_root = root.fromMaybe cwd let path = my_root / makeRelative "/" fname @@ -45,8 +45,8 @@ where serving path = do content <- path.read_binary_file - size <- file_size path ^ from_i - mtime_str <- file_mtime path ^ httpdate + size <- path.file_size ^ from_i + mtime_str <- path.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/Head.hs b/src/Hack/Contrib/Middleware/Head.hs --- a/src/Hack/Contrib/Middleware/Head.hs +++ b/src/Hack/Contrib/Middleware/Head.hs @@ -10,5 +10,5 @@ head app = \env -> do response <- app env if env.request_method.is HEAD - then return $ response .set_body "" .set_content_length 0 - else return $ response + then response .set_body "" .set_content_length 0 .return + else response .return 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,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} --- the entire logging framework is stole from [innate](http://github.com/manveru/innate/tree/master) +-- the entire logging framework is stolen from [innate](http://github.com/manveru/innate/tree/master) module Hack.Contrib.Middleware.Hub where 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 @@ -4,7 +4,6 @@ import Hack import Hack.Contrib.Response -import Hack.Contrib.Utils import Hack.Contrib.Constants import MPSUTF8 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 @@ -4,7 +4,6 @@ import Hack import Hack.Contrib.Response -import Hack.Contrib.Utils import Hack.Contrib.Constants import MPSUTF8 diff --git a/src/Hack/Contrib/Middleware/NotFound.hs b/src/Hack/Contrib/Middleware/NotFound.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/Middleware/NotFound.hs @@ -0,0 +1,17 @@ +module Hack.Contrib.Middleware.NotFound (not_found) where + +import Hack +import Hack.Contrib.Response +import Hack.Contrib.Constants + +import MPSUTF8 +import Prelude hiding ((.), (^), (>), (+)) +import Data.Default + + +not_found :: Middleware +not_found _ = \_ -> return $ + def + .set_status 404 + .set_content_type _TextHtml + .set_content_length 0 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 @@ -24,7 +24,7 @@ then let i = response.status - message = i.show_status_code .fromMaybe (i.show) + message = i.show_status_message .fromMaybe (i.show) detail = env.custom_"hack.showstatus.detail" .fromMaybe message result = template message detail env response size = result.bytesize 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 @@ -13,25 +13,16 @@ import Data.Default import Control.Arrow ((>>>), (<<<)) -import Data.Map (lookup, Map) +import qualified Data.Map as M import Data.Time -import Text.Template import qualified Data.ByteString.Lazy.Char8 as B import Control.Monad (mplus, MonadPlus) import Data.Maybe import System.IO -import System.Posix.Files import System.Locale -import System.Directory -import Data.Time.Clock.POSIX import System.FilePath (()) -import Data.Char (ord) import Control.Category (Category) -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Codec.Compression.GZip as GZip -import Codec.Binary.Base64.String as C - -- import Date.Time (>) :: (Control.Category.Category cat) => cat a b -> cat b c -> cat a c @@ -65,58 +56,25 @@ escape_html :: String -> String escape_html = concatMap fixChar where - fixChar '<' = "<" - fixChar '>' = ">" - fixChar '&' = "&" - fixChar '"' = "\"" - fixChar c | ord c < 0x80 = [c] - fixChar c = "&#" ++ show (ord c) ++ ";" - + fixChar '&' = "&" + fixChar '<' = "<" + fixChar '>' = ">" + fixChar '\'' = "'" + fixChar '"' = """ + fixChar x = [x] -show_status_code :: Int -> Maybe String -show_status_code x = status_code.lookup x - --- MPS candidate - -now :: IO UTCTime -now = getCurrentTime - -format_time :: String -> UTCTime -> String -format_time = formatTime defaultTimeLocale - -interpolate :: String -> [(String, String)] -> String -interpolate s params = B.unpack $ substitute (B.pack s) (context params) - where - context = map packPair > to_h - packPair (x, y) = (B.pack x, B.pack y) - -just_lookup :: (Ord k) => k -> Data.Map.Map k a -> a -just_lookup s xs = xs.lookup s .fromJust +show_status_message :: Int -> Maybe String +show_status_message x = status_code.M.lookup x httpdate :: UTCTime -> String httpdate x = x.format_time rfc822DateFormat where -file_size :: String -> IO Integer -file_size path = withFile (path.u2b) ReadMode hFileSize - -file_mtime :: String -> IO UTCTime -file_mtime path = getFileStatus (path.u2b) - ^ modificationTime ^ realToFrac ^ posixSecondsToUTCTime - -read_binary_file :: String -> IO String -read_binary_file path = path.u2b.B.readFile ^ B.unpack - -get_permissions :: String -> IO Permissions -get_permissions path = getPermissions (path.u2b) - url2unicode :: String -> String url2unicode s = s.unEscapeString.b2u -get_current_directory :: IO String -get_current_directory = getCurrentDirectory ^ b2u +just_lookup :: (Ord k) => k -> M.Map k a -> a +just_lookup s xs = xs.M.lookup s .fromJust -zip64, unzip64 :: String -> String -zip64 = B.pack > GZip.compress > B.unpack > C.encode -unzip64 = C.decode > B.pack > GZip.decompress > B.unpack +-- MPS candidate