new module: Resource.Dispatcher

[Lucu.git] / Network / HTTP / Lucu / DefaultPage.hs

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 8fcc37d74800cfd1a75eeeddc056d73576ab666d..076ad1059e029b85bab761e9ada6537a2a94061a 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -18,6 +18,7 @@ import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
+import qualified Data.CaseInsensitive as CI
 import Data.Maybe
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Config
@@ -56,7 +57,7 @@ mkDefaultPage conf status msgA
     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
           sig  = concat [ A.toString (cnfServerSoftware conf)
                         , " at "
-                        , T.unpack (cnfServerHost conf)
+                        , T.unpack $ CI.original $ cnfServerHost conf
                         ]
       in ( eelem "/"
            += ( eelem "html"
@@ -79,7 +80,7 @@ getMsg req res@(Response {..})
     -- 1xx responses don't have a body.
     -- 2xx responses don't need a body to be completed.
     -- 3xx:
-    | toStatusCode resStatus ≡ Just MovedPermanently
+    | resStatus ≈ MovedPermanently
         = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
           <+>
           eelem "a" += sattr "href" loc
@@ -87,7 +88,7 @@ getMsg req res@(Response {..})
           <+>
           txt " permanently."
 
-    | toStatusCode resStatus ≡ Just Found
+    | resStatus ≈ Found
         = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
           <+>
           eelem "a" += sattr "href" loc
@@ -95,7 +96,7 @@ getMsg req res@(Response {..})
           <+>
           txt ". This is not a permanent relocation."
 
-    | toStatusCode resStatus ≡ Just SeeOther
+    | resStatus ≈ SeeOther
         = txt ("The resource at " ⧺ path ⧺ " can be found at ")
           <+>
           eelem "a" += sattr "href" loc
@@ -103,7 +104,7 @@ getMsg req res@(Response {..})
           <+>
           txt "."
 
-    | toStatusCode resStatus ≡ Just TemporaryRedirect
+    | resStatus ≈ TemporaryRedirect
         = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
           <+>
           eelem "a" += sattr "href" loc
@@ -112,25 +113,25 @@ getMsg req res@(Response {..})
           txt "."
 
       -- 4xx:
-    | toStatusCode resStatus ≡ Just BadRequest
+    | resStatus ≈ BadRequest
         = txt "The server could not understand the request you sent."
-    | toStatusCode resStatus ≡ Just Unauthorized
+    | resStatus ≈ Unauthorized
         = txt ("You need a valid authentication to access " ⧺ path)
-    | toStatusCode resStatus ≡ Just Forbidden
+    | resStatus ≈ Forbidden
         = txt ("You don't have permission to access " ⧺ path)
-    | toStatusCode resStatus ≡ Just NotFound
+    | resStatus ≈ NotFound
         = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
-    | toStatusCode resStatus ≡ Just Gone
+    | resStatus ≈ Gone
         = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
-    | toStatusCode resStatus ≡ Just RequestEntityTooLarge
+    | resStatus ≈ RequestEntityTooLarge
         = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
-    | toStatusCode resStatus ≡ Just RequestURITooLarge
+    | resStatus ≈ RequestURITooLarge
         = txt "The request URI you sent was too large to accept."
 
       -- 5xx:
-    | toStatusCode resStatus ≡ Just InternalServerError
+    | resStatus ≈ InternalServerError
         = txt ("An internal server error has occured during the process of your request to " ⧺ path)
-    | toStatusCode resStatus ≡ Just ServiceUnavailable
+    | resStatus ≈ ServiceUnavailable
         = txt "The service is temporarily unavailable. Try later."
 
     | otherwise