Network/HTTP/Lucu/StatusCode/Internal.hs

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