{-# LANGUAGE OverloadedStrings #-} module Text.Html.Encoding.Detection ( EncodingName , detect , detectBom , detectMetaCharset ) where import Control.Monad import Data.Maybe import Data.Word import Prelude hiding (drop, take) import Data.Attoparsec.ByteString hiding (Done, Fail, Result, parse, take) import Data.Attoparsec.ByteString.Lazy (Result (..), parse) import Codec.Text.Detect (detectEncodingName) import qualified Data.ByteString import Data.ByteString.Lazy -- | Represent a name of text encoding (i.e., @charset@). E.g., @"UTF-8"@. type EncodingName = String -- | Detect the character encoding from a given HTML fragment. The precendence -- order for determining the character encoding is: -- -- 1. A BOM (byte order mark) before any other data in the HTML document itself. -- (See also 'detectBom' function for details.) -- 2. A @<meta>@ declaration with a @charset@ attribute or an @http-equiv@ -- attribute set to @Content-Type@ and a value set for @charset@. -- Note that it looks at only first 1024 bytes. -- (See also 'detectMetaCharset' for details.) -- 3. [Mozilla's Charset -- Detectors](https://www-archive.mozilla.org/projects/intl/chardet.html) -- heuristics. To be specific, it delegates to 'detectEncodingName' from the -- [charsetdetect-ae](https://hackage.haskell.org/package/charsetdetect-ae) -- package, a Haskell implementation of that. -- -- >>> :set -XOverloadedStrings -- >>> detect "\xef\xbb\xbf\xe4\xbd\xa0\xe5\xa5\xbd<html><head>..." -- Just "UTF-8" -- >>> detect "<html><head><meta charset=latin-1>..." -- Just "latin-1" -- >>> detect "<html><head><title>\xbe\xee\xbc\xad\xbf\xc0\xbc\xbc\xbf\xe4..." -- Just "EUC-KR" -- -- It may return 'Nothing' if it fails to determine the character encoding, -- although it's less likely. detect :: ByteString -> Maybe EncodingName detect fragment = listToMaybe $ mapMaybe ($ fragment) [ detectBom , detectMetaCharset . take 1024 , detectEncodingName ] -- | Detect the character encoding from a given HTML fragment by looking the -- initial BOM (byte order mark). -- -- >>> :set -XOverloadedStrings -- >>> detectBom "\xef\xbb\xbf\xe4\xbd\xa0\xe5\xa5\xbd" -- Just "UTF-8" -- >>> detectBom "\xfe\xff\x4f\x60\x59\x7d" -- Just "UTF-16BE" -- >>> detectBom "\xff\xfe\x60\x4f\x7d\x59" -- Just "UTF-16LE" -- >>> detectBom "\x00\x00\xfe\xff\x00\x00\x4f\x60\x00\x00\x59\x7d" -- Just "UTF-32BE" -- >>> detectBom "\xff\xfe\x00\x00\x60\x4f\x00\x00\x7d\x59\x00\x00" -- Just "UTF-32LE" -- >>> detectBom "\x84\x31\x95\x33\xc4\xe3\xba\xc3" -- Just "GB-18030" -- -- It returns 'Nothing' if it fails to find no valid BOM sequence. -- -- >>> detectBom "foobar" -- Nothing detectBom :: ByteString -> Maybe EncodingName detectBom fragment = case take 2 fragment of "\xfe\xff" -> Just "UTF-16BE" "\xef\xbb" -> if take 1 (drop 2 fragment) == "\xbf" then Just "UTF-8" else Nothing "\x00\x00" -> if take 2 (drop 2 fragment) == "\xfe\xff" then Just "UTF-32BE" else Nothing "\xff\xfe" -> if take 2 (drop 2 fragment) == "\x00\x00" then Just "UTF-32LE" else Just "UTF-16LE" "\x84\x31" -> if take 2 (drop 2 fragment) == "\x95\x33" then Just "GB-18030" else Nothing _ -> Nothing -- | Detect the character encoding from a given HTML fragment by looking -- a @<meta>@ declaration with a @charset@ attribute or an @http-equiv@ -- attribute set to @Content-Type@ and a value set for @charset@. -- -- >>> :set -XOverloadedStrings -- >>> detectMetaCharset "<html><head><meta charset=utf-8>" -- Just "utf-8" -- >>> detectMetaCharset "<html><head><meta charset='EUC-KR'>" -- Just "EUC-KR" -- >>> detectMetaCharset "<html><head><meta charset=\"latin-1\"/></head></html>" -- Just "latin-1" -- >>> :{ -- detectMetaCharset -- "<meta http-equiv=content-type content='text/html; charset=utf-8'>" -- :} -- Just "utf-8" -- -- Return 'Nothing' if it failed to any appropriate @<meta>@ tag: -- -- >>> detectMetaCharset "<html><body></body></html>" -- Nothing detectMetaCharset :: ByteString -> Maybe EncodingName detectMetaCharset fragment = case parse html fragment of Fail {} -> Nothing Done _ r -> decodeAscii <$> r where html :: Parser (Maybe Data.ByteString.ByteString) html = do metas <- many' $ choice [ do -- [^<]+ void $ takeWhile1 (/= 0x3c) return Nothing , metaCharset , do -- [<] void $ word8 0x3c return Nothing ] return $ case catMaybes metas of [] -> Nothing name : _ -> Just name metaCharset :: Parser (Maybe Data.ByteString.ByteString) metaCharset = do void $ string "<meta" void space candidates <- many' $ choice [ do -- [^>Cc]+ void $ takeWhile1 $ \ c -> c /= 0x3e && c /= 0x43 && c /= 0x63 return Nothing , do -- (?iCHARSET) void $ string' "CHARSET" -- [=] void $ word8 0x3d -- ["']? q <- option 0 $ satisfy $ \ c -> c == 0x22 || c == 0x27 -- [A-Za-z0-9._-]+ charset <- takeWhile1 $ \ c -> 0x41 <= c && c <= 0x5a || 0x61 <= c && c <= 0x7a || 0x30 <= c && c <= 0x39 || c == 0x2e || c == 0x5f || c == 0x2d when (q /= 0) $ void $ word8 q return $ Just charset , do -- [^>] void $ satisfy (/= 0x3e) return Nothing ] return $ case catMaybes candidates of [] -> Nothing name : _ -> Just name isSpace :: Word8 -> Bool isSpace c = -- [ \t\n\xff\r] c == 0x20 || c == 0x09 || c == 0x0a || c == 0xff || c == 0x0d space :: Parser Word8 space = satisfy isSpace string' :: String -> Parser () string' s = sequence_ [ satisfy $ \ i -> toEnum (fromEnum c) == i || toEnum (fromEnum c + 32) == i | c <- s ] decodeAscii :: Data.ByteString.ByteString -> String decodeAscii = fmap (toEnum . fromEnum) . Data.ByteString.unpack