X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=c5ae6f5c5d485ea8dbe4ca6046e70cbd7258ce47;hp=6a980104d3dfe6a1f6d9b66202b9898aaa0ae1fd;hb=6680828c79aff38431704075c339e043b577589e;hpb=3d017dd65ddede9a11c5b7a34a91e04340e67bc4 diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 6a98010..c5ae6f5 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,168 +1,135 @@ +{-# LANGUAGE + OverloadedStrings + , RecordWildCards + , ScopedTypeVariables + , TypeOperators + , UnicodeSyntax + #-} module Network.HTTP.Lucu.DefaultPage - ( getDefaultPage - , writeDefaultPage - , mkDefaultPage + ( defaultPageContentType + , defaultPageForResponse + , defaultPageWithMessage ) where - -import Control.Arrow -import Control.Arrow.ArrowList -import Control.Concurrent.STM -import Control.Monad -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Maybe -import Network -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.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 :: Config -> Maybe Request -> Response -> String -getDefaultPage conf req res - = conf `seq` req `seq` res `seq` - let msgA = getMsg req res - in - unsafePerformIO $ - do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA - >>> - writeDocumentToString [ (a_indent, v_1) ] - ) - return xmlStr - - -writeDefaultPage :: Interaction -> STM () -writeDefaultPage itr - = itr `seq` - -- Content-Type が正しくなければ補完できない。 - do res <- readItr itr itrResponse id - when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType) - $ do reqM <- readItr itr itrRequest id - - let conf = itrConfig itr - page = L8.pack $ getDefaultPage conf reqM res - - writeTVar (itrBodyToSend itr) - $ page - - -mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree -mkDefaultPage conf status msgA - = conf `seq` status `seq` msgA `seq` - let (# sCode, sMsg #) = statusCode status - sig = C8.unpack (cnfServerSoftware conf) - ++ " at " - ++ C8.unpack (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 "head" - += ( eelem "title" - += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg) - )) - += ( eelem "body" - += ( eelem "h1" - += txt (C8.unpack sMsg) - ) - += ( 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 - = req `seq` res `seq` - 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 - - +import Blaze.ByteString.Builder (Builder) +import Data.Ascii (Ascii) +import qualified Data.CaseInsensitive as CI +import Data.Convertible.Base +import Data.Convertible.Utils +import Data.Maybe +import Data.Monoid.Unicode +import Data.Text (Text) +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.URI hiding (path) +import Prelude hiding (head) +import Prelude.Unicode +import Text.Blaze +import Text.Blaze.Html5 hiding (hr) +import Text.Blaze.Html5.Attributes hiding (title) +import Text.Blaze.Renderer.Utf8 + +defaultPageContentType ∷ Ascii +{-# INLINE defaultPageContentType #-} +defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\"" + +defaultPageForResponse ∷ Config → Maybe Request → Response → Builder +{-# INLINEABLE defaultPageForResponse #-} +defaultPageForResponse conf req res + = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res + +defaultPageWithMessage ∷ ∀sc. StatusCode sc ⇒ Config → sc → Html → Builder +{-# INLINEABLE defaultPageWithMessage #-} +defaultPageWithMessage (Config {..}) sc msg + = renderHtmlBuilder $ + do unsafeByteString "" + docType + html ! xmlns "http://www.w3.org/1999/xhtml" $ + do let status = toHtml $ scText sc + head $ title status + body $ do h1 status + p msg + hr + address $ do toHtml (cs cnfServerSoftware ∷ Text) + unsafeByteString " at " + toHtml $ CI.original cnfServerHost + where + scText ∷ sc → Text + scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode + +defaultMessage ∷ Maybe Request → Response → Html +{-# INLINEABLE defaultMessage #-} +defaultMessage req res@(Response {..}) + -- 1xx responses don't have a body. + -- 2xx responses don't need a body to be completed. + -- 3xx: + | resStatus ≈ MovedPermanently + = do unsafeByteString "The resource at " + path + unsafeByteString " has been moved to " + a ! href (toValue loc) $ toHtml loc + unsafeByteString " permanently." + + | resStatus ≈ Found + = do unsafeByteString "The resource at " + path + unsafeByteString " is currently located at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString ". This is not a permanent relocation." + + | resStatus ≈ SeeOther + = do unsafeByteString "The resource at " + path + unsafeByteString " can be found at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString "." + + | resStatus ≈ TemporaryRedirect + = do unsafeByteString "The resource at " + path + unsafeByteString " is temporarily located at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString "." + + -- 4xx: + | resStatus ≈ BadRequest + = unsafeByteString "The server could not understand the request you sent." + | resStatus ≈ Unauthorized + = unsafeByteString "You need a valid authentication to access " ⊕ path + | resStatus ≈ Forbidden + = unsafeByteString "You don't have permission to access " ⊕ path + | resStatus ≈ NotFound + = do unsafeByteString "The requested URL " + path + unsafeByteString " was not found on this server." + | resStatus ≈ Gone + = do unsafeByteString "The resource at " + path + unsafeByteString " was here in past times, but has gone permanently." + | resStatus ≈ RequestEntityTooLarge + = do unsafeByteString "The request entity you sent for " + path + unsafeByteString " was too large to accept." + | resStatus ≈ RequestURITooLarge + = unsafeByteString "The request URI you sent was too large to accept." + + -- 5xx: + | resStatus ≈ InternalServerError + = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path + | resStatus ≈ ServiceUnavailable + = unsafeByteString "The service is temporarily unavailable. Try later." + + | otherwise + = (∅) where - path :: String - path = let uri = reqURI $! fromJust req - in - uriPath uri + path ∷ Html + path = toHtml ∘ uriPath ∘ reqURI $ fromJust req - loc :: String - loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res + loc ∷ Text + loc = cs ∘ fromJust $ getHeader "Location" res -{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-} \ No newline at end of file +hr ∷ Html +{-# INLINE hr #-} +hr = unsafeByteString "
"