happstack-server 6.5.6 → 6.5.7

raw patch · 4 files changed

+60/−2 lines, 4 files

Files

• happstack-server.cabal +2/−1
• src/Happstack/Server.hs +3/−0
• src/Happstack/Server/I18N.hs +54/−0
• src/Happstack/Server/Response.hs +1/−1

@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             6.5.6+Version:             6.5.7 Synopsis:            Web related tools and services. Description:         Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course <http://happstack.com/docs/crashcourse/index.html> License:             BSD3@@ -43,6 +43,7 @@                        Happstack.Server.Error                        Happstack.Server.FileServe                        Happstack.Server.FileServe.BuildingBlocks+                       Happstack.Server.I18N                        Happstack.Server.Internal.Compression                        Happstack.Server.Internal.Cookie                        Happstack.Server.Internal.Types

@@ -55,6 +55,8 @@     , module Happstack.Server.Auth     -- * Error Handling     , module Happstack.Server.Error+    -- * I18N+    , module Happstack.Server.I18N     -- * Web-related Monads     , module Happstack.Server.Monads     -- * Proxying@@ -83,6 +85,7 @@ import Happstack.Server.Auth import Happstack.Server.Cookie import Happstack.Server.Error+import Happstack.Server.I18N import Happstack.Server.Response import Happstack.Server.Routing import Happstack.Server.Proxy

@@ -0,0 +1,54 @@+module Happstack.Server.I18N +     ( acceptLanguage+     , bestLanguage+     ) where++import Control.Applicative ((<$>))++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 =+    do mAcceptLanguage <- (fmap C.unpack) <$> getHeaderM "Accept-Language"+       case mAcceptLanguage of+         Nothing   -> return []+         (Just al) ->+             case parse encodings al al of+               (Left _) -> return []+               (Right encs) -> return (map (first Text.pack) 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 range =+    -- is no 'q' param, set 'q' to 1.0+    map (second $ fromMaybe 1)     >>>+    -- sort in descending order+    sortBy (flip compare `on` snd) >>>+    -- 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.+    filter (\(lang, q) -> lang /= (Text.singleton '*') && q > 0)  >>>+    -- lookup fallback (RFC 4647, Section 3.4)+    concatMap (explode . fst) $+    range+    where+      -- | example: "en-us-gb" -> ["en-us-gb","en-us","en"]+      explode :: Text -> [Text]+      explode lang = lang : (reverse $ map fst $ breakOnAll (singleton '-') lang)

@@ -159,7 +159,7 @@  -- | alias for: @fmap toResponse@ ----- turns @m a@ icd n-heptane/pnto @m 'Response'@ using 'toResponse'.+-- turns @m a@ into @m 'Response'@ using 'toResponse'. -- -- > main = simpleHTTP nullConf $ flatten $ do return "flatten me." flatten :: (ToMessage a, Functor f) => f a -> f Response