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