2 ExistentialQuantification
4 , MultiParamTypeClasses
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13 module Network.HTTP.Lucu.Response.StatusCode.Internal
19 import Control.Applicative
20 import Control.Applicative.Unicode
21 import Control.Monad.Unicode
22 import Data.Ascii (Ascii, AsciiBuilder)
23 import qualified Data.Ascii as A
24 import Data.Attoparsec.Char8
25 import qualified Data.Attoparsec.Lazy as LP
26 import qualified Data.ByteString.Lazy.Char8 as Lazy
27 import Data.Convertible.Base
28 import Data.Convertible.Instances.Ascii ()
29 import Data.Convertible.Utils
32 import Language.Haskell.TH.Lib
33 import Language.Haskell.TH.Syntax
34 import Language.Haskell.TH.Quote
35 import Network.HTTP.Lucu.OrphanInstances ()
36 import Network.HTTP.Lucu.Parser
37 import Prelude.Unicode
39 -- |Type class for HTTP status codes.
41 -- Declaring types for each statuses is surely a pain. See:
42 -- 'statusCodes' quasi-quoter.
44 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
45 class (Eq sc, Show sc) ⇒ StatusCode sc where
46 -- |Return the 3-digit integer for this status e.g. @200@
47 numericCode ∷ sc → Int
48 -- |Return the combination of 3-digit integer and reason phrase
49 -- for this status e.g. @200 OK@
50 textualStatus ∷ sc → AsciiBuilder
51 -- |Wrap the status code into 'SomeStatusCode'.
52 fromStatusCode ∷ sc → SomeStatusCode
53 {-# INLINE CONLIKE fromStatusCode #-}
54 fromStatusCode = SomeStatusCode
56 instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
57 {-# INLINE convertSuccess #-}
58 convertSuccess = fromStatusCode
60 instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
61 {-# INLINE convertSuccess #-}
62 convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
64 instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
65 {-# INLINE convertSuccess #-}
66 convertSuccess = textualStatus
68 instance StatusCode sc ⇒ ConvertAttempt sc SomeStatusCode where
69 {-# INLINE convertAttempt #-}
70 convertAttempt = return ∘ cs
72 instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
73 {-# INLINE convertAttempt #-}
74 convertAttempt = return ∘ cs
76 instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
77 {-# INLINE convertAttempt #-}
78 convertAttempt = return ∘ cs
80 -- |Container type for the 'StatusCode' type class.
82 = ∀sc. StatusCode sc ⇒ SomeStatusCode !sc
84 -- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and
85 -- @β@ are said to be equivalent iff @'numericCode' α '=='
86 -- 'numericCode' β@.
87 instance Eq SomeStatusCode where
89 (==) = (∘ numericCode) ∘ (==) ∘ numericCode
91 instance Show SomeStatusCode where
92 show (SomeStatusCode sc) = show sc
94 instance StatusCode SomeStatusCode where
95 {-# INLINE numericCode #-}
96 numericCode (SomeStatusCode sc) = numericCode sc
97 {-# INLINE textualStatus #-}
98 textualStatus (SomeStatusCode sc) = textualStatus sc
99 {-# INLINE CONLIKE fromStatusCode #-}
102 -- |'QuasiQuoter' for 'StatusCode' declarations.
104 -- Top-level splicing
110 -- 405 Method Not Allowed
117 -- data OK = OK deriving ('Eq', 'Show')
118 -- instance 'StatusCode' OK where
119 -- 'numericCode' _ = 200
120 -- 'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
122 -- data BadRequest = BadRequest deriving ('Eq', 'Show')
123 -- instance 'StatusCode' BadRequest where
124 -- 'numericCode' _ = 400
125 -- 'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
127 -- data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
128 -- instance 'StatusCode' MethodNotAllowed where
129 -- 'numericCode' _ = 405
130 -- 'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
132 statusCodes ∷ QuasiQuoter
133 statusCodes = QuasiQuoter {
134 quoteExp = const unsupported
135 , quotePat = const unsupported
136 , quoteType = const unsupported
137 , quoteDec = (concat <$>)
138 ∘ (mapM statusDecl =≪)
143 unsupported ∷ Monad m ⇒ m α
144 unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
146 parseStatusCodes ∷ Monad m ⇒ Lazy.ByteString → m [(Int, [Ascii])]
148 = case LP.parse pairs src of
150 → fail $ "Unparsable status codes: "
151 ⧺ intercalate ", " eCtx
157 pairs ∷ Parser [(Int, [Ascii])]
158 pairs = do skipMany endOfLine
159 xs ← sepBy pair (skipMany1 endOfLine)
166 pair ∷ Parser (Int, [Ascii])
170 phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
176 word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
178 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
179 statusDecl (num, phrase) = (:) <$> dataDecl ⊛ instanceDecl
182 dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]
185 name = mkName $ concatMap cs phrase
188 con = normalC name []
190 instanceDecl ∷ Q [Dec]
192 = [d| instance StatusCode $typ where
193 {-# INLINE CONLIKE numericCode #-}
194 numericCode _ = $(lift num)
195 {-# INLINE textualStatus #-}
196 textualStatus _ = cs $(lift txt)
203 txt = mconcat $ intersperse "\x20"
204 $ A.unsafeFromString (show num) : phrase