Homepage: http://ccm.sherry.jp/
Category: Incomplete
Build-Depends:
- base, mtl, network, stm, parsec
+ base, mtl, network, stm, parsec, hxt
Exposed-Modules:
Network.HTTP.Lucu.Config
Network.HTTP.Lucu.Headers
--- /dev/null
+CABAL_FILE = Lucu.cabal
+GHC = ghc
+WHAT_TO_RUN = ./dist/build/HelloWorld/HelloWorld
+
+run: build
+ @echo ".:.:. Let's go .:.:."
+ $(WHAT_TO_RUN)
+
+build: .setup-config Setup
+ ./Setup build
+
+.setup-config: $(CABAL_FILE) Setup
+ ./Setup configure
+
+Setup: Setup.hs
+ $(GHC) --make Setup
+
+clean:
+ rm -rf dist Setup Setup.o Setup.hi .setup-config
+ find . -name '*~' -exec rm -f {} \;
+
+.PHONY: run build clean
\ No newline at end of file
--- /dev/null
+module Network.HTTP.Lucu.DefaultPage
+ ( getDefaultPage -- Maybe Request -> Response -> String
+ , writeDefaultPage -- Interaction -> STM ()
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Concurrent.STM
+import Control.Monad
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Maybe
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import System.IO.Unsafe
+import Text.Printf
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+getDefaultPage :: Maybe Request -> Response -> String
+getDefaultPage req res
+ = let msgA = getMsg req res
+ in
+ unsafePerformIO $
+ do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA
+ >>>
+ writeDocumentToString [ (a_indent, v_1) ]
+ )
+ return xmlStr
+
+
+writeDefaultPage :: Interaction -> STM ()
+writeDefaultPage itr
+ = do wroteHeader <- readTVar (itrWroteHeader itr)
+
+ -- ヘッダが出力濟だったら意味が無い。
+ when wroteHeader
+ $ fail "writeDefaultPage: the header has already been written"
+
+ resM <- readTVar (itrResponse itr)
+
+ -- Response が不明ならばページ書込も不可
+ when (resM == Nothing)
+ $ fail "writeDefaultPage: response was Nothing"
+
+ let reqM = itrRequest itr
+ res = fromJust resM
+ page = B.pack $ getDefaultPage reqM res
+
+ writeTVar (itrResponse itr)
+ $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
+
+ writeTVar (itrBodyToSend itr)
+ $ page
+
+
+mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree
+mkDefaultPage status msgA
+ = let (sCode, sMsg) = statusCode status
+ in ( eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title"
+ += txt (printf "%03d %s" sCode sMsg)
+ ))
+ += ( eelem "body"
+ += ( eelem "h1"
+ += txt sMsg
+ )
+ += ( msgA
+ >>>
+ eelem "p" += ( this
+ >>>
+ mkText
+ )))))
+
+
+getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String
+getMsg req res
+ = constA "FIXME: NOT IMPL"
getHeaders :: a -> Headers
setHeaders :: a -> Headers -> a
- getHeader :: a -> String -> Maybe String
- getHeader a key
+ getHeader :: String -> a -> Maybe String
+ getHeader key a
= fmap snd $ find (noCaseEq key . fst) (getHeaders a)
- deleteHeader :: a -> String -> a
- deleteHeader a key
+ deleteHeader :: String -> a -> a
+ deleteHeader key a
= setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
- addHeader :: a -> String -> String -> a
- addHeader a key val
+ addHeader :: String -> String -> a -> a
+ addHeader key val a
= setHeaders a $ (getHeaders a) ++ [(key, val)]
- setHeader :: a -> String -> String -> a
- setHeader a key val
+ setHeader :: String -> String -> a -> a
+ setHeader key val a
= let list = getHeaders a
deleted = filter (not . noCaseEq key . fst) list
added = deleted ++ [(key, val)]
, InteractionQueue
, newInteractionQueue -- IO InteractionQueue
, newInteraction -- HostName -> Maybe Request -> IO Interaction
+
+ , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
+ , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
+ , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
+ , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
+ , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
)
where
, itrWroteContinue = wroteContinue
, itrWroteHeader = wroteHeader
}
+
+
+writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
+writeItr itr accessor value
+ = writeTVar (accessor itr) value
+
+
+readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
+readItr itr accessor reader
+ = readTVar (accessor itr) >>= return . reader
+
+
+readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
+readItrF itr accessor reader
+ = readItr itr accessor (fmap reader)
+
+
+updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
+updateItr itr accessor updator
+ = do old <- readItr itr accessor id
+ writeItr itr accessor (updator old)
+
+
+updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
+updateItrF itr accessor updator
+ = updateItr itr accessor (fmap updator)
postprocess :: Interaction -> STM ()
postprocess itr
- = do res <- readTVar (itrResponse itr)
+ = do res <- readItr itr itrResponse id
when (res == Nothing)
$ setStatus itr InternalServerError
when (itrRequest itr /= Nothing)
$ relyOnRequest itr
- do oldRes <- readTVar (itrResponse itr)
+ do oldRes <- readItr itr itrResponse id
newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes
- setRes itr newRes
+ writeItr itr itrResponse $ Just newRes
where
relyOnRequest itr
- = do resM <- readTVar (itrResponse itr)
+ = do status <- readItr itr itrResponse (resStatus . fromJust)
let req = fromJust $ itrRequest itr
reqVer = reqVersion req
- res = fromJust resM
- status = resStatus res
canHaveBody = if reqMethod req == HEAD then
False
else
- isInformational status ||
- status == NoContent ||
- status == ResetContent ||
- status == NotModified
+ not (isInformational status ||
+ status == NoContent ||
+ status == ResetContent ||
+ status == NotModified )
- setRes itr (deleteHeader res "Content-Length")
+ updateRes itr $ deleteHeader "Content-Length"
if canHaveBody then
- do if reqVer == HttpVersion 1 1 then
-
- case getHeader res "Transfer-Encoding" of
- Nothing -> setRes itr (setHeader res "Transfer-Encoding" "chunked")
- Just te -> let teList = [trim isWhiteSpace x
- | x <- splitBy (== ',') (map toLower te)]
- in
- when (teList == [] || last teList /= "chunked")
- $ setStatus itr InternalServerError
+ do teM <- readHeader itr "Transfer-Encoding"
+ if reqVer == HttpVersion 1 1 then
+
+ do case teM of
+ Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked"
+ Just te -> let teList = [trim isWhiteSpace x
+ | x <- splitBy (== ',') (map toLower te)]
+ in
+ when (teList == [] || last teList /= "chunked")
+ $ setStatus itr InternalServerError
+
+ writeItr itr itrWillChunkBody True
else
- case getHeader res "Transfer-Encoding" of
+ case fmap (map toLower) teM of
Nothing -> return ()
Just "identity" -> return ()
_ -> setStatus itr InternalServerError
-
- when (getHeader res "Content-Type" == Nothing)
- $ setRes itr (setHeader res "Content-Type" "application/octet-stream")
+
+ cType <- readHeader itr "Content-Type"
+ when (cType == Nothing)
+ $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
else
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
- do setRes itr (deleteHeader res "Transfer-Encoding")
+ do updateRes itr $ deleteHeader "Transfer-Encoding"
when (reqMethod req /= HEAD)
- $ setRes itr (deleteHeader res "Content-Type")
+ $ updateRes itr $ deleteHeader "Content-Type"
- if fmap (map toLower) (getHeader res "Connection") == Just "close" then
- writeTVar (itrWillClose itr) True
- else
- setRes itr (setHeader res "Connection" "close")
+ conn <- readHeader itr "Connection"
+ case fmap (map toLower) conn of
+ Just "close" -> writeItr itr itrWillClose True
+ _ -> updateRes itr $ setHeader "Connection" "close"
when (reqMethod req == HEAD || not canHaveBody)
$ writeTVar (itrWillDiscardBody itr) True
+ setStatus :: Interaction -> StatusCode -> STM ()
setStatus itr status
= writeTVar (itrResponse itr) (Just $ Response {
resVersion = HttpVersion 1 1
, resHeaders = []
})
- setRes itr res
- = writeTVar (itrResponse itr) (Just res)
+ readHeader :: Interaction -> String -> STM (Maybe String)
+ readHeader itr name
+ = do valueMM <- readItrF itr itrResponse $ getHeader name
+ case valueMM of
+ Just (Just val) -> return $ Just val
+ _ -> return Nothing
+
+ updateRes :: Interaction -> (Response -> Response) -> STM ()
+ updateRes itr updator
+ = updateItrF itr itrResponse updator
completeUnconditionalHeaders :: Response -> IO Response
= return res >>= compServer >>= compDate >>= return
where
compServer res
- = case getHeader res "Server" of
- Nothing -> return $ addHeader res "Server" "Lucu/1.0"
+ = case getHeader "Server" res of
+ Nothing -> return $ addHeader "Server" "Lucu/1.0" res
Just _ -> return res
compDate res
- = case getHeader res "Date" of
+ = case getHeader "Date" res of
Nothing -> do time <- getClockTime
- return $ addHeader res "Date" $ formatHTTPDateTime time
+ return $ addHeader "Date" (formatHTTPDateTime time) res
Just _ -> return res
\ No newline at end of file
reqVer /= HttpVersion 1 1 then
do setStatus itr HttpVersionNotSupported
- writeTVar (itrWillClose itr) True
+ writeItr itr itrWillClose True
else
do if reqVer == HttpVersion 1 0 then
-- HTTP/1.0 では Keep-Alive できない
- writeTVar (itrWillClose itr) True
+ writeItr itr itrWillClose True
else
-- URI または Host: ヘッダのどちらかにホストが無ければ
-- ならない。
when (uriAuthority (reqURI req) == Nothing &&
- getHeader req "Host" == Nothing)
+ getHeader "Host" req == Nothing)
$ setStatus itr BadRequest
case reqMethod req of
GET -> return ()
- HEAD -> writeTVar (itrWillDiscardBody itr) True
+ HEAD -> writeItr itr itrWillDiscardBody True
POST -> ensureHavingBody itr
PUT -> ensureHavingBody itr
_ -> setStatus itr NotImplemented
ensureHavingBody itr
= let req = fromJust $ itrRequest itr
in
- if getHeader req "Content-Length" == Nothing &&
- getHeader req "Transfer-Encoding" == Nothing then
+ if getHeader "Content-Length" req == Nothing &&
+ getHeader "Transfer-Encoding" req == Nothing then
setStatus itr LengthRequired
else
- writeTVar (itrRequestHasBody itr) True
+ writeItr itr itrRequestHasBody True
setStatus itr status
- = writeTVar (itrResponse itr) (Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = status
- , resHeaders = []
- })
+ = writeItr itr itrResponse $ Just (Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = status
+ , resHeaders = []
+ })
preprocessHeader itr (name, value)
= case map toLower name of
"expect"
-> if value `noCaseEq` "100-continue" then
- writeTVar (itrExpectedContinue itr) True
+ writeItr itr itrExpectedContinue True
else
setStatus itr ExpectationFailed
"transfer-encoding"
-> case map toLower value of
"identity" -> return ()
- "chunked" -> writeTVar (itrRequestIsChunked itr) True
+ "chunked" -> writeItr itr itrRequestIsChunked True
_ -> setStatus itr NotImplemented
"content-length"
-> if all isDigit value then
- writeTVar (itrRequestBodyLength itr) (Just $ read value)
+ writeItr itr itrRequestBodyLength $ Just $ read value
else
setStatus itr BadRequest
"connection"
-> case map toLower value of
- "close" -> writeTVar (itrWillClose itr) True
+ "close" -> writeItr itr itrWillClose True
_ -> return ()
_ -> return ()
\ No newline at end of file
import Data.Sequence (Seq, (<|), ViewR(..))
import Network
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Parser
, resStatus = BadRequest
, resHeaders = []
}
- atomically $ do writeTVar (itrResponse itr) $ Just res
- writeTVar (itrWillClose itr) True
- writeTVar (itrState itr) Done
+ atomically $ do writeItr itr itrResponse $ Just res
+ writeItr itr itrWillClose True
+ writeItr itr itrState Done
+ writeDefaultPage itr
postprocess itr
enqueue itr
action
<- atomically $
do preprocess itr
- res <- readTVar (itrResponse itr)
- if fmap isError (fmap resStatus res) == Just True then
+ isErr <- readItrF itr itrResponse (isError . resStatus)
+ if isErr == Just True then
acceptSemanticallyInvalidRequest itr input'
else
case findResource tree $ (reqURI . fromJust . itrRequest) itr of
acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
acceptSemanticallyInvalidRequest itr input
- = do writeTVar (itrState itr) Done
+ = do writeItr itr itrState Done
+ writeDefaultPage itr
postprocess itr
enqueue itr
return $ acceptRequest input
, resStatus = NotFound
, resHeaders = []
}
- writeTVar (itrResponse itr) $ Just res
- writeTVar (itrState itr) Done
+ writeItr itr itrResponse $ Just res
+ writeItr itr itrState Done
+ writeDefaultPage itr
postprocess itr
enqueue itr
return $ acceptRequest input
acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
acceptRequestForExistentResource itr input rsrcDef
- = do requestHasBody <- readTVar (itrRequestHasBody itr)
- writeTVar (itrState itr) (if requestHasBody
- then ExaminingHeader
- else DecidingHeader)
+ = do requestHasBody <- readItr itr itrRequestHasBody id
+ writeItr itr itrState (if requestHasBody
+ then ExaminingHeader
+ else DecidingHeader)
enqueue itr
return $ do runResource rsrcDef itr
if requestHasBody then
, hPutResponse -- Handle -> Response -> IO ()
, isInformational -- StatusCode -> Bool
, isError -- StatusCode -> Bool
+ , statusCode -- StatusCode -> (Int, String)
)
where
responseWriter :: Handle -> InteractionQueue -> IO ()
responseWriter h tQueue
- = catch awaitSomethingToWrite $ \ exc
- -> case exc of
- IOException _ -> return ()
- _ -> print exc
+ = awaitSomethingToWrite
where
awaitSomethingToWrite :: IO ()
awaitSomethingToWrite
-- GettingBody 状態にあり、Continue が期待され
-- てゐて、それがまだ送信前なのであれば、
-- Continue を送信する。
- state <- readTVar (itrState itr)
+ state <- readItr itr itrState id
if state == GettingBody then
writeContinueIfNecessary itr
writeContinueIfNecessary :: Interaction -> STM (IO ())
writeContinueIfNecessary itr
- = do expectedContinue <- readTVar (itrExpectedContinue itr)
+ = do expectedContinue <- readItr itr itrExpectedContinue id
if expectedContinue then
- do wroteContinue <- readTVar $ itrWroteContinue itr
+ do wroteContinue <- readItr itr itrWroteContinue id
if wroteContinue then
-- 既に Continue を書込み濟
retry
-- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
-- 空でなければ、それを出力する。空である時は、もし状態が
-- Done であれば後処理をする。
- = do wroteHeader <- readTVar (itrWroteHeader itr)
+ = do wroteHeader <- readItr itr itrWroteHeader id
if not wroteHeader then
return $ writeHeader itr
else
- do bodyToSend <- readTVar (itrBodyToSend itr)
+ do bodyToSend <- readItr itr itrBodyToSend id
if B.null bodyToSend then
- do state <- readTVar (itrState itr)
+ do state <- readItr itr itrState id
if state == Done then
return $ finalize itr
writeHeader :: Interaction -> IO ()
writeHeader itr
- = do res <- atomically $ do writeTVar (itrWroteHeader itr) True
- readTVar (itrResponse itr)
+ = do res <- atomically $ do writeItr itr itrWroteHeader True
+ readItr itr itrResponse id
hPutResponse h (fromJust res)
hFlush h
awaitSomethingToWrite
writeBodyChunk :: Interaction -> IO ()
- writeBodyChunk itr = fail "FIXME: not implemented"
+ writeBodyChunk itr
+ = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
+ willChunkBody <- atomically $ readItr itr itrWillChunkBody id
+ chunk <- atomically $ do chunk <- readItr itr itrBodyToSend id
+ writeItr itr itrBodyToSend B.empty
+ return chunk
+ unless willDiscardBody
+ $ do if willChunkBody then
+ fail "FIXME: not implemented"
+ else
+ B.hPut h chunk
+ hFlush h
+ awaitSomethingToWrite
finishBodyChunk :: Interaction -> IO ()
finishBodyChunk itr = return () -- FIXME: not implemented
let (remaining :> _) = S.viewr queue
writeTVar tQueue remaining
- readTVar $ itrWillClose itr
+ readItr itr itrWillClose id
if willClose then
hClose h
else
projects / Lucu.git / commitdiff