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