Code reorganisation

[Lucu.git] / Network / HTTP / Lucu / Response / StatusCode / Internal.hs

diff --git a/Network/HTTP/Lucu/Response/StatusCode/Internal.hs b/Network/HTTP/Lucu/Response/StatusCode/Internal.hs
new file mode 100644 (file)
index 0000000..7d0da98
--- /dev/null
+++ b/Network/HTTP/Lucu/Response/StatusCode/Internal.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE
+    ExistentialQuantification
+  , FlexibleInstances
+  , MultiParamTypeClasses
+  , OverlappingInstances
+  , OverloadedStrings
+  , TemplateHaskell
+  , UndecidableInstances
+  , UnicodeSyntax
+  , ViewPatterns
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.HTTP.Lucu.Response.StatusCode.Internal
+    ( StatusCode(..)
+    , SomeStatusCode
+    , statusCodes
+    )
+    where
+import Control.Applicative
+import Control.Applicative.Unicode
+import Control.Monad.Unicode
+import Data.Ascii (Ascii, AsciiBuilder)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8
+import qualified Data.Attoparsec.Lazy as LP
+import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
+import Data.List
+import Data.Monoid
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Quote
+import Network.HTTP.Lucu.OrphanInstances ()
+import Network.HTTP.Lucu.Parser
+import Prelude.Unicode
+
+-- |Type class for HTTP status codes.
+--
+-- Declaring types for each statuses is surely a pain. See:
+-- 'statusCodes' quasi-quoter.
+--
+-- Minimal complete definition: 'numericCode' and 'textualStatus'.
+class (Eq sc, Show sc) ⇒ StatusCode sc where
+    -- |Return the 3-digit integer for this status e.g. @200@
+    numericCode ∷ sc → Int
+    -- |Return the combination of 3-digit integer and reason phrase
+    -- for this status e.g. @200 OK@
+    textualStatus ∷ sc → AsciiBuilder
+    -- |Wrap the status code into 'SomeStatusCode'.
+    fromStatusCode ∷ sc → SomeStatusCode
+    {-# INLINE CONLIKE fromStatusCode #-}
+    fromStatusCode = SomeStatusCode
+
+instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = fromStatusCode
+
+instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = textualStatus
+
+instance StatusCode sc ⇒ ConvertAttempt sc SomeStatusCode where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+-- |Container type for the 'StatusCode' type class.
+data SomeStatusCode
+    = ∀sc. StatusCode sc ⇒ SomeStatusCode !sc
+
+-- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and
+-- @β@ are said to be equivalent iff @'numericCode' α '=='
+-- 'numericCode' β@.
+instance Eq SomeStatusCode where
+    {-# INLINE (==) #-}
+    (==) = (∘ numericCode) ∘ (==) ∘ numericCode
+
+instance Show SomeStatusCode where
+    show (SomeStatusCode sc) = show sc
+
+instance StatusCode SomeStatusCode where
+    {-# INLINE numericCode #-}
+    numericCode (SomeStatusCode sc) = numericCode sc
+    {-# INLINE textualStatus #-}
+    textualStatus (SomeStatusCode sc) = textualStatus sc
+    {-# INLINE CONLIKE fromStatusCode #-}
+    fromStatusCode = id
+
+-- |'QuasiQuoter' for 'StatusCode' declarations.
+--
+-- Top-level splicing
+--
+-- @
+--   ['statusCodes'|
+--   200 OK
+--   400 Bad Request
+--   405 Method Not Allowed
+--   |]
+-- @
+--
+-- becomes:
+--
+-- @
+--   data OK = OK deriving ('Eq', 'Show')
+--   instance 'StatusCode' OK where
+--     'numericCode'   _ = 200
+--     'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
+--
+--   data BadRequest = BadRequest deriving ('Eq', 'Show')
+--   instance 'StatusCode' BadRequest where
+--     'numericCode'   _ = 400
+--     'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
+--
+--   data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
+--   instance 'StatusCode' MethodNotAllowed where
+--     'numericCode'   _ = 405
+--     'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
+-- @
+statusCodes ∷ QuasiQuoter
+statusCodes = QuasiQuoter {
+                quoteExp  = const unsupported
+              , quotePat  = const unsupported
+              , quoteType = const unsupported
+              , quoteDec  = (concat <$>)
+                            ∘ (mapM statusDecl =≪)
+                            ∘ parseStatusCodes
+                            ∘ Lazy.pack
+              }
+    where
+      unsupported ∷ Monad m ⇒ m α
+      unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
+
+parseStatusCodes ∷ Monad m ⇒ Lazy.ByteString → m [(Int, [Ascii])]
+parseStatusCodes src
+    = case LP.parse pairs src of
+        LP.Fail _ eCtx e
+            → fail $ "Unparsable status codes: "
+                   ⧺ intercalate ", " eCtx
+                   ⧺ ": "
+                   ⧺ e
+        LP.Done _ xs
+            → return xs
+    where
+      pairs ∷ Parser [(Int, [Ascii])]
+      pairs = do skipMany endOfLine
+                 xs ← sepBy pair (skipMany1 endOfLine)
+                 skipMany endOfLine
+                 endOfInput
+                 return xs
+              <?>
+              "pairs"
+
+      pair ∷ Parser (Int, [Ascii])
+      pair = do skipSpace
+                num ← decimal
+                skipSpace1
+                phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
+                return (num, phrase)
+             <?>
+             "pair"
+
+      word ∷ Parser Ascii
+      word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
+
+statusDecl ∷ (Int, [Ascii]) → Q [Dec]
+statusDecl (num, phrase) = (:) <$> dataDecl ⊛ instanceDecl
+    where
+      dataDecl ∷ Q Dec
+      dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]
+
+      name ∷ Name
+      name = mkName $ concatMap cs phrase
+
+      con ∷ Q Con
+      con = normalC name []
+
+      instanceDecl ∷ Q [Dec]
+      instanceDecl
+          = [d| instance StatusCode $typ where
+                  {-# INLINE CONLIKE numericCode #-}
+                  numericCode _ = $(lift num)
+                  {-# INLINE textualStatus #-}
+                  textualStatus _ = cs $(lift txt)
+              |]
+
+      typ ∷ Q Type
+      typ = conT name
+
+      txt ∷ Ascii
+      txt = mconcat $ intersperse "\x20"
+                    $ A.unsafeFromString (show num) : phrase