module Network.Libravatar
( avatarUrl
)
where
import Control.Monad (liftM)
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
hashMail :: String -> String
hashMail =
let h :: String -> MD5Digest
h = hash' . BU.fromString
in show . h
hashOpenid :: String -> String
hashOpenid = show . sha256 . BLU.fromString
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)
buildParams :: Maybe String -> Maybe Int -> [(String, String)]
buildParams def size =
let defParam = liftM ((,) "d") def
size' = liftM (max minAvatarSize . min maxAvatarSize) size
sizeParam = liftM ((,) "s" . show) size'
in catMaybes [defParam, sizeParam]
serviceName :: String -> Bool -> Domain
serviceName domain https =
BC.pack $
if https
then serviceBaseSecure ++ '.' : domain
else serviceBase ++ '.' : domain
weightedRandom :: (a -> Int) -> [a] -> IO a
weightedRandom getw l =
let wlist = map getw l
wlist' = map (max 0) 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'
targetSane :: Domain -> Int -> Bool
targetSane target port =
not (BC.null target) && BC.any ok_host target && 1 <= port && port <= 65535
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
topPrio = maximum $ map priority records
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)
normalizedTarget :: [(Int, Int, Int, Domain)]
-> Bool
-> IO (Maybe Host)
normalizedTarget records https = do
tp <- srvHostname records
let sane = maybe False (uncurry targetSane) tp
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
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 -> liftM Right $ normalizedTarget records https
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
avatarUrl
:: Either String String
-> Bool
-> Maybe String
-> Maybe Int
-> 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