import Network
import Network.BSD
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEType.Guess
import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
import System.IO.Unsafe
-- a good idea to use GnomeVFS
-- (<http://developer.gnome.org/doc/API/2.0/gnome-vfs-2.0/>)
-- instead of vanilla FS.
- , cnfExtToMIMEType :: Map String MIMEType
+ , cnfExtToMIMEType :: ExtMap
}
-- |The default configuration. Generally you can use this value as-is,
++
quoteStr token
--- |This is an equivalent to @'ETag' False@. If you want to generate
+-- |This is equivalent to @'ETag' False@. If you want to generate
-- an ETag from a file, try using
-- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'.
strongETag :: String -> ETag
strongETag = ETag False
--- |This is an equivalent to @'ETag' True@.
+-- |This is equivalent to @'ETag' True@.
weakETag :: String -> ETag
weakETag = ETag True
maj </> min
= MIMEType maj min []
--- |\<\:\> appends a @(name, value)@ pair to a MIME Type.
+-- |This operator appends a @(name, value)@ pair to a MIME Type.
(<:>) :: MIMEType -> (String, String) -> MIMEType
mt@(MIMEType _ _ params) <:> pair
= mt {
mtParams = mtParams mt ++ [pair]
}
--- |\<\=\> takes two strings and makes a tuple of them. So you can say
--- @\"text\" \<\/\> \"xml\" \<\:\> \"charset\" \<\=\> \"UTF-8\" \<\:\>
--- \"q\" \<\=\> \"0.9\"@ to represent \"text\/xml; charset=UTF-8;
--- q=0.9\".
+-- |This operator takes two strings and makes a tuple of them. So you
+-- can say
+--
+-- > "text" </> "xml" <:> "charset" <=> "UTF-8" <:> "q" <=> "0.9"
+--
+-- to represent \"text\/xml; charset=UTF-8; q=0.9\".
(<=>) :: String -> String -> (String, String)
name <=> value = (name, value)
+-- |This module is automatically generated from data\/mime.types.
+-- 'defaultExtensionMap' contains every possible pairs of an extension
+-- and a MIME Type.
+
{- !!! WARNING !!!
- This file is automatically generated from data/mime.types.
+ This file is automatically generated.
DO NOT EDIT BY HAND OR YOU WILL REGRET -}
module Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
(defaultExtensionMap) where
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEType.Guess
import qualified Data.Map as M
import Data.Map (Map)
-defaultExtensionMap :: Map String MIMEType
+defaultExtensionMap :: ExtMap
defaultExtensionMap
= M.fromList
[("3gp", "application" </> "x-3gp"), ("669", "audio" </> "x-mod"),
+-- |MIME Type guesser which guesses by a file extension. This is a
+-- poor man's way of guessing MIME Types. It is simple and fast.
+--
+-- In general you don't have to use this module directly.
module Network.HTTP.Lucu.MIMEType.Guess
( ExtMap
- , guessTypeByFileName -- ExtMap -> FilePath -> Maybe MIMEType
+ , guessTypeByFileName
- , parseExtMapFile -- FilePath -> IO ExtMap
- , outputExtMapAsHS -- ExtMap -> FilePath -> IO ()
+ , parseExtMapFile
+ , serializeExtMap
)
where
import Network.HTTP.Lucu.Utils
import System.IO
+-- |Map from extension to MIME Type.
type ExtMap = Map String MIMEType
-
+-- |Guess the MIME Type of file.
guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
guessTypeByFileName extMap fpath
= let ext = last $ splitBy (== '.') fpath
in
M.lookup ext extMap >>= return
-
+-- |Read an Apache mime.types and parse it.
parseExtMapFile :: FilePath -> IO ExtMap
parseExtMapFile fpath
= do file <- B.readFile fpath
tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
tr (mime, exts) = [ (ext, mime) | ext <- exts ]
-
-outputExtMapAsHS :: ExtMap -> FilePath -> IO ()
-outputExtMapAsHS extMap fpath
+-- |@'serializeExtMap' extMap moduleName variableName@ generates a
+-- Haskell source code which contains the following things:
+--
+-- * A definition of module named @moduleName@.
+--
+-- * @variableName :: 'ExtMap'@ whose content is a serialization of
+-- @extMap@.
+--
+-- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
+-- surely generated using this function.
+serializeExtMap :: ExtMap -> String -> String -> String
+serializeExtMap extMap moduleName variableName
= let hsModule = HsModule undefined modName (Just exports) imports decls
- modName = Module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap"
- exports = [HsEVar (UnQual (HsIdent "defaultExtensionMap"))]
+ modName = Module moduleName
+ exports = [HsEVar (UnQual (HsIdent variableName))]
imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
+ , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
, HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
, HsImportDecl undefined (Module "Data.Map") False Nothing (Just (False, [HsIAbs (HsIdent "Map")]))
]
- decls = [ HsTypeSig undefined [HsIdent "defaultExtensionMap"]
- (HsQualType [] (HsTyApp (HsTyApp (HsTyCon (UnQual (HsIdent "Map")))
- (HsTyCon (UnQual (HsIdent "String"))))
- (HsTyCon (UnQual (HsIdent "MIMEType")))))
- , HsFunBind [HsMatch undefined (HsIdent "defaultExtensionMap")
+ decls = [ HsTypeSig undefined [HsIdent variableName]
+ (HsQualType []
+ (HsTyCon (UnQual (HsIdent "ExtMap"))))
+ , HsFunBind [HsMatch undefined (HsIdent variableName)
[] (HsUnGuardedRhs extMapExp) []]
]
extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
comment = "{- !!! WARNING !!!\n"
- ++ " This file is automatically generated from data/mime.types.\n"
+ ++ " This file is automatically generated.\n"
++ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
in
- writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n"
+ comment ++ prettyPrint hsModule ++ "\n"
where
records :: [HsExp]
records = map record $ M.assocs extMap
+-- |Yet another parser combinator. This is mostly a subset of Parsec
+-- but there are some differences:
+--
+-- * This parser works on ByteString instead of String.
+--
+-- * Backtracking is the only possible behavior so there is no \"try\"
+-- action.
+--
+-- * On success, the remaining string is returned as well as the
+-- parser result.
+--
+-- * You can treat reaching EOF (trying to eat one more letter at the
+-- end of string) a fatal error or a normal failure. If a fatal
+-- error occurs, the entire parsing process immediately fails
+-- without trying any backtracks. The default behavior is to treat
+-- EOF fatal.
+--
+-- In general, you don't have to use this module directly.
module Network.HTTP.Lucu.Parser
- ( Parser(..)
+ ( Parser
, ParserResult(..)
- , parse -- Parser a -> ByteString -> (ParserResult a, ByteString)
- , parseStr -- Parser a -> String -> (ParserResult a, ByteString)
-
- , anyChar -- Parser Char
- , eof -- Parser ()
- , allowEOF -- Parser a -> Parser a
- , satisfy -- (Char -> Bool) -> Parser Char
- , char -- Char -> Parser Char
- , string -- String -> Parser String
- , (<|>) -- Parser a -> Parser a -> Parser a
- , oneOf -- [Char] -> Parser Char
- , digit -- Parser Char
- , hexDigit -- Parser Char
- , notFollowedBy -- Parser a -> Parser ()
- , many -- Parser a -> Parser [a]
- , many1 -- Parser a -> Parser [a]
- , manyTill -- Parser a -> Parser end -> Parser [a]
- , many1Till -- Parser a -> Parser end -> Parser [a]
- , count -- Int -> Parser a -> Parser [a]
- , option -- a -> Parser a -> Parser a
- , sepBy -- Parser a -> Parser sep -> Parser [a]
- , sepBy1 -- Parser a -> Parser sep -> Parser [a]
-
- , sp -- Parser Char
- , ht -- Parser Char
- , crlf -- Parser String
+ , parse
+ , parseStr
+
+ , anyChar
+ , eof
+ , allowEOF
+ , satisfy
+ , char
+ , string
+ , (<|>)
+ , oneOf
+ , digit
+ , hexDigit
+ , notFollowedBy
+ , many
+ , many1
+ , manyTill
+ , many1Till
+ , count
+ , option
+ , sepBy
+ , sepBy1
+
+ , sp
+ , ht
+ , crlf
)
where
import qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)
+-- |@Parser a@ is obviously a parser which parses and returns @a@.
data Parser a = Parser {
runParser :: State ParserState (ParserResult a)
}
Success a -> runParser (f a)
IllegalInput -> do put saved -- 状態を復歸
return IllegalInput
- ReachedEOF -> if isEOFFatal then
- return ReachedEOF
- else
- do put saved
- return IllegalInput
+ ReachedEOF -> do unless isEOFFatal
+ $ put saved -- 状態を復歸
+ return ReachedEOF
return = Parser . return . Success
fail _ = Parser $ return IllegalInput
-
+-- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result,
+-- remaining)@.
parse :: Parser a -> ByteString -> (ParserResult a, ByteString)
parse p input = let (result, (input', _)) = runState (runParser p) (input, True)
in
(result, input')
-
+-- |@'parseStr' p str@ packs @str@ and parses it.
parseStr :: Parser a -> String -> (ParserResult a, ByteString)
parseStr p input = parse p $ B.pack input
else
return IllegalInput
-
+-- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure.
allowEOF :: Parser a -> Parser a
allowEOF f = Parser $ do (input, isEOFFatal) <- get
put (input, False)
infixr 0 <|>
+-- |This is the backtracking alternation. There is no non-backtracking
+-- equivalent.
(<|>) :: Parser a -> Parser a -> Parser a
f <|> g = Parser $ do saved@(_, isEOFFatal) <- get -- 状態を保存
result <- runParser f
+-- |This is an auxiliary parser utilities for parsing things related
+-- on HTTP protocol.
+--
+-- In general you don't have to use this module directly.
module Network.HTTP.Lucu.Parser.Http
- ( isCtl -- Char -> Bool
- , isSeparator -- Char -> Bool
- , isChar -- Char -> Bool
- , isToken -- Char -> Bool
- , listOf -- Parser a -> Parser [a]
- , token -- Parser String
- , lws -- Parser String
- , text -- Parser Char
- , separator -- Parser Char
- , quotedStr -- Parser String
+ ( isCtl
+ , isSeparator
+ , isChar
+ , isToken
+ , listOf
+ , token
+ , lws
+ , text
+ , separator
+ , quotedStr
)
where
import Data.List
import Network.HTTP.Lucu.Parser
+-- |@'isCtl' c@ is True iff @0x20 <= @c@ < 0x7F@.
isCtl :: Char -> Bool
isCtl c
| c < '\x1f' = True
| c >= '\x7f' = True
| otherwise = False
-
+-- |@'isSeparator' c@ is True iff c is one of HTTP separators.
isSeparator :: Char -> Bool
isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t"
-
+-- |@'isChar' c@ is True iff @c <= 0x7f@.
isChar :: Char -> Bool
isChar c
| c <= '\x7f' = True
| otherwise = False
-
+-- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
+-- c)@
isToken :: Char -> Bool
isToken c = not (isCtl c || isSeparator c)
-
+-- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p
+-- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any
+-- occurrences of LWS before and after each tokens.
listOf :: Parser a -> Parser [a]
listOf p = do many lws
sepBy p (do many lws
char ','
many lws)
-
+-- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
+-- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
token :: Parser String
token = many1 $ satisfy isToken
-
+-- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
+-- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
lws :: Parser String
lws = do s <- option "" crlf
xs <- many1 (sp <|> ht)
return (s ++ xs)
-
+-- |'text' accepts one character which doesn't satisfy 'isCtl'.
text :: Parser Char
text = satisfy (\ c -> not (isCtl c))
-
+-- |'separator' accepts one character which satisfies 'isSeparator'.
separator :: Parser Char
separator = satisfy isSeparator
-
+-- |'quotedStr' accepts a string surrounded by double quotation
+-- marks. Quotes can be escaped by backslashes.
quotedStr :: Parser String
quotedStr = do char '"'
xs <- many (qdtext <|> quotedPair)
+-- |This module parses and prints RFC 1123 Date and Time string.
+--
+-- In general you don't have to use this module directly.
module Network.HTTP.Lucu.RFC1123DateTime
( formatRFC1123DateTime
, formatHTTPDateTime
month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
+-- |Format a @CalendarTime@ to RFC 1123 Date and Time string.
formatRFC1123DateTime :: CalendarTime -> String
formatRFC1123DateTime time
= printf "%s, %02d %s %04d %02d:%02d:%02d %s"
(ctSec time)
(ctTZName time)
-
+-- |Format a @ClockTime@ to HTTP Date and Time. Time zone will be
+-- always UTC but prints as GMT.
formatHTTPDateTime :: ClockTime -> String
formatHTTPDateTime = formatRFC1123DateTime . (\cal -> cal { ctTZName = "GMT" }) . toUTCTime
-
+-- |Parse an HTTP Date and Time.
+--
+-- Limitation: RFC 2616 (HTTP\/1.1) says we must accept these three
+-- formats:
+--
+-- * @Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123@
+--
+-- * @Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036@
+--
+-- * @Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format@
+--
+-- ...but currently this function only supports the RFC 1123
+-- format. This is a violation of RFC 2616 so this should be fixed
+-- later. What a bother!
parseHTTPDateTime :: String -> Maybe ClockTime
parseHTTPDateTime src
= case parseStr httpDateTime src of
+-- #prune
+
+-- |Definition of things related on HTTP request.
+--
+-- In general you don't have to use this module directly.
module Network.HTTP.Lucu.Request
( Method(..)
, Request(..)
- , requestP -- Parser Request
+ , requestP
)
where
import Network.HTTP.Lucu.Parser.Http
import Network.URI
+-- |This is the definition of HTTP request methods, which shouldn't
+-- require any description.
data Method = OPTIONS
| GET
| HEAD
| ExtensionMethod String
deriving (Eq, Show)
-
+-- |This is the definition of HTTP reqest.
data Request
= Request {
reqMethod :: Method
+-- #prune
+
+-- |Definition of things related on HTTP response.
module Network.HTTP.Lucu.Response
( StatusCode(..)
, Response(..)
- , hPutResponse -- Handle -> Response -> IO ()
- , isInformational -- StatusCode -> Bool
- , isSuccessful -- StatusCode -> Bool
- , isRedirection -- StatusCode -> Bool
- , isError -- StatusCode -> Bool
- , statusCode -- StatusCode -> (Int, String)
+ , hPutResponse
+ , isInformational
+ , isSuccessful
+ , isRedirection
+ , isError
+ , isClientError
+ , isServerError
+ , statusCode
)
where
import System.IO
import Text.Printf
+-- |This is the definition of HTTP status code.
+-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses
+-- so you don't have to memorize, for instance, that \"Gateway
+-- Timeout\" is 504.
data StatusCode = Continue
| SwitchingProtocols
| Processing
in
hPrintf h "%03d %s" num msg
-
+-- |@'isInformational' sc@ is True iff @sc < 200@.
isInformational :: StatusCode -> Bool
isInformational = doesMeet (< 200)
+-- |@'isSuccessful' sc@ is True iff @200 <= sc < 300@.
isSuccessful :: StatusCode -> Bool
isSuccessful = doesMeet (\ n -> n >= 200 && n < 300)
+-- |@'isRedirection' sc@ is True iff @300 <= sc < 400@.
isRedirection :: StatusCode -> Bool
isRedirection = doesMeet (\ n -> n >= 300 && n < 400)
+-- |@'isError' sc@ is True iff @400 <= sc@
isError :: StatusCode -> Bool
isError = doesMeet (>= 400)
+-- |@'isClientError' sc@ is True iff @400 <= sc < 500@.
+isClientError :: StatusCode -> Bool
+isClientError = doesMeet (\ n -> n >= 400 && n < 500)
+
+-- |@'isServerError' sc@ is True iff @500 <= sc@.
+isServerError :: StatusCode -> Bool
+isServerError = doesMeet (>= 500)
+
+
doesMeet :: (Int -> Bool) -> StatusCode -> Bool
doesMeet p sc = let (num, _) = statusCode sc
in
p num
+-- |@'statusCode' sc@ returns a tuple of numeric and textual
+-- representation of @sc@.
statusCode :: StatusCode -> (Int, String)
statusCode Continue = (100, "Continue")
statusCode SwitchingProtocols = (101, "Switching Protocols")
+-- |Utility functions used internally in the Lucu httpd. These
+-- functions may be useful too for something else.
module Network.HTTP.Lucu.Utils
- ( splitBy -- (a -> Bool) -> [a] -> [[a]]
- , joinWith -- [a] -> [[a]] -> [a]
- , trim -- (a -> Bool) -> [a] -> [a]
- , noCaseEq -- String -> String -> Bool
- , isWhiteSpace -- Char -> Bool
- , quoteStr -- String -> String
+ ( splitBy
+ , joinWith
+ , trim
+ , noCaseEq
+ , isWhiteSpace
+ , quoteStr
)
where
import Foreign.C
import Network.URI
-
+-- |> splitBy (== ':') "ab:c:def"
+-- > ==> ["ab", "c", "def"]
splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy isSeparator src
= case break isSeparator src
of (last , [] ) -> last : []
(first, sep:rest) -> first : splitBy isSeparator rest
-
+-- |> joinWith ':' ["ab", "c", "def"]
+-- > ==> "ab:c:def"
joinWith :: [a] -> [[a]] -> [a]
joinWith separator xs
= foldr (++) [] $ intersperse separator xs
-
+-- |> trim (== '_') "__ab_c__def___"
+-- > ==> "ab_c__def"
trim :: (a -> Bool) -> [a] -> [a]
trim p = trimTail . trimHead
where
trimHead = dropWhile p
trimTail = reverse . trimHead . reverse
-
+-- |@'noCaseEq' a b@ is equivalent to @(map toLower a) == (map toLower
+-- b)@
noCaseEq :: String -> String -> Bool
noCaseEq a b
= (map toLower a) == (map toLower b)
-
+-- |@'isWhiteSpace' c@ is True iff c is one of SP, HT, CR and LF.
isWhiteSpace :: Char -> Bool
isWhiteSpace = flip elem " \t\r\n"
-
+-- |> quoteStr "abc"
+-- > ==> "\"abc\""
+--
+-- > quoteStr "ab\"c"
+-- > ==> "\"ab\\\"c\""
quoteStr :: String -> String
quoteStr str = foldr (++) "" (["\""] ++ map quote str ++ ["\""])
where
#!/usr/bin/env runghc
import Network.HTTP.Lucu.MIMEType.Guess
+import System
-main = do extMap <- parseExtMapFile "/dev/stdin"
- outputExtMapAsHS extMap "/dev/stdout"
+main = do [inFile, outFile] <- getArgs
+ extMap <- parseExtMapFile inFile
+
+ let src = serializeExtMap
+ extMap
+ "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap"
+ "defaultExtensionMap"
+ doc = "-- |This module is automatically generated from data\\/mime.types.\n" ++
+ "-- 'defaultExtensionMap' contains every possible pairs of an extension\n" ++
+ "-- and a MIME Type.\n" ++
+ "\n"
+
+ writeFile outFile $ doc ++ src
projects / Lucu.git / commitdiff