2 ExistentialQuantification
4 , MultiParamTypeClasses
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13 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
28 import Data.Eq.Indirect
30 import Language.Haskell.TH.Lib
31 import Language.Haskell.TH.Syntax
32 import Language.Haskell.TH.Quote
33 import Network.HTTP.Lucu.Parser
34 import Prelude.Unicode
36 -- |Type class for HTTP status codes.
38 -- Declaring types for each statuses is surely a pain. See:
39 -- 'statusCodes' quasi-quoter.
41 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
42 class (Eq sc, Show sc) ⇒ StatusCode sc where
43 -- |Return the 3-digit integer for this status e.g. @200@
44 numericCode ∷ sc → Int
45 -- |Return the combination of 3-digit integer and reason phrase
46 -- for this status e.g. @200 OK@
47 textualStatus ∷ sc → AsciiBuilder
48 -- |Wrap the status code into 'SomeStatusCode'.
49 fromStatusCode ∷ sc → SomeStatusCode
50 fromStatusCode = SomeStatusCode
52 -- |Equivalence of 'StatusCode's. Two 'StatusCode's @a@ and @b@ are
53 -- said to be equivalent iff @'numericCode' a '==' 'numericCode' b@.
54 instance StatusCode sc ⇒ Eq' sc where
56 {-# INLINE CONLIKE unify #-}
59 -- |Container type for the 'StatusCode' type class.
61 = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
63 instance Eq SomeStatusCode where
64 {-# INLINE CONLIKE (==) #-}
67 instance Show SomeStatusCode where
68 show (SomeStatusCode sc) = show sc
70 instance StatusCode SomeStatusCode where
71 numericCode (SomeStatusCode sc) = numericCode sc
72 textualStatus (SomeStatusCode sc) = textualStatus sc
75 instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
76 {-# INLINE convertSuccess #-}
77 convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
79 instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
80 {-# INLINE convertSuccess #-}
81 convertSuccess = textualStatus
83 instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
84 {-# INLINE convertAttempt #-}
85 convertAttempt = return ∘ cs
87 instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
88 {-# INLINE convertAttempt #-}
89 convertAttempt = return ∘ cs
91 -- |'QuasiQuoter' for 'StatusCode' declarations.
99 -- 405 Method Not Allowed
106 -- data OK = OK deriving ('Eq', 'Show')
108 -- 'numericCode' _ = 200
109 -- 'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
111 -- data BadRequest = BadRequest deriving ('Eq', 'Show')
112 -- instance BadRequest where
113 -- 'numericCode' _ = 400
114 -- 'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
116 -- data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
117 -- instance MethodNotAllowed where
118 -- 'numericCode' _ = 405
119 -- 'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
121 statusCodes ∷ QuasiQuoter
122 statusCodes = QuasiQuoter {
123 quoteExp = const unsupported
124 , quotePat = const unsupported
125 , quoteType = const unsupported
126 , quoteDec = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack
129 unsupported ∷ Monad m ⇒ m α
130 unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
132 parseStatusCodes ∷ Lazy.ByteString → [(Int, [Ascii])]
134 = case LP.parse pairs src of
136 → error $ "Unparsable status codes: "
137 ⧺ intercalate ", " eCtx
143 pairs ∷ Parser [(Int, [Ascii])]
144 pairs = do skipMany endOfLine
145 xs ← sepBy pair (skipMany1 endOfLine)
152 pair ∷ Parser (Int, [Ascii])
156 phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
162 word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
164 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
165 statusDecl (num, phrase)
171 name = mkName $ concatMap cs phrase
174 dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]
176 instanceDecl ∷ Q [Dec]
178 = [d| instance StatusCode $typ where
179 {-# INLINE CONLIKE numericCode #-}
180 numericCode _ = $(lift num)
181 {-# INLINE CONLIKE textualStatus #-}
182 textualStatus _ = $txt
189 con = return $ NormalC name []
192 txt = [| cs ($(lift txt') ∷ Ascii) |]
195 txt' = concat $ intersperse "\x20"
196 $ show num : map cs phrase