Network/HTTP/Lucu/StatusCode/Internal.hs

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