Network/HTTP/Lucu/DefaultPage.hs

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