Network/HTTP/Lucu/StatusCode/Internal.hs

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