Network/HTTP/Lucu/ETag.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , TemplateHaskell
   6   , UnicodeSyntax
   7   #-}
   8 -- |An internal module for entity tags.
   9 module Network.HTTP.Lucu.ETag
  10     ( ETag(..)
  11     , parseETag
  12     , printETag
  13
  14     , strongETag
  15     , weakETag
  16     , eTag
  17     , eTagList
  18     )
  19     where
  20 import Control.Applicative
  21 import Control.Monad
  22 import Data.Ascii (Ascii, AsciiBuilder)
  23 import qualified Data.Ascii as A
  24 import Data.Attoparsec.Char8
  25 import Data.Data
  26 import Data.Monoid.Unicode
  27 import Language.Haskell.TH.Syntax
  28 import Network.HTTP.Lucu.OrphanInstances ()
  29 import Network.HTTP.Lucu.Parser
  30 import Network.HTTP.Lucu.Parser.Http hiding (token)
  31 import Network.HTTP.Lucu.Utils
  32 import Prelude.Unicode
  33
  34 -- |An entity tag consists of a weakness flag and an opaque string.
  35 data ETag = ETag {
  36       -- |The weakness flag. Weak tags looks like @W\/\"blahblah\"@
  37       -- and strong tags are like @\"blahblah\"@. See:
  38       -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec13.html#sec13.3.3>
  39       etagIsWeak ∷ !Bool
  40       -- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~)
  41       -- are allowed.
  42     , etagToken  ∷ !Ascii
  43     } deriving (Eq, Show, Data, Typeable)
  44
  45 instance Lift ETag where
  46     lift (ETag {..})
  47         = [| ETag {
  48                etagIsWeak = $(lift etagIsWeak)
  49              , etagToken  = $(lift etagToken )
  50              }
  51            |]
  52
  53 -- |Convert an 'ETag' to an 'AsciiBuilder'.
  54 printETag ∷ ETag → AsciiBuilder
  55 {-# INLINEABLE printETag #-}
  56 printETag et
  57     = ( if etagIsWeak et then
  58             A.toAsciiBuilder "W/"
  59         else
  60             (∅)
  61       )
  62       ⊕
  63       quoteStr (etagToken et)
  64
  65 -- |Parse 'Etag' from an 'Ascii'. This functions throws an exception
  66 -- for parse error.
  67 parseETag ∷ Ascii → ETag
  68 {-# INLINEABLE parseETag #-}
  69 parseETag str
  70     = case parseOnly (finishOff eTag) $ A.toByteString str of
  71         Right et → et
  72         Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err)
  73
  74 -- |This is equivalent to @'ETag' 'False'@. If you want to generate an
  75 -- ETag from a file, try using
  76 -- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'.
  77 strongETag ∷ Ascii → ETag
  78 {-# INLINE strongETag #-}
  79 strongETag = ETag False
  80
  81 -- |This is equivalent to @'ETag' 'True'@.
  82 weakETag ∷ Ascii → ETag
  83 {-# INLINE weakETag #-}
  84 weakETag = ETag True
  85
  86 -- |'Parser' for an 'ETag'.
  87 eTag ∷ Parser ETag
  88 {-# INLINEABLE eTag #-}
  89 eTag = do isWeak ← option False (string "W/" *> return True)
  90           str    ← quotedStr
  91           return $ ETag isWeak str
  92
  93 -- |'Parser' for a list of 'ETag's.
  94 eTagList ∷ Parser [ETag]
  95 {-# INLINEABLE eTagList #-}
  96 eTagList = do xs ← listOf eTag
  97               when (null xs) $
  98                   fail "empty list of ETags"
  99               return xs