+{-# LANGUAGE
+ OverloadedStrings
+ , RecordWildCards
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.DefaultPage
- ( getDefaultPage -- Maybe Request -> Response -> String
- , writeDefaultPage -- Interaction -> STM ()
+ ( getDefaultPage
+ , defaultPageContentType
+ , mkDefaultPage
)
where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.ListArrow
+import Control.Arrow.Unicode
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Maybe
+import qualified Data.Text as T
+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.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
-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.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-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 :: Maybe Request -> Response -> String
-getDefaultPage req res
- = let msgA = getMsg req res
+getDefaultPage ∷ Config → Maybe Request → Response → Builder
+{-# INLINEABLE getDefaultPage #-}
+getDefaultPage conf req res
+ = let msgA = getMsg req res
+ [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
+ ⋙
+ writeDocumentToString [ withIndent True ]
+ ) ()
in
- unsafePerformIO $
- do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA
- >>>
- writeDocumentToString [ (a_indent, v_1) ]
- )
- return xmlStr
-
-
-writeDefaultPage :: Interaction -> STM ()
-writeDefaultPage itr
- = do wroteHeader <- readTVar (itrWroteHeader itr)
-
- -- ヘッダが出力濟だったら意味が無い。
- when wroteHeader
- $ fail "writeDefaultPage: the header has already been written"
-
- resM <- readTVar (itrResponse itr)
-
- -- Response が不明ならばページ書込も不可
- when (resM == Nothing)
- $ fail "writeDefaultPage: response was Nothing"
-
- let reqM = itrRequest itr
- res = fromJust resM
- page = B.pack $ getDefaultPage reqM res
-
- writeTVar (itrResponse itr)
- $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
+ BB.fromString xmlStr
- writeTVar (itrBodyToSend itr)
- $ page
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml"
-
-mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree
-mkDefaultPage status msgA
- = let (sCode, sMsg) = statusCode status
+mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc)
+ ⇒ Config
+ → sc
+ → b ⇝ XmlTree
+ → b ⇝ XmlTree
+{-# INLINEABLE mkDefaultPage #-}
+mkDefaultPage conf status msgA
+ = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
+ sig = concat [ A.toString (cnfServerSoftware conf)
+ , " at "
+ , T.unpack (cnfServerHost conf)
+ ]
in ( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
- += txt (printf "%03d %s" sCode sMsg)
+ += txt sStr
))
+= ( eelem "body"
+= ( eelem "h1"
- += txt sMsg
+ += txt sStr
)
- += ( msgA
- >>>
- eelem "p" += ( this
- >>>
- mkText
- )))))
+ += ( eelem "p" += msgA )
+ += eelem "hr"
+ += ( eelem "address" += txt sig ))))
+
+getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree
+{-# INLINEABLE getMsg #-}
+getMsg req res@(Response {..})
+ -- 1xx responses don't have a body.
+ -- 2xx responses don't need a body to be completed.
+ -- 3xx:
+ | resStatus ≈ MovedPermanently
+ = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt " permanently."
+
+ | resStatus ≈ Found
+ = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt ". This is not a permanent relocation."
+
+ | resStatus ≈ SeeOther
+ = txt ("The resource at " ⧺ path ⧺ " can be found at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt "."
+ | resStatus ≈ TemporaryRedirect
+ = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt "."
+
+ -- 4xx:
+ | resStatus ≈ BadRequest
+ = txt "The server could not understand the request you sent."
+ | resStatus ≈ Unauthorized
+ = txt ("You need a valid authentication to access " ⧺ path)
+ | resStatus ≈ Forbidden
+ = txt ("You don't have permission to access " ⧺ path)
+ | resStatus ≈ NotFound
+ = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
+ | resStatus ≈ Gone
+ = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
+ | resStatus ≈ RequestEntityTooLarge
+ = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
+ | resStatus ≈ RequestURITooLarge
+ = txt "The request URI you sent was too large to accept."
+
+ -- 5xx:
+ | resStatus ≈ InternalServerError
+ = txt ("An internal server error has occured during the process of your request to " ⧺ path)
+ | resStatus ≈ ServiceUnavailable
+ = txt "The service is temporarily unavailable. Try later."
+
+ | otherwise
+ = none
+ where
+ path ∷ String
+ path = uriPath $ reqURI $ fromJust req
-getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String
-getMsg req res
- = constA "FIXME: NOT IMPL"
+ loc ∷ String
+ loc = A.toString $ fromJust $ getHeader "Location" res
projects / Lucu.git / blobdiff