]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/StatusCode/Internal.hs
e3122da1f55e21af4587abf5cf7d4175e8ccdd93
[Lucu.git] / Network / HTTP / Lucu / StatusCode / Internal.hs
1 {-# LANGUAGE
2     ExistentialQuantification
3   , FlexibleInstances
4   , MultiParamTypeClasses
5   , OverlappingInstances
6   , TemplateHaskell
7   , UndecidableInstances
8   , UnicodeSyntax
9   , ViewPatterns
10   #-}
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 module Network.HTTP.Lucu.StatusCode.Internal
13     ( StatusCode(..)
14     , SomeStatusCode
15     , (≈)
16     , (≉)
17     , statusCodes
18     )
19     where
20 import Control.Applicative
21 import Data.Ascii (Ascii, AsciiBuilder)
22 import qualified Data.Ascii as A
23 import Data.Attoparsec.Char8
24 import qualified Data.Attoparsec.Lazy as LP
25 import qualified Data.ByteString.Lazy.Char8 as Lazy
26 import Data.Convertible.Base
27 import Data.Convertible.Instances.Ascii ()
28 import Data.Convertible.Utils
29 import Data.List
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
35
36 -- |Type class for HTTP status codes.
37 --
38 -- Declaring types for each statuses is surely a pain. See:
39 -- 'statusCodes' quasi-quoter.
40 --
41 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
42 class 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
51
52 instance StatusCode sc ⇒ Eq sc where
53     (==) = (≈)
54
55 -- |Container type for the 'StatusCode' type class.
56 data SomeStatusCode
57     = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
58
59 instance Show SomeStatusCode where
60     show (SomeStatusCode sc) = show sc
61
62 infix 4 ≈, ≉
63 -- |Equivalence of 'StatusCode's. Two 'StatusCode's @a@ and @b@ are
64 -- said to be equivalent iff @'numericCode' a '==' 'numericCode' b@.
65 --
66 -- U+2248, ALMOST EQUAL TO
67 (≈) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
68 {-# INLINE (≈) #-}
69 α ≈ β = numericCode α ≡ numericCode β
70
71 -- |@(a ≉ b) '==' 'not' (a ≈ b)@
72 --
73 -- U+2249, NOT ALMOST EQUAL TO
74 (≉) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
75 {-# INLINE (≉) #-}
76 (≉) = ((¬) ∘) ∘ (≈)
77
78 instance StatusCode SomeStatusCode where
79     numericCode   (SomeStatusCode sc) = numericCode   sc
80     textualStatus (SomeStatusCode sc) = textualStatus sc
81     fromStatusCode = id
82
83 instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
84     {-# INLINE convertSuccess #-}
85     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
86
87 instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
88     {-# INLINE convertSuccess #-}
89     convertSuccess = textualStatus
90
91 instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
92     {-# INLINE convertAttempt #-}
93     convertAttempt = return ∘ cs
94
95 instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
96     {-# INLINE convertAttempt #-}
97     convertAttempt = return ∘ cs
98
99 -- |'QuasiQuoter' for 'StatusCode' declarations.
100 --
101 -- Top-level splicing
102 --
103 -- @
104 --   ['statusCodes'|
105 --   200 OK
106 --   400 Bad Request
107 --   405 Method Not Allowed
108 --   |]
109 -- @
110 --
111 -- becomes:
112 --
113 -- @
114 --   data OK = OK deriving ('Show')
115 --   instance OK where
116 --     'numericCode'   _ = 200
117 --     'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
118 --
119 --   data BadRequest = BadRequest deriving ('Show')
120 --   instance BadRequest where
121 --     'numericCode'   _ = 400
122 --     'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
123 --
124 --   data MethodNotAllowed = MethodNotAllowed deriving ('Show')
125 --   instance MethodNotAllowed where
126 --     'numericCode'   _ = 405
127 --     'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
128 -- @
129 statusCodes ∷ QuasiQuoter
130 statusCodes = QuasiQuoter {
131                 quoteExp  = const unsupported
132               , quotePat  = const unsupported
133               , quoteType = const unsupported
134               , quoteDec  = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack
135               }
136     where
137       unsupported ∷ Monad m ⇒ m α
138       unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
139
140 parseStatusCodes ∷ Lazy.ByteString → [(Int, [Ascii])]
141 parseStatusCodes src
142     = case LP.parse pairs src of
143         LP.Fail _ eCtx e
144             → error $ "Unparsable status codes: "
145                     ⧺ intercalate ", " eCtx
146                     ⧺ ": "
147                     ⧺ e
148         LP.Done _ xs
149             → xs
150     where
151       pairs ∷ Parser [(Int, [Ascii])]
152       pairs = do skipMany endOfLine
153                  xs ← sepBy pair (skipMany1 endOfLine)
154                  skipMany endOfLine
155                  endOfInput
156                  return xs
157               <?>
158               "pairs"
159
160       pair ∷ Parser (Int, [Ascii])
161       pair = do skipSpace
162                 num ← decimal
163                 skipSpace1
164                 phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
165                 return (num, phrase)
166              <?>
167              "pair"
168
169       word ∷ Parser Ascii
170       word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
171
172 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
173 statusDecl (num, phrase)
174     = do a  ← dataDecl
175          bs ← instanceDecl
176          return (a:bs)
177     where
178       name ∷ Name
179       name = mkName $ concatMap cs phrase
180
181       dataDecl ∷ Q Dec
182       dataDecl = dataD (cxt []) name [] [con] [''Show]
183
184       instanceDecl ∷ Q [Dec]
185       instanceDecl
186           = [d| instance StatusCode $typ where
187                   {-# INLINE CONLIKE numericCode #-}
188                   numericCode _ = $(lift num)
189                   {-# INLINE CONLIKE textualStatus #-}
190                   textualStatus _ = $txt
191               |]
192
193       typ ∷ Q Type
194       typ = conT name
195
196       con ∷ Q Con
197       con = return $ NormalC name []
198
199       txt ∷ Q Exp
200       txt = [| cs ($(lift txt') ∷ Ascii) |]
201
202       txt' ∷ String
203       txt' = concat $ intersperse "\x20"
204                     $ show num : map cs phrase