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