2 ExistentialQuantification
4 , MultiParamTypeClasses
10 {-# OPTIONS_GHC -fno-warn-orphans #-}
11 module Network.HTTP.Lucu.StatusCode.Internal
19 import Control.Applicative
20 import Data.Ascii (Ascii, AsciiBuilder)
21 import qualified Data.Ascii as A
22 import Data.Attoparsec.Char8
23 import qualified Data.Attoparsec.Lazy as LP
24 import qualified Data.ByteString.Lazy.Char8 as Lazy
25 import Data.Convertible.Base
26 import Data.Convertible.Instances.Ascii ()
27 import Data.Convertible.Utils
29 import Language.Haskell.TH.Lib
30 import Language.Haskell.TH.Syntax
31 import Language.Haskell.TH.Quote
32 import Network.HTTP.Lucu.Parser
33 import Prelude.Unicode
35 -- |The type class for HTTP status codes.
37 -- Declaring types for each statuses is surely a pain. See:
40 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
41 class Show sc ⇒ StatusCode sc where
42 -- |Return the 3-digit integer for this status e.g. @200@
43 numericCode ∷ sc → Int
44 -- |Return the combination of 3-digit integer and reason phrase
45 -- for this status e.g. @200 OK@
46 textualStatus ∷ sc → AsciiBuilder
47 -- |Wrap the status code into 'SomeStatusCode'.
48 fromStatusCode ∷ sc → SomeStatusCode
49 fromStatusCode = SomeStatusCode
51 -- |Container type for 'StatusCode' type class.
53 = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
55 instance Show SomeStatusCode where
56 show (SomeStatusCode sc) = show sc
58 instance Eq SomeStatusCode where
59 (SomeStatusCode α) == (SomeStatusCode β) = α ≈ β
62 -- |Equivalence of 'StatusCode's. Two 'StatusCode's @a@ and @b@ are
63 -- said to be equivalent iff @'numericCode' a '==' 'numericCode' b@.
65 -- U+2248, ALMOST EQUAL TO
66 (≈) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
68 α ≈ β = numericCode α ≡ numericCode β
70 -- |@(a ≉ b) '==' 'not' (a ≈ b)@
72 -- U+2249, NOT ALMOST EQUAL TO
73 (≉) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
77 instance StatusCode SomeStatusCode where
78 numericCode (SomeStatusCode sc) = numericCode sc
79 textualStatus (SomeStatusCode sc) = textualStatus sc
82 instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
83 {-# INLINE convertSuccess #-}
84 convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
86 instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
87 {-# INLINE convertSuccess #-}
88 convertSuccess = textualStatus
90 instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
91 {-# INLINE convertAttempt #-}
92 convertAttempt = return ∘ cs
94 instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
95 {-# INLINE convertAttempt #-}
96 convertAttempt = return ∘ cs
98 -- |'QuasiQuoter' for 'StatusCode' declarations.
100 -- Top-level splicing
106 -- 405 Method Not Allowed
113 -- data OK = OK deriving ('Show')
115 -- 'numericCode' _ = 200
116 -- 'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
118 -- data BadRequest = BadRequest deriving ('Show')
119 -- instance BadRequest where
120 -- 'numericCode' _ = 400
121 -- 'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
123 -- data MethodNotAllowed = MethodNotAllowed deriving ('Show')
124 -- instance MethodNotAllowed where
125 -- 'numericCode' _ = 405
126 -- 'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
128 statusCodes ∷ QuasiQuoter
129 statusCodes = QuasiQuoter {
130 quoteExp = const unsupported
131 , quotePat = const unsupported
132 , quoteType = const unsupported
133 , quoteDec = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack
136 unsupported ∷ Monad m ⇒ m α
137 unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
139 parseStatusCodes ∷ Lazy.ByteString → [(Int, [Ascii])]
141 = case LP.parse pairs src of
143 → error $ "Unparsable status codes: "
144 ⧺ intercalate ", " eCtx
150 pairs ∷ Parser [(Int, [Ascii])]
151 pairs = do skipMany endOfLine
152 xs ← sepBy pair (skipMany1 endOfLine)
159 pair ∷ Parser (Int, [Ascii])
163 phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
169 word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
171 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
172 statusDecl (num, phrase)
178 name = mkName $ concatMap cs phrase
181 dataDecl = dataD (cxt []) name [] [con] [''Show]
183 instanceDecl ∷ Q [Dec]
185 = [d| instance StatusCode $typ where
186 {-# INLINE numericCode #-}
187 numericCode _ = $(lift num)
188 {-# INLINE textualStatus #-}
189 textualStatus _ = $txt
196 con = return $ NormalC name []
199 txt = [| cs ($(lift txt') ∷ Ascii) |]
202 txt' = concat $ intersperse "\x20"
203 $ show num : map cs phrase