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 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
  32 class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where
  33     -- |Return the 3-digit integer for this status e.g. @200@
  34     numericCode ∷ sc → Int
  35     -- |Return the combination of 3-digit integer and reason phrase
  36     -- for this status e.g. @200 OK@
  37     textualStatus ∷ sc → Ascii
  38     -- |Wrap the status code into 'SomeStatusCode'.
  39     fromStatusCode ∷ sc → SomeStatusCode
  40     fromStatusCode = SomeStatusCode
  41     -- |Cast the status code from 'SomeStatusCode'.
  42     toStatusCode ∷ SomeStatusCode → Maybe sc
  43     toStatusCode (SomeStatusCode sc) = cast sc
  44
  45 -- |FIXME: doc
  46 data SomeStatusCode
  47     = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
  48       deriving Typeable
  49
  50 instance Show SomeStatusCode where
  51     show (SomeStatusCode sc) = show sc
  52
  53 instance Eq SomeStatusCode where
  54     (SomeStatusCode α) == (SomeStatusCode β)
  55         = numericCode α ≡ numericCode β
  56
  57 instance StatusCode SomeStatusCode where
  58     numericCode   (SomeStatusCode sc) = numericCode   sc
  59     textualStatus (SomeStatusCode sc) = textualStatus sc
  60     fromStatusCode = id
  61     toStatusCode   = Just
  62
  63 -- |FIXME: doc
  64 statusCodes ∷ QuasiQuoter
  65 statusCodes = QuasiQuoter {
  66                 quoteExp  = const unsupported
  67               , quotePat  = const unsupported
  68               , quoteType = const unsupported
  69               , quoteDec  = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack
  70               }
  71     where
  72       unsupported ∷ Monad m ⇒ m α
  73       unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
  74
  75 parseStatusCodes ∷ Lazy.ByteString → [(Int, [Ascii])]
  76 parseStatusCodes src
  77     = case LP.parse pairs src of
  78         LP.Fail _ eCtx e
  79             → error $ "Unparsable status codes: "
  80                     ⧺ intercalate ", " eCtx
  81                     ⧺ ": "
  82                     ⧺ e
  83         LP.Done _ xs
  84             → xs
  85     where
  86       pairs ∷ Parser [(Int, [Ascii])]
  87       pairs = do skipMany endOfLine
  88                  xs ← sepBy pair (skipMany1 endOfLine)
  89                  skipMany endOfLine
  90                  endOfInput
  91                  return xs
  92               <?>
  93               "pairs"
  94
  95       pair ∷ Parser (Int, [Ascii])
  96       pair = do skipSpace
  97                 num ← decimal
  98                 skipSpace1
  99                 phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
 100                 return (num, phrase)
 101              <?>
 102              "pair"
 103
 104       word ∷ Parser Ascii
 105       word = A.unsafeFromByteString <$> P.takeWhile1 isAlpha_ascii
 106
 107 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
 108 statusDecl (num, phrase)
 109     = do a  ← dataDecl
 110          bs ← instanceDecl
 111          return (a:bs)
 112     where
 113       name ∷ Name
 114       name = mkName $ concatMap A.toString phrase
 115
 116       dataDecl ∷ Q Dec
 117       dataDecl = dataD (cxt [])
 118                        name
 119                        []
 120                        [con]
 121                        [ mkName "Eq"
 122                        , mkName "Show"
 123                        , mkName "Typeable"
 124                        ]
 125
 126       instanceDecl ∷ Q [Dec]
 127       instanceDecl
 128           = [d| instance StatusCode $typ where
 129                   {-# INLINE numericCode #-}
 130                   numericCode _ = $(lift num)
 131                   {-# INLINE textualStatus #-}
 132                   textualStatus _ = $txt
 133               |]
 134
 135       typ ∷ Q Type
 136       typ = conT name
 137
 138       con ∷ Q Con
 139       con = return $ NormalC name []
 140
 141       txt ∷ Q Exp
 142       txt = [| A.unsafeFromString $(lift txt') |]
 143
 144       txt' ∷ String
 145       txt' = concat $ intersperse "\x20"
 146                     $ show num : map A.toString phrase