diff --git a/Handler/Activate.hs b/Handler/Activate.hs index befc858..22f216f 100644 --- a/Handler/Activate.hs +++ b/Handler/Activate.hs @@ -1,20 +1,60 @@ module Handler.Activate where -import Import as I +import Import as I hiding (returnJson) import Data.Text +import Data.Text.Encoding +import Data.Maybe import System.Directory import System.FilePath getActivateR :: Text -> Handler Html getActivateR token = do - t <- runDB $ selectFirst [TokenToken ==. token] [] + t <- runDB $ selectFirst [ActivatorToken ==. token] [] case t of Nothing -> do setMessage "Invalid Token!" redirect $ HomeR - Just x -> do - userId <- runDB $ insert $ tokenUser (entityVal x) - liftIO $ createDirectoryIfMissing True $ "static" > "data" > (unpack $ extractKey userId) - runDB $ delete (entityKey x) - setMessage $ "User activated" - redirect $ HomeR + Just (Entity activatorKey activator) -> do + uSalt <- return $ userSalt $ activatorUser activator + mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] + case mToken of + Just (Entity uTokenId uToken) -> do + hexSalt <- return $ toHex uSalt + defaultLayout $ do + $(widgetFile "activate") + _ -> do + returnJsonError "Invalid token!" + redirect $ ActivateR token + +postActivateR :: Text -> Handler RepJson +postActivateR token = do + msalted <- fromJust <$> lookupPostParam "salted" + salted <- return $ fromHex' $ unpack msalted + mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] + case mToken of + Just (Entity uTokenId uToken) -> do + newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] + case newUser of + Just (Entity aId activ) -> do + -- putting user in active state + uId <- runDB $ insert $ activatorUser activ + runDB $ update uId [UserSalted =. (Just salted)] + -- create user directory + liftIO $ createDirectoryIfMissing True $ "static" > "data" > (unpack $ extractKey uId) + -- cleanup + runDB $ delete aId + runDB $ delete uTokenId + -- login and redirect + setSession "userId" (extractKey uId) + welcomeLink <- ($ ProfileR uId) <$> getUrlRender + returnJson ["welcome" .= welcomeLink] + -- redirect $ HomeR + _ -> do + returnJsonError "Invalid activation token!" + +returnJson :: (Monad m, ToJSON a, a ~ Value) => + [(Text, a)] -> m RepJson +returnJson = return . repJson . object + +returnJsonError :: Text -> Handler RepJson +returnJsonError = returnJson . (:[]) . ("error" .=) diff --git a/Handler/Login.hs b/Handler/Login.hs index c24491f..dae4dc2 100644 --- a/Handler/Login.hs +++ b/Handler/Login.hs @@ -1,7 +1,14 @@ module Handler.Login where -import Import -import Data.Text +import Import hiding (returnJson) +import qualified Data.Text as T +import Yesod hiding (returnJson) +import Crypto.HMAC +import Crypto.Hash.CryptoAPI (SHA1) +import qualified Data.ByteString as B +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Serialize (encode) +import Data.Maybe data Credentials = Credentials { credentialsName :: Text @@ -11,29 +18,59 @@ data Credentials = Credentials getLoginR :: Handler Html getLoginR = do - (loginWidget, enctype) <- generateFormPost loginForm +-- (loginWidget, enctype) <- generateFormPost loginForm defaultLayout $ do $(widgetFile "login") -postLoginR :: Handler Html + +postLoginR :: Handler RepJson postLoginR = do - ((result, loginWidget), enctype) <- runFormPost loginForm - case result of - FormSuccess cred -> do - tuser <- runDB $ selectFirst [UserName ==. credentialsName cred] [] - case tuser of - Just user -> do - case credentialsPasswd cred == userPassword (entityVal user) of - True -> do - setSession "userId" $ extractKey $ entityKey user - setMessage "Successfully logged in" - redirect $ HomeR - False -> do - setMessage $ "Login error" - redirect $ LoginR - Nothing -> do - setMessage "User does not exist" - redirect $ LoginR + mUserName <- lookupPostParam "username" + mHexToken <- lookupPostParam "token" + mHexResponse <- lookupPostParam "response" + + case (mUserName, mHexToken, mHexResponse) of + (Just userName, Nothing, Nothing) -> do + tempUser <- runDB $ selectFirst [UserName ==. userName] [] + case tempUser of + Just (Entity userId user) -> do + salt <- return $ userSalt user + token <- liftIO makeRandomToken + tokenId <- runDB $ insert $ Token (encodeUtf8 token) "login" (Just userId) + returnJson ["salt" .= (toHex salt), "token" .= (toHex $ encodeUtf8 token)] + Nothing -> + returnJsonError ("No such user" :: T.Text) + + (Nothing, Just hexToken, Just hexResponse) -> do + response <- do + tempToken <- return $ fromHex' $ T.unpack hexToken + savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] [] + case savedToken of + Just (Entity tokenId token) -> do + savedUserId <- return $ tokenUser token + queriedUser <- runDB $ getJust (fromJust savedUserId) + salted <- return $ userSalted queriedUser + hexSalted <- return $ toHex $ fromJust salted + expected <- return $ hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted) + case (fromHex' $ T.unpack hexResponse) == expected of + True -> + -- Success!! + return $ Right savedUserId + _ -> + return $ Left ("Wrong password" :: T.Text) + Nothing -> + return $ Left "Invalid token" + case response of + Left msg -> + returnJsonError msg + Right userId -> do + setSession "userId" $ extractKey (fromJust userId) + welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender + returnJson ["welcome" .= welcomeLink] + + _ -> + returnJsonError ("Protocol error" :: T.Text) + loginForm :: Form Credentials loginForm = renderDivs $ Credentials @@ -45,3 +82,13 @@ getLogoutR = do deleteSession "userId" setMessage "Succesfully logged out" redirect $ HomeR + +returnJson = return . repJson . object + +returnJsonError = returnJson . (:[]) . ("error" .=) + +hmacSHA1 keyData msgData = + let key = MacKey keyData + sha1 :: SHA1 + sha1 = hmac' key msgData + in encode sha1 diff --git a/Handler/Signup.hs b/Handler/Signup.hs index c13e43f..4119ebc 100644 --- a/Handler/Signup.hs +++ b/Handler/Signup.hs @@ -4,54 +4,72 @@ module Handler.Signup where import Import as I import System.Random import Data.Text as T +import Data.Text.Encoding +import Data.ByteString as B +import Data.Maybe import Network.Mail.Mime import Text.Blaze.Html.Renderer.Utf8 getSignupR :: Handler Html getSignupR = do - (signupWidget, enctype) <- generateFormPost signupForm +-- (signupWidget, enctype) <- generateFormPost signupForm defaultLayout $ do $(widgetFile "signup") postSignupR :: Handler Html postSignupR = do - ((result, signupWidget), enctype) <- runFormPost signupForm - case result of - FormSuccess user -> do - namesakes <- runDB $ selectList [UserName ==. (userName user)] [] - case (validateLen (userName user)) && ((I.length namesakes) == 0) of - True -> do - tokenString <- liftIO generateString - uId <- runDB $ insert $ Token tokenString user - activateLink <- ($ ActivateR tokenString) <$> getUrlRender - sendMail (userEmail user) "Please activate your account!" $ - [shamlet| -