Network/HTTP/Lucu/DefaultPage.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , OverloadedStrings
   4   , UnboxedTuples
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.DefaultPage
   8     ( getDefaultPage
   9     , writeDefaultPage
  10     , mkDefaultPage
  11     )
  12     where
  13 import qualified Blaze.ByteString.Builder.ByteString as BB
  14 import Control.Arrow
  15 import Control.Arrow.ArrowList
  16 import Control.Arrow.ListArrow
  17 import Control.Arrow.Unicode
  18 import Control.Concurrent.STM
  19 import Control.Monad
  20 import qualified Data.Ascii as A
  21 import Data.Maybe
  22 import Data.Text (Text)
  23 import qualified Data.Text as T
  24 import Data.Text.Encoding
  25 import Network.HTTP.Lucu.Config
  26 import Network.HTTP.Lucu.Headers
  27 import Network.HTTP.Lucu.Interaction
  28 import Network.HTTP.Lucu.Request
  29 import Network.HTTP.Lucu.Response
  30 import Network.URI hiding (path)
  31 import Prelude.Unicode
  32 import Text.XML.HXT.Arrow.WriteDocument
  33 import Text.XML.HXT.Arrow.XmlArrow
  34 import Text.XML.HXT.Arrow.XmlState
  35 import Text.XML.HXT.DOM.TypeDefs
  36
  37 getDefaultPage ∷ Config → Maybe Request → Response → Text
  38 {-# INLINEABLE getDefaultPage #-}
  39 getDefaultPage !conf !req !res
  40     = let msgA     = getMsg req res
  41           [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
  42                              ⋙
  43                              writeDocumentToString [ withIndent True ]
  44                            ) ()
  45       in
  46         T.pack xmlStr
  47
  48 writeDefaultPage ∷ Interaction → STM ()
  49 writeDefaultPage !itr
  50     -- Content-Type が正しくなければ補完できない。
  51     = do res ← readItr itrResponse id itr
  52          when (getHeader "Content-Type" res == Just defaultPageContentType)
  53                   $ do reqM ← readItr itrRequest id itr
  54
  55                        let conf = itrConfig itr
  56                            page = getDefaultPage conf reqM res
  57
  58                        putTMVar (itrBodyToSend itr)
  59                                 (BB.fromByteString $ encodeUtf8 page)
  60
  61 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
  62 {-# INLINEABLE mkDefaultPage #-}
  63 mkDefaultPage !conf !status !msgA
  64     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
  65           sig  = concat [ A.toString (cnfServerSoftware conf)
  66                         , " at "
  67                         , T.unpack (cnfServerHost conf)
  68                         ]
  69       in ( eelem "/"
  70            += ( eelem "html"
  71                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
  72                 += ( eelem "head"
  73                      += ( eelem "title"
  74                           += txt sStr
  75                         ))
  76                 += ( eelem "body"
  77                      += ( eelem "h1"
  78                           += txt sStr
  79                         )
  80                      += ( eelem "p" += msgA )
  81                      += eelem "hr"
  82                      += ( eelem "address" += txt sig ))))
  83
  84 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
  85 {-# INLINEABLE getMsg #-}
  86 getMsg !req !res
  87     = case resStatus res of
  88         -- 1xx は body を持たない
  89         -- 2xx の body は補完しない
  90
  91         -- 3xx
  92         MovedPermanently
  93             → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
  94                <+>
  95                eelem "a" += sattr "href" loc
  96                          += txt loc
  97                <+>
  98                txt " permanently."
  99
 100         Found
 101             → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
 102                <+>
 103                eelem "a" += sattr "href" loc
 104                          += txt loc
 105                <+>
 106                txt ". This is not a permanent relocation."
 107
 108         SeeOther
 109             → txt ("The resource at " ⧺ path ⧺ " can be found at ")
 110                <+>
 111                eelem "a" += sattr "href" loc
 112                          += txt loc
 113                <+>
 114                txt "."
 115
 116         TemporaryRedirect
 117             → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
 118                <+>
 119                eelem "a" += sattr "href" loc
 120                          += txt loc
 121                <+>
 122                txt "."
 123
 124         -- 4xx
 125         BadRequest
 126             → txt "The server could not understand the request you sent."
 127
 128         Unauthorized
 129             → txt ("You need a valid authentication to access " ⧺ path)
 130
 131         Forbidden
 132             → txt ("You don't have permission to access " ⧺ path)
 133
 134         NotFound
 135             → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
 136
 137         Gone
 138             → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
 139
 140         RequestEntityTooLarge
 141             → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
 142
 143         RequestURITooLarge
 144             → txt "The request URI you sent was too large to accept."
 145
 146         -- 5xx
 147         InternalServerError
 148             → txt ("An internal server error has occured during the process of your request to " ⧺ path)
 149
 150         ServiceUnavailable
 151             → txt "The service is temporarily unavailable. Try later."
 152
 153         _  → none
 154
 155     where
 156       path ∷ String
 157       path = let uri = reqURI $ fromJust req
 158              in
 159                uriPath uri
 160
 161       loc ∷ String
 162       loc = A.toString $ fromJust $ getHeader "Location" res