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