libravatar 0.3.0.1 → 0.4

raw patch · 3 files changed

+205/−135 lines, 3 filesdep +memorydep +textdep +uri-bytestringdep −network-uridep −utf8-stringdep ~bytestringdep ~cryptonitedep ~data-default-classPVP ok

version bump matches the API change (PVP)

Dependencies added: memory, text, uri-bytestring

Dependencies removed: network-uri, utf8-string

Dependency ranges changed: bytestring, cryptonite, data-default-class, dns, random, url

API changes (from Hackage documentation)

Files

• NEWS.md +29/−0
• libravatar.cabal +34/−41
• src/Network/Libravatar.hs +142/−94

@@ -3,6 +3,35 @@   +libravatar 0.4        2016-05-10+================================++General, build and documentation changes:++* Use `Text` instead of `String`+* Remove `defOpts` function, just use `def` instead+* Some intro docs and examples move to module comment, i.e. top of page+* Use more `ByteString` and less `String` internally, in particular replace+  `network-uri` with `uri-bytestring`++New APIs, features and enhancements:++* (None)++Bug fixes:++* (none)++Dependency changes:++* Remove network-uri+         utf8-string+* Add    uri-bytestring+++++ libravatar 0.3.0.1 -- 2016-04-30 ================================ 

@@ -1,45 +1,38 @@-name: libravatar-version: 0.3.0.1-cabal-version: >=1.10-build-type: Simple-license: PublicDomain-license-file: COPYING-copyright: ♡ Copying is an act of love. Please copy, reuse and share.-maintainer: fr33domlover@riseup.net-homepage: http://rel4tion.org/projects/libravatar/-bug-reports: http://rel4tion.org/projects/libravatar/tickets/-synopsis: Use Libravatar, the decentralized avatar delivery service-description:-    This package is a Haskell library for-    <http://libravatar.org Libravatar>.-category: Network, Web-author: fr33domlover-extra-source-files:-    AUTHORS-    ChangeLog-    COPYING-    INSTALL.md-    NEWS.md-    README.md+name:                libravatar+version:             0.4+synopsis:            Use Libravatar, the decentralized avatar delivery service+description:         This package is a Haskell library for+                     <http://libravatar.org Libravatar>.+homepage:            http://rel4tion.org/projects/libravatar/+bug-reports:         http://rel4tion.org/projects/libravatar/tickets/+license:             PublicDomain+license-file:        COPYING+author:              fr33domlover+maintainer:          fr33domlover@riseup.net+copyright:           ♡ Copying is an act of love. Please copy, reuse and share.+category:            Network, Web+build-type:          Simple+extra-source-files:  AUTHORS ChangeLog COPYING INSTALL.md NEWS.md README.md+cabal-version:       >=1.10  source-repository head-    type: darcs-    location: http://hub.darcs.net/fr33domlover/libravatar+  type:                darcs+  location:            http://hub.darcs.net/fr33domlover/libravatar  library-    exposed-modules:-        Network.Libravatar-    build-depends:-        base >=4.7 && <5,-        bytestring >=0.10.6.0,-        cryptonite >=0.10,-        data-default-class >=0.0.1,-        dns >=2.0.2,-        network-uri >=2.6.1.0,-        random >=1.1,-        url >=2.1.3,-        utf8-string >=1.0.1.1-    default-language: Haskell2010-    hs-source-dirs: src-    ghc-options: -Wall-+  exposed-modules:     Network.Libravatar+  -- other-modules:+  -- other-extensions:    +  build-depends:       base               >=4.7 && <5+                     , bytestring+                     , cryptonite+                     , data-default-class+                     , dns+                     , memory+                     , random+                     , text+                     , uri-bytestring+                     , url+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall

