Last modified and etag for snap

Utils.hs

{-# LANGUAGE OverloadedStrings #-}
module SmAssetMan.Utils
       (encodeHttpDate
       ,decodeHttpDate
       ,getIfModifiedSince
       ,getIfUnmodifiedSince
       ,getIfMatch
       ,getIfNoneMatch
       ,setETag
       ,setLastModified
       )
       where

import Data.Attoparsec

import           Data.ByteString       (ByteString)
import qualified Data.ByteString.Char8 as BS

import Data.Time
import Data.Word (Word8)

import System.Locale (defaultTimeLocale)

import Snap

import SmAssetMan.Types.Common (ETag(..))

rfc822DateFormat :: String
rfc822DateFormat = "%a, %_d %b %Y %H:%M:%S %Z"

encodeHttpDate :: UTCTime -> ByteString
encodeHttpDate = BS.pack .
                 formatTime defaultTimeLocale rfc822DateFormat


decodeHttpDate :: ByteString -> Maybe UTCTime
decodeHttpDate = parseTime defaultTimeLocale rfc822DateFormat
                 . BS.unpack


getIfModifiedSince :: HasHeaders h => h -> Maybe UTCTime
getIfModifiedSince h = getHeader "If-Modified-Since" h
                       >>= decodeHttpDate

getIfUnmodifiedSince :: HasHeaders h => h -> Maybe UTCTime
getIfUnmodifiedSince h = getHeader "If-Unmodified-Since" h >>= decodeHttpDate


setLastModified :: HasHeaders h => UTCTime -> h -> h
setLastModified = setHeader "Last-Modified" . encodeHttpDate

setETag :: HasHeaders h => ETag -> h -> h
setETag t = setHeader "ETag" $ '"' `BS.cons` (unETag t) `BS.snoc` '"'

getIfMatch :: HasHeaders h => h -> [ETag]
getIfMatch = parseETags' . getHeader "If-Match"

getIfNoneMatch :: HasHeaders h => h -> [ETag]
getIfNoneMatch = parseETags' . getHeader "If-None-Match"

parseETags' :: Maybe ByteString -> [ETag]
parseETags' bs =
  case bs of
    Nothing -> []
    Just inp -> case parseOnly parseETags inp of
      Left _ -> []
      Right r -> map (ETag . snd) r

parseETags :: Parser [(Bool, ByteString)]
parseETags =
  ((,) <$> (skipWhile ows *> option False (True <$ string "W/") )
    <*> (word8 0x22 *> takeWhile1 etagBodyChar <* word8 0x22)
  )`sepBy` word8 0x2C
  <* endOfInput

etagBodyChar :: Word8 -> Bool
etagBodyChar w =
  w /= 0x22 && ( w >= 0x21 && w <= 0x7F) || (w >= 0x80 && w <= 0xFF)

ows :: Word8 -> Bool
ows w =
  w == 0x11 || w == 0x20