Network/HTTP/Lucu/StatusCode/Internal.hs

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