@@ -13,13 +13,71 @@  - <http://creativecommons.org/publicdomain/zero/1.0/>.  -} +{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Libravatar is a decentralized avatar delivery system. Instead of relying+-- on a single centralized provider, it can use DNS records to detect the host+-- of the avatar image. There is a server implementation which anyone can run+-- and host their avatars and there are client libraries for many languages,+-- all free-as-in-freedom software.+--+-- This module is a Haskell client library for Libravatar.+--+-- Note that this library doesn't actually fetch the image over HTTP. That part+-- is left to the various HTTP client packages, such as @http-client@. What+-- this library does is construct the image URL, possibly using DNS queries+-- when needed for the decentralization. You can then fetch the image over HTTP+-- or use the URL in your web app's HTML page templates, in which case the+-- user's web brower will be downloading the image.+--+-- Now let's see how it works.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Data.Default.Class (def)+-- > import Network.Libravatar+--+-- Examples:+--+-- Email, HTTP, default fallback image (the libravatar logo),+-- default size (80):+--+-- >>> avatarUrl (Email "john@doe.org") def+-- >>>     { optSecure  = False+-- >>>     , optDefault = ImgLibravatarLogo+-- >>>     , optSize    = DefaultSize+-- >>>     }+-- Just "http://cdn.libravatar.org/avatar/bc6a715808d9aae0ddeefb1e47e482a6"+--+-- Email, HTTPS, default fallback image, size 100. But now use an email with a+-- domain which has SRV records for avatars:+--+-- >>> avatarUrl (Email "fr33domlover@rel4tion.org") def+-- >>>     { optSecure  = True+-- >>>     , optDefault = ImgLibravatarLogo+-- >>>     , optSize    = Size 100+-- >>>     }+-- Just "https://avatars.rel4tion.org:5679/avatar/e9e9ccabc2a166b1783bd7f4f9ceb376?s=100"+--+-- OpenID, HTTPS, specified fallback (special value \"retro\"), default+-- size (80):+--+-- >>> avatarUrl (OpenID "https://examplibre.org/accounts/xyz/id") def+-- >>>     { optSecure  = True+-- >>>     , optDefault = ImgSpecial SpecialRetro+-- >>>     , optSize    = DefaultSize+-- >>>     }+-- Just "https://seccdn.libravatar.org/avatar/c2cbc5f5a1784fa7105380e550360d73f15c4c1f9c7ca1ac436c45a33027fcd7?d=retro"+--+-- (Note that the 2nd example uses dummy SRV records created by the author,+-- and he isn't really running a Libravatar provider. This is just an example,+-- the specific URL here will probably result with 404.) module Network.Libravatar     ( UserAddress (..)     , SpecialImage (..)     , DefaultImage (..)     , Size (..)     , AvatarOptions ()-    , defOpts     , optSecure     , optDefault     , optSize@@ -31,31 +89,48 @@ import Control.Monad (liftM) import Crypto.Hash (hashWith) import Crypto.Hash.Algorithms (SHA256 (SHA256), MD5 (MD5))+import Data.ByteArray.Encoding+import Data.ByteString (ByteString) import Data.Char (toLower) import Data.Default.Class import Data.List (partition) import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text) import Network.DNS.Lookup import Network.DNS.Resolver import Network.DNS.Types (DNSError, Domain)-import Network.URI-import Network.URL import System.Random (randomRIO)+import URI.ByteString -import qualified Data.ByteString.UTF8 as BU (fromString)+import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Network.URL as NU -defaultHost       = Host (HTTP False) "cdn.libravatar.org"    Nothing-defaultHostSecure = Host (HTTP True)  "seccdn.libravatar.org" Nothing-serviceBase       = "_avatars._tcp"+defaultHost :: NU.Host+defaultHost = NU.Host (NU.HTTP False) "cdn.libravatar.org" Nothing++defaultHostSecure :: NU.Host+defaultHostSecure = NU.Host (NU.HTTP True) "seccdn.libravatar.org" Nothing++serviceBase :: ByteString+serviceBase = "_avatars._tcp"++serviceBaseSecure :: ByteString serviceBaseSecure = "_avatars-sec._tcp"-minAvatarSize     = 1-maxAvatarSize     = 512 +minAvatarSize :: Int+minAvatarSize = 1++maxAvatarSize :: Int+maxAvatarSize = 512+ -- | User address for which to generate an avatar URL. Email or OpenID. data UserAddress-    = Email String  -- ^ For example @john\@doe.org@-    | OpenID String -- ^ For example @https://example.org/accounts/john/id@+    = Email Text  -- ^ For example @john\@doe.org@+    | OpenID Text -- ^ For example @https://example.org/accounts/john/id@  -- | Special values available for the default image. The comments briefly -- explain the origin of the image/technique.@@ -100,7 +175,7 @@     -- | Use one of the available special images or image generators.     | ImgSpecial SpecialImage     -- | Use the given image URL as the default.-    | ImgCustom String+    | ImgCustom Text  instance Default DefaultImage where     def = ImgLibravatarLogo@@ -143,45 +218,50 @@         , optTryGravatar = True         } --- | A default 'AvatarOptions' value in which you can override fields. It is--- simply a convenience wrapper of 'def', i.e. this is the same as using the--- 'Default' instance.-defOpts :: AvatarOptions-defOpts = def--hashMD5 :: String -> String-hashMD5 = show . hashWith MD5 . BU.fromString+hashMD5 :: ByteString -> ByteString+hashMD5 = convertToBase Base16 . hashWith MD5 -hashSHA256 :: String -> String-hashSHA256 = show . hashWith SHA256 . BU.fromString+hashSHA256 :: ByteString -> ByteString+hashSHA256 = convertToBase Base16 . hashWith SHA256  -- Hash email using MD5 or SHA256 depending on whether gr4va7ar should be used-hashMail :: Bool -> String -> String+hashMail :: Bool -> ByteString -> ByteString hashMail True  = hashMD5 hashMail False = hashSHA256  -- OpenIDs must be hashed with SHA256-hashOpenid :: String -> String+hashOpenid :: ByteString -> ByteString hashOpenid = hashSHA256  -- From email or openid, generate avatar hash and get the relevant domain-parseUserAddress :: UserAddress -> Bool -> Maybe (String, String)+parseUserAddress :: UserAddress -> Bool -> Maybe (ByteString, ByteString) parseUserAddress (Email email) grav =-    let lowEmail = map toLower email-        d        = dropWhile (/= '@') lowEmail-        domain   = if null d then d else tail d+    let lowEmail = TE.encodeUtf8 $ T.toLower email+        domain   = B.drop 1 $ BC.dropWhile (/= '@') lowEmail         hash     = hashMail grav lowEmail     in  Just (hash, domain)-parseUserAddress (OpenID openid) _ = do-    uri <- parseAbsoluteURI openid-    auth <- uriAuthority uri-    let lower = map toLower-        authl = auth { uriRegName = lower $ uriRegName auth }-        openidl = uri-            { uriScheme = lower $ uriScheme uri-            , uriAuthority = Just authl-            }-    return (hashOpenid $ uriToString id openidl "", uriRegName authl)+parseUserAddress (OpenID openid) _ =+    case parseURI laxURIParserOptions $ TE.encodeUtf8 openid of+        Left _ -> Nothing+        Right uri ->+            case uriAuthority uri of+                Nothing -> Nothing+                Just auth ->+                    let lower = BC.map toLower+                        hostl = lower $ hostBS $ authorityHost auth+                        openidl = uri+                            { uriScheme =+                                Scheme $ lower $ schemeBS $ uriScheme uri+                            , uriAuthority =+                                Just $ auth { authorityHost = Host hostl}+                            }+                        serialize =+#if MIN_VERSION_uri_bytestring(0,2,0)+                            serializeURIRef'+#else+                            serializeURI'+#endif+                    in  Just (hashOpenid $ serialize openidl, hostl)  -- Convert 'Size' to 'Maybe' for use with 'Maybe' functor sizeToMaybe :: Size -> Maybe Int@@ -201,23 +281,22 @@ showDefault ImgLibravatarLogo = Nothing showDefault ImgNotFound       = Just "404" showDefault (ImgSpecial img)  = Just $ showSpecial img-showDefault (ImgCustom url)   = Just url+showDefault (ImgCustom url)   = Just $ T.unpack url  -- Determine URL query parameters buildParams :: DefaultImage -> Size -> [(String, String)]-buildParams def size =-    let defParam = fmap ((,) "d") $ showDefault def+buildParams di size =+    let defParam = fmap ((,) "d") $ showDefault di         size' = fmap (max minAvatarSize . min maxAvatarSize) $ sizeToMaybe size         sizeParam = fmap ((,) "s" . show) size'     in  catMaybes [defParam, sizeParam]  -- Get the DNS service to query for a given domain and scheme-serviceName :: String -> Bool -> Domain+serviceName :: ByteString -> Bool -> Domain serviceName domain https =-    BC.pack $     if https-        then serviceBaseSecure ++ '.' : domain-        else serviceBase       ++ '.' : domain+        then serviceBaseSecure <> "." <> domain+        else serviceBase       <> "." <> domain  -- Get a random list item, with distribution based on weights. Weights must be -- non-negative. Any negative weights will just be treated as zero weights.@@ -227,7 +306,7 @@         wlist' = map (max 0) wlist         totalw = sum wlist'         l' = zip l wlist'-        f r w []     = error "weightedRandom: got an empty list"+        f _ _ []     = error "weightedRandom: got an empty list"         f r w (i:is) =             let w' = w + snd i             in  if w' >= r@@ -239,7 +318,9 @@ -- resolver targetSane :: Domain -> Int -> Bool targetSane target port =-    not (BC.null target) && BC.any ok_host target && 1 <= port && port <= 65535+    not (BC.null target) &&+    BC.any NU.ok_host target &&+    1 <= port && port <= 65535  -- Get the right (target, port) pair from a list of SRV records srvHostname :: [(Int, Int, Int, Domain)] -> IO (Maybe (Domain, Int))@@ -256,15 +337,15 @@         topRecords = wz ++ wnz     in  case topRecords of             [(_, _, port, target)] -> return $ Just (target, port)-            l                      ->-                weightedRandom weight l >>=+            rs                     ->+                weightedRandom weight rs >>=                 \ (_, _, port, target) -> return $ Just (target, port)  -- Pick the right server and return its normalized hostname, i.e. only include -- the port number if it's necessary normalizedTarget :: [(Int, Int, Int, Domain)]                  -> Bool-                 -> IO (Maybe Host)+                 -> IO (Maybe NU.Host) normalizedTarget records https = do     tp <- srvHostname records     let sane = maybe False (uncurry targetSane) tp@@ -276,13 +357,13 @@                     if https && port /= 443 || not https && port /= 80                         then Just $ fromIntegral port                         else Nothing-            in  Just $ Host (HTTP https) target' port'-        _                           -> Nothing+            in  Just $ NU.Host (NU.HTTP https) target' port'+        _ -> Nothing  -- Get avatar server from SRV record-lookupAvatarServer :: String+lookupAvatarServer :: ByteString                    -> Bool-                   -> IO (Either DNSError (Maybe Host))+                   -> IO (Either DNSError (Maybe NU.Host)) lookupAvatarServer domain https = do     let service = serviceName domain https     rs <- makeResolvSeed defaultResolvConf@@ -292,62 +373,29 @@         Right records -> liftM Right $ normalizedTarget records https  -- Assemble the final avatar URL based on the provided components-composeAvatarUrl :: Maybe Host -> String -> [(String, String)] -> Bool -> URL+composeAvatarUrl+    :: Maybe NU.Host -> ByteString -> [(String, String)] -> Bool -> NU.URL composeAvatarUrl server hash params https =     let server' =             fromMaybe (if https then defaultHostSecure else defaultHost) server-    in  URL (Absolute server') ("avatar/" ++ hash) params+    in  NU.URL (NU.Absolute server') (BC.unpack $ "avatar/" <> hash) params  -- | Return a URL to the avatar image. -- -- If an error occurs, return 'Nothing'. Currently, this happens only if the -- user address fails to be parsed. ----- Examples:------ Email, HTTP, default fallback image (the libravatar logo),--- default size (80):------ >>> avatarUrl (Email "john@doe.org") defOpts--- >>>     { optSecure  = False--- >>>     , optDefault = ImgLibravatarLogo--- >>>     , optSize    = DefaultSize--- >>>     }--- Just "http://cdn.libravatar.org/avatar/bc6a715808d9aae0ddeefb1e47e482a6"------ Email, HTTPS, default fallback image, size 100. But now use an email with a--- domain which has SRV records for avatars:------ >>> avatarUrl (Email "fr33domlover@rel4tion.org") defOpts--- >>>     { optSecure  = True--- >>>     , optDefault = ImgLibravatarLogo--- >>>     , optSize    = Size 100--- >>>     }--- Just "https://avatars.rel4tion.org:5679/avatar/e9e9ccabc2a166b1783bd7f4f9ceb376?s=100"------ OpenID, HTTPS, specified fallback (special value \"retro\"), default--- size (80):------ >>> avatarUrl (OpenID "https://examplibre.org/accounts/xyz/id") defOpts--- >>>     { optSecure  = True--- >>>     , optDefault = ImgSpecial SpecialRetro--- >>>     , optSize    = DefaultSize--- >>>     }--- Just "https://seccdn.libravatar.org/avatar/c2cbc5f5a1784fa7105380e550360d73f15c4c1f9c7ca1ac436c45a33027fcd7?d=retro"------ (Note that the 2nd example uses dummy SRV records created by the author,--- and he isn't really running a Libravatar provider. This is just an example,--- the specific URL here will probably result with 404.)-avatarUrl :: UserAddress -> AvatarOptions -> IO (Maybe String)+-- See examples at the top of the page.+avatarUrl :: UserAddress -> AvatarOptions -> IO (Maybe Text) avatarUrl address options =     let grav = optTryGravatar options         (hash, domain) = fromMaybe ("", "") $ parseUserAddress address grav         params = buildParams (optDefault options) (optSize options)         https = optSecure options-    in  if null domain+    in  if B.null domain             then return Nothing             else do                 result <- lookupAvatarServer domain https                 let server = either (const Nothing) id result                     url = composeAvatarUrl server hash params https-                return $ Just $ exportURL url+                return $ Just $ T.pack $ NU.exportURL url