, abortPage
)
where
-import Control.Arrow
+import Control.Arrow.ArrowIO
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
import Control.Concurrent.STM
import Text.XML.HXT.Arrow.XmlState
data Abortion = Abortion {
- aboStatus :: !StatusCode
- , aboHeaders :: !Headers
- , aboMessage :: !(Maybe Text)
+ aboStatus ∷ !StatusCode
+ , aboHeaders ∷ !Headers
+ , aboMessage ∷ !(Maybe Text)
} deriving (Eq, Show, Typeable)
instance Exception Abortion
-- > abort MovedPermanently
-- > [("Location", "http://example.net/")]
-- > (Just "It has been moved to example.net")
-abort :: MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a
+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 → [ (CIAscii, Ascii) ] → Maybe Text → a
+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 → [ (CIAscii, Ascii) ] → Maybe Text → STM a
+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 :: Arrow (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
+abortA ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
{-# INLINE abortA #-}
abortA = proc (status, (headers, msg)) →
- returnA ⤙ abortPurely status headers msg
+ arrIO throwIO ⤙ Abortion status (toHeaders headers) msg
-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
-- ければならない。
-abortPage :: Config → Maybe Request → Response → Abortion → Lazy.Text
+abortPage ∷ Config → Maybe Request → Response → Abortion → Lazy.Text
abortPage conf reqM res abo
= case aboMessage abo of
Just msg