{- This file is part of libravatar for Haskell. - - Written in 2015 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 - . -} module Network.Libravatar ( avatarUrl ) where import Crypto.Classes (hash') import qualified Data.ByteString.Char8 as BC import Data.ByteString.UTF8 as BU (fromString) import Data.ByteString.Lazy.UTF8 as BLU (fromString) import Data.Char (toLower) import Data.Digest.Pure.MD5 (MD5Digest) import Data.Digest.Pure.SHA (sha256) import Data.List (partition) import Data.Maybe (catMaybes, fromMaybe) import Network.DNS.Lookup import Network.DNS.Resolver import Network.DNS.Types (DNSError, Domain) import Network.URI import Network.URL import System.Random (randomRIO) defaultHost = Host (HTTP False) "cdn.libravatar.org" Nothing defaultHostSecure = Host (HTTP True) "seccdn.libravatar.org" Nothing serviceBase = "_avatars._tcp" serviceBaseSecure = "_avatars-sec._tcp" minAvatarSize = 1 maxAvatarSize = 512 -- Hash emails with MD5, I think it's faster than SHA256 hashMail :: String -> String hashMail = let h :: String -> MD5Digest h = hash' . BU.fromString in show . h -- OpenIDs must be hashed with SHA256 hashOpenid :: String -> String hashOpenid = show . sha256 . BLU.fromString -- From email or openid, generate avatar hash and get the relevant domain parseUserAddress :: Either String String -> Maybe (String, String) parseUserAddress (Left email) = let lowEmail = map toLower email d = dropWhile (/= '@') lowEmail domain = if null d then d else tail d hash = hashMail lowEmail in Just (hash, domain) parseUserAddress (Right 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) -- Determine URL query parameters buildParams :: Maybe String -> Maybe Int -> [(String, String)] buildParams def size = let defParam = def >>= return . (,) "d" size' = size >>= return . max minAvatarSize . min maxAvatarSize sizeParam = size' >>= return . (,) "s" . show in catMaybes [defParam, sizeParam] -- Get the DNS service to query for a given domain and scheme serviceName :: String -> Bool -> Domain serviceName domain https = BC.pack $ 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 :: (a -> Int) -> [a] -> IO a weightedRandom getw l = let wlist = map getw l wlist' = map (\ w -> if w < 0 then 0 else w) wlist totalw = sum wlist' l' = zip l wlist' f r w [] = 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 targetSane :: Domain -> Int -> Bool targetSane target port = not (BC.null target) && BC.any 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)) 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) l -> weightedRandom weight l >>= \ (_, _, 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) 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 $ Host (HTTP https) target' port' _ -> Nothing -- Get avatar server from SRV record lookupAvatarServer :: String -> Bool -> IO (Either DNSError (Maybe 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 -> normalizedTarget records https >>= return . Right -- Assemble the final avatar URL based on the provided components composeAvatarUrl :: Maybe Host -> String -> [(String, String)] -> Bool -> URL composeAvatarUrl server hash params https = let server' = fromMaybe (if https then defaultHostSecure else defaultHost) server in URL (Absolute server') ("avatar/" ++ hash) params -- | Return a URL to the avatar image. avatarUrl :: Either String String -- ^ Email or OpenID -> Bool -- ^ Whether to use HTTPS -> Maybe String -- ^ Default picture URL if avatar not found -> Maybe Int -- ^ Image size in pixels, default is 80 -> IO (Maybe String) avatarUrl address https def size = let (hash, domain) = fromMaybe ("", "") $ parseUserAddress address params = buildParams def size in if 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