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