Network/HTTP/Lucu/Response/StatusCode/Internal.hs

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