Network/HTTP/Lucu/DefaultPage.hs

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