  Most functionality on Vocabulink --- such as review scheduling --- is for
-- registered members only.

module Vocabulink.Member ( Member(..), AuthToken(..), validAuth, authToken
                         , authCookie, emptyAuthCookie, authShelfLife
                         ) where

import Vocabulink.Utils

import qualified Data.ByteString.Lazy.Char8 as BC8
import qualified Data.ByteString.UTF8 as BU
import Data.Digest.Pure.SHA (hmacSha1)
import Web.Cookie (SetCookie(..))

data Member = Member { memberNumber :: Int32
                     , memberName   :: String
                     , memberEmail  :: Maybe String
                     } deriving (Eq, Show)

instance ToJSON Member where
  toJSON m = object [ "name" .= (memberName m)
                    , "hash" .= (gravatarHash `liftM` memberEmail m)
                    ]

-- Creating the Auth Token

-- Each time a member logs in, we send an authentication cookie to their
-- browser. The cookie is a digest of some state information. We then use the
-- cookie for authenticating their identity on subsequent requests.

data AuthToken = AuthToken { authMemberNumber  :: Int32
                           , authExpiry        :: EpochTime
  HMAC hash
                           }

  We give the token 30 days to expire . We do n't want it expiring too soon
-- because it becomes bothersome to keep logging in. However, we don't want
-- members to stay logged in forever, and using a non-expiring cookie would
-- require us to check the database for each authentication to see if we need
-- to de-authenticate the client.

authShelfLife :: EpochTime
authShelfLife = 30 * 24 * 60 * 60

-- Here is the format of the actual cookie we send to the client.

instance Show AuthToken where
  show a = show (authMemberNumber a) ++ "." ++ show (authExpiry a) ++ "." ++ (authDigest a)

instance Read AuthToken where
  readsPrec _ =
    \s -> case splitOn "." s of
            [m,e,d] -> [(AuthToken (read m) (read e) d, "")]
            _ -> []

  | Create an AuthToken with the default expiration time , automatically
-- calculating the digest.
authToken :: Int32 -> String -> IO AuthToken
authToken memberNo tokenKey = do
  now <- epochTime
  let expires = now + authShelfLife
      digest = tokenDigest AuthToken { authMemberNumber = memberNo
                                     , authExpiry = expires
                                     , authDigest = ""
                                     } tokenKey
  return AuthToken { authMemberNumber  = memberNo
                   , authExpiry = expires
                   , authDigest = digest
                   }

  | This generates the HMAC digest of the auth token using  .
  Eventually , we need to rotate the key used to generate the HMAC , while still
-- storing old keys long enough to use them for any valid login session. Without
-- this, authentication is less secure.
tokenDigest :: AuthToken -> String -> String
tokenDigest a tokenKey = show $ hmacSha1 (BC8.pack tokenKey) (BC8.pack token)
  where token = show (authMemberNumber a) ++ show (authExpiry a)

-- -- Setting the cookie is rather simple by this point. We just create the auth
-- -- token and send it to the client.

authCookie :: Int32 -> String -> IO SetCookie
authCookie memberNo tokenKey = do
  token <- authToken memberNo tokenKey
  return $ emptyAuthCookie { setCookieValue  = BU.fromString $ show token
                           , setCookieMaxAge = Just $ secondsToDiffTime $ convert authShelfLife
                           }

emptyAuthCookie :: SetCookie
emptyAuthCookie =
  def { setCookieName     = "auth"
      , setCookieValue    = ""
      , setCookieDomain   = Just "www.vocabulink.com"
      , setCookiePath     = Just "/"
      , setCookieHttpOnly = True
      }

-- Reading the Auth Token

-- This retrieves the auth token from the HTTP request, verifies it, and if
-- valid, returns it. To verify an auth token, we verify the token digest and
-- check that the cookie hasn't expired.

validAuth :: String -> String -> IO (Maybe AuthToken)
validAuth tokenKey token = do
  case readMaybe token of
    Nothing -> return Nothing
    Just t -> do
      now <- epochTime
      if tokenDigest t tokenKey == authDigest t && authExpiry t > now
        then return $ Just t
        else return Nothing

