#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)
#endif
module Data.IterIO.Http (
HttpReq(..), defaultHttpReq, reqNormalPath
, httpReqI, inumHttpBody
, inumToChunks, inumFromChunks
, http_fmt_time, dateI
, FormField(..), foldForm
, enumHttpReq
, HttpStatus(..)
, stat100, stat200
, stat301, stat302, stat303, stat304, stat307
, stat400, stat401, stat403, stat404, stat405
, stat500, stat501
, HttpResp(..), defaultHttpResp, respAddHeader
, mkHttpHead, mkHtmlResp, mkContentLenResp, mkOnumResp
, resp301, resp303, resp403, resp404, resp405, resp500
, enumHttpResp, httpRespI
, HttpRequestHandler
, HttpServerConf(..), nullHttpServer, ioHttpServer
, inumHttpServer
, absUri, uri, path2list
) where
import Control.Exception (SomeException(..))
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Trans
import Data.Array.Unboxed
import Data.Bits
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.ByteString.Internal (w2c, c2w)
import Data.Char
import Data.Int
import Data.List
import Data.Time
import Data.Typeable
import Data.Word
import System.Locale (defaultTimeLocale)
import System.IO
import Text.Printf
import Data.IterIO
import Data.IterIO.Parse
import Data.IterIO.Search
type L = L8.ByteString
type S = S.ByteString
strictify :: L -> S
strictify = S.concat . L.toChunks
lazyfy :: S -> L
lazyfy = L.pack . S.unpack
crlf :: (Monad m) => Iter L m Word8
crlf = char '\r' *> char '\n' <|> char '\n'
spaces :: (Monad m) => Iter L m ()
spaces = skipWhile1I (\c -> c == eord ' ' || c == eord '\t')
<?> "spaces"
lws :: (Monad m) => Iter L m L
lws = optionalI crlf >> L8.singleton ' ' <$ spaces <?> "linear white space"
olws :: (Monad m) => Iter L m ()
olws = optionalI lws
noctl :: (Monad m) => Iter L m L
noctl = while1I (\c -> c >= 0x20 && c < 0x7f) <?> "non-control characters"
text :: (Monad m) => Iter L m L
text = concat1I (noctl <|> lws) <?> "text (Data.IterIO.Http)"
text_except :: (Monad m) => String -> Iter L m L
text_except except = concat1I (while1I ok <|> lws)
where
except' = fmap c2w except
ok c = c >= 0x20 && c < 0x7f && c `notElem` except'
hex :: (Monad m) => Iter L m Int
hex = headI >>= digit <?> "hex digit"
where
digit c | c > 127 = expectedI (show $ w2c c) "hex digit"
| otherwise = case hexTab ! c of
1 -> expectedI (show $ w2c c) "hex digit"
n -> return $ fromIntegral n
hexTab :: UArray Word8 Int8
hexTab = listArray (0,127) $ fmap digitval ['\0'..'\177']
digitval c | isHexDigit c = toEnum $ digitToInt c
| otherwise = 1
hexInt :: (Monad m) => Iter L m Int
hexInt = foldM1I digit 0 hex
where
maxok = maxBound `shiftR` 4
digit n d | n > maxok = throwParseI "hex integer too large"
| otherwise = return $ (n `shiftL` 4) .|. d
token :: (Monad m) => Iter L m S
token = strictify <$> token'
token' :: (Monad m) => Iter L m L
token' = while1I (\c -> c < 127 && tokenTab ! c) <?> "token"
where
tokenTab :: UArray Word8 Bool
tokenTab = listArray (0,127) $ fmap isTokenChar [0..127]
isTokenChar c = c > 0x20 && c < 0x7f && chr c `notElem` separators
separators = "()<>@,;:\\\"/[]?={} \t\177"
percent_decode :: (Monad m) => (Word8 -> Bool) -> Iter L m L
percent_decode test = foldrI L.cons' L.empty getc
where
getc = do
c <- headI
case c of
_ | c == eord '%' -> getval
_ | test c -> return c
_ -> expectedI (show c) "percent_decode predicate"
getval = do hi <- hex; lo <- hex; return $ toEnum $ 16 * hi + lo
quoted_pair :: (Monad m) => Iter L m L
quoted_pair = char '\\' <:> headI <:> nil
quoted_string :: (Monad m) => Iter L m S
quoted_string = do char '"'
ret <- concatI (text_except "\"" <|> quoted_pair)
char '"'
return $ strictify ret
parameter :: (Monad m) => Iter L m (S, S)
parameter = do
olws
k <- token
olws; char '='; olws
v <- token <|> quoted_string
return (k, v)
http_fmt_time :: UTCTime -> String
http_fmt_time = formatTime defaultTimeLocale "%a, %_d %b %Y %H:%M:%S GMT"
dowmap :: Map L Int
dowmap = Map.fromList $ flip zip ([0..6] ++ [0..6]) $
map L8.pack ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"
, "Sunday", "Monday", "Tuesday", "Wednesday"
, "Thursday", "Friday", "Saturday", "Sunday"]
weekdayI :: (Monad m) => Iter L.ByteString m Int
weekdayI = mapI dowmap <?> "Day of Week"
monmap :: Map L Int
monmap = Map.fromList $ flip zip [1..12] $
map L8.pack ["Jan", "Feb", "Mar", "Apr", "May", "Jun"
, "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
monthI :: (Monad m) => Iter L.ByteString m Int
monthI = mapI monmap <?> "Month"
timeI :: (Monad m) => Iter L.ByteString m TimeOfDay
timeI = do
hours <- whileMinMaxI 2 2 (isDigit . w2c) >>= readI <?> "Hours"
char ':'
minutes <- whileMinMaxI 2 2 (isDigit . w2c) >>= readI <?> "Minutes"
char ':'
seconds <- whileMinMaxI 2 2 (isDigit . w2c) >>= readI <?> "Seconds"
when (hours >= 24 || minutes >= 60 || seconds > 62) $
throwParseI "timeI: Invalid hours/minutes/seconds"
return $ TimeOfDay hours minutes (fromIntegral (seconds :: Int))
rfc822_time :: (Monad m) => Iter L m UTCTime
rfc822_time = do
weekdayI
char ','
spaces
mday <- whileMinMaxI 1 2 (isDigit . w2c) >>= readI <?> "Day of Month"
spaces
month <- monthI
spaces
year <- whileMinMaxI 4 5 (isDigit . w2c) >>= readI <?> "Year"
spaces
tod <- timeI
spaces
string "GMT"
return $ localTimeToUTC utc LocalTime {
localDay = fromGregorian year month mday
, localTimeOfDay = tod
}
rfc850_time :: (Monad m) => Iter L m UTCTime
rfc850_time = do
weekdayI
char ','
spaces
mday <- whileMinMaxI 2 2 (isDigit . w2c) >>= readI <?> "Day of Month"
char '-'
month <- monthI
char '-'
year <- do y2 <- whileMinMaxI 2 2 (isDigit . w2c) >>= readI <?> "Year"
return $ if y2 < 70 then y2 + 2000 else y2 + 1900
spaces
tod <- timeI
spaces
string "GMT"
return $ localTimeToUTC utc LocalTime {
localDay = fromGregorian year month mday
, localTimeOfDay = tod
}
asctime_time :: (Monad m) => Iter L m UTCTime
asctime_time = do
weekdayI
spaces
month <- monthI
spaces
mday <- whileMinMaxI 1 2 (isDigit . w2c) >>= readI <?> "Day of Month"
spaces
tod <- timeI
spaces
year <- whileMinMaxI 4 5 (isDigit . w2c) >>= readI <?> "Year"
return $ localTimeToUTC utc LocalTime {
localDay = fromGregorian year month mday
, localTimeOfDay = tod
}
dateI :: (Monad m) => Iter L.ByteString m UTCTime
dateI = rfc822_time <|> rfc850_time <|> asctime_time <?> "HTTP date/time"
rfc3986_unreserved :: Word8
rfc3986_unreserved = 0x1
rfc3986_gen_delims :: Word8
rfc3986_gen_delims = 0x2
rfc3986_sub_delims :: Word8
rfc3986_sub_delims = 0x4
rfc3986_schemechars :: Word8
rfc3986_schemechars = 0x8
rfc3986_addrchars :: Word8
rfc3986_addrchars = 0x10
rfc3986_pcharslash :: Word8
rfc3986_pcharslash = 0x20
rfc3986_syntax :: UArray Word8 Word8
rfc3986_syntax = listArray (0, 255) $ fmap bits ['\0'..'\377']
where
bits c = foldl' (.|.) 0 [
if isAlphaNum c || c `elem` "-._~"
then rfc3986_unreserved else 0
, if c `elem` ":/?#[]@" then rfc3986_gen_delims else 0
, if c `elem` "!$&'()*+,;=" then rfc3986_sub_delims else 0
, if isAlphaNum c || c `elem` "+-."
then rfc3986_schemechars else 0
, if isAlphaNum c || c `elem` "-._~:!$&'()*+,;="
then rfc3986_addrchars else 0
, if isAlphaNum c || c `elem` "-._~!$&'()*+,;=:@/"
then rfc3986_pcharslash else 0
]
rfc3986_test :: Word8 -> Word8 -> Bool
rfc3986_test mask c = rfc3986_syntax ! c .&. mask /= 0
hostI :: (Monad m) => Iter L m (S, Maybe Int)
hostI = (,) <$> host <*> (Just <$> port <|> return Nothing) <?> "host"
where
host = S8.map toLower <$> strictify <$>
(bracketed <|> percent_decode regnamechar)
port = do _ <- char ':'; whileI (isDigit . w2c) >>= readI
regnamechar c = (rfc3986_syntax ! c
.&. (rfc3986_unreserved .|. rfc3986_sub_delims)) /= 0
addrchar c = 0 /= rfc3986_syntax ! c .&. rfc3986_addrchars
bracketed = char '[' <:> percent_decode addrchar <++> char ']' <:> nil
pathI :: (Monad m) => Iter L m (S, S)
pathI = dopath <?> "path"
where
dopath = do
path <- strictify <$>
(ensureI (== eord '/')
*> percent_decode (rfc3986_test rfc3986_pcharslash))
<|> return (S8.pack "/")
query <- char '?' *> (strictify <$> whileI qpcharslash) <|> nil
return (path, query)
qpcharslash c = rfc3986_test rfc3986_pcharslash c
|| c == eord '?' || c == eord '%'
absUri :: (Monad m) => Iter L m (S, S, Maybe Int, S, S)
absUri = do
scheme <- strictify <$> satisfy (isAlpha . w2c)
<:> while1I (rfc3986_test rfc3986_schemechars)
string "://"
optionalI $ userinfo >> string "@"
authority <- hostI
(path, query) <- pathI
return (scheme, fst authority, snd authority, path, query)
where
userinfo = percent_decode $ \c ->
rfc3986_test (rfc3986_unreserved .|. rfc3986_sub_delims) c
|| c == eord ':'
uri :: (Monad m) => Iter L m (S, S, Maybe Int, S, S)
uri = absUri
<|> path
<|> char '*' *> return (S.empty, S.empty, Nothing, S8.pack "*", S.empty)
<?> "URI"
where
path = do (p, q) <- ensureI (== eord '/') *> pathI
return (S.empty, S.empty, Nothing, p, q)
path2list :: S -> [S]
path2list path = runIdentity $ inumPure path |$ (slash [] <?> "absolute path")
where
slash acc = while1I (eord '/' ==) \/ eofI *> return (reverse acc) $
const $ comp acc
comp acc = while1I (eord '/' /=) \/ return (reverse acc) $ \n ->
case () of
() | n == S8.pack "." -> slash acc
() | n == S8.pack ".." ->
if null acc then slash [] else slash $ tail acc
() -> slash $ n:acc
data HttpReq s = HttpReq {
reqScheme :: !S.ByteString
, reqMethod :: !S.ByteString
, reqPath :: !S.ByteString
, reqPathLst :: ![S.ByteString]
, reqPathParams :: ![S.ByteString]
, reqPathCtx :: ![S.ByteString]
, reqQuery :: !S.ByteString
, reqHost :: !S.ByteString
, reqPort :: !(Maybe Int)
, reqVers :: !(Int, Int)
, reqHeaders :: ![(S.ByteString, S.ByteString)]
, reqCookies :: ![(S.ByteString, S.ByteString)]
, reqContentType :: !(Maybe (S.ByteString, [(S.ByteString,S.ByteString)]))
, reqContentLength :: !(Maybe Int)
, reqTransferEncoding :: !S.ByteString
, reqIfModifiedSince :: !(Maybe UTCTime)
, reqSession :: s
} deriving (Typeable, Show)
defaultHttpReq :: HttpReq ()
defaultHttpReq = HttpReq { reqScheme = S.empty
, reqMethod = S.empty
, reqPath = S.empty
, reqPathLst = []
, reqPathParams = []
, reqPathCtx = []
, reqQuery = S.empty
, reqHost = S.empty
, reqPort = Nothing
, reqVers = (0, 0)
, reqHeaders = []
, reqCookies = []
, reqContentType = Nothing
, reqContentLength = Nothing
, reqTransferEncoding = S.empty
, reqIfModifiedSince = Nothing
, reqSession = ()
}
reqNormalPath :: HttpReq s -> S.ByteString
reqNormalPath rq =
S.intercalate slash $ S.empty : reqPathCtx rq ++ reqPathLst rq
where slash = S8.singleton '/'
hTTPvers :: (Monad m) => Iter L m (Int, Int)
hTTPvers = do
string "HTTP/"
major <- whileI (isDigit . w2c) >>= readI
char '.'
minor <- whileI (isDigit . w2c) >>= readI
return (major, minor)
request_line :: (Monad m) => Iter L m (HttpReq ())
request_line = do
method <- strictify <$> while1I (isUpper . w2c)
spaces
(scheme, host, mport, path, query) <- uri
spaces
(major, minor) <- hTTPvers
optionalI spaces
skipI crlf
return defaultHttpReq {
reqScheme = scheme
, reqMethod = method
, reqPath = path
, reqPathLst = path2list path
, reqQuery = query
, reqHost = host
, reqPort = mport
, reqVers = (major, minor)
}
request_headers :: (Monad m) => Map S (HttpReq a -> Iter L m (HttpReq a))
request_headers = Map.fromList $
map (\(a, b) -> (S8.map toLower $ S8.pack a, b)) $
[
("Host", host_hdr)
, ("Cookie", cookie_hdr)
, ("Content-Type", content_type_hdr)
, ("Content-Length", content_length_hdr)
, ("Transfer-Encoding", transfer_encoding_hdr)
, ("If-Modified-Since", if_modified_since_hdr)
]
host_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s)
host_hdr req = do
(host, mport) <- hostI
return req { reqHost = host, reqPort = mport }
cookie_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s)
cookie_hdr req = ifParse cookiesI setCookies ignore
where
cookiesI = sepBy1 parameter sep <* eofI
sep = do olws; char ';' <|> char ','
setCookies cookies = return $ req { reqCookies = cookies }
ignore = nullI >> return req
content_type_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s)
content_type_hdr req = do
typ <- token <++> char '/' <:> token
parms <- many $ olws >> char ';' >> parameter
return req { reqContentType = Just (typ, parms) }
content_length_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s)
content_length_hdr req = do
len <- olws >> (while1I (isDigit . w2c) >>= readI) <* olws
return req { reqContentLength = Just len }
transfer_encoding_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s)
transfer_encoding_hdr req = do
tclist <- tc
return req { reqTransferEncoding = tclist }
where
tc = do
olws
coding <- S8.map toLower <$> token
skipMany $ olws >> char ';' >> parameter
return coding
if_modified_since_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s)
if_modified_since_hdr req = do
modtime <- dateI
return req { reqIfModifiedSince = Just modtime }
hdr_field_val :: (Monad m) => Iter L m (S, S)
hdr_field_val = do
field <- S8.map toLower <$> token
char ':'
olws
val <- strictify <$> text
crlf
return (field, val)
any_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s)
any_hdr req = do
(field, val) <- hdr_field_val
let req' = req { reqHeaders = (field, val) : reqHeaders req }
case Map.lookup field request_headers of
Nothing -> return req'
Just f -> inumPure (L.fromChunks [val]) .|$
(f req' <* (optionalI spaces >> eofI)
<?> (S8.unpack field ++ " header"))
httpReqI :: Monad m => Iter L.ByteString m (HttpReq ())
httpReqI = do
skipMany crlf
(request_line >>= next_hdr) <* crlf
where next_hdr req = seq req $ any_hdr req \/ return req $ next_hdr
inumToChunks :: (Monad m) => Inum L.ByteString L.ByteString m a
inumToChunks = mkInumM loop
where
loop = do
Chunk s eof <- chunkI
let len = L8.length s
chunksize = L8.pack $ printf "%x\r\n" len
trailer = if eof && len > 0
then L8.pack "\r\n0\r\n\r\n"
else L8.pack "\r\n"
ifeed $ L8.concat [chunksize, s, trailer]
unless eof loop
inumFromChunks :: (Monad m) => Inum L.ByteString L.ByteString m a
inumFromChunks = mkInum $ do
eof <- atEOFI
if eof then return L.empty else chunkedBodyI
inumHttpBody :: (Monad m) => HttpReq s -> Inum L.ByteString L.ByteString m a
inumHttpBody req =
case reqTransferEncoding req of
enc | S.null enc || enc == S8.pack "identity" ->
if hasclen then inumTakeExact (fromJust $ reqContentLength req)
else inumNull
enc | enc == S8.pack "chunked" -> inumFromChunks
enc -> inumFromChunks |. tcInum enc
where
hasclen = isJust $ reqContentLength req
tcInum e = mkInum $ fail $ "unknown Transfer-Coding " ++ chunkShow e
data FormField = FormField {
ffName :: !S.ByteString
, ffParams :: ![(S.ByteString, S.ByteString)]
, ffHeaders :: ![(S.ByteString, S.ByteString)]
} deriving (Show)
defaultFormField :: FormField
defaultFormField = FormField {
ffName = S.empty
, ffParams = []
, ffHeaders = []
}
foldForm :: (Monad m) =>
HttpReq s
-> (a -> FormField -> Iter L.ByteString m a)
-> a
-> Iter L.ByteString m a
foldForm req = case reqContentType req of
Nothing -> foldQuery req
Just (mt, _) | mt == urlencoded -> foldUrlencoded req
Just (mt, _) | mt == multipart -> foldMultipart req
_ -> \_ _ -> throwParseI "foldForm: invalid Content-Type"
urlencoded :: S
urlencoded = S8.pack "application/x-www-form-urlencoded"
urlencTab :: UArray Word8 Bool
urlencTab = listArray (0, 127) $ fmap ok ['\0'..'\177']
where ok c | c <= ' ' = False
| c >= '\177' = False
| c `elem` "%+&=" = False
| otherwise = True
controlI :: (Monad m) => Iter L m (S, S)
controlI = flip (<?>) "form control NAME=VALUE" $ do
name <- encval
value <- (char '=' >> encval) <|> nil
return (name, value)
where
encval = liftM strictify $ concatI $
someI (percent_decode (urlencTab !))
<|> L8.singleton ' ' <$ char '+'
inumBind :: (ChunkData t, Monad m) =>
Iter t m a -> (a -> Iter t m a) -> Iter t m a
inumBind m k = tryRI m >>= either reRunIter k
infixl 1 `inumBind`
foldControls :: (Monad m) => (a -> FormField -> Iter L m a) -> a -> Iter L m a
foldControls f z =
controlI \/ return z $ \(k, v) ->
inumPure (L.fromChunks [v]) .|
f z defaultFormField { ffName = k } `inumBind` \a ->
char '&' \/ return a $ \_ -> foldControls f a
foldUrlencoded :: (Monad m) =>
HttpReq s -> (a -> FormField -> Iter L m a) -> a -> Iter L m a
foldUrlencoded _req f z = foldControls f z
foldQuery :: (Monad m) =>
HttpReq s -> (a -> FormField -> Iter L m a) -> a -> Iter L m a
foldQuery req f z = inumPure (L.fromChunks [reqQuery req]) .| foldControls f z
multipart :: S
multipart = S8.pack "multipart/form-data"
reqBoundary :: HttpReq s -> Maybe S
reqBoundary req = case reqContentType req of
Just (typ, parms) | typ == multipart ->
lookup (S8.pack "boundary") parms
_ -> Nothing
multipartI :: (Monad m) => HttpReq s -> Iter L m (Maybe FormField)
multipartI req = case reqBoundary req of
Just b -> findpart $ S8.pack "--" `S8.append` b
Nothing -> return Nothing
where
nextLine :: (Monad m) => Iter L m ()
nextLine = skipWhileI (\c -> c `elem` map eord " \t\r") >>
char '\n' >> return ()
findpart b = do
match $ L.fromChunks [b]
done <- ((string "--" >> return True) <|> return False) <* nextLine
if done then return Nothing else Just <$> parsepart
parsepart = do
cdhdr@(field, val) <- hdr_field_val
inumPure field .|$ stringCase "Content-Disposition"
parms <- inumPure (L.fromChunks [val]) .|$
sepBy (parameter <|> (token >>= \t -> return (t, S.empty)))
(olws >> char ';')
hdrs <- many hdr_field_val
crlf
return FormField {
ffName = fromMaybe S.empty $ lookup (S8.pack "name") parms
, ffParams = parms
, ffHeaders = cdhdr:hdrs
}
inumMultipart :: (Monad m) => HttpReq s -> Inum L L m a
inumMultipart req iter = flip mkInumM (iter <* nullI) $ do
b <- bstr
ipipe $ inumStopString b
(crlf <?> chunkShow b)
where
bstr = case reqBoundary req of
Just b -> return $ S8.pack "\r\n--" `S8.append` b
Nothing -> throwParseI "inumMultipart: no parts"
foldMultipart :: (Monad m) =>
HttpReq s -> (a -> FormField -> Iter L m a) -> a -> Iter L m a
foldMultipart req f z = multipartI req >>= doPart
where
doPart Nothing = return z
doPart (Just mp) =
inumMultipart req .| (f z mp <* nullI) `inumBind` \a ->
foldMultipart req f a
data HttpStatus = HttpStatus !Int !S.ByteString deriving Show
instance Eq HttpStatus where
HttpStatus c0 _ == HttpStatus c1 _ = c0 == c1
mkStat :: Int -> String -> HttpStatus
mkStat n s = HttpStatus n $ S8.pack s
fmtStat :: HttpStatus -> L
fmtStat (HttpStatus n s) = L.fromChunks [
S8.pack $ "HTTP/1.1 " ++ show n ++ " "
, s, S8.pack "\r\n"]
stat100, stat200
, stat301, stat302, stat303, stat304, stat307
, stat400, stat401, stat403, stat404, stat405
, stat500, stat501 :: HttpStatus
stat100 = mkStat 100 "Continue"
stat200 = mkStat 200 "OK"
stat301 = mkStat 301 "Moved Permanently"
stat302 = mkStat 302 "Found"
stat303 = mkStat 303 "See Other"
stat304 = mkStat 304 "Not Modified"
stat307 = mkStat 307 "Temporary Redirect"
stat400 = mkStat 400 "Bad Request"
stat401 = mkStat 401 "Unauthorized"
stat403 = mkStat 403 "Forbidden"
stat404 = mkStat 404 "Not Found"
stat405 = mkStat 405 "Method not allowed"
stat500 = mkStat 500 "Internal Server Error"
stat501 = mkStat 501 "Not Implemented"
data HttpResp m = HttpResp {
respStatus :: !HttpStatus
, respHeaders :: ![(S.ByteString, S.ByteString)]
, respChunk :: !Bool
, respBody :: !(Onum L.ByteString m (IterR L.ByteString m ()))
}
respAddHeader :: (S.ByteString, S.ByteString) -> HttpResp m -> HttpResp m
respAddHeader hdr resp = resp { respHeaders = hdr : respHeaders resp }
instance Show (HttpResp m) where
showsPrec _ resp rest = "HttpResp (" ++ show (respStatus resp)
++ ") " ++ show (respHeaders resp) ++ rest
defaultHttpResp :: (Monad m) => HttpResp m
defaultHttpResp = HttpResp { respStatus = stat200
, respHeaders = []
, respChunk = True
, respBody = inumNull
}
mkHttpHead :: (Monad m) => HttpStatus -> HttpResp m
mkHttpHead stat = HttpResp { respStatus = stat
, respHeaders = []
, respChunk = False
, respBody = inumNull }
mkHtmlResp :: (Monad m) =>
HttpStatus
-> L.ByteString
-> HttpResp m
mkHtmlResp stat html = resp
where resp0 = mkHttpHead stat `asTypeOf` resp
ctype = (S8.pack "Content-Type", S8.pack"text/html")
len = (S8.pack "Content-Length", S8.pack $ show (L8.length html))
resp = resp0 { respHeaders = respHeaders resp0 ++ [ctype, len]
, respBody = inumPure html
}
mkContentLenResp :: (Monad m)
=> HttpStatus
-> String
-> L.ByteString
-> HttpResp m
mkContentLenResp stat ctype body =
HttpResp { respStatus = stat
, respHeaders = [contentType, contentLength]
, respChunk = False
, respBody = inumPure body }
where
contentType = (S8.pack "Content-Type", S8.pack ctype)
contentLength = (S8.pack "Content-Length", S8.pack . show . L8.length $ body)
mkOnumResp :: (Monad m)
=> HttpStatus
-> String
-> Onum L.ByteString m (IterR L.ByteString m ())
-> HttpResp m
mkOnumResp stat ctype body =
HttpResp { respStatus = stat
, respHeaders = [contentType]
, respChunk = True
, respBody = body }
where
contentType = (S8.pack "Content-Type", S8.pack ctype)
htmlEscapeChar :: Char -> Maybe String
htmlEscapeChar '<' = Just "<"
htmlEscapeChar '>' = Just ">"
htmlEscapeChar '&' = Just "&"
htmlEscapeChar '"' = Just """
htmlEscapeChar '\'' = Just "&"
htmlEscapeChar _ = Nothing
htmlEscape :: String -> L.ByteString
htmlEscape str = L8.unfoldr next (str, "")
where
next (s, h:t) = Just (h, (s, t))
next (h:t, "") = maybe (Just (h, (t, ""))) (curry next t) $
htmlEscapeChar h
next ("", "") = Nothing
resp301 :: (Monad m) => String -> HttpResp m
resp301 target =
respAddHeader (S8.pack "Location", S8.pack target) $ mkHtmlResp stat301 html
where html = L8.concat
[L8.pack
"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
\<HTML><HEAD>\n\
\<TITLE>301 Moved Permanently</TITLE>\n\
\</HEAD><BODY>\n\
\<H1>Moved Permanently</H1>\n\
\<P>The document has moved <A HREF=\""
, htmlEscape target
, L8.pack "\">here</A>.</P>\n"]
resp303 :: (Monad m) => String -> HttpResp m
resp303 target =
respAddHeader (S8.pack "Location", S8.pack target) $ mkHtmlResp stat303 html
where html = L8.concat
[L8.pack
"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
\<HTML><HEAD>\n\
\<TITLE>303 See Other</TITLE>\n\
\</HEAD><BODY>\n\
\<H1>See Other</H1>\n\
\<P>The document has moved <A HREF=\""
, htmlEscape target
, L8.pack "\">here</A>.</P>\n"]
resp403 :: (Monad m) => HttpReq s -> HttpResp m
resp403 req = mkHtmlResp stat403 html
where html = L8.concat
[L8.pack
"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
\<HTML><HEAD>\n\
\<TITLE>403 Forbidden</TITLE>\n\
\</HEAD><BODY>\n\
\<H1>Forbidden</H1>\n\
\<P>You don't have permission to access "
, htmlEscape $ S8.unpack (reqNormalPath req)
, L8.pack " on this server.</P>\n\
\</BODY></HTML>\n"]
resp404 :: (Monad m) => HttpReq s -> HttpResp m
resp404 req = mkHtmlResp stat404 html
where html = L8.concat
[L8.pack
"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
\<HTML><HEAD>\n\
\<TITLE>404 Not Found</TITLE>\n\
\</HEAD><BODY>\n\
\<H1>Not Found</H1>\n\
\<P>The requested URL "
, htmlEscape $ S8.unpack (reqNormalPath req)
, L8.pack " was not found on this server.</P>\n\
\</BODY></HTML>\n"]
resp405 :: (Monad m) => HttpReq s -> HttpResp m
resp405 req = mkHtmlResp stat405 html
where html = L8.concat
[L8.pack
"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
\<HTML><HEAD>\n\
\<TITLE>405 Method Not Allowed</TITLE>\n\
\</HEAD><BODY>\n\
\<H1>Method Not Allowed</H1>\n\
\<P>The requested method "
, L.fromChunks [reqMethod req]
, L8.pack " is not allowed for the URL "
, htmlEscape $ S8.unpack (reqNormalPath req)
, L8.pack ".</P>\n\
\</BODY></HTML>\n"]
resp500 :: (Monad m) => String -> HttpResp m
resp500 msg = mkHtmlResp stat500 html
where html = L8.concat
[L8.pack
"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
\<HTML><HEAD>\n\
\<TITLE>500 Internal Server Error</TITLE>\n\
\</HEAD><BODY>\n\
\<H1>Internal Server Error</H1>\n\
\<P>"
, htmlEscape msg
, L8.pack "</P>\n</BODY></HTML>\n"]
enumHttpResp :: (Monad m) =>
HttpResp m
-> Onum L.ByteString m ()
enumHttpResp resp = inumPure fmtresp `cat` (respBody resp |. maybeChunk)
where
fmtresp = (fmtStat $ respStatus resp) `L.append` hdrsL
hdrsS = if respChunk resp
then (transferEncoding, S8.pack "chunked") :
(filter ((/= transferEncoding) . fst) $ respHeaders resp)
else respHeaders resp
hdrsL = (L.concat $ map mkHeader hdrsS) `L8.append` L8.pack "\r\n"
maybeChunk = if respChunk resp then inumToChunks else inumNop
mkHeader (k, v) = lazyfy k `L8.append` L8.pack ": "
`L8.append` lazyfy v `L8.append` L8.pack "\r\n"
transferEncoding = S8.pack "Transfer-Encoding"
type HttpRequestHandler m s = HttpReq s -> Iter L.ByteString m (HttpResp m)
data HttpServerConf m = HttpServerConf {
srvLogger :: !(String -> Iter L.ByteString m ())
, srvDate :: !(Iter L.ByteString m (Maybe UTCTime))
, srvHandler :: !(HttpRequestHandler m ())
}
nullHttpServer :: (Monad m) => HttpRequestHandler m () -> HttpServerConf m
nullHttpServer handler = HttpServerConf {
srvLogger = const $ return ()
, srvDate = return Nothing
, srvHandler = handler
}
ioHttpServer :: (MonadIO m) => HttpRequestHandler m () -> HttpServerConf m
ioHttpServer handler = HttpServerConf {
srvLogger = liftIO . hPutStrLn stderr
, srvDate = liftIO $ Just `liftM` getCurrentTime
, srvHandler = handler
}
inumHttpServer :: (Monad m) =>
HttpServerConf m
-> Inum L.ByteString L.ByteString m ()
inumHttpServer server = mkInumM loop
where
loop = do
eof <- atEOFI
unless eof doreq
doreq = do
req <- httpReqI
let handler = srvHandler server req
resp <- liftI $ inumHttpBody req .|
(catchI handler errHandler <* nullI)
now <- liftI $ srvDate server
let respWithDate = maybe resp (addDate resp) now
tryI (irun $ enumHttpResp respWithDate) >>=
either (fatal . fst) (const loop)
errHandler e@(SomeException _) _ = do
srvLogger server $ "Response error: " ++ show e
return $ resp500 $ show e
fatal e@(SomeException _) = do
liftI $ srvLogger server $ "Reply error: " ++ show e
return ()
addDate resp t = respAddHeader (S8.pack "Date"
, S8.pack . http_fmt_time $ t) resp
enumHttpReq :: (Monad m) => HttpReq s -> L -> Onum L m a
enumHttpReq req body =
enumNoBody |. inumStoL
`lcat` (enumPure body |. maybeChunk)
where enumNoBody = enumPure $ S.concat [ mkHttpRequest_Line req False
, mkHttpReqHeaders req
, S8.pack "\r\n"
]
maybeChunk = case lookup transferEncoding (reqHeaders req) of
Just v | v == S8.pack "chunked" -> inumToChunks
_ -> inumNop
transferEncoding = S8.pack "Transfer-Encoding"
mkHttpRequest_Line :: HttpReq s -> Bool -> S
mkHttpRequest_Line req absURI = S.concat [
reqMethod req
, sp
, mkReqURI req absURI
, sp
, let (major, minor) = reqVers req
in S8.pack $ "HTTP/" ++ show major ++ "." ++ show minor
, S8.pack "\r\n"
]
where sp = S8.singleton ' '
mkReqURI :: HttpReq s -> Bool -> S
mkReqURI req absURI = S.concat
[ if absURI then authorization else S.empty
, if null $ reqPathLst req
then reqPath req
else reqNormalPath req
, emptyIfNull reqQuery $ \q -> S8.append (S8.singleton '?') q
]
where emptyIfNull rF g = let r = (rF req)
in if S.null r then S.empty else g r
authorization = emptyIfNull reqHost $ \h -> S.concat
[ emptyIfNull reqScheme $ \s -> S8.append s (S8.pack "://")
, h
, maybe S.empty (S8.pack . (":"++) . show) $ reqPort req
]
mkHttpReqHeaders :: HttpReq s -> S
mkHttpReqHeaders req = S.concat . nub . filter (not . S.null) $
hostHeader
: contentTypeHeader
: contentLengthHeader
: cookieHeader
: transferEncodingHeader
: ifModifiedSinceHeader
: allHeaders
where mkHeader (k,v) =
if S.null v
then S.empty
else k `S8.append` S8.pack ": "
`S8.append` v `S8.append` S8.pack "\r\n"
hostHeader = mkHeader (S8.pack "Host", reqHost req)
transferEncodingHeader =
mkHeader (S8.pack "Transfer-Encoding", reqTransferEncoding req)
contentLengthHeader =
mkHeader (S8.pack "Content-Length"
, maybe S.empty (S8.pack . show) $ reqContentLength req)
ifModifiedSinceHeader =
mkHeader (S8.pack "If-Modified-Since"
, maybe S.empty (S8.pack . http_fmt_time)
$ reqIfModifiedSince req)
cookieHeader =
mkHeader (S8.pack "Cookie"
, S8.intercalate (S8.singleton ';') $ map p $ reqCookies req)
p (k, v) = k `S8.append` S8.singleton '=' `S8.append` v
contentTypeHeader =
mkHeader (S8.pack "Content-Type"
, maybe S.empty ctF $ reqContentType req)
ctF (mt,params) = mt `S8.append`
(S8.intercalate (S8.singleton ';') $ map p params)
allHeaders = map mkHeader $ reqHeaders req
httpStatusI :: (Monad m) => Iter L m HttpStatus
httpStatusI = do
_ <- hTTPvers
spaces
status <- whileMinMaxI 3 3 (isDigit . w2c) >>= readI <?> "Status code"
spaces
phrase <- L8.unpack <$> text_except "\r\n"
skipI crlf
return $ mkStat status phrase
httpRespI :: (MonadIO m) => Iter L m (HttpResp m)
httpRespI = do
stat <- httpStatusI
hdrs <- many hdr_field_val
chunked <- maybe (return False) (isChunked . L8.map toLower . lazyfy) $
lookup (S8.pack "transfer-encoding") hdrs
let hdrs' = if chunked
then filter ((/= S8.pack "transfer-encoding") . fst) hdrs
else hdrs
skipI crlf
body <- httpBodyI hdrs' chunked
let resp = HttpResp { respStatus = stat
, respHeaders = hdrs'
, respChunk = chunked
, respBody = enumPure body }
return resp
where isChunked v = enumPure v |$ (cI <|> return False)
cI = do optionalI spaces
match $ L8.pack "chunked"
optionalI spaces
return True
httpBodyI :: (Monad m) => [(S,S)] -> Bool -> Iter L m L
httpBodyI hdrs isChunked =
if isChunked
then chunkedBodyI
else let mLen = do lenS <- lookup (S8.pack "content-length") hdrs
maybeRead . S8.unpack $ lenS
in maybe pureI takeI mLen
where maybeRead = fmap fst . listToMaybe . reads
chunkedBodyI :: Monad m => Iter L m L
chunkedBodyI = do
r <- many chunk_
skipMany trailer
skipI crlf
return $ L.concat r
where chunk_ = do size <- chunk_size
chunk_ext
crlf
b <- if size > 0
then takeI size <* crlf
else return L.empty
return b
chunk_size = hexInt
chunk_ext = skipMany $ do char ';'
osp
chunk_ext_name
optionalI $ char '=' >> chunk_ext_val
chunk_ext_name = token
chunk_ext_val = token <|> quoted_string
trailer = hdr_field_val
osp = skipWhileI $ \c -> c == eord ' ' || c == eord '\t'