, 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,
-- > 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
-- |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 ]
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
{-# LANGUAGE
BangPatterns
+ , OverloadedStrings
, UnboxedTuples
, UnicodeSyntax
#-}
, 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"
+= ( 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 を持たない
-- 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
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
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
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
-- 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
projects / Lucu.git / commitdiff