module Happstack.Server.I18N
     ( acceptLanguage
     , bestLanguage
     ) where

import Control.Arrow ((>>>), first, second)
import Data.Function (on)
import qualified Data.ByteString.Char8 as C
import Data.List     (sortBy)
import Data.Maybe    (fromMaybe)
import Data.Text     as Text (Text, breakOnAll, pack, singleton)
import Happstack.Server.Monads (Happstack, getHeaderM)
import Happstack.Server.Internal.Compression (encodings)
import Text.ParserCombinators.Parsec (parse)

-- TODO: proper Accept-Language parser

-- | parse the 'Accept-Language' header, or [] if not found.
acceptLanguage :: (Happstack m) => m [(Text, Maybe Double)]
acceptLanguage :: m [(Text, Maybe Double)]
acceptLanguage =
    do Maybe [Char]
mAcceptLanguage <- ((ByteString -> [Char]) -> Maybe ByteString -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> [Char]
C.unpack) (Maybe ByteString -> Maybe [Char])
-> m (Maybe ByteString) -> m (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m (Maybe ByteString)
forall (m :: * -> *).
ServerMonad m =>
[Char] -> m (Maybe ByteString)
getHeaderM [Char]
"Accept-Language"
       case Maybe [Char]
mAcceptLanguage of
         Maybe [Char]
Nothing   -> [(Text, Maybe Double)] -> m [(Text, Maybe Double)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
         (Just [Char]
al) ->
             case Parsec [Char] () [([Char], Maybe Double)]
-> [Char] -> [Char] -> Either ParseError [([Char], Maybe Double)]
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec [Char] () [([Char], Maybe Double)]
forall st. GenParser Char st [([Char], Maybe Double)]
encodings [Char]
al [Char]
al of
               (Left ParseError
_) -> [(Text, Maybe Double)] -> m [(Text, Maybe Double)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
               (Right [([Char], Maybe Double)]
encs) -> [(Text, Maybe Double)] -> m [(Text, Maybe Double)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((([Char], Maybe Double) -> (Text, Maybe Double))
-> [([Char], Maybe Double)] -> [(Text, Maybe Double)]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> Text) -> ([Char], Maybe Double) -> (Text, Maybe Double)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Char] -> Text
Text.pack) [([Char], Maybe Double)]
encs)

-- | deconstruct the 'acceptLanguage' results a return a list of
-- languages sorted by preference in descending order.
--
-- Note: this implementation does not conform to RFC4647
--
-- Among other things, it does not handle wildcards. A proper
-- implementation needs to take a list of available languages.
bestLanguage :: [(Text, Maybe Double)] -> [Text]
bestLanguage :: [(Text, Maybe Double)] -> [Text]
bestLanguage [(Text, Maybe Double)]
range =
    -- is no 'q' param, set 'q' to 1.0
    ((Text, Maybe Double) -> (Text, Double))
-> [(Text, Maybe Double)] -> [(Text, Double)]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe Double -> Double) -> (Text, Maybe Double) -> (Text, Double)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Maybe Double -> Double)
 -> (Text, Maybe Double) -> (Text, Double))
-> (Maybe Double -> Double)
-> (Text, Maybe Double)
-> (Text, Double)
forall a b. (a -> b) -> a -> b
$ Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1)     ([(Text, Maybe Double)] -> [(Text, Double)])
-> ([(Text, Double)] -> [Text]) -> [(Text, Maybe Double)] -> [Text]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    -- sort in descending order
    ((Text, Double) -> (Text, Double) -> Ordering)
-> [(Text, Double)] -> [(Text, Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Double -> Double -> Ordering) -> Double -> Double -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Double -> Double -> Ordering)
-> ((Text, Double) -> Double)
-> (Text, Double)
-> (Text, Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Text, Double) -> Double
forall a b. (a, b) -> b
snd) ([(Text, Double)] -> [(Text, Double)])
-> ([(Text, Double)] -> [Text]) -> [(Text, Double)] -> [Text]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    -- remove entries with '*' or q == 0. Removing '*' entries is not
    -- technically correct, but it is the best we can do with out a
    -- list of available languages.
    ((Text, Double) -> Bool) -> [(Text, Double)] -> [(Text, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
lang, Double
q) -> Text
lang Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= (Char -> Text
Text.singleton Char
'*') Bool -> Bool -> Bool
&& Double
q Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0)  ([(Text, Double)] -> [(Text, Double)])
-> ([(Text, Double)] -> [Text]) -> [(Text, Double)] -> [Text]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    -- lookup fallback (RFC 4647, Section 3.4)
    ((Text, Double) -> [Text]) -> [(Text, Double)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> [Text]
explode (Text -> [Text])
-> ((Text, Double) -> Text) -> (Text, Double) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Double) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Maybe Double)] -> [Text])
-> [(Text, Maybe Double)] -> [Text]
forall a b. (a -> b) -> a -> b
$
    [(Text, Maybe Double)]
range
    where
      -- | example: "en-us-gb" -> ["en-us-gb","en-us","en"]
      explode :: Text -> [Text]
      explode :: Text -> [Text]
explode Text
lang = Text
lang Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ([Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)]
breakOnAll (Char -> Text
singleton Char
'-') Text
lang)