+{-# LANGUAGE
+ FlexibleContexts
+ , UnicodeSyntax
+ #-}
+-- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
+-- in any 'Prelude.IO' monads or arrows.
module Network.HTTP.Lucu.Abortion
- ( Abortion(..)
- , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
- , abortIO -- StatusCode -> [ (String, String) ] -> String -> IO a
- , abortSTM -- StatusCode -> [ (String, String) ] -> String -> STM a
- , abortA -- ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
- , aboPage -- Config -> Abortion -> String
+ ( Abortion
+ , mkAbortion
+ , mkAbortion'
+
+ , abort
)
where
-
-import Control.Arrow
-import Control.Arrow.ArrowIO
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad.Trans
-import GHC.Conc (unsafeIOToSTM)
-import Data.Dynamic
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.DefaultPage
-import Network.HTTP.Lucu.Headers
-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.XmlIOStateArrow
-import Text.XML.HXT.DOM.XmlKeywords
-
-
-data Abortion = Abortion {
- aboStatus :: StatusCode
- , aboHeaders :: Headers
- , aboMessage :: String
- } deriving (Show, Typeable)
-
-
-abort :: MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
-abort status headers msg
- = liftIO $ abortIO status headers msg
-
-
-abortIO :: StatusCode -> [ (String, String) ] -> String -> IO a
-abortIO status headers msg
- = let abo = Abortion status headers msg
- exc = DynException (toDyn abo)
- in
- throwIO exc
-
-
-abortSTM :: StatusCode -> [ (String, String) ] -> String -> STM a
-abortSTM status headers msg
- = unsafeIOToSTM $ abortIO status headers msg
-
-
-abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
-abortA status headers msg
- = arrIO0 $ abortIO status headers msg
-
-
-aboPage :: Config -> Abortion -> String
-aboPage conf abo
- = let [html] = unsafePerformIO
- $ runX ( mkDefaultPage conf (aboStatus abo) (txt $ aboMessage abo)
- >>>
- writeDocumentToString [(a_indent, v_1)]
- )
- in
- html
+import Control.Exception
+import Control.Monad.Trans
+import Data.Ascii (Ascii, CIAscii)
+import Data.Collections
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import Network.HTTP.Lucu.Abortion.Internal
+import Network.HTTP.Lucu.Response
+import Prelude.Unicode
+
+-- |Construct an 'Abortion' with additional headers and an optional
+-- message text.
+mkAbortion ∷ (StatusCode sc, Foldable f (CIAscii, Ascii))
+ ⇒ sc
+ → f
+ → Maybe Text
+ → Abortion
+{-# INLINE mkAbortion #-}
+mkAbortion sc hdrs msg
+ = Abortion {
+ aboStatus = fromStatusCode sc
+ , aboHeaders = fromFoldable hdrs
+ , aboMessage = msg
+ }
+
+-- |Construct an 'Abortion' without any additional headers but with a
+-- message text.
+mkAbortion' ∷ StatusCode sc ⇒ sc → Text → Abortion
+{-# INLINE mkAbortion' #-}
+mkAbortion' sc msg
+ = Abortion {
+ aboStatus = fromStatusCode sc
+ , aboHeaders = (∅)
+ , aboMessage = Just msg
+ }
+
+-- |Throw an 'Abortion' in a 'MonadIO', including the very
+-- 'Network.HTTP.Lucu.Resource.Resource' monad.
+abort ∷ MonadIO m ⇒ Abortion → m a
+{-# INLINE abort #-}
+abort = liftIO ∘ throwIO