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