diff --git a/NEWS.md b/NEWS.md --- a/NEWS.md +++ b/NEWS.md @@ -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 ================================ diff --git a/libravatar.cabal b/libravatar.cabal --- a/libravatar.cabal +++ b/libravatar.cabal @@ -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 - . -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 + . +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 diff --git a/src/Network/Libravatar.hs b/src/Network/Libravatar.hs --- a/src/Network/Libravatar.hs +++ b/src/Network/Libravatar.hs @@ -13,13 +13,71 @@ - . -} +{-# 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