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