- such as review scheduling --- is for
 registered members only.
 Creating the Auth Token
 Each time a member logs in, we send an authentication cookie to their
 browser. The cookie is a digest of some state information. We then use the
 cookie for authenticating their identity on subsequent requests.
 because it becomes bothersome to keep logging in. However, we don't want
 members to stay logged in forever, and using a non-expiring cookie would
 require us to check the database for each authentication to see if we need
 to de-authenticate the client.
 Here is the format of the actual cookie we send to the client.
 calculating the digest.
 storing old keys long enough to use them for any valid login session. Without
 this, authentication is less secure.
 -- Setting the cookie is rather simple by this point. We just create the auth
 -- token and send it to the client.
 Reading the Auth Token
 This retrieves the auth token from the HTTP request, verifies it, and if
 valid, returns it. To verify an auth token, we verify the token digest and
 check that the cookie hasn't expired.

module Vocabulink.Member ( Member(..), AuthToken(..), validAuth, authToken
                         , authCookie, emptyAuthCookie, authShelfLife
                         ) where

import Vocabulink.Utils

import qualified Data.ByteString.Lazy.Char8 as BC8
import qualified Data.ByteString.UTF8 as BU
import Data.Digest.Pure.SHA (hmacSha1)
import Web.Cookie (SetCookie(..))

data Member = Member { memberNumber :: Int32
                     , memberName   :: String
                     , memberEmail  :: Maybe String
                     } deriving (Eq, Show)

instance ToJSON Member where
  toJSON m = object [ "name" .= (memberName m)
                    , "hash" .= (gravatarHash `liftM` memberEmail m)
                    ]



data AuthToken = AuthToken { authMemberNumber  :: Int32
                           , authExpiry        :: EpochTime
  HMAC hash
                           }

  We give the token 30 days to expire . We do n't want it expiring too soon

authShelfLife :: EpochTime
authShelfLife = 30 * 24 * 60 * 60


instance Show AuthToken where
  show a = show (authMemberNumber a) ++ "." ++ show (authExpiry a) ++ "." ++ (authDigest a)

instance Read AuthToken where
  readsPrec _ =
    \s -> case splitOn "." s of
            [m,e,d] -> [(AuthToken (read m) (read e) d, "")]
            _ -> []

  | Create an AuthToken with the default expiration time , automatically
authToken :: Int32 -> String -> IO AuthToken
authToken memberNo tokenKey = do
  now <- epochTime
  let expires = now + authShelfLife
      digest = tokenDigest AuthToken { authMemberNumber = memberNo
                                     , authExpiry = expires
                                     , authDigest = ""
                                     } tokenKey
  return AuthToken { authMemberNumber  = memberNo
                   , authExpiry = expires
                   , authDigest = digest
                   }

  | This generates the HMAC digest of the auth token using  .
  Eventually , we need to rotate the key used to generate the HMAC , while still
tokenDigest :: AuthToken -> String -> String
tokenDigest a tokenKey = show $ hmacSha1 (BC8.pack tokenKey) (BC8.pack token)
  where token = show (authMemberNumber a) ++ show (authExpiry a)


authCookie :: Int32 -> String -> IO SetCookie
authCookie memberNo tokenKey = do
  token <- authToken memberNo tokenKey
  return $ emptyAuthCookie { setCookieValue  = BU.fromString $ show token
                           , setCookieMaxAge = Just $ secondsToDiffTime $ convert authShelfLife
                           }

emptyAuthCookie :: SetCookie
emptyAuthCookie =
  def { setCookieName     = "auth"
      , setCookieValue    = ""
      , setCookieDomain   = Just "www.vocabulink.com"
      , setCookiePath     = Just "/"
      , setCookieHttpOnly = True
      }



validAuth :: String -> String -> IO (Maybe AuthToken)
validAuth tokenKey token = do
  case readMaybe token of
    Nothing -> return Nothing
    Just t -> do
      now <- epochTime
      if tokenDigest t tokenKey == authDigest t && authExpiry t > now
        then return $ Just t
        else return Nothing
