import Network.HTTP.Lucu.Response
data Interaction = Interaction {
- itrConfig :: Config
- , itrRemoteHost :: HostName
- , itrRequest :: Maybe Request
- , itrResponse :: TVar (Maybe Response)
-
+ itrConfig :: Config
+ , itrRemoteHost :: HostName
+ , itrResourcePath :: Maybe [String]
+ , itrRequest :: Maybe Request
+ , itrResponse :: TVar (Maybe Response)
+
+ -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
+ -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
+ -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
+ -- からにすべき。
, itrRequestHasBody :: TVar Bool
, itrRequestIsChunked :: TVar Bool
, itrExpectedContinue :: TVar Bool
wroteHeader <- newTVarIO False
return $ Interaction {
- itrConfig = conf
- , itrRemoteHost = host
- , itrRequest = req
- , itrResponse = responce
+ itrConfig = conf
+ , itrRemoteHost = host
+ , itrResourcePath = Nothing
+ , itrRequest = req
+ , itrResponse = responce
, itrRequestHasBody = requestHasBody
, itrRequestIsChunked = requestIsChunked
guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
guessTypeByFileName extMap fpath
- = let ext = head $ reverse $ splitBy (== '.') fpath
+ = let ext = last $ splitBy (== '.') fpath
in
M.lookup ext extMap >>= return
updateRes itr $ deleteHeader "Content-Length"
+ cType <- readHeader itr "Content-Type"
+ when (cType == Nothing)
+ $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
+
if canHaveBody then
do teM <- readHeader itr "Transfer-Encoding"
if reqVer == HttpVersion 1 1 then
$ Just ("Transfer-Encoding must be `identity' because "
++ "this is an HTTP/1.0 request: "
++ te)
-
- cType <- readHeader itr "Content-Type"
- when (cType == Nothing)
- $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
else
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
do updateRes itr $ deleteHeader "Transfer-Encoding"
Nothing -- Resource が無かった
-> acceptRequestForNonexistentResource itr input
- Just rsrcDef -- あった
- -> acceptRequestForExistentResource itr input rsrcDef
+ Just (rsrcPath, rsrcDef) -- あった
+ -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
action
acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
enqueue itr
return $ acceptRequest input
- acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
- acceptRequestForExistentResource itr input rsrcDef
- = do requestHasBody <- readItr itr itrRequestHasBody id
+ acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
+ acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
+ = do let itr = oldItr { itrResourcePath = Just rsrcPath }
+ requestHasBody <- readItr itr itrRequestHasBody id
enqueue itr
return $ do runResource rsrcDef itr
if requestHasBody then
module Network.HTTP.Lucu.Resource
( Resource
- , getConfig -- Resource Config
- , getMethod -- Resource Method
- , getHeader -- String -> Resource (Maybe String)
- , getAccept -- Resource [MIMEType]
+ , getConfig -- Resource Config
+ , getRequest -- Resource Request
+ , getMethod -- Resource Method
+ , getRequestURI -- Resource URI
+ , getResourcePath -- Resource [String]
+ , getPathInfo -- Resource [String]
+
+ , getHeader -- String -> Resource (Maybe String)
+ , getAccept -- Resource [MIMEType]
, getContentType -- Resource (Maybe MIMEType)
, foundEntity -- ETag -> ClockTime -> Resource ()
return $ itrConfig itr
+getRequest :: Resource Request
+getRequest = do itr <- ask
+ return $ fromJust $ itrRequest itr
+
+
getMethod :: Resource Method
-getMethod = do itr <- ask
- return $ reqMethod $ fromJust $ itrRequest itr
+getMethod = do req <- getRequest
+ return $ reqMethod req
+
+
+getRequestURI :: Resource URI
+getRequestURI = do req <- getRequest
+ return $ reqURI req
+
+
+getResourcePath :: Resource [String]
+getResourcePath = do itr <- ask
+ return $ fromJust $ itrResourcePath itr
+
+
+getPathInfo :: Resource [String]
+getPathInfo = do rsrcPath <- getResourcePath
+ reqURI <- getRequestURI
+ let reqPathStr = uriPath reqURI
+ reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
+ -- rsrcPath と reqPath の共通する先頭部分を reqPath か
+ -- ら全部取り除くと、それは PATH_INFO のやうなものにな
+ -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
+ -- ければこの Resource が撰ばれた筈が無い）ので、
+ -- rsrcPath の長さの分だけ削除すれば良い。
+ return $ drop (length rsrcPath) reqPath
getHeader :: String -> Resource (Maybe String)
outputChunkBS :: ByteString -> Resource ()
outputChunkBS str
= do driftTo DecidingBody
- unless (B.null str)
- $ do itr <- ask
+ itr <- ask
+
+ let limit = cnfMaxOutputChunkLength $ itrConfig itr
+ when (limit <= 0)
+ $ fail ("cnfMaxOutputChunkLength must be positive: "
+ ++ show limit)
- let limit = cnfMaxOutputChunkLength $ itrConfig itr
- when (limit <= 0)
- $ fail ("cnfMaxOutputChunkLength must be positive: "
- ++ show limit)
+ discardBody <- liftIO $ atomically $
+ readItr itr itrWillDiscardBody id
- sendChunks str limit
+ unless (discardBody)
+ $ sendChunks str limit
- liftIO $ atomically $
- writeItr itr itrBodyIsNull False
+ unless (B.null str)
+ $ liftIO $ atomically $
+ writeItr itr itrBodyIsNull False
where
sendChunks :: ByteString -> Int -> Resource ()
sendChunks str limit
, ResTree
, mkResTree -- [ ([String], ResourceDef) ] -> ResTree
- , findResource -- ResTree -> URI -> Maybe ResourceDef
+ , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
, runResource -- ResourceDef -> Interaction -> IO ThreadId
)
where
import Data.Maybe
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Response
subtree
-findResource :: ResTree -> URI -> Maybe ResourceDef
+findResource :: ResTree -> URI -> Maybe ([String], ResourceDef)
findResource (ResNode rootDefM subtree) uri
= let pathStr = uriPath uri
path = [x | x <- splitBy (== '/') pathStr, x /= ""]
in
if null path then
- rootDefM
+ do def <- rootDefM
+ return (path, def)
else
- walkTree subtree path
+ walkTree subtree path []
where
- walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
+ walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
- walkTree subtree (name:[])
+ walkTree subtree (name:[]) soFar
= case M.lookup name subtree of
Nothing -> Nothing
- Just (ResNode defM _) -> defM
+ Just (ResNode defM _) -> do def <- defM
+ return (soFar ++ [name], def)
- walkTree subtree (x:xs)
+ walkTree subtree (x:xs) soFar
= case M.lookup x subtree of
Nothing -> Nothing
Just (ResNode defM children) -> case defM of
Just (ResourceDef { resIsGreedy = True })
- -> defM
- _ -> walkTree children xs
+ -> do def <- defM
+ return (soFar ++ [x], def)
+ _ -> walkTree children xs (soFar ++ [x])
runResource :: ResourceDef -> Interaction -> IO ThreadId
-- FIXME: 同じ名前で複數の値があった時は、こ
-- れではまずいと思ふ。
mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
- setHeader "Content-Type" "application/xhtml+xml"
+ setContentType ("application" +/+ "xhtml+xml")
output $ abortPage conf reqM resM abo
else
hPutStrLn stderr $ show abo
module Network.HTTP.Lucu.StaticFile
( staticFile -- FilePath -> ResourceDef
, handleStaticFile -- FilePath -> Resource ()
+
+ , staticDir -- FilePath -> ResourceDef
+ , handleStaticDir -- FilePath -> Resource ()
)
where
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
import System.Directory
import System.Posix.Files
import Text.Printf
handleStaticFile :: FilePath -> Resource ()
handleStaticFile path
- = do exist <- liftIO $ fileExist path
- if exist then
+ = do isFile <- liftIO $ doesFileExist path
+ if isFile then
-- 存在はした。讀めるかどうかは知らない。
do readable <- liftIO $ fileAccess path True False False
unless readable
-- 實際にファイルを讀んで送る
(liftIO $ B.readFile path) >>= outputBS
else
- foundNoEntity Nothing
+ do isDir <- liftIO $ doesDirectoryExist path
+ if isDir then
+ abort Forbidden [] Nothing
+ else
+ foundNoEntity Nothing
-- inode-size-lastmod
size = fromEnum $ fileSize stat
lastmod = fromEnum $ modificationTime stat
return $ strongETag $ printf "%x-%x-%x" inode size lastmod
+
+
+staticDir :: FilePath -> ResourceDef
+staticDir path
+ = ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = True
+ , resGet = Just $ handleStaticDir path
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+
+
+handleStaticDir :: FilePath -> Resource ()
+handleStaticDir basePath
+ = do extraPath <- getPathInfo
+ let path = basePath ++ "/" ++ joinWith "/" extraPath
+
+ handleStaticFile path
import Data.List
import Foreign
import Foreign.C
+import Network.URI
splitBy :: (a -> Bool) -> [a] -> [[a]]
main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }
resources = mkResTree [ ( []
, helloWorld )
- , ( ["compilers"]
- , staticFile "/etc/compilers" )
+
+ , ( ["index.html"]
+ , staticFile "/Users/admin/Sites/index.html" )
+
+ , ( ["urandom"]
+ , staticFile "/dev/urandom" )
+
+ , ( ["inc"]
+ , staticDir "/usr/include" )
]
in
do installHandler sigPIPE Ignore Nothing
projects / Lucu.git / commitdiff