module Network.Salvia.Handler.Login
(
Username
, Password
, Email
, Action
, User (User)
, email
, username
, password
, actions
, LoginM (..)
, UserPayload (..)
, UserSession
, UserDatabase (UserDatabase)
, users
, backend
, Backend (..)
, noBackend
, fileBackend
, hGetUser
, hSignup
, hLogin
, hLogout
, hLoginfo
, hAuthorized
)
where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.State hiding (get)
import Data.ByteString.Lazy.UTF8 hiding (lines)
import Data.Digest.Pure.MD5
import Data.List
import Data.Maybe
import Data.Record.Label
import Network.Protocol.Http
import Network.Protocol.Uri
import Network.Salvia.Handler.Body
import Network.Salvia.Handler.Session
import Network.Salvia.Impl.Handler
import Network.Salvia.Interface
import Prelude hiding (mod)
import Safe
import qualified Control.Monad.State as S
type Username = String
type Email = String
type Password = String
type Action = String
data User = User
{ _username :: Username
, _email :: Email
, _password :: Password
, _actions :: [Action]
} deriving (Eq, Show)
$(mkLabels [''User])
username :: User :-> Username
email :: User :-> Email
password :: User :-> Password
actions :: User :-> [Action]
data UserPayload a = UserPayload
{ upUser :: User
, upLoggedIn :: Bool
, upPayload :: Maybe a
} deriving (Eq, Show)
type UserSession a = Session (UserPayload a)
data Backend = Backend
{ read :: MonadIO m => m UserDatabase
, add :: MonadIO m => User -> m ()
}
data UserDatabase = UserDatabase
{ _backend :: Backend
, _users :: [User]
}
$(mkLabels [''UserDatabase])
users :: UserDatabase :-> [User]
backend :: UserDatabase :-> Backend
class (Applicative m, Monad m) => LoginM p m | m -> p where
login :: m a -> (User -> m a) -> m a
loginfo :: m ()
logout :: m ()
signup :: [Action] -> m a -> (User -> m a) -> m a
authorized :: Maybe Action -> m a -> (User -> m a) -> m a
instance ( Contains q (TVar (Sessions (UserPayload p)))
, Contains q (TVar UserDatabase)
) => LoginM p (Handler q) where
login = hLogin (undefined :: p)
logout = hLogout (undefined :: p)
loginfo = hLoginfo (undefined :: p)
signup = hSignup (undefined :: p)
authorized = hAuthorized (undefined :: p)
hGetUser :: LoginM p m => m (Maybe User)
hGetUser = authorized Nothing (return Nothing) (return . Just)
hSignup
:: forall m q p a. (MonadIO m, PayloadM q UserDatabase m, SessionM (UserPayload p) m, BodyM Request m, HttpM Request m)
=> p -> [Action] -> m a -> (User -> m a) -> m a
hSignup _ acts onFail onOk =
do ps <- hRequestParameters "utf-8"
join . payload $
do db <- S.get
case freshUserInfo ps (get users db) acts of
Nothing -> return onFail
Just user ->
do modM users (user:)
return $
do add (get backend db) user
onOk user
freshUserInfo :: Parameters -> [User] -> [Action] -> Maybe User
freshUserInfo ps us acts =
do user <- "username" `lookup` ps >>= id
mail <- "email" `lookup` ps >>= id
pass <- "password" `lookup` ps >>= id
if null user || null mail || null pass
then Nothing
else case ( headMay $ filter ((==user) . get username) us
, headMay $ filter ((==mail) . get email) us
) of
(Nothing, Nothing) -> return $ User user mail (show (md5 (fromString pass))) acts
_ -> Nothing
hLogin
:: forall m q p a. (PayloadM q UserDatabase m, SessionM (UserPayload p) m, HttpM Request m, MonadIO m, BodyM Request m)
=> p -> m a -> (User -> m a) -> m a
hLogin _ onFail onOk =
do ps <- hRequestParameters "utf-8"
db <- payload S.get :: m UserDatabase
case authenticate ps db of
Nothing -> onFail
Just user -> do let pl = Just (UserPayload user True Nothing)
withSession (set sPayload pl)
onOk user
authenticate :: Parameters -> UserDatabase -> Maybe User
authenticate ps db =
do user <- "username" `lookup` ps >>= id
pass <- "password" `lookup` ps >>= id
case headMay $ filter ((==user) . get username) (get users db) of
Just u | get password u == show (md5 (fromString pass)) -> Just u
_ -> Nothing
hLogout :: SessionM (UserPayload p) m => p -> m ()
hLogout _ = withSession (set sPayload Nothing)
hLoginfo :: (SessionM (UserPayload p) m, SendM m) => p -> m ()
hLoginfo _ =
do hSessionInfo
s <- getSession
case get sPayload s of
Nothing -> return ()
Just (UserPayload (User uname mail _ acts) _ _) ->
do send $ "\n" ++ intercalate "\n"
[ "username=" ++ uname
, "mail=" ++ mail
, "actions=" ++ intercalate " " acts
]
hAuthorized :: SessionM (UserPayload p) m => p -> Maybe Action -> m b -> (User -> m b) -> m b
hAuthorized _ maction onFail onOk =
do session <- getSession
case (maction, get sPayload session) of
(Nothing, Just (UserPayload user _ _)) -> onOk user
(Just action, Just (UserPayload user _ _)) | action `elem` get actions user -> onOk user
_ -> onFail
noBackend :: Backend
noBackend = let b = Backend (return (UserDatabase b [])) (const (return ())) in b
fileBackend :: FilePath -> Backend
fileBackend file = bcknd
where
bcknd = Backend
((UserDatabase bcknd . parse) `liftM` liftIO (readFile file))
(liftIO . appendFile file . printUserLine)
parse = catMaybes . map parseUserLine . lines
parseUserLine line =
case (line, words line) of
('#':_, _) -> Nothing
(_, user:mail:pass:acts) -> Just (User user mail pass acts)
_ -> Nothing
printUserLine u = intercalate " " $
[ get username u
, get email u
, get password u
] ++ get actions u ++ ["\n"]