{- This file is part of libravatar for Haskell. - - Written in 2015, 2016, 2017 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - - The author(s) have dedicated all copyright and related and neighboring - rights to this software to the public domain worldwide. This software is - distributed without any warranty. - - You should have received a copy of the CC0 Public Domain Dedication along - with this software. If not, see - . -} {-# 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 () , optSecure , optDefault , optSize , optTryGravatar , avatarUrl ) where 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) #if MIN_VERSION_dns(3,0,0) import Data.Word (Word16) #endif import Network.DNS.Lookup import Network.DNS.Resolver import Network.DNS.Types (DNSError, Domain) import System.Random (randomRIO) import URI.ByteString 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 :: 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 :: Int minAvatarSize = 1 maxAvatarSize :: Int maxAvatarSize = 512 -- | User address for which to generate an avatar URL. Email or OpenID. data UserAddress = 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. data SpecialImage -- | A very simple outline of a person (constant image, does not vary by -- user address). Sometimes referred to as “mystery man”. = SpecialMysteryPerson -- | Geometric pattern based on a user address hash. -- -- Origin: A visual representation of a hash value, usually of an -- IP address, that serves to identify a user of a computer system as a -- form of avatar while protecting the users' privacy. | SpecialIdenticon -- | A generated monster image with different colors, faces, etc. -- -- Origin: A method to generate a unique monster image based upon a -- certain identifier (IP address, email address, etc.). It can be used to -- automatically provide personal avatar images in blog comments or other -- community services. | SpecialMonsterID -- | A generated face with differing features and backgrounds. -- -- Origin: Wavatars is a Wordpress plugin that will generate and assign -- icons to the visitors leaving comments at your site. The icons are based -- on email, so a given visitor will get the same icon each time they -- comment. It livens up comment threads and gives people memorable “faces” -- to aid in following conversation threads. It’s also fun. | SpecialWavatar -- | A generated, 8-bit arcade-style pixelated face. -- -- Origin: I don't know :P | SpecialRetro -- | What to do if the user's address isn't found in the Libravatar server's -- database. data DefaultImage -- | Don't specify a default image, let the server send its default image, -- which is the Libravatar logo (the orange butterfly). = ImgLibravatarLogo -- | Return HTTP 404 error (i.e. file not found) instead of an image. | ImgNotFound -- | Use one of the available special images or image generators. | ImgSpecial SpecialImage -- | Use the given image URL as the default. | ImgCustom Text instance Default DefaultImage where def = ImgLibravatarLogo -- | Image size in pixels. data Size -- | Use the given size. Acceptable values are between 1 and 512. Note that -- this library doesn't check the size you pass here, so make sure you -- pass a size within that range. = Size Int -- | Use the default size, which is 80 pixels. | DefaultSize instance Default Size where def = DefaultSize -- | Avatar details in addition to the user address itself. Define by starting -- with 'defOpts' and override fields using record syntax. data AvatarOptions = AvatarOptions { -- | Whether the avatar URL should be secure (use HTTPS). optSecure :: Bool -- | What to do if the user address isn't found in the Libravatar -- database. , optDefault :: DefaultImage -- | Image size in pixels. , optSize :: Size -- | If an image is not found in the Libravatar database, it can first -- redirect to gravatar in case the image exists there, and only then -- honour the 'optDefault' parameter. This option sets whether Libravatar -- should try gravatar or go straight to the 'optDefault' when an image -- isn't found. , optTryGravatar :: Bool } instance Default AvatarOptions where def = AvatarOptions { optSecure = False , optDefault = def , optSize = def , optTryGravatar = True } hashMD5 :: ByteString -> ByteString hashMD5 = convertToBase Base16 . hashWith MD5 hashSHA256 :: ByteString -> ByteString hashSHA256 = convertToBase Base16 . hashWith SHA256 -- Hash email using MD5 or SHA256 depending on whether gr4va7ar should be used hashMail :: Bool -> ByteString -> ByteString hashMail True = hashMD5 hashMail False = hashSHA256 -- OpenIDs must be hashed with SHA256 hashOpenid :: ByteString -> ByteString hashOpenid = hashSHA256 -- From email or openid, generate avatar hash and get the relevant domain parseUserAddress :: UserAddress -> Bool -> Maybe (ByteString, ByteString) parseUserAddress (Email email) grav = 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) _ = 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 sizeToMaybe (Size n) = Just n sizeToMaybe DefaultSize = Nothing -- Get name string for special image showSpecial :: SpecialImage -> String showSpecial SpecialMysteryPerson = "mm" showSpecial SpecialIdenticon = "identicon" showSpecial SpecialMonsterID = "monsterid" showSpecial SpecialWavatar = "wavatar" showSpecial SpecialRetro = "retro" -- Get name string for default image showDefault :: DefaultImage -> Maybe String showDefault ImgLibravatarLogo = Nothing showDefault ImgNotFound = Just "404" showDefault (ImgSpecial img) = Just $ showSpecial img showDefault (ImgCustom url) = Just $ T.unpack url -- Determine URL query parameters buildParams :: DefaultImage -> Size -> [(String, String)] 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 :: ByteString -> Bool -> Domain serviceName domain https = if https 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. weightedRandom #if MIN_VERSION_dns(3,0,0) :: (a -> Word16) #else :: (a -> Int) #endif -> [a] -> IO a weightedRandom getw l = let wlist = map getw l wlist' = map (max 0) wlist totalw = sum wlist' l' = zip l wlist' f _ _ [] = error "weightedRandom: got an empty list" f r w (i:is) = let w' = w + snd i in if w' >= r then fst i else f r w' is in randomRIO (0, totalw) >>= \ r -> return $ f r 0 l' -- Ensure we are getting a (mostly) valid hostname and port number from the DNS -- resolver #if MIN_VERSION_dns(3,0,0) targetSane :: Domain -> Word16 -> Bool #else targetSane :: Domain -> Int -> Bool #endif targetSane target port = not (BC.null target) && BC.any NU.ok_host target && #if MIN_VERSION_dns(3,0,0) 1 <= port #else 1 <= port && port <= 65535 #endif -- Get the right (target, port) pair from a list of SRV records srvHostname #if MIN_VERSION_dns(3,0,0) :: [(Word16, Word16, Word16, Domain)] -> IO (Maybe (Domain, Word16)) #else :: [(Int, Int, Int, Domain)] -> IO (Maybe (Domain, Int)) #endif srvHostname [] = return Nothing srvHostname [(_, _, port, target)] = return $ Just (target, port) srvHostname records = let priority (p, _, _, _) = p weight (_, w, _, _) = w -- Determine the highest priority the records contain topPrio = maximum $ map priority records -- Collect top priority records, zero-weight ones first l = filter ((== topPrio) . priority) records (wz, wnz) = partition ((<= 0) . weight) l topRecords = wz ++ wnz in case topRecords of [(_, _, port, target)] -> return $ Just (target, port) 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 #if MIN_VERSION_dns(3,0,0) :: [(Word16, Word16, Word16, Domain)] #else :: [(Int, Int, Int, Domain)] #endif -> Bool -> IO (Maybe NU.Host) normalizedTarget records https = do tp <- srvHostname records let sane = maybe False (uncurry targetSane) tp -- If sane, the target contains only ASCII, so byte-based unpack works return $ case (tp, sane) of (Just (target, port), True) -> let target' = BC.unpack target port' = if https && port /= 443 || not https && port /= 80 then Just $ fromIntegral port else Nothing in Just $ NU.Host (NU.HTTP https) target' port' _ -> Nothing -- Get avatar server from SRV record lookupAvatarServer :: ByteString -> Bool -> IO (Either DNSError (Maybe NU.Host)) lookupAvatarServer domain https = do let service = serviceName domain https rs <- makeResolvSeed defaultResolvConf result <- withResolver rs $ \ resolver -> lookupSRV resolver service case result of Left e -> return $ Left e Right records -> liftM Right $ normalizedTarget records https -- Assemble the final avatar URL based on the provided components 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 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. -- -- 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 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 $ T.pack $ NU.exportURL url