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 let page = getDefaultPage itrConfig itrRequest res
  53                   putTMVar itrBodyToSend (BB.fromLazyText page)
  54
  55 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
  56 {-# INLINEABLE mkDefaultPage #-}
  57 mkDefaultPage conf status msgA
  58     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
  59           sig  = concat [ A.toString (cnfServerSoftware conf)
  60                         , " at "
  61                         , T.unpack (cnfServerHost conf)
  62                         ]
  63       in ( eelem "/"
  64            += ( eelem "html"
  65                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
  66                 += ( eelem "head"
  67                      += ( eelem "title"
  68                           += txt sStr
  69                         ))
  70                 += ( eelem "body"
  71                      += ( eelem "h1"
  72                           += txt sStr
  73                         )
  74                      += ( eelem "p" += msgA )
  75                      += eelem "hr"
  76                      += ( eelem "address" += txt sig ))))
  77
  78 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
  79 {-# INLINEABLE getMsg #-}
  80 getMsg req res
  81     = case resStatus res of
  82         -- 1xx は body を持たない
  83         -- 2xx の body は補完しない
  84
  85         -- 3xx
  86         MovedPermanently
  87             → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
  88                <+>
  89                eelem "a" += sattr "href" loc
  90                          += txt loc
  91                <+>
  92                txt " permanently."
  93
  94         Found
  95             → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
  96                <+>
  97                eelem "a" += sattr "href" loc
  98                          += txt loc
  99                <+>
 100                txt ". This is not a permanent relocation."
 101
 102         SeeOther
 103             → txt ("The resource at " ⧺ path ⧺ " can be found at ")
 104                <+>
 105                eelem "a" += sattr "href" loc
 106                          += txt loc
 107                <+>
 108                txt "."
 109
 110         TemporaryRedirect
 111             → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
 112                <+>
 113                eelem "a" += sattr "href" loc
 114                          += txt loc
 115                <+>
 116                txt "."
 117
 118         -- 4xx
 119         BadRequest
 120             → txt "The server could not understand the request you sent."
 121
 122         Unauthorized
 123             → txt ("You need a valid authentication to access " ⧺ path)
 124
 125         Forbidden
 126             → txt ("You don't have permission to access " ⧺ path)
 127
 128         NotFound
 129             → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
 130
 131         Gone
 132             → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
 133
 134         RequestEntityTooLarge
 135             → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
 136
 137         RequestURITooLarge
 138             → txt "The request URI you sent was too large to accept."
 139
 140         -- 5xx
 141         InternalServerError
 142             → txt ("An internal server error has occured during the process of your request to " ⧺ path)
 143
 144         ServiceUnavailable
 145             → txt "The service is temporarily unavailable. Try later."
 146
 147         _  → none
 148
 149     where
 150       path ∷ String
 151       path = let uri = reqURI $ fromJust req
 152              in
 153                uriPath uri
 154
 155       loc ∷ String
 156       loc = A.toString $ fromJust $ getHeader "Location" res