MimeHeader.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
---------------------------------------------------------
-- Copyright     : Michael Snoyman
-- License       : BSD3
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
---------------------------------------------------------

-- | Functions for parsing MIME headers (Key: value; k1=v1; k2=v2)
module Web.Encodings.MimeHeader
    ( Header
    , parseHeader
    , lookupHeader
    , lookupHeaderAttr
    , AttributeNotFound (..)
    , HeaderNotFound (..)
    ) where

--import Data.String.Util
import qualified Web.Encodings.StringLike as SL
import Web.Encodings.StringLike (StringLike)
import Control.Failure
import Control.Exception (Exception)
import Data.Typeable (Typeable)

type SomeMap a = [(a, a)]

-- | A single MIME header.
--type Header = (B8.ByteString, B8.ByteString, BSMap)
type Header a = (a, a, SomeMap a)

-- | Parse a header line in the format:
--
-- Name: value; attkey=attval; attkey2=attval2.
parseHeader :: StringLike a => a -> Header a
parseHeader s =
    let (k, rest) = SL.span (/= ':') s
        (v, attrs) = parseRest rest
     in (k, v, attrs) where
    parseRest :: StringLike a => a -> (a, SomeMap a)
    parseRest s' =
        let (v, rest) = SL.span (/= ';') s'
            attrs = parseAttrs rest
         in (SL.dropPrefix' (SL.pack ": ") v, attrs)
    parseAttrs :: StringLike a => a -> SomeMap a
    parseAttrs a | SL.null a = []
    parseAttrs a =
        let s' = SL.dropPrefix' (SL.pack "; ") a
            (next, rest) = SL.span (/= ';') s'
            (k, v) = SL.span (/= '=') next
            v' = SL.dropPrefix' (SL.pack "=") v
            v'' = SL.dropQuotes v'
         in (k, v'') : parseAttrs rest

data AttributeNotFound s = AttributeNotFound s s
    deriving (Show, Typeable)
instance (Typeable s, Show s) => Exception (AttributeNotFound s)
lookupHeaderAttr :: ( Failure (AttributeNotFound s) m, StringLike s
                    , Eq s
                    , Monad m)
                 => s
                 -> s
                 -> [Header s]
                 -> m s
lookupHeaderAttr k1 k2 [] = failure $ AttributeNotFound k1 k2
lookupHeaderAttr k1 k2 ((key, _, vals):rest)
    | k1 == key = case lookup k2 vals of
                    Nothing -> failure $ AttributeNotFound k1 k2
                    Just v -> return v
    | otherwise = lookupHeaderAttr k1 k2 rest

data HeaderNotFound s = HeaderNotFound s
    deriving (Typeable, Show)
instance (Show s, Typeable s) => Exception (HeaderNotFound s)

lookupHeader :: (StringLike s, Failure (HeaderNotFound s) m, Eq s,
                 Monad m)
             => s
             -> [Header s]
             -> m s
lookupHeader k [] = failure $ HeaderNotFound k
lookupHeader k ((key, val, _):rest)
    | k == key = return val
    | otherwise = lookupHeader k rest