X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=dbc3835d6bbd8e5e7362426c900c81d736771278;hb=54778963482bef9f6dfc305e593658e0e9d1a4c5;hp=a79e47b49c9f143d6d83638868d42be26cd0d901;hpb=858129cb755aa09da2b7bd758efb8519f2c89103;p=Lucu.git diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index a79e47b..dbc3835 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,102 +1,96 @@ --- #hide, prune +{-# LANGUAGE + BangPatterns + , OverloadedStrings + , UnboxedTuples + , UnicodeSyntax + #-} module Network.HTTP.Lucu.DefaultPage ( getDefaultPage , writeDefaultPage , mkDefaultPage ) 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 -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 -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 +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Arrow.ListArrow +import Control.Arrow.Unicode +import Control.Concurrent.STM +import Control.Monad +import qualified Data.Ascii as A +import Data.Maybe +import qualified Data.Sequence as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +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 hiding (path) +import Prelude.Unicode +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.DOM.TypeDefs + +getDefaultPage ∷ Config → Maybe Request → Response → Text +{-# INLINEABLE getDefaultPage #-} +getDefaultPage !conf !req !res + = let msgA = getMsg req res + [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA + ⋙ + writeDocumentToString [ withIndent True ] + ) () in - unsafePerformIO $ - do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA - >>> - writeDocumentToString [ (a_indent, v_1) ] - ) - return xmlStr - + T.pack xmlStr -writeDefaultPage :: Interaction -> STM () -writeDefaultPage itr - = itr `seq` - do wroteHeader <- readTVar (itrWroteHeader itr) - - -- Content-Type が正しくなければ補完できない。 - res <- readItr itr itrResponse id +writeDefaultPage ∷ Interaction → STM () +writeDefaultPage !itr + -- Content-Type が正しくなければ補完できない。 + = do res ← readItr itr itrResponse id when (getHeader "Content-Type" res == Just defaultPageContentType) - $ do reqM <- readItr itr itrRequest id + $ do reqM ← readItr itr itrRequest id let conf = itrConfig itr - page = B.pack $ getDefaultPage conf reqM res + page = 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 = cnfServerSoftware conf - ++ " at " - ++ cnfServerHost conf - ++ ( case cnfServerPort conf of - Service serv -> ", service " ++ serv - PortNumber num -> ", port " ++ show num - UnixSocket path -> ", unix socket " ++ show path - ) + (S.singleton (encodeUtf8 page)) + +mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree +{-# INLINEABLE mkDefaultPage #-} +mkDefaultPage !conf !status !msgA + = let sStr = A.toString $ printStatusCode status + sig = concat [ A.toString (cnfServerSoftware conf) + , " at " + , T.unpack (cnfServerHost conf) + ] in ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" - += txt (fmtDec 3 sCode ++ " " ++ sMsg) + += txt sStr )) += ( eelem "body" += ( eelem "h1" - += txt sMsg + += txt sStr ) += ( 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 +getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree +{-# INLINEABLE getMsg #-} +getMsg !req !res + = case resStatus res of -- 1xx は body を持たない -- 2xx の body は補完しない -- 3xx MovedPermanently - -> txt ("The resource at " ++ path ++ " has been moved to ") + → txt ("The resource at " ⧺ path ⧺ " has been moved to ") <+> eelem "a" += sattr "href" loc += txt loc @@ -104,7 +98,7 @@ getMsg req res txt " permanently." Found - -> txt ("The resource at " ++ path ++ " is currently located at ") + → txt ("The resource at " ⧺ path ⧺ " is currently located at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -112,7 +106,7 @@ getMsg req res txt ". This is not a permanent relocation." SeeOther - -> txt ("The resource at " ++ path ++ " can be found at ") + → txt ("The resource at " ⧺ path ⧺ " can be found at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -120,7 +114,7 @@ getMsg req res txt "." TemporaryRedirect - -> txt ("The resource at " ++ path ++ " is temporarily located at ") + → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -129,43 +123,40 @@ getMsg req res -- 4xx BadRequest - -> txt "The server could not understand the request you sent." + → txt "The server could not understand the request you sent." Unauthorized - -> txt ("You need a valid authentication to access " ++ path) + → txt ("You need a valid authentication to access " ⧺ path) Forbidden - -> txt ("You don't have permission to access " ++ path) + → txt ("You don't have permission to access " ⧺ path) NotFound - -> txt ("The requested URL " ++ path ++ " was not found on this server.") + → 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.") + → 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.") + → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.") RequestURITooLarge - -> txt "The request URI you sent was too big to accept." + → txt "The request URI you sent was too large to accept." -- 5xx InternalServerError - -> txt ("An internal server error has occured during the process of your request to " ++ path) + → txt ("An internal server error has occured during the process of your request to " ⧺ path) ServiceUnavailable - -> txt "The service is temporarily unavailable. Try later." + → txt "The service is temporarily unavailable. Try later." - _ -> none + _ → none - where - path :: String - path = let uri = reqURI $! fromJust req + path ∷ String + path = let uri = reqURI $ fromJust req in uriPath uri - loc :: String - loc = fromJust $! getHeader "Location" res - -{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-} \ No newline at end of file + loc ∷ String + loc = A.toString $ fromJust $ getHeader "Location" res