diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,11 @@ +2009.4.29 +----------- + +### Fix + +* -Wall clean + + 2009.4.28 ----------- diff --git a/hack.cabal b/hack.cabal --- a/hack.cabal +++ b/hack.cabal @@ -1,5 +1,5 @@ Name: hack -Version: 2009.4.28 +Version: 2009.4.29 Build-type: Simple Synopsis: a sexy Haskell Webserver Interface Description: @@ -19,7 +19,7 @@ data-files: readme.md, changelog.md library - ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-type-defaults + ghc-options: -Wall build-depends: base, cgi, network, haskell98, old-locale, old-time, directory, filepath, containers, bytestring, template, base64-string, zlib, hyena, ansi-wl-pprint, mps >= 2009.4.21, kibro >= 0.4.3, data-default >= 0.2, ansi-wl-pprint, bytestring, template, unix, time hs-source-dirs: src/ exposed-modules: diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -37,7 +37,7 @@ ### install hack - cabal install hack + cabal install happy; cabal install hack ### Create a Hack app diff --git a/src/Hack.hs b/src/Hack.hs --- a/src/Hack.hs +++ b/src/Hack.hs @@ -25,7 +25,7 @@ type HackErrors = Stream instance Show HackErrors where - show x = "HackHackErrors" + show _ = "HackHackErrors" data Env = Env { request_method :: RequestMethod @@ -62,10 +62,11 @@ instance Default Response where def = Response def def def -const_io = const (return ()) + instance Default Env where def = Env def def def def def def def def def def const_io False False False def + where const_io = const (return ()) type Application = Env -> IO Response diff --git a/src/Hack/Constants.hs b/src/Hack/Constants.hs --- a/src/Hack/Constants.hs +++ b/src/Hack/Constants.hs @@ -9,7 +9,60 @@ -- header constants +_CacheControl :: String +_Connection :: String +_Date :: String +_Pragma :: String +_TransferEncoding :: String +_Upgrade :: String +_Via :: String +_Accept :: String +_AcceptCharset :: String +_AcceptEncoding :: String +_AcceptLanguage :: String +_Authorization :: String +_Cookie :: String +_Expect :: String +_From :: String +_Host :: String +_IfModifiedSince :: String +_IfMatch :: String +_IfNoneMatch :: String +_IfRange :: String +_IfUnmodifiedSince :: String +_MaxForwards :: String +_ProxyAuthorization :: String +_Range :: String +_Referer :: String +_UserAgent :: String +_Age :: String +_Location :: String +_ProxyAuthenticate :: String +_Public :: String +_RetryAfter :: String +_Server :: String +_SetCookie :: String +_TE :: String +_Trailer :: String +_Vary :: String +_Warning :: String +_WWWAuthenticate :: String +_Allow :: String +_ContentBase :: String +_ContentEncoding :: String +_ContentLanguage :: String +_ContentLength :: String +_ContentLocation :: String +_ContentMD5 :: String +_ContentRange :: String +_ContentType :: String +_ETag :: String +_Expires :: String +_LastModified :: String +_ContentTransferEncoding :: String + + _CacheControl = "Cache-Control" _Connection = "Connection" _Date = "Date" @@ -64,9 +117,11 @@ -- mime type +_TextPlain :: String +_TextHtml :: String -_TextPlain = "text/plain" -_TextHtml = "text/html" +_TextPlain = "text/plain" +_TextHtml = "text/html" -- status code diff --git a/src/Hack/Contrib/ContentSize.hs b/src/Hack/Contrib/ContentSize.hs --- a/src/Hack/Contrib/ContentSize.hs +++ b/src/Hack/Contrib/ContentSize.hs @@ -1,4 +1,4 @@ -module Hack.Contrib.ContentSize where +module Hack.Contrib.ContentSize (content_size) where import Hack import Hack.Utils @@ -7,8 +7,6 @@ import MPSUTF8 import Prelude hiding ((.), (^), (>)) - -import Data.Maybe content_size :: MiddleWare content_size app = \env -> do diff --git a/src/Hack/Contrib/ContentType.hs b/src/Hack/Contrib/ContentType.hs --- a/src/Hack/Contrib/ContentType.hs +++ b/src/Hack/Contrib/ContentType.hs @@ -1,7 +1,6 @@ -module Hack.Contrib.ContentType where +module Hack.Contrib.ContentType (content_type) where import Hack -import Hack.Utils import Hack.Response import Hack.Constants @@ -15,5 +14,4 @@ case response.header _ContentType of Nothing -> response.set_header _ContentType s .return - otherwise -> response .return - + Just _ -> response .return diff --git a/src/Hack/Contrib/File.hs b/src/Hack/Contrib/File.hs --- a/src/Hack/Contrib/File.hs +++ b/src/Hack/Contrib/File.hs @@ -1,16 +1,14 @@ -module Hack.Contrib.File where +module Hack.Contrib.File (file) where import Hack import Hack.Utils import Hack.Response import Hack.Constants -import Hack.Contrib.Hub import Hack.Contrib.Mime import MPSUTF8 import Prelude hiding ((.), (^), (>), (+), (/), readFile) -import System.Directory (getCurrentDirectory) import Data.Default import Data.Maybe import Data.List (isInfixOf) @@ -19,7 +17,7 @@ file :: Maybe String -> MiddleWare -file root app = \env -> do +file root _ = \env -> do let path = env.path_info .url2unicode if ".." `isInfixOf` path @@ -28,7 +26,7 @@ serve :: Maybe String -> FilePath -> Env -> IO Response -serve root fname env = do +serve root fname _ = do cwd <- get_current_directory let my_root = root.fromMaybe cwd let path = my_root / makeRelative "/" fname @@ -62,6 +60,7 @@ .set_last_modified mtime_str .set_status 200 +no_permission :: String -> IO Response no_permission path = return $ def .set_status 404 @@ -71,6 +70,7 @@ where msg = "No permission: " ++ path ++ "\n" +not_found :: String -> IO Response not_found path = return $ def .set_status 404 @@ -80,6 +80,7 @@ where msg = "File not found: " ++ path ++ "\n" +forbidden :: IO Response forbidden = return $ def .set_status 403 diff --git a/src/Hack/Contrib/Head.hs b/src/Hack/Contrib/Head.hs --- a/src/Hack/Contrib/Head.hs +++ b/src/Hack/Contrib/Head.hs @@ -1,7 +1,6 @@ -module Hack.Contrib.Head where +module Hack.Contrib.Head (head) where import Hack -import Hack.Utils import Hack.Response import MPSUTF8 diff --git a/src/Hack/Contrib/Hub.hs b/src/Hack/Contrib/Hub.hs --- a/src/Hack/Contrib/Hub.hs +++ b/src/Hack/Contrib/Hub.hs @@ -7,14 +7,12 @@ import Hack import Hack.Utils -import Hack.Constants import MPSUTF8 import Prelude hiding ((.), (^), (>), (+)) import Text.Printf import System.Posix.Process (getProcessID) -import System.Time import Data.Maybe import Text.PrettyPrint.ANSI.Leijen import Data.Time @@ -72,5 +70,5 @@ , ( Unknown , green ) ] - color severity = level_color.lookup severity .fromMaybe green + color severity' = level_color.lookup severity' .fromMaybe green diff --git a/src/Hack/Contrib/Lambda.hs b/src/Hack/Contrib/Lambda.hs --- a/src/Hack/Contrib/Lambda.hs +++ b/src/Hack/Contrib/Lambda.hs @@ -1,23 +1,17 @@ {-# LANGUAGE QuasiQuotes #-} -module Hack.Contrib.Lambda where +module Hack.Contrib.Lambda (lambda) where import Hack import Hack.Response import Hack.Utils -import Hack.Contrib.File (file) import Hack.Constants import MPSUTF8 import Prelude hiding ((.), (^), (>), (+)) -import Data.Maybe -import List (find, isPrefixOf) import Data.Default -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Codec.Compression.GZip as GZip -import Codec.Binary.Base64.String as C - +data64 :: String data64 = [$here| H4sIAAAAAAAAA+3dMVMbMRQE4J5foaGhpMhMCkP4LcpknCrBN0BB/n1yIbHkRNKd @@ -40,9 +34,6 @@ SIur+9vp6fjwE8s/QZd0jAAA |].strip - -zip64 = B.pack > GZip.compress > B.unpack > C.encode -unzip64 = C.decode > B.pack > GZip.decompress > B.unpack lambda :: MiddleWare lambda app = \env -> do diff --git a/src/Hack/Contrib/Lucky.hs b/src/Hack/Contrib/Lucky.hs --- a/src/Hack/Contrib/Lucky.hs +++ b/src/Hack/Contrib/Lucky.hs @@ -1,26 +1,16 @@ {-# LANGUAGE QuasiQuotes #-} -module Hack.Contrib.Lucky where +module Hack.Contrib.Lucky (lucky) where import Hack import Hack.Response import Hack.Utils -import Hack.Contrib.File (file) import Hack.Constants import MPSUTF8 import Prelude hiding ((.), (^), (>), (+)) -import Data.Maybe -import List (find, isPrefixOf) import Data.Default -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Codec.Compression.GZip as GZip -import Codec.Binary.Base64.String as C - -zip64 = B.pack > GZip.compress > B.unpack > C.encode -unzip64 = C.decode > B.pack > GZip.decompress > B.unpack - lucky :: MiddleWare lucky app = \env -> do if env.path_info.is "/lucky" @@ -32,7 +22,7 @@ else app env - +data64 :: String data64 = [$here| H4sIAAAAAAAAA+y9yZYsS5ZcN+dX1AI+AGbaKwjyX7SzEYjCAjAA/55q/jJv8/Kl y1YP9YhbxXtjkmulPnNrtDlHjhyR//Lf/8f4l//5v/7f/zr+r/9w/et/+1//+V/C diff --git a/src/Hack/Contrib/Mime.hs b/src/Hack/Contrib/Mime.hs --- a/src/Hack/Contrib/Mime.hs +++ b/src/Hack/Contrib/Mime.hs @@ -4,6 +4,7 @@ import MPSUTF8 import Prelude hiding ((.)) +mime_types :: M.Map String String mime_types = [ x ".3gp" "video/3gpp" , x ".a" "application/octet-stream" diff --git a/src/Hack/Contrib/RawRouter.hs b/src/Hack/Contrib/RawRouter.hs --- a/src/Hack/Contrib/RawRouter.hs +++ b/src/Hack/Contrib/RawRouter.hs @@ -1,8 +1,8 @@ -module Hack.Contrib.RawRouter where +module Hack.Contrib.RawRouter (route) where import Hack import Hack.Utils -import Hack.Request +import Hack.Request hiding (path) import MPSUTF8 import Prelude hiding ((.), (^), (>)) diff --git a/src/Hack/Contrib/ShowExceptions.hs b/src/Hack/Contrib/ShowExceptions.hs --- a/src/Hack/Contrib/ShowExceptions.hs +++ b/src/Hack/Contrib/ShowExceptions.hs @@ -1,11 +1,10 @@ -module Hack.Contrib.ShowExceptions where +module Hack.Contrib.ShowExceptions (show_exceptions) where import Hack -import Hack.Utils import Hack.Contrib.Hub import MPSUTF8 -import Prelude hiding ((.), (^), (>)) +import Prelude hiding ((.), (^), (>), log) import Data.Maybe import Data.Default @@ -14,6 +13,7 @@ import System.IO.Error +program :: String program = "ShowExceptions" show_exceptions :: Maybe Stream -> MiddleWare diff --git a/src/Hack/Contrib/ShowStatus.hs b/src/Hack/Contrib/ShowStatus.hs --- a/src/Hack/Contrib/ShowStatus.hs +++ b/src/Hack/Contrib/ShowStatus.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Hack.Contrib.ShowStatus where +module Hack.Contrib.ShowStatus (show_status) where import Hack import Hack.Utils @@ -18,7 +18,7 @@ response <- app env let content_length = response.header _ContentLength .fromMaybe "0" - let content_empty = content_length .read .(<= 0) + let content_empty = content_length .read .(<= (0 :: Int)) if response.status >= 400 && content_empty then @@ -38,7 +38,7 @@ else return response - +template :: String -> String -> Env -> Response -> String template message detail env response = let h = escape_html in [$here| diff --git a/src/Hack/Contrib/SimpleAccessLogger.hs b/src/Hack/Contrib/SimpleAccessLogger.hs --- a/src/Hack/Contrib/SimpleAccessLogger.hs +++ b/src/Hack/Contrib/SimpleAccessLogger.hs @@ -1,4 +1,4 @@ -module Hack.Contrib.SimpleAccessLogger where +module Hack.Contrib.SimpleAccessLogger (simple_access_logger) where import Hack import Hack.Utils @@ -6,9 +6,10 @@ import Hack.Contrib.Hub import MPSUTF8 -import Prelude hiding ((.), (^), (>)) +import Prelude hiding ((.), (^), (>), log) import Data.Maybe +program :: String program = "SimpleAccessLogger" simple_access_logger :: Maybe Stream -> MiddleWare diff --git a/src/Hack/Contrib/SimpleRouter.hs b/src/Hack/Contrib/SimpleRouter.hs --- a/src/Hack/Contrib/SimpleRouter.hs +++ b/src/Hack/Contrib/SimpleRouter.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Hack.Contrib.SimpleRouter where +module Hack.Contrib.SimpleRouter (route) where import Hack import Hack.Utils @@ -22,4 +22,4 @@ in case h.find (fst > (`isPrefixOf` path) ) of Nothing -> app env - Just (location, app) -> app (mod_env location) + Just (location, app') -> app' (mod_env location) diff --git a/src/Hack/Contrib/Static.hs b/src/Hack/Contrib/Static.hs --- a/src/Hack/Contrib/Static.hs +++ b/src/Hack/Contrib/Static.hs @@ -1,7 +1,6 @@ -module Hack.Contrib.Static where +module Hack.Contrib.Static (static) where import Hack -import Hack.Response import Hack.Utils import Hack.Contrib.File (file) @@ -9,8 +8,6 @@ import Prelude hiding ((.), (^), (>), (+)) import Data.Maybe import List (find, isPrefixOf) - -program = "Static" static :: Maybe String -> [String] -> MiddleWare static root urls app = \env -> do diff --git a/src/Hack/Handler/Hyena.hs b/src/Hack/Handler/Hyena.hs --- a/src/Hack/Handler/Hyena.hs +++ b/src/Hack/Handler/Hyena.hs @@ -9,7 +9,6 @@ import Hyena.Server import Network.Wai as Wai -import Network.URI import Data.Default import Prelude hiding ((.), (^)) import MPSUTF8 hiding (to_s) @@ -17,14 +16,19 @@ import qualified Data.ByteString.Char8 as C import qualified Data.ByteString as S -import Control.Applicative import Control.Monad import Data.Maybe +to_s :: S.ByteString -> String to_s = C.unpack + +to_b :: String -> S.ByteString to_b = C.pack +both_to_s :: (S.ByteString, S.ByteString) -> (String, String) both_to_s (a,b) = (a.to_s, b.to_s) + +both_to_b :: (String, String) -> (S.ByteString, S.ByteString) both_to_b (a,b) = (a.to_b, b.to_b) hyena_env_to_hack_env :: Environment -> IO Hack.Env @@ -73,7 +77,6 @@ let hyena_response = r.hack_response_to_hyena_response enum return hyena_response - -run app = app.hack_to_wai.serve -main = run dummy_app +run :: Hack.Application -> IO () +run app = app.hack_to_wai.serve diff --git a/src/Hack/Handler/Kibro.hs b/src/Hack/Handler/Kibro.hs --- a/src/Hack/Handler/Kibro.hs +++ b/src/Hack/Handler/Kibro.hs @@ -9,38 +9,39 @@ import MPSUTF8 import System.IO -get_env = do - uri <- requestURI - request_method' <- requestMethod - let script_name' = "" - let path_info' = uri.uriPath - let query_string' = uri.uriQuery - server_name' <- serverName - server_port' <- serverPort - hack_input' <- getBody - - def - { request_method = request_method'.read - , script_name = script_name' - , path_info = path_info' - , query_string = query_string'.remove_question_mark - , server_name = server_name' - , server_port = server_port' - , hack_input = hack_input' - , hack_errors = \x -> hPutStr stderr (x.u2b) - } - .return - where - remove_question_mark = dropWhile (is '?') +run :: Application -> IO () +run app' = startKibro [("", handle app')] + where + + get_env = do + uri <- requestURI + request_method' <- requestMethod + let script_name' = "" + let path_info' = uri.uriPath + let query_string' = uri.uriQuery + server_name' <- serverName + server_port' <- serverPort + hack_input' <- getBody -handle app = do - env <- get_env - response <- app env .liftIO - - -- set response - response.headers.mapM_ (splash setHeader) - response.status.show.setHeader "Status" - response.body.output + def + { request_method = request_method'.read + , script_name = script_name' + , path_info = path_info' + , query_string = query_string'.remove_question_mark + , server_name = server_name' + , server_port = server_port' + , hack_input = hack_input' + , hack_errors = \x -> hPutStr stderr (x.u2b) + } + .return + where + remove_question_mark = dropWhile (is '?') -run :: Application -> IO () -run app = startKibro [("", handle app)] + handle app = do + env <- get_env + response <- app env .liftIO + + -- set response + response.headers.mapM_ (splash setHeader) + response.status.show.setHeader "Status" + response.body.output diff --git a/src/Hack/Response.hs b/src/Hack/Response.hs --- a/src/Hack/Response.hs +++ b/src/Hack/Response.hs @@ -3,7 +3,6 @@ module Hack.Response where import Hack -import Hack.Utils import Hack.Constants import MPSUTF8 diff --git a/src/Hack/Utils.hs b/src/Hack/Utils.hs --- a/src/Hack/Utils.hs +++ b/src/Hack/Utils.hs @@ -9,16 +9,15 @@ import MPSUTF8 import Prelude hiding ((.), (^), (>), lookup, (+), (/)) -import Network.CGI hiding (Html) import Network.URI hiding (path) import Data.Default import Control.Arrow ((>>>), (<<<)) -import Data.Map (toList, lookup) +import Data.Map (lookup, Map) import Data.Time import Text.Template import qualified Data.ByteString.Lazy.Char8 as B -import Control.Monad (mplus) +import Control.Monad (mplus, MonadPlus) import Data.Maybe import System.IO import System.Posix.Files @@ -26,14 +25,20 @@ import System.Directory import Data.Time.Clock.POSIX import System.FilePath (()) -import Network.URI (unEscapeString) 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 (>) = (>>>) infixl 8 > +(+) :: (MonadPlus m) => m a -> m a -> m a (+) = mplus infixl 8 + @@ -57,6 +62,7 @@ dummy_app :: Application dummy_app _ = return $ def { status = 500 } +escape_html :: String -> String escape_html = concatMap fixChar where fixChar '<' = "<" @@ -68,10 +74,9 @@ - +show_status_code :: Int -> Maybe String show_status_code x = status_code.lookup x - - + -- MPS candidate now :: IO UTCTime @@ -85,7 +90,8 @@ 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 httpdate :: UTCTime -> String @@ -109,3 +115,8 @@ get_current_directory :: IO String get_current_directory = getCurrentDirectory ^ b2u + +zip64, unzip64 :: String -> String +zip64 = B.pack > GZip.compress > B.unpack > C.encode +unzip64 = C.decode > B.pack > GZip.decompress > B.unpack +