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