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
data UserAddress
= Email Text
| OpenID Text
data SpecialImage
= SpecialMysteryPerson
| SpecialIdenticon
| SpecialMonsterID
| SpecialWavatar
| SpecialRetro
data DefaultImage
= ImgLibravatarLogo
| ImgNotFound
| ImgSpecial SpecialImage
| ImgCustom Text
instance Default DefaultImage where
def = ImgLibravatarLogo
data Size
= Size Int
| DefaultSize
instance Default Size where
def = DefaultSize
data AvatarOptions = AvatarOptions
{
optSecure :: Bool
, optDefault :: DefaultImage
, optSize :: Size
, 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
hashMail :: Bool -> ByteString -> ByteString
hashMail True = hashMD5
hashMail False = hashSHA256
hashOpenid :: ByteString -> ByteString
hashOpenid = hashSHA256
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)
sizeToMaybe :: Size -> Maybe Int
sizeToMaybe (Size n) = Just n
sizeToMaybe DefaultSize = Nothing
showSpecial :: SpecialImage -> String
showSpecial SpecialMysteryPerson = "mm"
showSpecial SpecialIdenticon = "identicon"
showSpecial SpecialMonsterID = "monsterid"
showSpecial SpecialWavatar = "wavatar"
showSpecial SpecialRetro = "retro"
showDefault :: DefaultImage -> Maybe String
showDefault ImgLibravatarLogo = Nothing
showDefault ImgNotFound = Just "404"
showDefault (ImgSpecial img) = Just $ showSpecial img
showDefault (ImgCustom url) = Just $ T.unpack url
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]
serviceName :: ByteString -> Bool -> Domain
serviceName domain https =
if https
then serviceBaseSecure <> "." <> domain
else serviceBase <> "." <> domain
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'
#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
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
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)
rs ->
weightedRandom weight rs >>=
\ (_, _, port, target) -> return $ Just (target, port)
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
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
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
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
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