Network/HTTP/Lucu/DefaultPage.hs

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