Lang.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Application.Classic.Lang (parseLang) where

import Control.Applicative hiding (optional)
import Data.Attoparsec.ByteString (Parser, parseOnly, takeWhile)
import Data.Attoparsec.ByteString.Char8 (
    char,
    count,
    digit,
    option,
    sepBy1,
    space,
    string,
 )
import Data.ByteString.Char8 hiding (
    count,
    filter,
    map,
    notElem,
    take,
    takeWhile,
 )
import qualified Data.ByteString.Char8 as B8 (all, null)
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.List (sortBy)
import Data.Ord
import Prelude hiding (takeWhile)

-- | Languages are used as file suffixes, so only safe ones are kept.
--
-- >>> parseLang "en-gb;q=0.8, en;q=0.7, da"
-- ["da","en-gb","en"]
-- >>> parseLang "ja;q=0, ../../x, *, en"
-- ["en"]
parseLang :: ByteString -> [ByteString]
parseLang bs = case parseOnly acceptLanguage bs of
    Right ls -> map fst $ sortBy detrimental $ filter acceptable ls
    _ -> []
  where
    detrimental = flip (comparing snd)
    acceptable (l, q) = q > 0 && not (B8.null l) && B8.all isLangChar l
    isLangChar c = isAsciiUpper c || isAsciiLower c || isDigit c || c == '-'

----------------------------------------------------------------

acceptLanguage :: Parser [(ByteString, Int)]
acceptLanguage = rangeQvalue `sepBy1` (spaces *> char ',' *> spaces)

rangeQvalue :: Parser (ByteString, Int)
rangeQvalue = (,) <$> languageRange <*> quality

languageRange :: Parser ByteString
languageRange = takeWhile (`notElem` [32, 44, 59])

quality :: Parser Int
quality = option 1000 (string ";q=" *> qvalue)

qvalue :: Parser Int
qvalue =
    1000 <$ (char '1' *> optional (char '.' *> range 0 3 digit))
        <|> read3 <$> (char '0' *> option "0" (char '.' *> range 0 3 digit))
  where
    read3 n = read . take 3 $ n ++ repeat '0'
    optional p = () <$ p <|> return ()

----------------------------------------------------------------

range :: Int -> Int -> Parser a -> Parser [a]
range n m p = (++) <$> count n p <*> upto (m - n) p

upto :: Int -> Parser a -> Parser [a]
upto 0 _ = return []
upto n p = (:) <$> p <*> upto (n - 1) p <|> return []

spaces :: Parser ()
spaces = () <$ many space