Network/HTTP/Lucu/DefaultPage.hs

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