module Happstack.Authenticate.Core
( HappstackAuthenticateI18N(..)
, UserId(..)
, unUserId
, rUserId
, succUserId
, jsonOptions
, toJSONResponse
, toJSONSuccess
, toJSONError
, Username(..)
, unUsername
, rUsername
, Email(..)
, unEmail
, User(..)
, userId
, username
, email
, UserIxs
, IxUser
, SharedSecret(..)
, unSharedSecret
, genSharedSecret
, genSharedSecretDevURandom
, genSharedSecretSysRandom
, SharedSecrets
, initialSharedSecrets
, CoreError(..)
, NewAccountMode(..)
, AuthenticateState(..)
, sharedSecrets
, users
, nextUserId
, defaultSessionTimeout
, newAccountMode
, initialAuthenticateState
, SetSharedSecret(..)
, GetSharedSecret(..)
, SetDefaultSessionTimeout(..)
, GetDefaultSessionTimeout(..)
, SetNewAccountMode(..)
, GetNewAccountMode(..)
, CreateUser(..)
, CreateAnonymousUser(..)
, UpdateUser(..)
, DeleteUser(..)
, GetUserByUsername(..)
, GetUserByUserId(..)
, GetUserByEmail(..)
, GetAuthenticateState(..)
, getOrGenSharedSecret
, Token(..)
, tokenUser
, tokenIsAuthAdmin
, TokenText
, issueToken
, decodeAndVerifyToken
, authCookieName
, addTokenCookie
, deleteTokenCookie
, getTokenCookie
, getTokenHeader
, getToken
, getUserId
, AuthenticationMethod(..)
, unAuthenticationMethod
, rAuthenticationMethod
, AuthenticationHandler
, AuthenticationHandlers
, AuthenticateURL(..)
, rAuthenticationMethods
, rControllers
, authenticateURL
, nestAuthenticationMethod
) where
import Control.Applicative (Applicative(pure), Alternative, (<$>), optional)
import Control.Category ((.), id)
import Control.Exception (SomeException)
import qualified Control.Exception as E
import Control.Lens ((?=), (.=), (^.), (.~), makeLenses, view, set)
import Control.Lens.At (IxValue(..), Ixed(..), Index(..), At(at))
import Control.Monad.Trans (MonadIO(liftIO))
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put, modify)
import Data.Aeson (FromJSON(..), ToJSON(..), Result(..), fromJSON)
import qualified Data.Aeson as A
import Data.Aeson.Types (Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON)
import Data.Acid (AcidState, Update, Query, makeAcidic)
import Data.Acid.Advanced (update', query')
import Data.ByteString.Base64 (encode)
import qualified Data.ByteString.Char8 as B
import Data.Data (Data, Typeable)
import Data.Default (def)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, maybeToList)
import Data.Monoid ((<>), mconcat)
import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)
import Data.IxSet.Typed
import qualified Data.IxSet.Typed as IxSet
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Data.UserId (UserId(..), rUserId, succUserId, unUserId)
import GHC.Generics (Generic)
import Happstack.Server (Cookie(secure), CookieLife(Session, MaxAge), Happstack, ServerPartT, Request(rqSecure), Response, addCookie, askRq, expireCookie, getHeaderM, lookCookie, lookCookieValue, mkCookie, notFound, toResponseBS)
import Language.Javascript.JMacro
import Prelude hiding ((.), id)
import System.IO (IOMode(ReadMode), withFile)
import System.Random (randomRIO)
import Text.Boomerang.TH (makeBoomerangs)
import Text.Shakespeare.I18N (RenderMessage(renderMessage), mkMessageFor)
import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, secret, verify)
import Web.Routes (RouteT, PathInfo(..), nestURL)
import Web.Routes.Boomerang
import Web.Routes.Happstack ()
import Web.Routes.TH (derivePathInfo)
data HappstackAuthenticateI18N = HappstackAuthenticateI18N
jsonOptions :: Options
jsonOptions = defaultOptions { fieldLabelModifier = drop 1 }
toJSONResponse :: (RenderMessage HappstackAuthenticateI18N e, ToJSON a) => Either e a -> Response
toJSONResponse (Left e) = toJSONError e
toJSONResponse (Right a) = toJSONSuccess a
toJSONSuccess :: (ToJSON a) => a -> Response
toJSONSuccess a = toResponseBS "application/json" (A.encode a)
toJSONError :: forall e. (RenderMessage HappstackAuthenticateI18N e) => e -> Response
toJSONError e = toResponseBS "application/json" (A.encode (A.object ["error" A..= renderMessage HappstackAuthenticateI18N ["en"] e]))
newtype Username = Username { _unUsername :: Text }
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
deriveSafeCopy 1 'base ''Username
makeLenses ''Username
makeBoomerangs ''Username
instance ToJSON Username where toJSON (Username i) = toJSON i
instance FromJSON Username where parseJSON v = Username <$> parseJSON v
instance PathInfo Username where
toPathSegments (Username t) = toPathSegments t
fromPathSegments = Username <$> fromPathSegments
newtype Email = Email { _unEmail :: Text }
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
deriveSafeCopy 1 'base ''Email
makeLenses ''Email
instance ToJSON Email where toJSON (Email i) = toJSON i
instance FromJSON Email where parseJSON v = Email <$> parseJSON v
instance PathInfo Email where
toPathSegments (Email t) = toPathSegments t
fromPathSegments = Email <$> fromPathSegments
data User = User
{ _userId :: UserId
, _username :: Username
, _email :: Maybe Email
}
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
deriveSafeCopy 1 'base ''User
makeLenses ''User
instance ToJSON User where toJSON = genericToJSON jsonOptions
instance FromJSON User where parseJSON = genericParseJSON jsonOptions
type UserIxs = '[UserId, Username, Email]
type IxUser = IxSet UserIxs User
instance Indexable UserIxs User where
indices = ixList
(ixFun $ (:[]) . view userId)
(ixFun $ (:[]) . view username)
(ixFun $ maybeToList . view email)
newtype SharedSecret = SharedSecret { _unSharedSecret :: Text }
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
deriveSafeCopy 1 'base ''SharedSecret
makeLenses ''SharedSecret
genSharedSecret :: (MonadIO m) => m SharedSecret
genSharedSecret = liftIO $ E.catch genSharedSecretDevURandom (\(_::SomeException) -> genSharedSecretSysRandom)
genSharedSecretDevURandom :: IO SharedSecret
genSharedSecretDevURandom = withFile "/dev/urandom" ReadMode $ \h -> do
secret <- B.hGet h 32
return $ SharedSecret . Text.decodeUtf8 . encode $ secret
genSharedSecretSysRandom :: IO SharedSecret
genSharedSecretSysRandom = randomChars >>= return . SharedSecret . Text.decodeUtf8 . encode . B.pack
where randomChars = sequence $ replicate 32 $ randomRIO ('\NUL', '\255')
type SharedSecrets = Map UserId SharedSecret
initialSharedSecrets :: SharedSecrets
initialSharedSecrets = Map.empty
data CoreError
= HandlerNotFound
| URLDecodeFailed
| UsernameAlreadyExists
| AuthorizationRequired
| Forbidden
| JSONDecodeFailed
| InvalidUserId
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
instance ToJSON CoreError where toJSON = genericToJSON jsonOptions
instance FromJSON CoreError where parseJSON = genericParseJSON jsonOptions
instance ToJExpr CoreError where
toJExpr = toJExpr . toJSON
deriveSafeCopy 0 'base ''CoreError
mkMessageFor "HappstackAuthenticateI18N" "CoreError" "messages/core" ("en")
data NewAccountMode
= OpenRegistration
| ModeratedRegistration
| ClosedRegistration
deriving (Eq, Show, Typeable, Generic)
deriveSafeCopy 1 'base ''NewAccountMode
data AuthenticateState = AuthenticateState
{ _sharedSecrets :: SharedSecrets
, _users :: IxUser
, _nextUserId :: UserId
, _defaultSessionTimeout :: Int
, _newAccountMode :: NewAccountMode
}
deriving (Eq, Show, Typeable, Generic)
deriveSafeCopy 1 'base ''AuthenticateState
makeLenses ''AuthenticateState
initialAuthenticateState :: AuthenticateState
initialAuthenticateState = AuthenticateState
{ _sharedSecrets = initialSharedSecrets
, _users = IxSet.empty
, _nextUserId = UserId 1
, _defaultSessionTimeout = 60*60
, _newAccountMode = OpenRegistration
}
setSharedSecret :: UserId
-> SharedSecret
-> Update AuthenticateState ()
setSharedSecret userId sharedSecret =
sharedSecrets . at userId ?= sharedSecret
getSharedSecret :: UserId
-> Query AuthenticateState (Maybe SharedSecret)
getSharedSecret userId =
view (sharedSecrets . at userId)
setDefaultSessionTimeout :: Int
-> Update AuthenticateState ()
setDefaultSessionTimeout newTimeout =
modify $ \as@AuthenticateState{..} -> as { _defaultSessionTimeout = newTimeout }
getDefaultSessionTimeout :: Query AuthenticateState Int
getDefaultSessionTimeout =
view defaultSessionTimeout <$> ask
setNewAccountMode :: NewAccountMode
-> Update AuthenticateState ()
setNewAccountMode mode =
newAccountMode .= mode
getNewAccountMode :: Query AuthenticateState NewAccountMode
getNewAccountMode =
view newAccountMode
createUser :: User
-> Update AuthenticateState (Either CoreError User)
createUser u =
do as@AuthenticateState{..} <- get
if IxSet.null $ (as ^. users) @= (u ^. username)
then do
let user' = set userId _nextUserId u
as' = as { _users = IxSet.insert user' _users
, _nextUserId = succ _nextUserId
}
put as'
return (Right user')
else
return (Left UsernameAlreadyExists)
createAnonymousUser :: Update AuthenticateState User
createAnonymousUser =
do as@AuthenticateState{..} <- get
let user = User { _userId = _nextUserId
, _username = Username ("Anonymous " <> Text.pack (show _nextUserId))
, _email = Nothing
}
as' = as { _users = IxSet.insert user _users
, _nextUserId = succ _nextUserId
}
put as'
return user
updateUser :: User
-> Update AuthenticateState ()
updateUser u =
do as@AuthenticateState{..} <- get
let as' = as { _users = IxSet.updateIx (u ^. userId) u _users
}
put as'
deleteUser :: UserId
-> Update AuthenticateState ()
deleteUser uid =
do as@AuthenticateState{..} <- get
let as' = as { _users = IxSet.deleteIx uid _users
}
put as'
getUserByUsername :: Username
-> Query AuthenticateState (Maybe User)
getUserByUsername username =
do us <- view users
return $ getOne $ us @= username
getUserByUserId :: UserId
-> Query AuthenticateState (Maybe User)
getUserByUserId userId =
do us <- view users
return $ getOne $ us @= userId
getUserByEmail :: Email
-> Query AuthenticateState (Maybe User)
getUserByEmail email =
do us <- view users
return $ getOne $ us @= email
getAuthenticateState :: Query AuthenticateState AuthenticateState
getAuthenticateState = ask
makeAcidic ''AuthenticateState
[ 'setDefaultSessionTimeout
, 'getDefaultSessionTimeout
, 'setSharedSecret
, 'getSharedSecret
, 'setNewAccountMode
, 'getNewAccountMode
, 'createUser
, 'createAnonymousUser
, 'updateUser
, 'deleteUser
, 'getUserByUsername
, 'getUserByUserId
, 'getUserByEmail
, 'getAuthenticateState
]
getOrGenSharedSecret :: (MonadIO m) =>
AcidState AuthenticateState
-> UserId
-> m (SharedSecret)
getOrGenSharedSecret authenticateState uid =
do mSSecret <- query' authenticateState (GetSharedSecret uid)
case mSSecret of
(Just ssecret) -> return ssecret
Nothing -> do
ssecret <- genSharedSecret
update' authenticateState (SetSharedSecret uid ssecret)
return ssecret
data Token = Token
{ _tokenUser :: User
, _tokenIsAuthAdmin :: Bool
}
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
makeLenses ''Token
instance ToJSON Token where toJSON = genericToJSON jsonOptions
instance FromJSON Token where parseJSON = genericParseJSON jsonOptions
type TokenText = Text
issueToken :: (MonadIO m) =>
AcidState AuthenticateState
-> (UserId -> IO Bool)
-> User
-> m TokenText
issueToken authenticateState isAuthAdmin user =
do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId)
admin <- liftIO $ isAuthAdmin (user ^. userId)
let claims = def { unregisteredClaims =
Map.fromList [ ("user" , toJSON user)
, ("authAdmin", toJSON admin)
] }
return $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims
decodeAndVerifyToken :: (MonadIO m) =>
AcidState AuthenticateState
-> TokenText
-> m (Maybe (Token, JWT VerifiedJWT))
decodeAndVerifyToken authenticateState token =
do
let mUnverified = decode token
case mUnverified of
Nothing -> return Nothing
(Just unverified) ->
case Map.lookup "user" (unregisteredClaims (claims unverified)) of
Nothing -> return Nothing
(Just uv) ->
case fromJSON uv of
(Error _) -> return Nothing
(Success u) ->
do
mssecret <- query' authenticateState (GetSharedSecret (u ^. userId))
case mssecret of
Nothing -> return Nothing
(Just ssecret) ->
case verify (secret (_unSharedSecret ssecret)) unverified of
Nothing -> return Nothing
(Just verified) ->
case Map.lookup "authAdmin" (unregisteredClaims (claims verified)) of
Nothing -> return (Just (Token u False, verified))
(Just a) ->
case fromJSON a of
(Error _) -> return (Just (Token u False, verified))
(Success b) -> return (Just (Token u b, verified))
authCookieName :: String
authCookieName = "atc"
addTokenCookie :: (Happstack m) =>
AcidState AuthenticateState
-> (UserId -> IO Bool)
-> User
-> m TokenText
addTokenCookie authenticateState isAuthAdmin user =
do token <- issueToken authenticateState isAuthAdmin user
s <- rqSecure <$> askRq
addCookie (MaxAge (60*60*24*30)) ((mkCookie authCookieName (Text.unpack token)) { secure = s })
return token
deleteTokenCookie :: (Happstack m) =>
m ()
deleteTokenCookie =
expireCookie authCookieName
getTokenCookie :: (Happstack m) =>
AcidState AuthenticateState
-> m (Maybe (Token, JWT VerifiedJWT))
getTokenCookie authenticateState =
do mToken <- optional $ lookCookieValue authCookieName
case mToken of
Nothing -> return Nothing
(Just token) -> decodeAndVerifyToken authenticateState (Text.pack token)
getTokenHeader :: (Happstack m) =>
AcidState AuthenticateState
-> m (Maybe (Token, JWT VerifiedJWT))
getTokenHeader authenticateState =
do mAuth <- getHeaderM "Authorization"
case mAuth of
Nothing -> return Nothing
(Just auth') ->
do let auth = B.drop 7 auth'
decodeAndVerifyToken authenticateState (Text.decodeUtf8 auth)
getToken :: (Happstack m) =>
AcidState AuthenticateState
-> m (Maybe (Token, JWT VerifiedJWT))
getToken authenticateState =
do mToken <- getTokenHeader authenticateState
case mToken of
Nothing -> getTokenCookie authenticateState
(Just token) -> return (Just token)
getUserId :: (Happstack m) =>
AcidState AuthenticateState
-> m (Maybe UserId)
getUserId authenticateState =
do mToken <- getToken authenticateState
case mToken of
Nothing -> return Nothing
(Just (token, _)) -> return $ Just (token ^. tokenUser ^. userId)
newtype AuthenticationMethod = AuthenticationMethod
{ _unAuthenticationMethod :: Text }
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
derivePathInfo ''AuthenticationMethod
deriveSafeCopy 1 'base ''AuthenticationMethod
makeLenses ''AuthenticationMethod
makeBoomerangs ''AuthenticationMethod
instance ToJSON AuthenticationMethod where toJSON (AuthenticationMethod method) = toJSON method
instance FromJSON AuthenticationMethod where parseJSON v = AuthenticationMethod <$> parseJSON v
type AuthenticationHandler = [Text] -> RouteT AuthenticateURL (ServerPartT IO) Response
type AuthenticationHandlers = Map AuthenticationMethod AuthenticationHandler
data AuthenticateURL
=
AuthenticationMethods (Maybe (AuthenticationMethod, [Text]))
| Controllers
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
makeBoomerangs ''AuthenticateURL
authenticateURL :: Router () (AuthenticateURL :- ())
authenticateURL =
(
"authentication-methods" </> ( rAuthenticationMethods . rMaybe authenticationMethod)
<> "controllers" . rControllers
)
where
userId = rUserId . integer
authenticationMethod = rPair . (rAuthenticationMethod . anyText) </> (rListSep anyText eos)
instance PathInfo AuthenticateURL where
fromPathSegments = boomerangFromPathSegments authenticateURL
toPathSegments = boomerangToPathSegments authenticateURL
nestAuthenticationMethod :: (PathInfo methodURL) =>
AuthenticationMethod
-> RouteT methodURL m a
-> RouteT AuthenticateURL m a
nestAuthenticationMethod authenticationMethod =
nestURL $ \methodURL -> AuthenticationMethods $ Just (authenticationMethod, toPathSegments methodURL)