module Network.HTTP.Lucu.DefaultPage
- ( getDefaultPage -- Maybe Request -> Response -> String
- , writeDefaultPage -- Interaction -> STM ()
+ ( getDefaultPage
+ , writeDefaultPage
+ , mkDefaultPage
)
where
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 qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Maybe
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import Network.URI hiding (path)
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.Arrow.XmlState
import Text.XML.HXT.DOM.TypeDefs
-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) ]
+ writeDocumentToString [ withIndent True ]
)
return xmlStr
writeDefaultPage :: Interaction -> STM ()
-writeDefaultPage itr
- = do wroteHeader <- readTVar (itrWroteHeader itr)
+writeDefaultPage !itr
+ -- Content-Type が正しくなければ補完できない。
+ = do res <- readItr itr itrResponse id
+ when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
+ $ do reqM <- readItr itr itrRequest id
- -- ヘッダが出力濟だったら意味が無い。
- when wroteHeader
- $ fail "writeDefaultPage: the header has already been written"
+ let conf = itrConfig itr
+ page = L8.pack $ getDefaultPage conf reqM res
- resM <- readTVar (itrResponse itr)
+ writeTVar (itrBodyToSend itr)
+ $ page
- -- 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
+mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
+mkDefaultPage !conf !status !msgA
+ = let (# sCode, sMsg #) = statusCode status
+ sig = C8.unpack (cnfServerSoftware conf)
+ ++ " at "
+ ++ C8.unpack (cnfServerHost conf)
in ( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
- += txt (printf "%03d %s" sCode sMsg)
+ += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)
))
+= ( eelem "body"
+= ( eelem "h1"
- += txt sMsg
+ += txt (C8.unpack sMsg)
)
- += ( msgA
- >>>
- eelem "p" += ( this
- >>>
- mkText
- )))))
+ += ( eelem "p" += msgA )
+ += eelem "hr"
+ += ( eelem "address" += txt sig ))))
+{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
+
+getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
+getMsg !req !res
+ = case resStatus res of
+ -- 1xx は body を持たない
+ -- 2xx の body は補完しない
+
+ -- 3xx
+ MovedPermanently
+ -> txt ("The resource at " ++ path ++ " has been moved to ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt " permanently."
+
+ Found
+ -> txt ("The resource at " ++ path ++ " is currently located at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt ". This is not a permanent relocation."
+
+ SeeOther
+ -> txt ("The resource at " ++ path ++ " can be found at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt "."
+
+ TemporaryRedirect
+ -> txt ("The resource at " ++ path ++ " is temporarily located at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt "."
+
+ -- 4xx
+ BadRequest
+ -> txt "The server could not understand the request you sent."
+
+ Unauthorized
+ -> txt ("You need a valid authentication to access " ++ path)
+
+ Forbidden
+ -> txt ("You don't have permission to access " ++ path)
+
+ NotFound
+ -> txt ("The requested URL " ++ path ++ " was not found on this server.")
+
+ Gone
+ -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
+
+ RequestEntityTooLarge
+ -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
+
+ RequestURITooLarge
+ -> txt "The request URI you sent was too big to accept."
+
+ -- 5xx
+ InternalServerError
+ -> txt ("An internal server error has occured during the process of your request to " ++ 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 = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res
-getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String
-getMsg req res
- = constA "FIXME: NOT IMPL"
+{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file
projects / Lucu.git / blobdiff