{- 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
    ( UserAddress (..)
    , SpecialImage (..)
    , DefaultImage (..)
    , Size (..)
    , AvatarOptions (..)
    , 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

-- | User address for which to generate an avatar URL. Email or OpenID.
data UserAddress
    = Email String  -- ^ For example @john\@doe.org@
    | OpenID String -- ^ 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 String

-- | 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

-- | Avatar details in addition to the user address itself.
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
    }

-- 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 :: UserAddress -> Maybe (String, String)
parseUserAddress (Email 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 (OpenID 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)

-- 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 url

-- Determine URL query parameters
buildParams :: DefaultImage -> Size -> [(String, String)]
buildParams def size =
    let defParam = fmap ((,) "d") $ showDefault def
        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 :: 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 fails to be parsed.
--
-- Examples:
--
-- Email, HTTP, default fallback image (the libravatar logo),
-- default size (80):
--
-- >>> avatarUrl (Email "john@doe.org") AvatarOptions
-- >>>     { 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") AvatarOptions
-- >>>     { 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") AvatarOptions
-- >>>     { 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.)
avatarUrl :: UserAddress -> AvatarOptions -> IO (Maybe String)
avatarUrl address options =
    let (hash, domain) = fromMaybe ("", "") $ parseUserAddress address
        params = buildParams (optDefault options) (optSize options)
        https = optSecure options
    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