X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FAbortion.hs;h=dc33eb125bfda4027413bb5782aaac51b09cca8c;hp=bc03045b74b1d33ddbabb9adfeb7e2cde340de54;hb=1e53b8533fa22640147cc4ca4ce5075c8e39b0d8;hpb=50e8fe7af585a8d33d93b3721be8f8f01905b891 diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index bc03045..dc33eb1 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -17,7 +17,7 @@ import Control.Arrow.ArrowIO import Control.Concurrent.STM import Control.Exception import Control.Monad.Trans -import Data.ByteString.Base (ByteString) +import qualified Data.ByteString.Char8 as C8 import Data.Dynamic import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Config @@ -62,29 +62,31 @@ data Abortion = Abortion { -- > abort MovedPermanently -- > [("Location", "http://example.net/")] -- > (Just "It has been moved to example.net") -abort :: MonadIO m => StatusCode -> [ (ByteString, ByteString) ] -> 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 headers) msg + let abo = Abortion status (toHeaders $ map pack headers) msg exc = DynException (toDyn abo) in liftIO $ throwIO exc + where + pack (x, y) = (C8.pack x, C8.pack y) -- |This is similar to 'abort' but computes it with -- 'System.IO.Unsafe.unsafePerformIO'. -abortPurely :: StatusCode -> [ (ByteString, ByteString) ] -> 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 -> [ (ByteString, ByteString) ] -> 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, ([ (ByteString, ByteString) ], Maybe String)) c +abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c abortA = arrIO3 abort