{- This file is part of libravatar for Haskell.
 -
 - Written in 2015, 2016, 2017 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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/>.
 -}

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Libravatar is a decentralized avatar delivery system. Instead of relying
-- on a single centralized provider, it can use DNS records to detect the host
-- of the avatar image. There is a server implementation which anyone can run
-- and host their avatars and there are client libraries for many languages,
-- all free-as-in-freedom software.
--
-- This module is a Haskell client library for Libravatar.
--
-- Note that this library doesn't actually fetch the image over HTTP. That part
-- is left to the various HTTP client packages, such as @http-client@. What
-- this library does is construct the image URL, possibly using DNS queries
-- when needed for the decentralization. You can then fetch the image over HTTP
-- or use the URL in your web app's HTML page templates, in which case the
-- user's web brower will be downloading the image.
--
-- Now let's see how it works.
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > import Data.Default.Class (def)
-- > import Network.Libravatar
--
-- Examples:
--
-- Email, HTTP, default fallback image (the libravatar logo),
-- default size (80):
--
-- >>> avatarUrl (Email "john@doe.org") def
-- >>>     { 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") def
-- >>>     { 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") def
-- >>>     { 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.)
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

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

instance Default DefaultImage where
    def = ImgLibravatarLogo

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

instance Default Size where
    def = DefaultSize

-- | Avatar details in addition to the user address itself. Define by starting
-- with 'defOpts' and override fields using record syntax.
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
      -- | If an image is not found in the Libravatar database, it can first
      -- redirect to gravatar in case the image exists there, and only then
      -- honour the 'optDefault' parameter. This option sets whether Libravatar
      -- should try gravatar or go straight to the 'optDefault' when an image
      -- isn't found.
    , 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

-- Hash email using MD5 or SHA256 depending on whether gr4va7ar should be used
hashMail :: Bool -> ByteString -> ByteString
hashMail True  = hashMD5
hashMail False = hashSHA256

-- OpenIDs must be hashed with SHA256
hashOpenid :: ByteString -> ByteString
hashOpenid = hashSHA256

-- From email or openid, generate avatar hash and get the relevant domain
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)

-- 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 $ T.unpack url

-- Determine URL query parameters
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]

-- Get the DNS service to query for a given domain and scheme
serviceName :: ByteString -> Bool -> Domain
serviceName domain https =
    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
#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'

-- Ensure we are getting a (mostly) valid hostname and port number from the DNS
-- resolver
#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

-- Get the right (target, port) pair from a list of SRV records
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
        -- 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)
            rs                     ->
                weightedRandom weight rs >>=
                \ (_, _, 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
#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
    -- 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 $ NU.Host (NU.HTTP https) target' port'
        _ -> Nothing

-- Get avatar server from SRV record
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

-- Assemble the final avatar URL based on the provided components
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

-- | 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.
--
-- See examples at the top of the page.
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