Homepage: http://ccm.sherry.jp/
Category: Incomplete
Build-Depends:
- base, mtl, network, stm, parsec, hxt, haskell-src
+ base, mtl, network, stm, parsec, hxt, haskell-src, unix
Exposed-Modules:
Network.HTTP.Lucu.Abortion
Network.HTTP.Lucu.Chunk
Network.HTTP.Lucu.Httpd
Network.HTTP.Lucu.Interaction
Network.HTTP.Lucu.MIMEType
+ Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
Network.HTTP.Lucu.MIMEType.Guess
Network.HTTP.Lucu.Parser
Network.HTTP.Lucu.Parser.Http
Network.HTTP.Lucu.Resource.Tree
Network.HTTP.Lucu.Response
Network.HTTP.Lucu.ResponseWriter
+ Network.HTTP.Lucu.StaticFile
Network.HTTP.Lucu.Utils
ghc-options: -threaded -fglasgow-exts
module Network.HTTP.Lucu.Abortion
( Abortion(..)
- , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
- , abortSTM -- StatusCode -> [ (String, String) ] -> String -> STM a
- , abortA -- ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
- , aboPage -- Config -> Abortion -> String
+ , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
+ , abortSTM -- StatusCode -> [ (String, String) ] -> Maybe String -> STM a
+ , abortA -- ArrowIO a => StatusCode -> [ (String, String) ] -> Maybe String -> a b c
+ , abortPage -- Config -> Maybe Request -> Maybe Response -> Abortion -> String
)
where
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import System.IO.Unsafe
import Text.XML.HXT.Arrow.WriteDocument
data Abortion = Abortion {
aboStatus :: StatusCode
, aboHeaders :: Headers
- , aboMessage :: String
+ , aboMessage :: Maybe String
} deriving (Show, Typeable)
-abort :: MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
+abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
abort status headers msg
= let abo = Abortion status headers msg
exc = DynException (toDyn abo)
liftIO $ throwIO exc
-abortSTM :: StatusCode -> [ (String, String) ] -> String -> STM a
+abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
abortSTM status headers msg
= unsafeIOToSTM $ abort status headers msg
-abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
+abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> Maybe String -> a b c
abortA status headers msg
= arrIO0 $ abort status headers msg
-aboPage :: Config -> Abortion -> String
-aboPage conf abo
- = let [html] = unsafePerformIO
- $ runX ( mkDefaultPage conf (aboStatus abo) (txt $ aboMessage abo)
+-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
+-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
+-- ければならない。しかもその時は resM から Response を捏造までする必要
+-- がある。
+abortPage :: Config -> Maybe Request -> Maybe Response -> Abortion -> String
+abortPage conf reqM resM abo
+ = let msg = case aboMessage abo of
+ Just msg -> msg
+ Nothing -> let res' = case resM of
+ Just res -> res { resStatus = aboStatus abo }
+ Nothing -> Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = aboStatus abo
+ , resHeaders = []
+ }
+ res = foldl (.) id [setHeader name value
+ | (name, value) <- aboHeaders abo]
+ $ res'
+ in
+ getDefaultPage conf reqM res
+ [html] = unsafePerformIO
+ $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
>>>
writeDocumentToString [(a_indent, v_1)]
)
import Network
import Network.BSD
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
import System.IO.Unsafe
data Config = Config {
- cnfServerSoftware :: String
- , cnfServerHost :: HostName
- , cnfServerPort :: PortID
- , cnfMaxPipelineDepth :: Int
- , cnfMaxEntityLength :: Int
- , cnfMaxURILength :: Int
- , cnfExtToMIMEType :: Map String MIMEType
+ cnfServerSoftware :: String
+ , cnfServerHost :: HostName
+ , cnfServerPort :: PortID
+ , cnfMaxPipelineDepth :: Int
+ , cnfMaxEntityLength :: Int
+ , cnfMaxURILength :: Int
+ , cnfMaxOutputChunkLength :: Int
+ , cnfExtToMIMEType :: Map String MIMEType
}
defaultConfig = Config {
- cnfServerSoftware = "Lucu/1.0"
- , cnfServerHost = unsafePerformIO getHostName
- , cnfServerPort = Service "http"
- , cnfMaxPipelineDepth = 100
- , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
- , cnfMaxURILength = 4 * 1024 -- 4 KiB
- , cnfExtToMIMEType = undefined -- FIXME
+ cnfServerSoftware = "Lucu/1.0"
+ , cnfServerHost = unsafePerformIO getHostName
+ , cnfServerPort = Service "http"
+ , cnfMaxPipelineDepth = 100
+ , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
+ , cnfMaxURILength = 4 * 1024 -- 4 KiB
+ , cnfMaxOutputChunkLength = 5 * 1024 * 1024 -- 5 MiB
+ , cnfExtToMIMEType = defaultExtensionMap
}
module Network.HTTP.Lucu.MIMEType.Guess
- ( parseExtMapFile -- FilePath -> IO (Map String MIMEType)
- , outputExtMapAsHS -- Map String MIMEType -> FilePath -> IO ()
+ ( ExtMap
+ , guessTypeByFileName -- ExtMap -> FilePath -> Maybe MIMEType
+
+ , parseExtMapFile -- FilePath -> IO ExtMap
+ , outputExtMapAsHS -- ExtMap -> FilePath -> IO ()
)
where
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
import System.IO
-import Debug.Trace
+type ExtMap = Map String MIMEType
+
+
+guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
+guessTypeByFileName extMap fpath
+ = let ext = head $ reverse $ splitBy (== '.') fpath
+ in
+ M.lookup ext extMap >>= return
+
-parseExtMapFile :: FilePath -> IO (Map String MIMEType)
+parseExtMapFile :: FilePath -> IO ExtMap
parseExtMapFile fpath
= do file <- B.readFile fpath
case parse (allowEOF extMapP) file of
tr (mime, exts) = [ (ext, mime) | ext <- exts ]
-outputExtMapAsHS :: Map String MIMEType -> FilePath -> IO ()
+outputExtMapAsHS :: ExtMap -> FilePath -> IO ()
outputExtMapAsHS extMap fpath
= let hsModule = HsModule undefined modName (Just exports) imports decls
modName = Module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap"
when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
$ abortSTM InternalServerError []
- ("The status code is not good for a final status: "
- ++ show sc)
+ $ Just ("The status code is not good for a final status: "
+ ++ show sc)
when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
$ abortSTM InternalServerError []
- ("The status was " ++ show sc ++ " but no Allow header.")
+ $ Just ("The status was " ++ show sc ++ " but no Allow header.")
when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
$ abortSTM InternalServerError []
- ("The status code was " ++ show sc ++ " but no Location header.")
+ $ Just ("The status code was " ++ show sc ++ " but no Location header.")
when (itrRequest itr /= Nothing)
$ relyOnRequest itr
in
when (teList == [] || last teList /= "chunked")
$ abortSTM InternalServerError []
- ("Transfer-Encoding must end with `chunked' "
- ++ "because this is an HTTP/1.1 request: "
- ++ te)
+ $ Just ("Transfer-Encoding must end with `chunked' "
+ ++ "because this is an HTTP/1.1 request: "
+ ++ te)
writeItr itr itrWillChunkBody True
else
Nothing -> return ()
Just "identity" -> return ()
Just te -> abortSTM InternalServerError []
- ("Transfer-Encoding must be `identity' because "
+ $ Just ("Transfer-Encoding must be `identity' because "
++ "this is an HTTP/1.0 request: "
++ te)
module Network.HTTP.Lucu.Resource
( Resource
+ , getConfig -- Resource Config
, getMethod -- Resource Method
, getHeader -- String -> Resource (Maybe String)
, getAccept -- Resource [MIMEType]
type Resource a = ReaderT Interaction IO a
+getConfig :: Resource Config
+getConfig = do itr <- ask
+ return $ itrConfig itr
+
+
getMethod :: Resource Method
getMethod = do itr <- ask
return $ reqMethod $ fromJust $ itrRequest itr
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
-> when (not $ any (== tag) tags)
- $ abort PreconditionFailed [] ("The entity tag doesn't match: " ++ list)
- _ -> abort BadRequest [] ("Unparsable If-Match: " ++ fromJust ifMatch)
+ $ abort PreconditionFailed []
+ $ Just ("The entity tag doesn't match: " ++ list)
+ _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
let statusForNoneMatch = if method == GET || method == HEAD then
NotModified
ifNoneMatch <- getHeader "If-None-Match"
case ifNoneMatch of
Nothing -> return ()
- Just "*" -> abort statusForNoneMatch [] ("The entity tag matches: *")
+ Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
Just list -> case parseStr eTagListP list of
(Success tags, _)
-> when (any (== tag) tags)
- $ abort statusForNoneMatch [] ("The entity tag matches: " ++ list)
- _ -> abort BadRequest [] ("Unparsable If-None-Match: " ++ list)
+ $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
+ _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
driftTo GettingBody
Just str -> case parseHTTPDateTime str of
Just lastTime
-> when (timeStamp <= lastTime)
- $ abort statusForIfModSince [] ("The entity has not been modified since " ++ str)
+ $ abort statusForIfModSince []
+ $ Just ("The entity has not been modified since " ++ str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
Just str -> case parseHTTPDateTime str of
Just lastTime
-> when (timeStamp > lastTime)
- $ abort PreconditionFailed [] ("The entity has not been modified since " ++ str)
+ $ abort PreconditionFailed []
+ $ Just ("The entity has not been modified since " ++ str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
foundNoEntity msgM
= do driftTo ExaminingRequest
- let msg = fromMaybe "The requested entity was not found in this server." msgM
-
method <- getMethod
when (method /= PUT)
- $ abort NotFound [] msg
+ $ abort NotFound [] msgM
-- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
-- If-Match: 條件も滿たさない。
ifMatch <- getHeader "If-Match"
when (ifMatch /= Nothing)
- $ abort PreconditionFailed [] msg
+ $ abort PreconditionFailed [] msgM
driftTo GettingBody
tooLarge :: Int -> STM ()
tooLarge lim = abortSTM RequestEntityTooLarge []
- ("Request body must be smaller than "
- ++ show lim ++ " bytes.")
+ $ Just ("Request body must be smaller than "
+ ++ show lim ++ " bytes.")
inputChunk :: Int -> Resource String
redirect code uri
= do when (code == NotModified || not (isRedirection code))
$ abort InternalServerError []
- $ "Attempted to redirect with status " ++ show code
+ $ Just ("Attempted to redirect with status " ++ show code)
setStatus code
setHeader "Location" (uriToString id uri $ "")
outputChunk = outputChunkBS . B.pack
+{- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
+ B.readFile して作った ByteString をそのまま ResponseWriter に渡した
+ りすると大變な事が起こる。何故なら ResponseWriter は
+ Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
+ 測るから、その時に起こるであらう事は言ふまでも無い。 -}
+
outputChunkBS :: ByteString -> Resource ()
-outputChunkBS str = do driftTo DecidingBody
- itr <- ask
- liftIO $ atomically $
- do updateItr itr itrBodyToSend (flip B.append str)
- unless (B.null str)
- $ writeItr itr itrBodyIsNull False
+outputChunkBS str
+ = do driftTo DecidingBody
+ unless (B.null str)
+ $ do itr <- ask
+ let limit = cnfMaxOutputChunkLength $ itrConfig itr
+ when (limit <= 0)
+ $ fail ("cnfMaxOutputChunkLength must be positive: "
+ ++ show limit)
+
+ sendChunks str limit
+
+ liftIO $ atomically $
+ writeItr itr itrBodyIsNull False
+ where
+ sendChunks :: ByteString -> Int -> Resource ()
+ sendChunks str limit
+ | B.null str = return ()
+ | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
+ itr <- ask
+ liftIO $ atomically $
+ do buf <- readItr itr itrBodyToSend id
+ if B.null buf then
+ -- バッファが消化された
+ writeItr itr itrBodyToSend chunk
+ else
+ -- 消化されるのを待つ
+ retry
+ -- 殘りのチャンクについて繰り返す
+ sendChunks remaining limit
{-
driftTo Done
) itr
)
- $ \ exc -> processException (itrConfig itr) exc
+ $ \ exc -> processException exc
where
fork :: IO () -> IO ThreadId
fork = if (resUsesNativeThread def)
Just _ -> xs
Nothing -> []
- processException :: Config -> Exception -> IO ()
- processException conf exc
+ processException :: Exception -> IO ()
+ processException exc
= do let abo = case exc of
- ErrorCall msg -> Abortion InternalServerError [] msg
- IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE
+ ErrorCall msg -> Abortion InternalServerError [] $ Just msg
+ IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE
DynException dynE -> case fromDynamic dynE of
Just (abo :: Abortion) -> abo
Nothing
-> Abortion InternalServerError []
- $ show exc
- _ -> Abortion InternalServerError [] $ show exc
+ $ Just $ show exc
+ _ -> Abortion InternalServerError [] $ Just $ show exc
+ conf = itrConfig itr
+ reqM = itrRequest itr
-- まだ DecidingHeader 以前の状態だったら、この途中終了
-- を應答に反映させる餘地がある。さうでなければ stderr
-- にでも吐くしか無い。
state <- atomically $ readItr itr itrState id
+ resM <- atomically $ readItr itr itrResponse id
if state <= DecidingHeader then
flip runReaderT itr
$ do setStatus $ aboStatus abo
-- れではまずいと思ふ。
mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
setHeader "Content-Type" "application/xhtml+xml"
- output $ aboPage conf abo
+ output $ abortPage conf reqM resM abo
else
hPutStrLn stderr $ show abo
import Control.Concurrent
import Debug.Trace
+import GHC.Conc (unsafeIOToSTM)
responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
module Network.HTTP.Lucu.StaticFile
- (
+ ( staticFile -- FilePath -> ResourceDef
+ , handleStaticFile -- FilePath -> Resource ()
)
where
+import Control.Monad
+import Control.Monad.Trans
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.ETag
+import Network.HTTP.Lucu.MIMEType.Guess
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Response
+import System.Directory
+import System.Posix.Files
+import Text.Printf
+
staticFile :: FilePath -> ResourceDef
staticFile path
= ResourceDef {
resUsesNativeThread = False
, resIsGreedy = False
- , resGet
- = Just $ do
\ No newline at end of file
+ , resGet = Just $ handleStaticFile path
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+
+
+handleStaticFile :: FilePath -> Resource ()
+handleStaticFile path
+ = do exist <- liftIO $ fileExist path
+ if exist then
+ -- 存在はした。讀めるかどうかは知らない。
+ do readable <- liftIO $ fileAccess path True False False
+ unless readable
+ -- 讀めない
+ $ abort Forbidden [] Nothing
+
+ -- 讀める
+ tag <- liftIO $ generateETagFromFile path
+ lastMod <- liftIO $ getModificationTime path
+ foundEntity tag lastMod
+
+ -- MIME Type を推定
+ conf <- getConfig
+ case guessTypeByFileName (cnfExtToMIMEType conf) path of
+ Nothing -> return ()
+ Just mime -> setContentType mime
+
+ -- 實際にファイルを讀んで送る
+ (liftIO $ B.readFile path) >>= outputBS
+ else
+ foundNoEntity Nothing
+
+
+-- inode-size-lastmod
+generateETagFromFile :: FilePath -> IO ETag
+generateETagFromFile path
+ = do stat <- getFileStatus path
+ let inode = fromEnum $ fileID stat
+ size = fromEnum $ fileSize stat
+ lastmod = fromEnum $ modificationTime stat
+ return $ strongETag $ printf "%x-%x-%x" inode size lastmod
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.StaticFile
import Network.URI
import System.Posix.Signals
import System.Time
main :: IO ()
main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }
- resources = mkResTree [ ([], helloWorld) ]
+ resources = mkResTree [ ( []
+ , helloWorld )
+ , ( ["compilers"]
+ , staticFile "/etc/compilers" )
+ ]
in
do installHandler sigPIPE Ignore Nothing
runHttpd config resources
projects / Lucu.git / commitdiff