--- #hide, prune
+{-# LANGUAGE
+ OverloadedStrings
+ , RecordWildCards
+ , ScopedTypeVariables
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.DefaultPage
- ( getDefaultPage
- , writeDefaultPage
- , mkDefaultPage
+ ( defaultPageContentType
+ , defaultPageForResponse
+ , defaultPageWithMessage
)
where
-
-import Control.Arrow
-import Control.Arrow.ArrowList
-import Control.Concurrent.STM
-import Control.Monad
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
-import Data.Maybe
-import Network
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-import Network.URI
-import System.IO.Unsafe
-import Text.Printf
-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlIOStateArrow
-import Text.XML.HXT.DOM.TypeDefs
-import Text.XML.HXT.DOM.XmlKeywords
-
-
-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 [ (a_indent, v_1) ]
- )
- return xmlStr
-
-
-writeDefaultPage :: Interaction -> STM ()
-writeDefaultPage itr
- = do wroteHeader <- readTVar (itrWroteHeader itr)
-
- -- Content-Type が正しくなければ補完できない。
- res <- readItr itr itrResponse id
- when (getHeader "Content-Type" res == Just defaultPageContentType)
- $ do reqM <- readItr itr itrRequest id
-
- let conf = itrConfig itr
- page = B.pack $ getDefaultPage conf reqM res
-
- writeTVar (itrBodyToSend itr)
- $ page
-
-
-mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
-mkDefaultPage conf status msgA
- = let (sCode, sMsg) = statusCode status
- sig = cnfServerSoftware conf
- ++ " at "
- ++ cnfServerHost conf
- ++ ( case cnfServerPort conf of
- Service serv -> ", service " ++ serv
- PortNumber num -> ", port " ++ show num
- UnixSocket path -> ", unix socket " ++ show path
- )
- in ( eelem "/"
- += ( eelem "html"
- += sattr "xmlns" "http://www.w3.org/1999/xhtml"
- += ( eelem "head"
- += ( eelem "title"
- += txt (printf "%03d %s" sCode sMsg)
- ))
- += ( eelem "body"
- += ( eelem "h1"
- += txt sMsg
- )
- += ( eelem "p" += msgA )
- += eelem "hr"
- += ( eelem "address" += txt sig ))))
-
-
-getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
-getMsg req res
- = case resStatus res of
- -- 1xx は body を持たない
- -- 2xx の body は補完しない
-
- -- 3xx
- MovedPermanently
- -> txt (printf "The resource at %s has been moved to " path)
- <+>
- eelem "a" += sattr "href" loc
- += txt loc
- <+>
- txt " permanently."
-
- Found
- -> txt (printf "The resource at %s is currently located at " path)
- <+>
- eelem "a" += sattr "href" loc
- += txt loc
- <+>
- txt ". This is not a permanent relocation."
-
- SeeOther
- -> txt (printf "The resource at %s can be found at " path)
- <+>
- eelem "a" += sattr "href" loc
- += txt loc
- <+>
- txt "."
-
- TemporaryRedirect
- -> txt (printf "The resource at %s is temporarily located at " path)
- <+>
- eelem "a" += sattr "href" loc
- += txt loc
- <+>
- txt "."
-
- -- 4xx
- BadRequest
- -> txt "The server could not understand the request you sent."
-
- Unauthorized
- -> txt (printf "You need a valid authentication to access %s" path)
-
- Forbidden
- -> txt (printf "You don't have permission to access %s" path)
-
- NotFound
- -> txt (printf "The requested URL %s was not found on this server." path)
-
- Gone
- -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
-
- RequestEntityTooLarge
- -> txt (printf "The request entity you sent for %s was too big to accept." path)
-
- RequestURITooLarge
- -> txt "The request URI you sent was too big to accept."
-
- -- 5xx
- InternalServerError
- -> txt (printf "An internal server error has occured during the process of your request to %s" path)
-
- ServiceUnavailable
- -> txt "The service is temporarily unavailable. Try later."
-
- _ -> none
-
-
+import Blaze.ByteString.Builder (Builder)
+import Data.Ascii (Ascii)
+import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
+import Data.Convertible.Utils
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.URI hiding (path)
+import Prelude hiding (head)
+import Prelude.Unicode
+import Text.Blaze
+import Text.Blaze.Html5 hiding (hr)
+import Text.Blaze.Html5.Attributes hiding (title)
+import Text.Blaze.Renderer.Utf8
+
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""
+
+defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
+{-# INLINEABLE defaultPageForResponse #-}
+defaultPageForResponse conf req res
+ = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
+
+defaultPageWithMessage ∷ ∀sc. StatusCode sc ⇒ Config → sc → Html → Builder
+{-# INLINEABLE defaultPageWithMessage #-}
+defaultPageWithMessage (Config {..}) sc msg
+ = renderHtmlBuilder $
+ do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+ docType
+ html ! xmlns "http://www.w3.org/1999/xhtml" $
+ do let status = toHtml $ scText sc
+ head $ title status
+ body $ do h1 status
+ p msg
+ hr
+ address $ do toHtml (cs cnfServerSoftware ∷ Text)
+ unsafeByteString " at "
+ toHtml $ CI.original cnfServerHost
+ where
+ scText ∷ sc → Text
+ scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode
+
+defaultMessage ∷ Maybe Request → Response → Html
+{-# INLINEABLE defaultMessage #-}
+defaultMessage req res@(Response {..})
+ -- 1xx responses don't have a body.
+ -- 2xx responses don't need a body to be completed.
+ -- 3xx:
+ | resStatus ≈ MovedPermanently
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " has been moved to "
+ a ! href (toValue loc) $ toHtml loc
+ unsafeByteString " permanently."
+
+ | resStatus ≈ Found
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " is currently located at "
+ a ! href (toValue loc) $ toHtml loc
+ unsafeByteString ". This is not a permanent relocation."
+
+ | resStatus ≈ SeeOther
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " can be found at "
+ a ! href (toValue loc) $ toHtml loc
+ unsafeByteString "."
+
+ | resStatus ≈ TemporaryRedirect
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " is temporarily located at "
+ a ! href (toValue loc) $ toHtml loc
+ unsafeByteString "."
+
+ -- 4xx:
+ | resStatus ≈ BadRequest
+ = unsafeByteString "The server could not understand the request you sent."
+ | resStatus ≈ Unauthorized
+ = unsafeByteString "You need a valid authentication to access " ⊕ path
+ | resStatus ≈ Forbidden
+ = unsafeByteString "You don't have permission to access " ⊕ path
+ | resStatus ≈ NotFound
+ = do unsafeByteString "The requested URL "
+ path
+ unsafeByteString " was not found on this server."
+ | resStatus ≈ Gone
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " was here in past times, but has gone permanently."
+ | resStatus ≈ RequestEntityTooLarge
+ = do unsafeByteString "The request entity you sent for "
+ path
+ unsafeByteString " was too large to accept."
+ | resStatus ≈ RequestURITooLarge
+ = unsafeByteString "The request URI you sent was too large to accept."
+
+ -- 5xx:
+ | resStatus ≈ InternalServerError
+ = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
+ | resStatus ≈ ServiceUnavailable
+ = unsafeByteString "The service is temporarily unavailable. Try later."
+
+ | otherwise
+ = (∅)
where
- path :: String
- path = let uri = reqURI $ fromJust req
- in
- uriPath uri
+ path ∷ Html
+ path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
+
+ loc ∷ Text
+ loc = cs ∘ fromJust $ getHeader "Location" res
- loc :: String
- loc = fromJust $ getHeader "Location" res
+hr ∷ Html
+{-# INLINE hr #-}
+hr = unsafeByteString "<hr/>"
projects / Lucu.git / blobdiff