module Hascat.Toolkit ( ResponseCode, Content(..), (//), getRelativePath, getReason, getCodeString, getResponse200, getResponse303, getResponse400, getResponse401, getResponse404, getResponse405, getResponse500, getResponse503, getDirectoryIndex, getFileOrDirectoryIndex, getFileResponse, getFileOrDirectoryIndexResponse, getErrorResponse, guessContentType, HP.ServletRequest(..), HP.Input(..), module Hascat.App ) where import Control.OldException import Data.Char import Data.Maybe import Data.List import Hascat.App import Hascat.Protocol as HP import Network.HTTP import Network.URI import System.Directory import Text.Html import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) class Show a => Content a where toResponse :: ResponseCode -> [Header] -> a -> Response Lazy.ByteString instance Content Lazy.ByteString where toResponse code headers s = replaceHeader HdrContentType "text/plain" $ Response { rspCode = code, rspReason = getReason code, rspHeaders = headers, rspBody = s } instance Content String where toResponse code headers s = replaceHeader HdrContentType "text/plain" $ Response { rspCode = code, rspReason = getReason code, rspHeaders = headers, rspBody = Lazy.pack s } instance Content Html where toResponse code headers html = replaceHeader HdrContentType "text/html" $ Response { rspCode = code, rspReason = getReason code, rspHeaders = headers, rspBody = Lazy.pack (show html) } (//) :: String -> String -> String "" // "" = "" "" // path = path _ // ('/':path) = '/':path dir // path = if last dir == '/' then dir ++ path else dir ++ "/" ++ path getRelativePath :: String -> String -> Maybe String getRelativePath path contextPath = let n = length contextPath in if take n path == contextPath then Just (drop n path) else Nothing getReason :: ResponseCode -> String getReason (1, 0, 0) = "Continue" getReason (1, 0, 1) = "Switching Protocols" getReason (2, 0, 0) = "OK" getReason (2, 0, 1) = "Created" getReason (2, 0, 2) = "Accepted" getReason (2, 0, 3) = "Non-Authoritive Information" getReason (2, 0, 4) = "No Content" getReason (2, 0, 5) = "Reset Content" getReason (2, 0, 6) = "Partial Content" getReason (3, 0, 0) = "Multiple Choices" getReason (3, 0, 1) = "Moved Permanently" getReason (3, 0, 2) = "Found" getReason (3, 0, 3) = "See Other" getReason (3, 0, 4) = "Not Modified" getReason (3, 0, 5) = "Use Proxy" getReason (3, 0, 7) = "Temporary Redirect" getReason (4, 0, 0) = "Bad Request" getReason (4, 0, 1) = "Unauthorized" getReason (4, 0, 2) = "Payment Required" getReason (4, 0, 3) = "Forbidden" getReason (4, 0, 4) = "Not Found" getReason (4, 0, 5) = "Method Not Allowed" getReason (4, 0, 6) = "Not Acceptable" getReason (4, 0, 7) = "Proxy Authentication Required" getReason (4, 0, 8) = "Request Timeout" getReason (4, 0, 9) = "Conflict" getReason (4, 1, 0) = "Gone" getReason (4, 1, 1) = "Length Required" getReason (4, 1, 2) = "Precondition Failed" getReason (4, 1, 3) = "Request Entity Too Large" getReason (4, 1, 4) = "Request-URI Too Long" getReason (4, 1, 5) = "Unsupported Media Type" getReason (4, 1, 6) = "Requested Range Not Satisfiable" getReason (4, 1, 7) = "Expectation Failed" getReason (5, 0, 0) = "Internal Server Error" getReason (5, 0, 1) = "Not Implemented" getReason (5, 0, 2) = "Bad Gateway" getReason (5, 0, 3) = "Service Unavailable" getReason (5, 0, 4) = "Gateway Timeout" getReason (5, 0, 5) = "HTTP Version Not Supported" getCodeString :: ResponseCode -> String getCodeString (a, b, c) = concat (map show [a, b, c]) getResponse200 :: Content a => a -> Response Lazy.ByteString getResponse200 content = toResponse (2, 0, 0) [] content getResponse303 :: String -> Response Lazy.ByteString getResponse303 location = getErrorResponse (3, 0, 3) [Header HdrLocation location] ("If your browser does not support redirection, " +++ "please click the following link: " +++ hotlink location [toHtml location]) getResponse400 :: Response Lazy.ByteString getResponse400 = getErrorResponse (4, 0, 0) [] $ toHtml "Hascat received a bad request." getResponse401 :: String -> Response Lazy.ByteString getResponse401 auth = getErrorResponse (4, 0, 1) [Header HdrWWWAuthenticate ("Basic realm=" ++ show auth)] $ toHtml "Authorization required." getResponse404 :: String -> Response Lazy.ByteString getResponse404 url = getErrorResponse (4, 0, 4) [] $ toHtml ("The resource " +++ (thespan ! [thestyle "font-style: italic"] << url) +++ " could not be found.") getResponse405 :: RequestMethod -> Response Lazy.ByteString getResponse405 method = getErrorResponse (4, 0, 5) [] $ toHtml ("Hascat does not support the method " ++ show method) getResponse500 :: String -> Response Lazy.ByteString getResponse500 message = getErrorResponse (5, 0, 0) [] $ toHtml $ "Hascat could not fulfill the request." ++ message getResponse503 :: String -> Response Lazy.ByteString getResponse503 path = getErrorResponse (5, 0, 3) [] $ "The application at the context path " +++ (thespan ! [thestyle "font-style: italic"] << path) +++ " is not running." getErrorResponse :: ResponseCode -> [Header] -> Html -> Response Lazy.ByteString getErrorResponse code headers html = let title = getReason code ++ " [" ++ getCodeString code ++ "]" in toResponse code headers $ thehtml << [header << thetitle << title, body << [h1 << title, paragraph << html]] getDirectoryIndex :: FilePath -> Bool -> IO [String] getDirectoryIndex path showHidden = do contents <- getDirectoryContents path return $ sort $ if showHidden then contents else filter (not.isPrefixOf ".") contents -- Left: file contents, Right: directory listing getFileOrDirectoryIndex :: FilePath -> Bool -> IO (Either (FilePath,Lazy.ByteString) [String]) getFileOrDirectoryIndex localPath showHidden = do isDir <- doesDirectoryExist localPath let filePath = if isDir then localPath // "index.html" else localPath isFile <- doesFileExist filePath if isDir && not isFile then do -- case index.html is not present dir <- getDirectoryIndex localPath showHidden return $ Right dir else do file <- Lazy.readFile filePath return $ Left (filePath,file) getFileOrDirectoryIndexResponse :: String -> FilePath -> Maybe String -> Bool -> IO (Response Lazy.ByteString) getFileOrDirectoryIndexResponse url localPath contentType showHidden = handle (\_ -> return $ getResponse404 url) $ do either <- getFileOrDirectoryIndex localPath showHidden return $ case either of Right dir -> directoryToResponse url dir Left (filePath,file) -> fileToResponse file filePath contentType getFileResponse :: String -> FilePath -> Maybe String -> IO (Response Lazy.ByteString) getFileResponse url localPath contentType = do handle (\_ -> return $ getResponse404 url) $ do either <- getFileOrDirectoryIndex localPath False return $ case either of Left (filePath,file) -> fileToResponse file filePath contentType _ -> getResponse404 url directoryToResponse :: String -> [String] -> Response Lazy.ByteString directoryToResponse url dir = toResponse (2, 0, 0) [] $ directoryIndexToHtml url dir fileToResponse :: Lazy.ByteString -> FilePath -> Maybe String -> Response Lazy.ByteString fileToResponse file localPath contentType = let code = (2, 0, 0) contentTypeString = fromMaybe (guessContentType localPath) contentType in Response { rspCode = code, rspReason = getReason code, rspHeaders = [Header HdrContentType contentTypeString], rspBody = file } directoryIndexToHtml :: String -> [String] -> Html directoryIndexToHtml url contents = thehtml << [header << thetitle << title, body << [h1 << title, paragraph << listing, paragraph << "Hascat web server 0.2"]] where title = "Directory Index for " ++ url listing = directoryIndexToHtml' url contents directoryIndexToHtml' _ [] = toHtml "" directoryIndexToHtml' url (f:fs) = (anchor ! [href (url // f)] $ toHtml f) +++ br +++ directoryIndexToHtml' url fs guessContentType :: FilePath -> String guessContentType path | ".txt" `isSuffixOf` path = "text/plain; charset=latin1" | ".html" `isSuffixOf` path = "text/html" | ".htm" `isSuffixOf` path = "text/html" | ".xml" `isSuffixOf` path = "text/xml" | ".css" `isSuffixOf` path = "text/css" | ".gif" `isSuffixOf` path = "image/gif" | ".jpg" `isSuffixOf` path = "image/jpeg" | ".jpeg" `isSuffixOf` path = "image/jpeg" | otherwise = "application/octet-stream"