X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=f318fcf7ca7a9cb9a0b2ec7d14ec166ab54d9a84;hb=42aad5a;hp=e61a6a50242779b91c665218ea565cbb85d69955;hpb=9961a721f98b101825ef154a2122c1fc2fa6d1ac;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index e61a6a5..f318fcf 100644
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -1,72 +1,131 @@
+{-# LANGUAGE
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings
+  , RecordWildCards
+  , TemplateHaskell
+  , UnicodeSyntax
+  , ViewPatterns
+  #-}
+-- |Definition of things related on HTTP response.
 module Network.HTTP.Lucu.Response
-    ( StatusCode(..)
+    ( -- * Class and Types
+      StatusCode(..)
+    , SomeStatusCode
     , Response(..)
+    , statusCodes
+    , module Network.HTTP.Lucu.StatusCode
+
+      -- * Functions
+    , emptyResponse
+    , setStatusCode
+    , resCanHaveBody
+
+    , isInformational
+    , isSuccessful
+    , isRedirection
+    , isError
+    , isClientError
+    , isServerError
     )
     where
+import Data.Ascii (Ascii, AsciiBuilder)
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
+import Data.Eq.Indirect
+import Data.Monoid.Unicode
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.StatusCode
+import Network.HTTP.Lucu.StatusCode.Internal
+import Prelude.Unicode
 
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
-import           Network.HTTP.Lucu.Headers
-import           Network.HTTP.Lucu.HttpVersion
-
-data StatusCode = Continue
-                | SwitchingProtocols
-                | Processing
-                -- 
-                | Ok
-                | Created
-                | Accepted
-                | NonAuthoritativeInformation
-                | NoContent
-                | ResetContent
-                | PartialContent
-                | MultiStatus
-                --
-                | MultipleChoices
-                | MovedPermanently
-                | Found
-                | SeeOther
-                | NotModified
-                | UseProxy
-                | TemporaryRedirect
-                --
-                | BadRequest
-                | Unauthorized
-                | PaymentRequired
-                | Forbidden
-                | NotFound
-                | MethodNotAllowed
-                | NotAcceptable
-                | ProxyAuthenticationRequired
-                | RequestTimeout
-                | Conflict
-                | Gone
-                | LengthRequired
-                | PreconditionFailed
-                | RequestEntityTooLarge
-                | RequestURITooLarge
-                | UnsupportedMediaType
-                | RequestRangeNotSatisfiable
-                | ExpectationFailed
-                | UnprocessableEntitiy
-                | Locked
-                | FailedDependency
-                --
-                | InternalServerError
-                | NotImplemented
-                | BadGateway
-                | ServiceUnavailable
-                | GatewayTimeout
-                | HttpVersionNotSupported
-                | InsufficientStorage
-
+-- |This is the definition of an HTTP response.
 data Response = Response {
-      resVersion :: HttpVersion
-    , resStatus  :: StatusCode
-    , resHeaders :: Headers
-    , resBody    :: Maybe ByteString
-    }
+      resVersion ∷ !HttpVersion
+    , resStatus  ∷ !SomeStatusCode
+    , resHeaders ∷ !Headers
+    } deriving (Show, Eq)
 
 instance HasHeaders Response where
-    getHeaders = resHeaders
+    getHeaders         = resHeaders
     setHeaders res hdr = res { resHeaders = hdr }
+
+instance ConvertSuccess Response Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess Response AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess (Response {..})
+        = cs resVersion           ⊕
+          cs (" " ∷ Ascii)        ⊕
+          cs resStatus            ⊕
+          cs ("\x0D\x0A" ∷ Ascii) ⊕
+          cs resHeaders
+
+deriveAttempts [ ([t| Response |], [t| Ascii        |])
+               , ([t| Response |], [t| AsciiBuilder |])
+               ]
+
+-- |Returns an HTTP\/1.1 'Response' with no header fields.
+emptyResponse ∷ StatusCode sc ⇒ sc → Response
+emptyResponse sc
+    = Response {
+        resVersion = HttpVersion 1 1
+      , resStatus  = fromStatusCode sc
+      , resHeaders = (∅)
+      }
+
+-- |@'setStatusCode' sc res@ sets the status code of @res@ to @sc@.
+setStatusCode ∷ StatusCode sc ⇒ sc → Response → Response
+setStatusCode sc res
+    = res {
+        resStatus = fromStatusCode sc
+      }
+
+-- |Returns 'True' iff a given 'Response' allows the existence of
+-- response entity body.
+resCanHaveBody ∷ Response → Bool
+{-# INLINEABLE resCanHaveBody #-}
+resCanHaveBody (Response {..})
+    | isInformational resStatus = False
+    | resStatus ≡: NoContent    = False
+    | resStatus ≡: ResetContent = False
+    | resStatus ≡: NotModified  = False
+    | otherwise                 = True
+
+-- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@.
+isInformational ∷ StatusCode sc ⇒ sc → Bool
+{-# INLINE isInformational #-}
+isInformational = satisfy (< 200)
+
+-- |@'isSuccessful' sc@ returns 'True' iff @200 '<=' sc '<' 300@.
+isSuccessful ∷ StatusCode sc ⇒ sc → Bool
+{-# INLINE isSuccessful #-}
+isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300)
+
+-- |@'isRedirection' sc@ returns 'True' iff @300 '<=' sc '<' 400@.
+isRedirection ∷ StatusCode sc ⇒ sc → Bool
+{-# INLINE isRedirection #-}
+isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400)
+
+-- |@'isError' sc@ returns 'True' iff @400 '<=' sc@
+isError ∷ StatusCode sc ⇒ sc → Bool
+{-# INLINE isError #-}
+isError = satisfy (≥ 400)
+
+-- |@'isClientError' sc@ returns 'True' iff @400 '<=' sc '<' 500@.
+isClientError ∷ StatusCode sc ⇒ sc → Bool
+{-# INLINE isClientError #-}
+isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500)
+
+-- |@'isServerError' sc@ returns 'True' iff @500 '<=' sc@.
+isServerError ∷ StatusCode sc ⇒ sc → Bool
+{-# INLINE isServerError #-}
+isServerError = satisfy (≥ 500)
+
+satisfy ∷ StatusCode sc ⇒ (Int → Bool) → sc → Bool
+{-# INLINE satisfy #-}
+satisfy p (numericCode → num) = p num