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