Network.HTTP.Lucu.Response
Network.HTTP.Lucu.Resource
Network.HTTP.Lucu.Request
-ghc-options: -threaded
+ghc-options: -threaded -fglasgow-exts
Executable: HelloWorld
Main-Is: HelloWorld.hs
Hs-Source-Dirs: ., examples
-ghc-options: -threaded
\ No newline at end of file
+ghc-options: -threaded -fglasgow-exts
\ No newline at end of file
--- /dev/null
+module Network.HTTP.Lucu.Abortion
+ ( Abortion(..)
+ , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
+ , abortIO -- StatusCode -> [ (String, String) ] -> String -> IO a
+ , abortSTM -- StatusCode -> [ (String, String) ] -> String -> STM a
+ , abortA -- ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
+ , aboPage -- Config -> Abortion -> String
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad.Trans
+import GHC.Conc (unsafeIOToSTM)
+import Data.Dynamic
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Response
+import System.IO.Unsafe
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+data Abortion = Abortion {
+ aboStatus :: StatusCode
+ , aboHeaders :: Headers
+ , aboMessage :: String
+ } deriving (Show, Typeable)
+
+
+abort :: MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
+abort status headers msg
+ = liftIO $ abortIO status headers msg
+
+
+abortIO :: StatusCode -> [ (String, String) ] -> String -> IO a
+abortIO status headers msg
+ = let abo = Abortion status headers msg
+ exc = DynException (toDyn abo)
+ in
+ throwIO exc
+
+
+abortSTM :: StatusCode -> [ (String, String) ] -> String -> STM a
+abortSTM status headers msg
+ = unsafeIOToSTM $ abortIO status headers msg
+
+
+abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
+abortA status headers msg
+ = arrIO0 $ abortIO status headers msg
+
+
+aboPage :: Config -> Abortion -> String
+aboPage conf abo
+ = let [html] = unsafePerformIO
+ $ runX ( mkDefaultPage conf (aboStatus abo) (txt $ aboMessage abo)
+ >>>
+ writeDocumentToString [(a_indent, v_1)]
+ )
+ in
+ html
where
import Network
+import Network.BSD
+import System.IO.Unsafe
data Config = Config {
- cnfServerPort :: PortID
+ cnfServerSoftware :: String
+ , cnfServerHost :: HostName
+ , cnfServerPort :: PortID
, cnfMaxPipelineDepth :: Int
- , cnfMaxEntityLength :: Integer
+ , cnfMaxEntityLength :: Int
, cnfMaxURILength :: Int
}
defaultConfig = Config {
- cnfServerPort = Service "http"
+ cnfServerSoftware = "Lucu/1.0"
+ , cnfServerHost = unsafePerformIO getHostName
+ , cnfServerPort = Service "http"
, cnfMaxPipelineDepth = 100
, cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
, cnfMaxURILength = 4 * 1024 -- 4 KiB
module Network.HTTP.Lucu.DefaultPage
- ( getDefaultPage -- Maybe Request -> Response -> String
+ ( getDefaultPage -- Config -> Maybe Request -> Response -> String
, writeDefaultPage -- Interaction -> STM ()
+ , mkDefaultPage -- (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
)
where
import qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Maybe
+import Network
+import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import Network.URI
import System.IO.Unsafe
import Text.Printf
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.DOM.XmlKeywords
-getDefaultPage :: Maybe Request -> Response -> String
-getDefaultPage req res
+getDefaultPage :: Config -> Maybe Request -> Response -> String
+getDefaultPage conf req res
= let msgA = getMsg req res
in
unsafePerformIO $
- do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA
+ do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
>>>
writeDocumentToString [ (a_indent, v_1) ]
)
let reqM = itrRequest itr
res = fromJust resM
- page = B.pack $ getDefaultPage reqM res
+ conf = itrConfig itr
+ page = B.pack $ getDefaultPage conf reqM res
writeTVar (itrResponse itr)
$ Just $ setHeader "Content-Type" "application/xhtml+xml" res
$ page
-mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree
-mkDefaultPage status msgA
+mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
+mkDefaultPage conf status msgA
= let (sCode, sMsg) = statusCode status
+ sig = cnfServerSoftware conf
+ ++ " at "
+ ++ cnfServerHost conf
+ ++ ( case cnfServerPort conf of
+ Service serv -> ", service " ++ serv
+ PortNumber num -> ", port " ++ show num
+ UnixSocket path -> ", unix socket " ++ show path
+ )
in ( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "h1"
+= txt sMsg
)
- += ( msgA
- >>>
- eelem "p" += ( this
- >>>
- mkText
- )))))
+ += ( eelem "p" += msgA )
+ += eelem "hr"
+ += ( eelem "address" += txt sig ))))
-getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String
+getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
getMsg req res
- = constA "FIXME: NOT IMPL"
+ = case resStatus res of
+ -- 1xx は body を持たない
+ -- 2xx の body は補完しない
+
+ -- 3xx
+ MovedPermanently
+ -> txt (printf "The resource at %s has been moved to " path)
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt " permanently."
+
+ Found
+ -> txt (printf "The resource at %s is currently located at " path)
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt ". This is not a permanent relocation."
+
+ SeeOther
+ -> txt (printf "The resource at %s can be found at " path)
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt "."
+
+ TemporaryRedirect
+ -> txt (printf "The resource at %s is temporarily located at " path)
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt "."
+
+ -- 4xx
+ BadRequest
+ -> txt "The server could not understand the request you sent."
+
+ Unauthorized
+ -> txt (printf "You need a valid authentication to access %s" path)
+
+ Forbidden
+ -> txt (printf "You don't have permission to access %s" path)
+
+ NotFound
+ -> txt (printf "The requested URL %s was not found on this server." path)
+
+ Gone
+ -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
+
+ RequestEntityTooLarge
+ -> txt (printf "The request entity you sent for %s was too big to accept." path)
+
+ RequestURITooLarge
+ -> txt "The request URI you sent was too big to accept."
+
+ -- 5xx
+ InternalServerError
+ -> txt (printf "An internal server error has occured during the process of your request to %s" path)
+
+ ServiceUnavailable
+ -> txt "The service is temporarily unavailable. Try later."
+
+ _ -> none
+
+
+ where
+ path :: String
+ path = let uri = reqURI $ fromJust req
+ in
+ uriPath uri
+
+ loc :: String
+ loc = fromJust $ getHeader "Location" res
, InteractionState(..)
, InteractionQueue
, newInteractionQueue -- IO InteractionQueue
- , newInteraction -- HostName -> Maybe Request -> IO Interaction
+ , newInteraction -- Config -> HostName -> Maybe Request -> IO Interaction
, writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
, readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
import qualified Data.Sequence as S
import Data.Sequence (Seq)
import Network
+import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
data Interaction = Interaction {
- itrRemoteHost :: HostName
+ itrConfig :: Config
+ , itrRemoteHost :: HostName
, itrRequest :: Maybe Request
, itrResponse :: TVar (Maybe Response)
, itrRequestHasBody :: TVar Bool
- , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
, itrRequestIsChunked :: TVar Bool
- , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
-
, itrExpectedContinue :: TVar Bool
- , itrWillChunkBody :: TVar Bool
- , itrWillDiscardBody :: TVar Bool
- , itrWillClose :: TVar Bool
- , itrBodyToSend :: TVar ByteString
+ , itrReqChunkLength :: TVar (Maybe Int)
+ , itrReqChunkRemaining :: TVar (Maybe Int)
+ , itrReqChunkIsOver :: TVar Bool
+ , itrReqBodyWanted :: TVar (Maybe Int)
+ , itrReqBodyWasteAll :: TVar Bool
+ , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
+
+ , itrWillReceiveBody :: TVar Bool
+ , itrWillChunkBody :: TVar Bool
+ , itrWillDiscardBody :: TVar Bool
+ , itrWillClose :: TVar Bool
+
+ , itrBodyToSend :: TVar ByteString
+ , itrBodyIsNull :: TVar Bool
, itrState :: TVar InteractionState
| DecidingHeader
| DecidingBody
| Done
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Enum)
type InteractionQueue = TVar (Seq Interaction)
newInteractionQueue = newTVarIO S.empty
-newInteraction :: HostName -> Maybe Request -> IO Interaction
-newInteraction host req
+newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
+newInteraction conf host req
= do responce <- newTVarIO Nothing
- requestHasBody <- newTVarIO False
- requestBodyLength <- newTVarIO Nothing
- requestIsChunked <- newTVarIO False
- receivedBody <- newTVarIO B.empty
-
- expectedContinue <- newTVarIO False
-
- willChunkBody <- newTVarIO False
- willDiscardBody <- newTVarIO False
- willClose <- newTVarIO False
- bodyToSend <- newTVarIO B.empty
+ requestHasBody <- newTVarIO False
+ requestIsChunked <- newTVarIO False
+ expectedContinue <- newTVarIO False
+
+ reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
+ reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
+ reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
+ reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
+ reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
+ receivedBody <- newTVarIO B.empty
+
+ willReceiveBody <- newTVarIO False
+ willChunkBody <- newTVarIO False
+ willDiscardBody <- newTVarIO False
+ willClose <- newTVarIO False
+
+ bodyToSend <- newTVarIO B.empty
+ bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
state <- newTVarIO undefined
wroteHeader <- newTVarIO False
return $ Interaction {
- itrRemoteHost = host
+ itrConfig = conf
+ , itrRemoteHost = host
, itrRequest = req
, itrResponse = responce
, itrRequestHasBody = requestHasBody
- , itrRequestBodyLength = requestBodyLength
, itrRequestIsChunked = requestIsChunked
+ , itrExpectedContinue = expectedContinue
+
+ , itrReqChunkLength = reqChunkLength
+ , itrReqChunkRemaining = reqChunkRemaining
+ , itrReqChunkIsOver = reqChunkIsOver
+ , itrReqBodyWanted = reqBodyWanted
+ , itrReqBodyWasteAll = reqBodyWasteAll
, itrReceivedBody = receivedBody
- , itrExpectedContinue = expectedContinue
+ , itrWillReceiveBody = willReceiveBody
+ , itrWillChunkBody = willChunkBody
+ , itrWillDiscardBody = willDiscardBody
+ , itrWillClose = willClose
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
- , itrBodyToSend = bodyToSend
+ , itrBodyToSend = bodyToSend
+ , itrBodyIsNull = bodyIsNull
, itrState = state
module Network.HTTP.Lucu.Postprocess
( postprocess -- Interaction -> STM ()
- , completeUnconditionalHeaders -- Response -> IO Response
+ , completeUnconditionalHeaders -- Config -> Response -> IO Response
)
where
import Data.Char
import Data.Maybe
import GHC.Conc (unsafeIOToSTM)
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
{-
- * Response が未設定なら、HTTP/1.1 500 Internal Server Error にする。
+ * Response が未設定なら、200 OK にする。
+
+ * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
+
+ * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
+
+ * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
+ する。
* Content-Length があれば、それを削除する。
* body を持つ事が出來る時、Content-Type が無ければ
application/octet-stream にする。出來ない時、HEAD でなければ
- Content-Type を削除する。
+ Content-Type, Etag, Last-Modified を削除する。
* body を持つ事が出來ない時、body 破棄フラグを立てる。
-}
-{- Postprocess は body を補完した後で實行する事 -}
-
postprocess :: Interaction -> STM ()
postprocess itr
- = do res <- readItr itr itrResponse id
-
- when (res == Nothing)
- $ setStatus itr InternalServerError
+ = do resM <- readItr itr itrResponse id
+
+ case resM of
+ Nothing -> writeItr itr itrResponse
+ $ Just $ Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Ok
+ , resHeaders = []
+ }
+ Just res -> do let sc = resStatus res
+
+ when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
+ $ abortSTM InternalServerError []
+ ("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.")
+
+ when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
+ $ abortSTM InternalServerError []
+ ("The status code was " ++ show sc ++ " but no Location header.")
when (itrRequest itr /= Nothing)
$ relyOnRequest itr
do oldRes <- readItr itr itrResponse id
- newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes
+ newRes <- unsafeIOToSTM
+ $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes)
writeItr itr itrResponse $ Just newRes
where
+ relyOnRequest :: Interaction -> STM ()
relyOnRequest itr
= do status <- readItr itr itrResponse (resStatus . fromJust)
| x <- splitBy (== ',') (map toLower te)]
in
when (teList == [] || last teList /= "chunked")
- $ setStatus itr InternalServerError
+ $ abortSTM InternalServerError []
+ ("Transfer-Encoding must end with `chunked' "
+ ++ "because this is an HTTP/1.1 request: "
+ ++ te)
writeItr itr itrWillChunkBody True
else
case fmap (map toLower) teM of
Nothing -> return ()
Just "identity" -> return ()
- _ -> setStatus itr InternalServerError
+ Just te -> abortSTM InternalServerError []
+ ("Transfer-Encoding must be `identity' because "
+ ++ "this is an HTTP/1.0 request: "
+ ++ te)
cType <- readHeader itr "Content-Type"
when (cType == Nothing)
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
do updateRes itr $ deleteHeader "Transfer-Encoding"
when (reqMethod req /= HEAD)
- $ updateRes itr $ deleteHeader "Content-Type"
+ $ do updateRes itr $ deleteHeader "Content-Type"
+ updateRes itr $ deleteHeader "Etag"
+ updateRes itr $ deleteHeader "Last-Modified"
conn <- readHeader itr "Connection"
case fmap (map toLower) conn of
Just "close" -> writeItr itr itrWillClose True
- _ -> updateRes itr $ setHeader "Connection" "close"
+ _ -> return ()
+
+ willClose <- readItr itr itrWillClose id
+ when willClose
+ $ 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
- , resStatus = status
- , resHeaders = []
- })
-
readHeader :: Interaction -> String -> STM (Maybe String)
readHeader itr name
= do valueMM <- readItrF itr itrResponse $ getHeader name
= updateItrF itr itrResponse updator
-completeUnconditionalHeaders :: Response -> IO Response
-completeUnconditionalHeaders res
+completeUnconditionalHeaders :: Config -> Response -> IO Response
+completeUnconditionalHeaders conf res
= return res >>= compServer >>= compDate >>= return
where
compServer res
= case getHeader "Server" res of
- Nothing -> return $ addHeader "Server" "Lucu/1.0" res
+ Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
Just _ -> return res
compDate res
"content-length"
-> if all isDigit value then
- writeItr itr itrRequestBodyLength $ Just $ read value
+ do let len = read value
+ writeItr itr itrReqChunkLength $ Just len
+ writeItr itr itrReqChunkRemaining $ Just len
else
setStatus itr BadRequest
let input = B.append soFar chunk
case parse requestP input of
(Success req , input') -> acceptParsableRequest req input'
- (IllegalInput, _ ) -> acceptNonparsableRequest
+ (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest
(ReachedEOF , _ ) -> if B.length input >= 1024 * 1024 then
-- ヘッダ長過ぎ
- acceptNonparsableRequest
+ acceptNonparsableRequest RequestEntityTooLarge
else
acceptRequest input
-
- acceptNonparsableRequest :: IO ()
- acceptNonparsableRequest
- = do itr <- newInteraction host Nothing
+ acceptNonparsableRequest :: StatusCode -> IO ()
+ acceptNonparsableRequest status
+ = do itr <- newInteraction cnf host Nothing
let res = Response {
resVersion = HttpVersion 1 1
- , resStatus = BadRequest
+ , resStatus = status
, resHeaders = []
}
atomically $ do writeItr itr itrResponse $ Just res
acceptParsableRequest :: Request -> ByteString -> IO ()
acceptParsableRequest req soFar
- = do itr <- newInteraction host (Just req)
+ = do itr <- newInteraction cnf host (Just req)
action
<- atomically $
do preprocess itr
acceptRequest soFar
observeRequest :: Interaction -> ByteString -> IO ()
- observeRequest itr soFar = fail "FIXME: Not Implemented"
+ observeRequest itr soFar
+ = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
+ if isChunked then
+ observeChunkedRequest itr soFar
+ else
+ observeNonChunkedRequest itr soFar
+
+ observeChunkedRequest :: Interaction -> ByteString -> IO ()
+ observeChunkedRequest itr soFar
+ = fail "FIXME: not implemented"
+
+ observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
+ observeNonChunkedRequest itr soFar
+ = fail "FIXME: not implemented"
+{-
+ = do action
+ <- atomically $
+ do wantedM <- readItr itr itrReqBodyWanted id
+ if wantedM == Nothing then
+ do wasteAll <- readItr itr itrReqBodyWasteAll id
+ if wasteAll then
+ return $ wasteAllReqBody itr soFar
+ else
+ retry
+ else
+ -- 受信要求が來た。
+ if B.empty soFar then
+ return $ receiveNonChunkedReqBody itr
+ else
+ do remaining <- readItr itr itrReqChunkRemaining fromJust
+
+ let wanted = fromJust wanted
+ (chunk, input') = B.splitAt (min wanted remaining) soFar
+ newRemaining = remaining - B.length chunk
+ isOver = newRemaining == 0
+
+ writeItr itr itrReqChunkRemaining newRemaining
+ writeItr itr itrReqChunkIsOver isOver
+ writeItr itr itrReqBodyWanted (if isOver then
+ Nothing
+ else
+ Just wanted)
+ writeItr itr itrReceivedBody chunk
+
+ if isOver then
+ return $ acceptRequest input'
+ else
+ return $ observeNonChunkedRequest itr input'
+ action
+
+ receiveNonChunkedReqBody :: Interaction -> IO ()
+ receiveNonChunkedReqBody itr
+ = do wanted <- atomically $ readItr itr itrReqBodyWanted fromJust
+ remaining <- atomically $ readItr itr itrReqChunkRemaining fromJust
+
+ hWaitForInput h (-1)
+ chunk <- B.hGetNonBlocking h (min wanted remaining)
+
+ let newRemaining = remaining - B.length chunk
+ isOver = newRemaining == 0
+
+ atomically $ do writeItr itr itrReqChunkRemaining newRemaining
+ writeItr itr itrReqChunkIsOver isOver
+ writeItr itr itrReqBodyWanted (if isOver then
+ Nothing
+ else
+ Just wanted)
+ writeItr itr itrReceivedBody chunk
+
+ if isOver then
+ return $ acceptRequest B.empty
+ else
+ return $ observeNonChunkedRequest itr B.empty
+
+
+ wasteAllReqBody :: Interaction -> ByteString -> IO ()
+ wasteAllReqBody itr soFar
+ =
+
+-}
enqueue :: Interaction -> STM ()
enqueue itr = do queue <- readTVar tQueue
, mkResTree -- [ ([String], ResourceDef) ] -> ResTree
, findResource -- ResTree -> URI -> Maybe ResourceDef
, runResource -- ResourceDef -> Interaction -> IO ThreadId
+
+ , input -- Int -> Resource String
+ , inputChunk -- Int -> Resource String
+ , inputBS -- Int -> Resource ByteString
+ , inputChunkBS -- Int -> Resource ByteString
+
+ , setStatus -- StatusCode -> Resource ()
+ , setHeader -- String -> String -> Resource ()
+
+ , redirect -- StatusCode -> URI -> Resource ()
+
+ , output -- String -> Resource ()
+ , outputChunk -- String -> Resource ()
+ , outputBS -- ByteString -> Resource ()
+ , outputChunkBS -- ByteString -> Resource ()
)
where
import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
import Control.Monad.Reader
import qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Dynamic
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
+import Data.Maybe
+import GHC.Conc (unsafeIOToSTM)
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
+import qualified Network.HTTP.Lucu.Headers as H
+import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Postprocess
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
import Network.URI
+import Prelude hiding (catch)
+import System.IO
+import System.IO.Error hiding (catch)
type Resource a = ReaderT Interaction IO a
data ResourceDef = ResourceDef {
resUsesNativeThread :: Bool
, resIsGreedy :: Bool
- , resResource :: Resource ()
+ , resGet :: Maybe (Resource ())
+ , resHead :: Maybe (Resource ())
+ , resPost :: Maybe (Resource ())
+ , resPut :: Maybe (Resource ())
+ , resDelete :: Maybe (Resource ())
}
type ResTree = ResNode -- root だから Map ではない
type ResSubtree = Map String ResNode
runResource :: ResourceDef -> Interaction -> IO ThreadId
-runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch
+runResource def itr
+ = fork
+ $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
+ driftTo Done
+ ) itr
+ )
+ $ \ exc -> processException (itrConfig itr) exc
where
+ fork :: IO () -> IO ThreadId
fork = if (resUsesNativeThread def)
then forkOS
else forkIO
- rsrc = resResource def
\ No newline at end of file
+
+ rsrc :: Maybe (Resource ())
+ rsrc = case reqMethod $ fromJust $ itrRequest itr of
+ GET -> resGet def
+ HEAD -> case resHead def of
+ Just r -> Just r
+ Nothing -> resGet def
+ POST -> resPost def
+ PUT -> resPut def
+ DELETE -> resDelete def
+
+ notAllowed :: Resource ()
+ notAllowed = do setStatus MethodNotAllowed
+ setHeader "Allow" $ joinWith ", " allowedMethods
+
+ allowedMethods :: [String]
+ allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
+ , methods resHead ["GET", "HEAD"]
+ , methods resPost ["POST"]
+ , methods resPut ["PUT"]
+ , methods resDelete ["DELETE"]
+ ]
+
+ methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
+ methods f xs = case f def of
+ Just _ -> xs
+ Nothing -> []
+
+ processException :: Config -> Exception -> IO ()
+ processException conf exc
+ = do let abo = case exc of
+ ErrorCall msg -> Abortion InternalServerError [] msg
+ IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE
+ DynException dynE -> case fromDynamic dynE of
+ Just (abo :: Abortion) -> abo
+ Nothing
+ -> Abortion InternalServerError []
+ $ show exc
+ _ -> Abortion InternalServerError [] $ show exc
+ -- まだ DecidingHeader 以前の状態だったら、この途中終了
+ -- を應答に反映させる餘地がある。さうでなければ stderr
+ -- にでも吐くしか無い。
+ state <- atomically $ readItr itr itrState id
+ if state <= DecidingHeader then
+ flip runReaderT itr
+ $ do setStatus $ aboStatus abo
+ -- FIXME: 同じ名前で複數の値があった時は、こ
+ -- れではまずいと思ふ。
+ mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
+ setHeader "Content-Type" "application/xhtml+xml"
+ output $ aboPage conf abo
+ else
+ hPutStrLn stderr $ show abo
+
+ flip runReaderT itr $ driftTo Done
+
+ formatIOE :: IOError -> String
+ formatIOE ioE = if isUserError ioE then
+ ioeGetErrorString ioE
+ else
+ show ioE
+
+
+{- Resource モナド -}
+
+input :: Int -> Resource String
+input limit = inputBS limit >>= return . B.unpack
+
+
+-- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
+-- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
+inputBS :: Int -> Resource ByteString
+inputBS limit
+ = do driftTo GettingBody
+ itr <- ask
+ let defaultLimit = cnfMaxEntityLength $ itrConfig itr
+ actualLimit = if limit <= 0 then
+ defaultLimit
+ else
+ limit
+ when (actualLimit <= 0)
+ $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
+ -- Reader にリクエスト
+ liftIO $ atomically
+ $ do chunkLen <- readItr itr itrReqChunkLength id
+ writeItr itr itrWillReceiveBody True
+ if fmap (> actualLimit) chunkLen == Just True then
+ -- 受信前から多過ぎる事が分かってゐる
+ tooLarge actualLimit
+ else
+ writeItr itr itrReqBodyWanted $ Just actualLimit
+ -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
+ chunk <- liftIO $ atomically
+ $ do chunk <- readItr itr itrReceivedBody id
+ chunkIsOver <- readItr itr itrReqChunkIsOver id
+ if B.length chunk < fromIntegral actualLimit then
+ -- 要求された量に滿たなくて、まだ殘りがある
+ -- なら再試行。
+ unless chunkIsOver
+ $ retry
+ else
+ -- 制限値一杯まで讀むやうに指示したのにまだ殘っ
+ -- てゐるなら、それは多過ぎる。
+ unless chunkIsOver
+ $ tooLarge actualLimit
+ -- 成功。itr 内にチャンクを置いたままにするとメ
+ -- モリの無駄になるので除去。
+ writeItr itr itrReceivedBody B.empty
+ return chunk
+ driftTo DecidingHeader
+ return chunk
+ where
+ tooLarge :: Int -> STM ()
+ tooLarge lim = abortSTM RequestEntityTooLarge []
+ ("Request body must be smaller than "
+ ++ show lim ++ " bytes.")
+
+
+inputChunk :: Int -> Resource String
+inputChunk limit = inputChunkBS limit >>= return . B.unpack
+
+
+-- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
+-- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
+-- る。これ以上ボディが殘ってゐなければ空文字列を返す。
+inputChunkBS :: Int -> Resource ByteString
+inputChunkBS limit
+ = do driftTo GettingBody
+ itr <- ask
+ let defaultLimit = cnfMaxEntityLength $ itrConfig itr
+ actualLimit = if limit < 0 then
+ defaultLimit
+ else
+ limit
+ when (actualLimit <= 0)
+ $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
+ -- Reader にリクエスト
+ liftIO $ atomically
+ $ do writeItr itr itrReqBodyWanted $ Just actualLimit
+ writeItr itr itrWillReceiveBody True
+ -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
+ chunk <- liftIO $ atomically
+ $ do chunk <- readItr itr itrReceivedBody id
+ -- 要求された量に滿たなくて、まだ殘りがあるなら
+ -- 再試行。
+ when (B.length chunk < fromIntegral actualLimit)
+ $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
+ unless chunkIsOver
+ $ retry
+ -- 成功
+ writeItr itr itrReceivedBody B.empty
+ return chunk
+ when (B.null chunk)
+ $ driftTo DecidingHeader
+ return chunk
+
+
+setStatus :: StatusCode -> Resource ()
+setStatus code
+ = do driftTo DecidingHeader
+ itr <- ask
+ liftIO $ atomically $ updateItr itr itrResponse
+ $ \ resM -> case resM of
+ Nothing -> Just $ Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = code
+ , resHeaders = []
+ }
+ Just res -> Just $ res {
+ resStatus = code
+ }
+
+
+setHeader :: String -> String -> Resource ()
+setHeader name value
+ = do driftTo DecidingHeader
+ itr <- ask
+ liftIO $ atomically $ updateItr itr itrResponse
+ $ \ resM -> case resM of
+ Nothing -> Just $ Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Ok
+ , resHeaders = [ (name, value) ]
+ }
+ Just res -> Just $ H.setHeader name value res
+
+
+redirect :: StatusCode -> URI -> Resource ()
+redirect code uri
+ = do when (code == NotModified || not (isRedirection code))
+ $ abort InternalServerError []
+ $ "Attempted to redirect with status " ++ show code
+ setStatus code
+ setHeader "Location" (uriToString id uri $ "")
+
+
+output :: String -> Resource ()
+output = outputBS . B.pack
+
+
+outputBS :: ByteString -> Resource ()
+outputBS str = do outputChunkBS str
+ driftTo Done
+
+
+outputChunk :: String -> Resource ()
+outputChunk = outputChunkBS . B.pack
+
+
+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
+
+
+{-
+
+ [GettingBody からそれ以降の状態に遷移する時]
+
+ body を讀み終へてゐなければ、殘りの body を讀み捨てる。
+
+
+ [DecidingHeader からそれ以降の状態に遷移する時]
+
+ postprocess する。
+
+
+ [Done に遷移する時]
+
+ bodyIsNull が False ならば何もしない。True だった場合は出力補完す
+ る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK
+ だった場合は、補完の代はりに 204 No Content に變へる。
+
+-}
+
+driftTo :: InteractionState -> Resource ()
+driftTo newState
+ = do itr <- ask
+ liftIO $ atomically $ do oldState <- readItr itr itrState id
+ if newState < oldState then
+ throwStateError oldState newState
+ else
+ do let a = [oldState .. newState]
+ b = tail a
+ c = zip a b
+ mapM_ (uncurry $ drift itr) c
+ writeItr itr itrState newState
+ where
+ throwStateError :: Monad m => InteractionState -> InteractionState -> m a
+
+ throwStateError Done DecidingBody
+ = fail "It makes no sense to output something after finishing to output."
+
+ throwStateError old new
+ = fail ("state error: " ++ show old ++ " ==> " ++ show new)
+
+
+ drift :: Interaction -> InteractionState -> InteractionState -> STM ()
+
+ drift itr GettingBody _
+ = writeItr itr itrReqBodyWasteAll True
+
+ drift itr DecidingHeader _
+ = postprocess itr
+
+ drift itr _ Done
+ = do bodyIsNull <- readItr itr itrBodyIsNull id
+ when bodyIsNull
+ $ do status <- readStatus itr
+ if status == Ok then
+ do updateItrF itr itrResponse
+ $ \ res -> res { resStatus = NoContent }
+ updateItrF itr itrResponse
+ $ H.deleteHeader "Content-Type"
+ updateItrF itr itrResponse
+ $ H.deleteHeader "ETag"
+ updateItrF itr itrResponse
+ $ H.deleteHeader "Last-Modified"
+ else
+ writeDefaultPage itr
+
+
+ drift _ _ _
+ = return ()
+
+
+ readStatus :: Interaction -> STM StatusCode
+ readStatus itr = readItr itr itrResponse (resStatus . fromJust)
\ No newline at end of file
, Response(..)
, hPutResponse -- Handle -> Response -> IO ()
, isInformational -- StatusCode -> Bool
+ , isSuccessful -- StatusCode -> Bool
+ , isRedirection -- StatusCode -> Bool
, isError -- StatusCode -> Bool
, statusCode -- StatusCode -> (Int, String)
)
where
+import Data.Dynamic
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import System.IO
| GatewayTimeout
| HttpVersionNotSupported
| InsufficientStorage
- deriving (Eq)
+ deriving (Typeable, Eq)
instance Show StatusCode where
show sc = let (num, msg) = statusCode sc
isInformational :: StatusCode -> Bool
-isInformational sc = let (num, _) = statusCode sc
- in num < 200
+isInformational = doesMeet (< 200)
+
+isSuccessful :: StatusCode -> Bool
+isSuccessful = doesMeet (\ n -> n >= 200 && n < 300)
+
+isRedirection :: StatusCode -> Bool
+isRedirection = doesMeet (\ n -> n >= 300 && n < 400)
isError :: StatusCode -> Bool
-isError sc = let (num, _) = statusCode sc
- in num >= 400
+isError = doesMeet (>= 400)
+
+doesMeet :: (Int -> Bool) -> StatusCode -> Bool
+doesMeet p sc = let (num, _) = statusCode sc
+ in
+ p num
statusCode :: StatusCode -> (Int, String)
= do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
willChunkBody <- atomically $ readItr itr itrWillChunkBody id
when (not willDiscardBody && willChunkBody)
- $ hPutStr h "0\r\n" >> hFlush h
+ $ hPutStr h "0\r\n\r\n" >> hFlush h
finalize :: Interaction -> IO ()
finalize itr
readItr itr itrWillClose id
if willClose then
+ -- reader は恐らく hWaitForInput してゐる最中なので、
+ -- スレッドを豫め殺して置かないとをかしくなる。
do killThread readerTID
hClose h
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
)
where
+import Control.Monad.Trans
import Data.Char
import Data.List
+import Foreign
+import Foreign.C
splitBy :: (a -> Bool) -> [a] -> [[a]]
(first, sep:rest) -> first : splitBy isSeparator rest
+joinWith :: [a] -> [[a]] -> [a]
+joinWith separator xs
+ = foldr (++) [] $ intersperse separator xs
+
+
trim :: (a -> Bool) -> [a] -> [a]
trim p = trimTail . trimHead
where
+import Data.Maybe
import Network
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Httpd
import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Response
+import Network.URI
import System.Posix.Signals
main :: IO ()
main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }
- resources = mkResTree []
+ resources = mkResTree [ ([], helloWorld) ]
in
do installHandler sigPIPE Ignore Nothing
- runHttpd config resources
\ No newline at end of file
+ runHttpd config resources
+
+
+helloWorld :: ResourceDef
+helloWorld
+ = ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = False
+ , resGet
+ = Just $ do setHeader "Content-Type" "text/plain"
+ outputChunk "Hello, "
+ outputChunk "World!\n"
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
\ No newline at end of file
projects / Lucu.git / commitdiff