{- This file is part of libravatar for Haskell.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ 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
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

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

-- 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 = liftM ((,) "d") def
        size' = liftM (max minAvatarSize . min maxAvatarSize) size
        sizeParam = liftM ((,) "s" . show) size'
    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 (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'

-- 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 -> liftM Right $ normalizedTarget records https

-- 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.
--
-- If an error occurs, return 'Nothing'. Currently, this happens only if the
-- user address (first parameter) fails to be parsed.
--
-- Examples:
--
-- Email, HTTP, default fallback image (the libravatar logo),
-- default size (80):
--
-- >>> avatarUrl (Left "john@doe.org") False Nothing Nothing
-- 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 (Left "fr33domlover@rel4tion.org") True Nothing (Just 100)
-- Just "https://avatars.rel4tion.org:5679/avatar/e9e9ccabc2a166b1783bd7f4f9ceb376?s=100"
--
-- OpenID, HTTPS, specified fallback (special value \"retro\"), default
-- size (80):
--
-- >>> avatarUrl (Right "https://examplibre.org/accounts/xyz/id") True (Just "retro") Nothing
-- Just "https://seccdn.libravatar.org/avatar/c2cbc5f5a1784fa7105380e550360d73f15c4c1f9c7ca1ac436c45a33027fcd7?d=retro"
--
-- (Note that the 2nd example uses dummy SRV records created by the author,
-- and he doesn't really run (at the time of writing) a Libravatar provider.
-- This is just an example, the specific URL here will probably result with
-- 404.)
avatarUrl
    :: Either String String
    -- ^ User address. Email or OpenID.
    -> Bool
    -- ^ Whether the generated URL should be secure (use HTTPS).
    -> Maybe String
    -- ^ Default image URL if the user address isn't found in the Libravatar
    -- server's database. If you pass 'Nothing', the default image will be the
    -- Libravatar logo. A few special values are available, such as @404@
    -- (return HTTP 404 error instead of an image) and @retro@ (one of the
    -- several available simple default images).
    -> 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