StatusCode is now a type class, not an algebraic data type.

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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 19a72936e2718608034e22c15885fb9ea2fbe747..8fcc37d74800cfd1a75eeeddc056d73576ab666d 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE
     OverloadedStrings
+  , RecordWildCards
+  , TypeOperators
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.DefaultPage
@@ -44,7 +46,11 @@ defaultPageContentType ∷ Ascii
 {-# INLINE defaultPageContentType #-}
 defaultPageContentType = "application/xhtml+xml"
 
-mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
+mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc)
+              ⇒ Config
+              → sc
+              → b ⇝ XmlTree
+              → b ⇝ XmlTree
 {-# INLINEABLE mkDefaultPage #-}
 mkDefaultPage conf status msgA
     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
@@ -67,82 +73,71 @@ mkDefaultPage conf status msgA
                      += eelem "hr"
                      += ( eelem "address" += txt sig ))))
 
-getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
+getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree
 {-# INLINEABLE getMsg #-}
-getMsg req res
-    = case resStatus res of
-        -- 1xx は body を持たない
-        -- 2xx の body は補完しない
-
-        -- 3xx
-        MovedPermanently
-            → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
-               <+>
-               eelem "a" += sattr "href" loc
-                         += txt loc
-               <+>
-               txt " permanently."
-
-        Found
-            → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
-               <+>
-               eelem "a" += sattr "href" loc
-                         += txt loc
-               <+>
-               txt ". This is not a permanent relocation."
-
-        SeeOther
-            → txt ("The resource at " ⧺ path ⧺ " can be found at ")
-               <+>
-               eelem "a" += sattr "href" loc
-                         += txt loc
-               <+>
-               txt "."
-
-        TemporaryRedirect
-            → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
-               <+>
-               eelem "a" += sattr "href" loc
-                         += txt loc
-               <+>
-               txt "."
-
-        -- 4xx
-        BadRequest
-            → txt "The server could not understand the request you sent."
-
-        Unauthorized
-            → txt ("You need a valid authentication to access " ⧺ path)
-
-        Forbidden
-            → txt ("You don't have permission to access " ⧺ path)
-
-        NotFound
-            → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
-
-        Gone
-            → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
-
-        RequestEntityTooLarge
-            → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
-
-        RequestURITooLarge
-            → txt "The request URI you sent was too large to accept."
-
-        -- 5xx
-        InternalServerError
-            → txt ("An internal server error has occured during the process of your request to " ⧺ path)
-
-        ServiceUnavailable
-            → txt "The service is temporarily unavailable. Try later."
-
-        _  → none
-
+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
+        = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
+          <+>
+          eelem "a" += sattr "href" loc
+                    += txt loc
+          <+>
+          txt " permanently."
+
+    | toStatusCode resStatus ≡ Just Found
+        = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
+          <+>
+          eelem "a" += sattr "href" loc
+                    += txt loc
+          <+>
+          txt ". This is not a permanent relocation."
+
+    | toStatusCode resStatus ≡ Just SeeOther
+        = txt ("The resource at " ⧺ path ⧺ " can be found at ")
+          <+>
+          eelem "a" += sattr "href" loc
+                    += txt loc
+          <+>
+          txt "."
+
+    | toStatusCode resStatus ≡ Just TemporaryRedirect
+        = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
+          <+>
+          eelem "a" += sattr "href" loc
+                    += txt loc
+          <+>
+          txt "."
+
+      -- 4xx:
+    | toStatusCode resStatus ≡ Just BadRequest
+        = txt "The server could not understand the request you sent."
+    | toStatusCode resStatus ≡ Just Unauthorized
+        = txt ("You need a valid authentication to access " ⧺ path)
+    | toStatusCode resStatus ≡ Just Forbidden
+        = txt ("You don't have permission to access " ⧺ path)
+    | toStatusCode resStatus ≡ Just NotFound
+        = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
+    | toStatusCode resStatus ≡ Just Gone
+        = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
+    | toStatusCode resStatus ≡ Just RequestEntityTooLarge
+        = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
+    | toStatusCode resStatus ≡ Just RequestURITooLarge
+        = txt "The request URI you sent was too large to accept."
+
+      -- 5xx:
+    | toStatusCode resStatus ≡ Just InternalServerError
+        = txt ("An internal server error has occured during the process of your request to " ⧺ path)
+    | toStatusCode resStatus ≡ Just ServiceUnavailable
+        = txt "The service is temporarily unavailable. Try later."
+
+    | otherwise
+        = none
     where
       path ∷ String
-      path = let uri = reqURI $ fromJust req
-             in
-               uriPath uri
+      path = uriPath $ reqURI $ fromJust req
 
       loc ∷ String
       loc = A.toString $ fromJust $ getHeader "Location" res