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| -

Welcome to Eidolon! - To complete your sgnup please activate your account by visiting the following link - #{activateLink} - |] - setMessage "User created" - redirect $ HomeR - False -> do - setMessage "Username error" - redirect $ SignupR + mUserName <- lookupPostParam "username" + newUserName <- case validateLen (fromJust mUserName) of + True -> return $ fromJust $ mUserName + False -> do + setMessage "Invalid username" + redirect $ SignupR + mEmail <- lookupPostParam "email" + mTos1 <- lookupPostParam "tos-1" + mTos2 <- lookupPostParam "tos-2" + case (mTos1, mTos2) of + (Just "tos-1", Just "tos-2") -> + return () _ -> do - setMessage "Please try again" + setMessage "You need to agree to our terms." redirect $ SignupR -signupForm :: Form User -signupForm = renderDivs $ User - <$> areq textField "Username" Nothing - <*> areq emailField "Email" Nothing - <*> areq passwordField "Password" Nothing - <*> pure [] + -- create user + namesakes <- runDB $ selectList [UserName ==. newUserName] [] + case namesakes of + [] -> do + salt <- liftIO generateSalt + newUser <- return $ User newUserName (fromJust mEmail) "" salt Nothing [] + activatorText <- liftIO generateString + aId <- runDB $ insert $ Activator activatorText newUser + tId <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing + activateLink <- ($ ActivateR activatorText) <$> getUrlRender + sendMail (userEmail newUser) "Please activate your account!" $ + [shamlet| +

Welcome to Eidolon! + To complete your sgnup please activate your account by visiting the following link: + #{activateLink} + |] + setMessage "User pending activation" + redirect $ HomeR + _ -> do + setMessage "This user already exists" + redirect $ SignupR + +--signupForm :: Form User +--signupForm = renderDivs $ User +-- <$> areq textField "Username" Nothing +-- <*> areq emailField "Email" Nothing +-- <*> areq passwordField "Password" Nothing +-- <*> pure ("" :: ByteString) +-- <*> pure [] validateLen :: Text -> Bool validateLen a = (T.length a) > 3 -generateString :: IO Text -generateString = (T.pack . I.take 16 . randoms) <$> newStdGen +generateString :: IO T.Text +generateString = (toHex . B.pack . I.take 16 . randoms) <$> newStdGen sendMail :: MonadIO m => Text -> Text -> Html -> m () sendMail toEmail subject body = diff --git a/Helper.hs b/Helper.hs index 73fbe47..0a9489c 100644 --- a/Helper.hs +++ b/Helper.hs @@ -2,6 +2,11 @@ module Helper ( getUserIdFromText , extractKey -- , getUserNameById + , fromHex + , fromHex' + , toHex + , makeRandomToken + , generateSalt ) where @@ -9,22 +14,27 @@ import Prelude import Model import Control.Applicative import Control.Monad.Trans.Class -import Data.Text import Data.Maybe +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text as T import Database.Persist import Database.Persist.Types import System.FilePath +import System.Random import Yesod.Persist.Core import Yesod.Core.Types +import Numeric (readHex, showHex) -getUserIdFromText :: Text -> UserId +getUserIdFromText :: T.Text -> UserId getUserIdFromText tempUserId = - Key $ PersistInt64 $ fromIntegral $ read $ unpack tempUserId + Key $ PersistInt64 $ fromIntegral $ read $ T.unpack tempUserId -extractKey :: KeyBackend backend entity -> Text +extractKey :: KeyBackend backend entity -> T.Text extractKey = extractKey' . unKey where - extractKey' (PersistInt64 k) = pack $ show k + extractKey' (PersistInt64 k) = T.pack $ show k extractKey' _ = "" --getUserNameById :: UserId -> Text @@ -33,3 +43,33 @@ extractKey = extractKey' . unKey -- user = runDB $ getJust $ userId -- in -- userName user + +fromHex :: String -> BL.ByteString +fromHex = BL.pack . hexToWords + where hexToWords (c:c':text) = + let hex = [c, c'] + word = case readHex hex of + (d,_):_ -> d + [] -> error "empty list" + _ -> error "fuckup" +-- (word, _):_ = readHex hex + in word : hexToWords text + hexToWords _ = [] + +-- strict variant + +fromHex' :: String -> B.ByteString +fromHex' = B.concat . BL.toChunks . fromHex + +toHex :: B.ByteString -> T.Text +toHex = T.pack . concatMap mapByte . B.unpack + where mapByte = pad 2 '0' . flip showHex "" + pad len padding s + | length s < len = pad len padding $ padding:s + | otherwise = s + +makeRandomToken :: IO T.Text +makeRandomToken = (T.pack . take 16 . randoms) `fmap` newStdGen + +generateSalt :: IO B.ByteString +generateSalt = (B.pack . take 8 . randoms) <$> getStdGen diff --git a/Model.hs b/Model.hs index f99ab04..72fc004 100644 --- a/Model.hs +++ b/Model.hs @@ -5,6 +5,7 @@ import Data.Text (Text) import Database.Persist.Quasi import Data.Typeable (Typeable) import Data.Time (UTCTime) +import Data.ByteString import System.FilePath (FilePath) -- You can define all of your database entities in the entities file. diff --git a/config/models b/config/models index a62c975..db0b98f 100644 --- a/config/models +++ b/config/models @@ -2,12 +2,19 @@ User name Text email Text password Text + salt ByteString + salted ByteString Maybe albums [AlbumId] deriving Typeable -Token +Activator token Text user User deriving +Token + token ByteString + kind Text + user UserId Maybe + deriving Album title Text owner UserId @@ -20,7 +27,7 @@ Medium time UTCTime owner UserId description Textarea - tags [Text] + tags Texts album AlbumId deriving diff --git a/config/routes b/config/routes index 4a37c02..a2373ad 100644 --- a/config/routes +++ b/config/routes @@ -7,7 +7,7 @@ /signup SignupR GET POST /login LoginR GET POST /logout LogoutR GET -/activate/#Text ActivateR GET +/activate/#Text ActivateR GET POST /profile/#UserId ProfileR GET /user/#Text UserR GET /upload UploadR GET POST diff --git a/eidolon.cabal b/eidolon.cabal index d045fe7..26c49eb 100644 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -85,6 +85,9 @@ library , yesod-persistent , transformers , old-locale + , cereal + , cryptohash-cryptoapi + , crypto-api executable eidolon if flag(library-only) diff --git a/templates/login.hamlet b/templates/login.hamlet index 94e0ecd..fcf2b72 100644 --- a/templates/login.hamlet +++ b/templates/login.hamlet @@ -1,6 +1,18 @@ -

Login +$newline always -
- ^{loginWidget} -
- +
+