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