snap-language (empty) → 0.1.0.0
raw patch · 6 files changed
+304/−0 lines, 6 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, containers, snap-core
Files
- CHANGELOG.md +2/−0
- LICENSE +30/−0
- README.md +44/−0
- Setup.hs +2/−0
- snap-language.cabal +44/−0
- src/Snap/Language.hs +182/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# v0.1.0.0+First import of package.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Petter Bergman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Petter Bergman nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,44 @@+# snap-language+Language handling for Snap.++Support for determining the client's prefered language using+the Accept-Language header or using suffixes to the requested URI.++Try this example:++```haskell+{-# LANGUAGE OverloadedStrings #-}++module Simple where++import Snap.Http.Server+import Snap.Core+import Data.Map+import Control.Applicative++import Snap.Language++data Lang = SV | EN deriving Eq++table :: RangeMapping Lang+table = fromList [("sv-SE",SV),("en-GB",EN)]++getLanguage :: Snap Lang+getLanguage = + getSuffixLanguage table <|> + getAcceptLanguage table <|> + return EN++test :: IO ()+test = quickHttpServe $ do+ lang <- getLanguage+ dir "hello" $ handler lang++handler :: Lang -> Snap ()+handler EN = writeBS "hello"+handler SV = writeBS "hej"+```++You can now access `/hello` and you will get an answer depending on your Accept-Language header.++Or you can access `/hello.en-GB` or `/hello.sv-SE` directly.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snap-language.cabal view
@@ -0,0 +1,44 @@+-- Initial snap-accept-language.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: snap-language+version: 0.1.0.0+synopsis: Language handling for Snap+description: + Language handling for Snap.+ .+ Support for determining the client's prefered language using+ the Accept-Language header or using suffixes to the requested URI.++homepage: https://github.com/jonpetterbergman/snap-accept-language+bug-reports: https://github.com/jonpetterbergman/snap-accept-language/issues+license: BSD3+license-file: LICENSE+author: Petter Bergman+maintainer: jon.petter.bergman@gmail.com+-- copyright: +category: Web+build-type: Simple+extra-source-files: README.md, CHANGELOG.md+cabal-version: >=1.22+source-repository head+ type: git+ location: http://github.com/jonpetterbergman/snap-accept-language++source-repository this+ type: git+ location: http://github.com/jonpetterbergman/snap-accept-language+ tag: v0.1.0.0+++library+ exposed-modules: Snap.Language+ -- other-modules: + other-extensions: OverloadedStrings+ build-depends: base >=4.8 && <4.9,+ bytestring >=0.10.6.0 && < 0.11,+ attoparsec >= 0.13.0.1 && < 0.14,+ snap-core >= 0.9.8.0 && < 0.10,+ containers >= 0.5.6.2 && < 0.6+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Snap/Language.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+-- |+-- Language handling for Snap.+--+-- Support for determining the client's prefered language using+-- the Accept-Language header or using suffixes to the requested URI.++module Snap.Language + ( RangeMapping+ , getAcceptLanguage+ , getSuffixLanguage+ , switchSuffixLanguage+ , setContentLanguage+ ) where++import Data.Attoparsec.ByteString.Char8(parseOnly,+ string,+ double,+ Parser,+ letter_ascii,+ many1,+ many',+ char,+ option,+ eitherP,+ sepBy,+ skipSpace,+ endOfLine)+import Data.ByteString (ByteString,+ isSuffixOf)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.Char (toLower)+import Data.List (intersperse,isPrefixOf,find)+import Control.Applicative ((*>),(<$>),(<*>),(<|>))+import Snap.Core (getsRequest,+ getRequest,+ putRequest,+ getHeader,+ MonadSnap,+ Cookie(..),+ addResponseCookie,+ modifyResponse,+ getCookie,+ setHeader,+ pass,+ rqPathInfo)+import Data.Maybe (mapMaybe,+ listToMaybe)+import Data.Map (Map,+ toList)+import Data.Tuple (swap)++range :: Parser String+range = (++) <$> mletters <*> (fmap concat $ many' $ (:) <$> (char '-') <*> mletters)+ where mletters = many1 letter_ascii++rangeval :: Parser (Maybe String, Double)+rangeval = + do+ r <- eitherP (char '*') range+ q <- option 1 $ string ";q=" *> double+ return (either (const Nothing) Just r,q)++acceptLanguageParser :: Parser [(Maybe String, Double)]+acceptLanguageParser = skipSpace *> (sepBy rangeval $ skipSpace *> char ',' <* skipSpace)++matches :: String + -> Maybe String + -> Bool+matches _ Nothing = True+matches provided (Just requested) = + (map toLower requested) `isPrefixOf` (map toLower provided)++candidates :: Map String a+ -> [(Maybe String, Double)]+ -> [(a,Double)]+candidates provided requested = concatMap go $ toList provided+ where go (range,x) = map (\(a,b) -> (x,b)) $ filter (matches range . fst) requested++pickLanguage' :: Map String a+ -> [(Maybe String,Double)]+ -> Maybe a+pickLanguage' provided requested = fmap fst $ foldr go Nothing $ candidates provided requested+ where go r' Nothing = return r'+ go r'@(val',q') (Just r@(val,q)) | q' > q = return r'+ | otherwise = return r ++pickLanguage :: Map String a+ -> ByteString+ -> Maybe a+pickLanguage provided headerString = + either (const Nothing) (pickLanguage' provided) $ parseOnly acceptLanguageParser headerString++-- | Attempt to find a suitable language according to the Accept-Language+-- header of the request. +--+-- This handler will call pass if it cannot find a suitable language.+getAcceptLanguage :: MonadSnap m+ => RangeMapping a+ -> m a+getAcceptLanguage rangeMapping =+ do+ al <- getsRequest $ getHeader "Accept-Language"+ maybe pass return $ al >>= pickLanguage rangeMapping++-- | A mapping from language ranges as defined in rfc2616 to languages in your own representation.+-- +-- For example:+--+-- > data Language = EN | SV deriving Eq+-- > +-- > mapping :: RangeMapping Language+-- > mapping = Map.fromList [("en-gb",EN),("sv-se",SV)]+type RangeMapping a = Map String a++removeSuffix :: ByteString+ -> ByteString+ -> Maybe ByteString+removeSuffix suf x | suf `B.isSuffixOf` x = Just $ B.take ((B.length x) - (B.length suf)) x+ | otherwise = Nothing++suffixes :: RangeMapping a+ -> [(ByteString,a)]+suffixes = map go . toList+ where go (str,val) = (BC.pack $ '.':str,val)++matchSuffix :: ByteString+ -> [(ByteString,a)]+ -> Maybe (ByteString,a)+matchSuffix str sfxs = listToMaybe $ mapMaybe go sfxs+ where go (sfx,val) = fmap (,val) $ removeSuffix sfx str++-- | Attempt to find a suitable language according to a suffix in the request URI corresponding to a language range.+--+-- Will call pass if it cannot find a suitable language.+--+-- If a match is found, the suffix will be removed from the URI in the request, so that you+-- can later match on your resource as usual and not worry about suffixes.+--+-- For example, with the following requested URI:+-- +-- > /resource.en-gb?param=value+--+-- 'getSuffixLanguage' with our previously defined mapping will return 'EN' and 'rqPathInfo' will be changed to:+--+-- > /resource?param=value+getSuffixLanguage :: MonadSnap m+ => RangeMapping a+ -> m a+getSuffixLanguage rangeMapping = + do+ r <- getRequest+ case matchSuffix (rqPathInfo r) $ suffixes rangeMapping of+ Nothing -> pass+ Just (rqPathInfo',val) -> + do+ putRequest $ r { rqPathInfo = rqPathInfo' }+ return val++-- | Change, or remove, the language suffix of an URI.+switchSuffixLanguage :: Eq a+ => RangeMapping a+ -> ByteString -- ^ The URI.+ -> Maybe a -- ^ The language to be appended to the URI, or Nothing to remove language suffix.+ -> ByteString+switchSuffixLanguage rangeMapping uri lang = maybe (addSuffix lang path) (addSuffix lang . fst) $ matchSuffix path $ suffixes rangeMapping+ where (path,params) = BC.break ((==) '?') uri+ addSuffix lang p = B.concat [p,findSfx lang,params]+ findSfx Nothing = B.empty+ findSfx (Just l) = maybe B.empty id $ lookup l $ map swap $ suffixes rangeMapping++-- | Set the Content-Language header in the response.+setContentLanguage :: (Eq a, MonadSnap m)+ => RangeMapping a+ -> a+ -> m ()+setContentLanguage rangeMapping val =+ maybe (return ()) go $ lookup val $ map swap $ toList rangeMapping+ where go = modifyResponse . setHeader "Content-Language" . BC.pack+