From 3b680675dec6d5b922356daf2ad715f1cea26e4a Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 6 Aug 2011 03:19:36 +0900 Subject: [PATCH] DefaultPage Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- Network/HTTP/Lucu/Abortion.hs | 52 +++++++------ Network/HTTP/Lucu/DefaultPage.hs | 125 ++++++++++++++++--------------- 2 files changed, 88 insertions(+), 89 deletions(-) diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 26ea8b0..6e74bea 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -15,33 +15,31 @@ module Network.HTTP.Lucu.Abortion , abortPage ) where - -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Concurrent.STM -import Control.Exception -import Control.Monad.Trans +import Control.Arrow +import Control.Arrow.ArrowIO +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.Trans import qualified Data.ByteString.Char8 as C8 -import Data.Typeable -import GHC.Conc (unsafeIOToSTM) -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Request -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.XmlState - +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Typeable +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState data Abortion = Abortion { aboStatus :: !StatusCode , aboHeaders :: !Headers , aboMessage :: !(Maybe String) - } deriving (Show, Typeable) + } deriving (Eq, Show, Typeable, Exception) -instance Exception Abortion +--instance Exception Abortion -- |Computation of @'abort' status headers msg@ aborts the -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status, @@ -67,7 +65,7 @@ instance Exception Abortion -- > abort MovedPermanently -- > [("Location", "http://example.net/")] -- > (Just "It has been moved to example.net") -abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a +abort :: MonadIO m ⇒ StatusCode → [ (String, String) ] → Maybe String → m a abort status headers msg = status `seq` headers `seq` msg `seq` let abo = Abortion status (toHeaders $ map pack headers) msg @@ -78,31 +76,31 @@ abort status headers msg -- |This is similar to 'abort' but computes it with -- 'System.IO.Unsafe.unsafePerformIO'. -abortPurely :: StatusCode -> [ (String, String) ] -> Maybe String -> a +abortPurely :: StatusCode → [ (String, String) ] → Maybe String → a abortPurely = ((unsafePerformIO .) .) . abort -- |Computation of @'abortSTM' status headers msg@ just computes -- 'abort' in a 'Control.Monad.STM.STM' monad. -abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a +abortSTM :: StatusCode → [ (String, String) ] → Maybe String → STM a abortSTM status headers msg = status `seq` headers `seq` msg `seq` unsafeIOToSTM $! abort status headers msg -- | Computation of @'abortA' -< (status, (headers, msg))@ just -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'. -abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c +abortA :: ArrowIO a ⇒ a (StatusCode, ([ (String, String) ], Maybe String)) c abortA = arrIO3 abort -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な -- ければならない。 -abortPage :: Config -> Maybe Request -> Response -> Abortion -> String +abortPage :: Config → Maybe Request → Response → Abortion → String abortPage conf reqM res abo = conf `seq` reqM `seq` res `seq` abo `seq` case aboMessage abo of Just msg - -> let [html] = unsafePerformIO + → let [html] = unsafePerformIO $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg) >>> writeDocumentToString [ withIndent True ] @@ -110,7 +108,7 @@ abortPage conf reqM res abo in html Nothing - -> let res' = res { resStatus = aboStatus abo } + → let res' = res { resStatus = aboStatus abo } res'' = foldl (.) id [setHeader name value | (name, value) <- fromHeaders $ aboHeaders abo] res' in diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 12aba15..1cc4638 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns + , OverloadedStrings , UnboxedTuples , UnicodeSyntax #-} @@ -9,66 +10,69 @@ module Network.HTTP.Lucu.DefaultPage , mkDefaultPage ) where - -import Control.Arrow -import Control.Arrow.ArrowList -import Control.Concurrent.STM -import Control.Monad +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Arrow.Unicode +import Control.Concurrent.STM +import Control.Monad +import qualified Data.Ascii as A 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.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 -> String +import Data.Maybe +import qualified Data.Sequence as S +import qualified Data.Text as T +import Data.Text.Encoding +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 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 → String getDefaultPage !conf !req !res = let msgA = getMsg req res in unsafePerformIO $ - do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA - >>> - writeDocumentToString [ withIndent True ] - ) + do [xmlStr] ← runX ( mkDefaultPage conf (resStatus res) msgA + ⋙ + writeDocumentToString [ withIndent True ] + ) return xmlStr - -writeDefaultPage :: Interaction -> STM () +writeDefaultPage ∷ Interaction → STM () 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 + = do res ← readItr itr itrResponse id + when (getHeader "Content-Type" res == Just defaultPageContentType) + $ do reqM ← readItr itr itrRequest id let conf = itrConfig itr - page = L8.pack $ getDefaultPage conf reqM res + page = T.pack $ getDefaultPage conf reqM res writeTVar (itrBodyToSend itr) - $ page + (S.singleton (encodeUtf8 page)) - -mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree +mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree +{-# INLINEABLE mkDefaultPage #-} mkDefaultPage !conf !status !msgA = let (# sCode, sMsg #) = statusCode status - sig = C8.unpack (cnfServerSoftware conf) - ++ " at " - ++ C8.unpack (cnfServerHost conf) + sig = concat [ 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 (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg) + += txt (fmtDec 3 sCode ⧺ " " ⧺ C8.unpack sMsg) )) += ( eelem "body" += ( eelem "h1" @@ -77,9 +81,9 @@ mkDefaultPage !conf !status !msgA += ( 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 ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree +{-# INLINEABLE getMsg #-} getMsg !req !res = case resStatus res of -- 1xx は body を持たない @@ -87,7 +91,7 @@ getMsg !req !res -- 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 @@ -95,7 +99,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 @@ -103,7 +107,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 @@ -111,7 +115,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 @@ -120,43 +124,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 = C8.unpack $! fromJust $! getHeader (C8.pack "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 -- 2.40.0