Network/HTTP/Lucu/DefaultPage.hs

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