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
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
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"