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 &#x2249; b) '==' 'not' (a &#x2248; 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