Network/HTTP/Lucu/DefaultPage.hs

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