module Web.Encodings.MimeHeader
( Header
, parseHeader
, lookupHeader
, lookupHeaderAttr
, AttributeNotFound (..)
, HeaderNotFound (..)
) where
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)]
type Header a = (a, a, SomeMap a)
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 :: ( MonadFailure (AttributeNotFound s) m, StringLike s
, Eq s)
=> 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, MonadFailure (HeaderNotFound s) m, Eq s)
=> s
-> [Header s]
-> m s
lookupHeader k [] = failure $ HeaderNotFound k
lookupHeader k ((key, val, _):rest)
| k == key = return val
| otherwise = lookupHeader k rest