summaryrefslogtreecommitdiff
path: root/Network/Gravatar.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Network/Gravatar.hs')
-rw-r--r--Network/Gravatar.hs165
1 files changed, 101 insertions, 64 deletions
diff --git a/Network/Gravatar.hs b/Network/Gravatar.hs
index c9a9c3f..38867aa 100644
--- a/Network/Gravatar.hs
+++ b/Network/Gravatar.hs
@@ -1,81 +1,118 @@
---------------------------------------------------------------------
+-------------------------------------------------------------------------------
-- |
--- Module : Network.Gravatar
--- Copyright : (c) Galois, Inc. 2008
--- License : BSD3
+-- Module : Network.Gravatar
+-- Copyright : (c) Patrick Brisbin 2010
+-- License : as-is
--
--- Maintainer: Don Stewart <dons@galois.com>
--- Stability : provisional
--- Portability:
+-- Maintainer : pbrisbin@gmail.com
+-- Stability : unstable
+-- Portability : unportable
--
---------------------------------------------------------------------
---
--- Return the URL of a gravatar image - an image associated with an
--- email address.
---
--- Simple use:
---
--- > > gravatar "dons@galois.com"
--- > "http://www.gravatar.com/avatar.php?gravatar_id=f21827076a1d0725c4f4bd5a640102e9"
---
--- Optional arguments to specify the maximum classification rating
--- allowed, a size of the image (between 1 and 80 pixels) and a default url
--- to redirect to are provided by 'gravatarWith'.
+-- <http://en.gravatar.com/>.
--
+-------------------------------------------------------------------------------
+module Network.Gravatar
+ ( gravatar
-module Network.Gravatar (
- gravatar, gravatarWith
- ,Rating(..)
- ,Size,size
- ) where
+ -- * Options
+ , GravatarOptions(..)
+ , Size(..)
+ , DefaultImg(..)
+ , ForceDefault(..)
+ , Rating(..)
+ , defaultConfig
+ ) where
-import Data.Digest.OpenSSL.MD5
-import Data.List
-import Data.Char
-import Network.URI
-import qualified Data.ByteString.Char8 as S
+import Data.Digest.Pure.MD5 (md5)
+import Data.Default (Default(..))
+import Data.List (intercalate)
+import Data.Maybe (catMaybes)
+import Data.Text (Text)
+import Network.HTTP.Base (urlEncode)
-------------------------------------------------------------------------
--- Implementing the gravatar protocol
+import qualified Data.ByteString.Lazy.Char8 as C8
+import qualified Data.Text as T
--- | Classification ratings for gravatars
-data Rating = G | PG | R | X
- deriving (Eq,Ord,Bounded,Enum,Show,Read)
+class GravatarParam a where
+ toParam :: a -> Maybe (String, String)
--- | An image size in pixels from 1 to 80.
+-- | Size in pixels
newtype Size = Size Int
- deriving (Eq,Ord,Show)
--- | A smart constructor for the Size type, ensuring it is between 1 and 80
-size :: Int -> Maybe Size
-size n | n >= 1 && n <= 80 = Just (Size n)
- | otherwise = Nothing
+instance GravatarParam Size where
+ toParam (Size i) = Just ("s", show i)
-------------------------------------------------------------------------
+-- | Always show the default image
+newtype ForceDefault = ForceDefault Bool
-baseURL = "http://www.gravatar.com/avatar.php?"
-gravatar_id = "gravatar_id"
+instance GravatarParam ForceDefault where
+ toParam (ForceDefault b) = if b then Just ("f", "y") else Nothing
--- | Return the url of a gravatar for an
--- email address (a globally recognized avatar).
---
-gravatar :: String -> String
-gravatar who = gravatarWith who Nothing Nothing Nothing
+-- | Image to show when an avatar is not available
+data DefaultImg = Custom String -- ^ supply your own url
+ | NotFound -- ^ do not load an image return a 404
+ | MM -- ^ mystery man
+ | Identicon -- ^ geometric pattern based on the hash
+ | MonsterId -- ^ a generated monster
+ | Wavatar -- ^ generated faces
+ | Retro -- ^ generated, 8-bit arcade style pixelated face
+
+instance GravatarParam DefaultImg where
+ toParam (Custom s) = Just ("d", urlEncode s)
+ toParam NotFound = Just ("d", "404" )
+ toParam MM = Just ("d", "mm" )
+ toParam Identicon = Just ("d", "identicon")
+ toParam MonsterId = Just ("d", "monsterid")
+ toParam Wavatar = Just ("d", "wavatar" )
+ toParam Retro = Just ("d", "retro" )
+
+-- | Limit the returned images by rating
+data Rating = G | PG | R | X
+
+instance GravatarParam Rating where
+ toParam G = Just ("r", "g" )
+ toParam PG = Just ("r", "pg")
+ toParam R = Just ("r", "r" )
+ toParam X = Just ("r", "x" )
+
+data GravatarOptions = GravatarOptions
+ { gSize :: Maybe Size
+ , gDefault :: Maybe DefaultImg
+ , gForceDefault :: ForceDefault
+ , gRating :: Maybe Rating
+ }
+
+instance Default GravatarOptions where
+ def = defaultConfig
+
+defaultConfig :: GravatarOptions
+defaultConfig = GravatarOptions
+ { gSize = Nothing
+ , gDefault = Nothing
+ , gForceDefault = ForceDefault False
+ , gRating = Nothing
+ }
+
+-- | Return the avatar for the given email using the provided options
+gravatar :: GravatarOptions -> Text -> String
+gravatar opts e = "http://www.gravatar.com/avatar/" ++ hashEmail e `addParams` opts
+
+-- | <http://en.gravatar.com/site/implement/hash/>
+hashEmail :: Text -> String
+hashEmail = md5sum . T.toLower . T.strip
--- | Construct the url of a gravatar with optional classification
--- rating to limit to, an optional size in pixels, and optional default
--- url to redirect to, should no image be found.
---
-gravatarWith :: String
- -> Maybe Rating
- -> Maybe Size
- -> Maybe String
- -> String
-gravatarWith who rating' sz' dflt'
- = concat [baseURL ,gravatar_id ,"=" ,(md5sum (S.pack (clean who))),rating,sz,dflt ]
where
- clean = let f = reverse . dropWhile isSpace in f . f
- rating = maybe "" (\r -> "&rating="++show r) rating'
- sz = maybe "" (\(Size n) -> "&size="++show n) sz'
- dflt = maybe "" (\r -> "&default="++escapeURIString isUnreserved r) dflt'
+ md5sum :: Text -> String
+ md5sum = show . md5 . C8.pack . T.unpack
+addParams :: String -> GravatarOptions -> String
+addParams url opts = helper url . map (\(k,v) -> k ++ "=" ++ v)
+ $ catMaybes [ toParam =<< gSize opts
+ , toParam =<< gDefault opts
+ , toParam $ gForceDefault opts
+ , toParam =<< gRating opts
+ ]
+ where
+ helper :: String -> [String] -> String
+ helper u [] = u
+ helper u l = (++) u . (:) '?' $ intercalate "&" l