From 69686745233be9269796be9f26621040fb7d9d1c Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 6 Aug 2011 03:47:46 +0900 Subject: [PATCH] Abortion Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- Network/HTTP/Lucu/Abortion.hs | 76 ++++++++++++++++---------------- Network/HTTP/Lucu/DefaultPage.hs | 19 ++++---- 2 files changed, 49 insertions(+), 46 deletions(-) diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 6e74bea..9ef433b 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,5 +1,8 @@ {-# LANGUAGE - DeriveDataTypeable + Arrows + , BangPatterns + , DeriveDataTypeable + , TypeOperators , UnicodeSyntax #-} {-# OPTIONS_HADDOCK prune #-} @@ -16,19 +19,21 @@ module Network.HTTP.Lucu.Abortion ) where import Control.Arrow -import Control.Arrow.ArrowIO +import Control.Arrow.ListArrow +import Control.Arrow.Unicode import Control.Concurrent.STM import Control.Exception import Control.Monad.Trans -import qualified Data.ByteString.Char8 as C8 +import Data.Ascii (Ascii, CIAscii) +import Data.Text (Text) 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 Prelude.Unicode import Text.XML.HXT.Arrow.WriteDocument import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlState @@ -36,10 +41,10 @@ import Text.XML.HXT.Arrow.XmlState data Abortion = Abortion { aboStatus :: !StatusCode , aboHeaders :: !Headers - , aboMessage :: !(Maybe String) - } deriving (Eq, Show, Typeable, Exception) + , aboMessage :: !(Maybe Text) + } deriving (Eq, Show, Typeable) ---instance Exception Abortion +instance Exception Abortion -- |Computation of @'abort' status headers msg@ aborts the -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status, @@ -65,51 +70,48 @@ data Abortion = 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 status headers msg - = status `seq` headers `seq` msg `seq` - let abo = Abortion status (toHeaders $ map pack headers) msg - in - liftIO $ throwIO abo - where - pack (x, y) = (C8.pack x, C8.pack y) +abort :: MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a +{-# INLINE abort #-} +abort status headers + = liftIO ∘ throwIO ∘ Abortion status (toHeaders headers) -- |This is similar to 'abort' but computes it with -- 'System.IO.Unsafe.unsafePerformIO'. -abortPurely :: StatusCode → [ (String, String) ] → Maybe String → a -abortPurely = ((unsafePerformIO .) .) . abort +abortPurely :: StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a +{-# INLINE abortPurely #-} +abortPurely status headers + = throw ∘ Abortion status (toHeaders headers) -- |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 status headers msg - = status `seq` headers `seq` msg `seq` - unsafeIOToSTM $! abort status headers msg +abortSTM :: StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a +{-# INLINE abortSTM #-} +abortSTM status headers + = throwSTM ∘ Abortion status (toHeaders headers) -- | 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 - = arrIO3 abort +abortA :: Arrow (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c +{-# INLINE abortA #-} +abortA = proc (status, (headers, msg)) → + returnA ⤙ abortPurely status headers msg -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な -- ければならない。 -abortPage :: Config → Maybe Request → Response → Abortion → String -abortPage conf reqM res abo - = conf `seq` reqM `seq` res `seq` abo `seq` - case aboMessage abo of +abortPage :: Config → Maybe Request → Response → Abortion → Text +abortPage !conf !reqM !res !abo + = case aboMessage abo of Just msg - → let [html] = unsafePerformIO - $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg) - >>> - writeDocumentToString [ withIndent True ] - ) - in - html + → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg) + ⋙ + writeDocumentToString [ withIndent True ] + ) () + in + T.pack html Nothing → let res' = res { resStatus = aboStatus abo } - res'' = foldl (.) id [setHeader name value - | (name, value) <- fromHeaders $ aboHeaders abo] res' + res'' = foldl (∘) id [setHeader name value + | (name, value) ← fromHeaders $ aboHeaders abo] res' in getDefaultPage conf reqM res'' diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 1cc4638..b5a9341 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -12,6 +12,7 @@ module Network.HTTP.Lucu.DefaultPage where import Control.Arrow import Control.Arrow.ArrowList +import Control.Arrow.ListArrow import Control.Arrow.Unicode import Control.Concurrent.STM import Control.Monad @@ -19,6 +20,7 @@ import qualified Data.Ascii as A import qualified Data.ByteString.Char8 as C8 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 @@ -28,23 +30,22 @@ 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 ∷ Config → Maybe Request → Response → Text +{-# INLINEABLE getDefaultPage #-} getDefaultPage !conf !req !res - = let msgA = getMsg req res - in - unsafePerformIO $ - do [xmlStr] ← runX ( mkDefaultPage conf (resStatus res) msgA + = let msgA = getMsg req res + [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA ⋙ writeDocumentToString [ withIndent True ] - ) - return xmlStr + ) () + in + T.pack xmlStr writeDefaultPage ∷ Interaction → STM () writeDefaultPage !itr @@ -54,7 +55,7 @@ writeDefaultPage !itr $ do reqM ← readItr itr itrRequest id let conf = itrConfig itr - page = T.pack $ getDefaultPage conf reqM res + page = getDefaultPage conf reqM res writeTVar (itrBodyToSend itr) (S.singleton (encodeUtf8 page)) -- 2.40.0