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          -- ヘッダが出力濟だったら意味が無い。
  49          when wroteHeader
  50                   $ fail "writeDefaultPage: the header has already been written"
  51
  52          resM <- readTVar (itrResponse itr)
  53
  54          -- Response が不明ならばページ書込も不可
  55          when (resM == Nothing)
  56                   $ fail "writeDefaultPage: response was Nothing"
  57
  58          let reqM = itrRequest itr
  59              res  = fromJust resM
  60              conf = itrConfig itr
  61              page = B.pack $ getDefaultPage conf reqM res
  62
  63          writeTVar (itrResponse itr)
  64                        $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
  65
  66          writeTVar (itrBodyToSend itr)
  67                        $ page
  68
  69
  70 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
  71 mkDefaultPage conf status msgA
  72     = let (sCode, sMsg) = statusCode status
  73           sig           = cnfServerSoftware conf
  74                           ++ " at "
  75                           ++ cnfServerHost conf
  76                           ++ ( case cnfServerPort conf of
  77                                  Service    serv -> ", service " ++ serv
  78                                  PortNumber num  -> ", port " ++ show num
  79                                  UnixSocket path -> ", unix socket " ++ show path
  80                              )
  81       in ( eelem "/"
  82            += ( eelem "html"
  83                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
  84                 += ( eelem "head"
  85                      += ( eelem "title"
  86                           += txt (printf "%03d %s" sCode sMsg)
  87                         ))
  88                 += ( eelem "body"
  89                      += ( eelem "h1"
  90                           += txt sMsg
  91                         )
  92                      += ( eelem "p" += msgA )
  93                      += eelem "hr"
  94                      += ( eelem "address" += txt sig ))))
  95
  96
  97 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
  98 getMsg req res
  99     = case resStatus res of
 100         -- 1xx は body を持たない
 101         -- 2xx の body は補完しない
 102
 103         -- 3xx
 104         MovedPermanently
 105             -> txt (printf "The resource at %s has been moved to " path)
 106                <+>
 107                eelem "a" += sattr "href" loc
 108                          += txt loc
 109                <+>
 110                txt " permanently."
 111
 112         Found
 113             -> txt (printf "The resource at %s is currently located at " path)
 114                <+>
 115                eelem "a" += sattr "href" loc
 116                          += txt loc
 117                <+>
 118                txt ". This is not a permanent relocation."
 119
 120         SeeOther
 121             -> txt (printf "The resource at %s can be found at " path)
 122                <+>
 123                eelem "a" += sattr "href" loc
 124                          += txt loc
 125                <+>
 126                txt "."
 127
 128         TemporaryRedirect
 129             -> txt (printf "The resource at %s is temporarily located at " path)
 130                <+>
 131                eelem "a" += sattr "href" loc
 132                          += txt loc
 133                <+>
 134                txt "."
 135
 136         -- 4xx
 137         BadRequest
 138             -> txt "The server could not understand the request you sent."
 139
 140         Unauthorized
 141             -> txt (printf "You need a valid authentication to access %s" path)
 142
 143         Forbidden
 144             -> txt (printf "You don't have permission to access %s" path)
 145
 146         NotFound
 147             -> txt (printf "The requested URL %s was not found on this server." path)
 148
 149         Gone
 150             -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
 151
 152         RequestEntityTooLarge
 153             -> txt (printf "The request entity you sent for %s was too big to accept." path)
 154
 155         RequestURITooLarge
 156             -> txt "The request URI you sent was too big to accept."
 157
 158         -- 5xx
 159         InternalServerError
 160             -> txt (printf "An internal server error has occured during the process of your request to %s" path)
 161
 162         ServiceUnavailable
 163             -> txt "The service is temporarily unavailable. Try later."
 164
 165         _  -> none
 166
 167
 168     where
 169       path :: String
 170       path = let uri = reqURI $ fromJust req
 171              in
 172                uriPath uri
 173
 174       loc :: String
 175       loc = fromJust $ getHeader "Location" res