diff --git a/Application.hs b/Application.hs index 1a587b8..ff3f29b 100755 --- a/Application.hs +++ b/Application.hs @@ -48,9 +48,10 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger), -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! import Handler.Home -import Handler.Signup -import Handler.Login -import Handler.Activate +-- import Handler.Signup +-- import Handler.Login +-- import Handler.Activate +-- import Handler.Reactivate import Handler.Profile import Handler.Upload import Handler.NewAlbum @@ -58,7 +59,6 @@ import Handler.Album import Handler.Medium import Handler.AlbumSettings import Handler.MediumSettings -import Handler.Reactivate import Handler.ProfileSettings import Handler.ProfileDelete import Handler.Admin diff --git a/Foundation.hs b/Foundation.hs index 6b9d04b..9dc0ec4 100755 --- a/Foundation.hs +++ b/Foundation.hs @@ -14,6 +14,8 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE FlexibleInstances #-} + module Foundation where import Prelude @@ -31,8 +33,12 @@ import Yesod.Core.Types -- costom imports import qualified Data.Text as T import Data.Text.Encoding +import Data.Maybe (fromJust) import Network.Wai -import Helper +import Helper hiding (hmacKeccak) +import Yesod.Auth +import Yesod.Auth.HmacKeccak +import System.IO.Unsafe (unsafePerformIO) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -68,28 +74,20 @@ renderLayout widget = do master <- getYesod route <- getCurrentRoute mmsg <- getMessage - msu <- lookupSession "userId" - username <- case msu of - Just a -> do - let uId = getUserIdFromText a - user <- runDB $ getJust uId - return $ userName user + -- msu <- lookupSession "userId" + musername <- maybeAuthId + slug <- case musername of + Just name -> do + user <- runDB $ getBy $ UniqueUser name + return $ userSlug $ entityVal $ fromJust user Nothing -> return ("" :: T.Text) - slug <- case msu of - Just a -> do - let uId = getUserIdFromText a - user <- runDB $ getJust uId - return $ userSlug user + admin <- case musername of + Just name -> do + user <- runDB $ getBy $ UniqueUser name + return $ userAdmin $ entityVal $ fromJust user Nothing -> - return ("" :: T.Text) - madmin <- case msu of - Just a -> do - let uId = getUserIdFromText a - user <- runDB $ getJust uId - return $ Just $ userAdmin user - Nothing -> - return Nothing + return False let block = appSignupBlocked $ appSettings master -- We break up the default layout into two components: @@ -114,6 +112,7 @@ renderLayout widget = do pc <- widgetToPageContent $ do mapM_ addScript $ map StaticR [ js_picturefill_js + , js_jquery_min_js ] mapM_ addStylesheet $ map StaticR [ css_bootstrap_min_css @@ -131,7 +130,7 @@ approotRequest master req = Nothing -> appRoot $ appSettings master where prefix = - if + if "https://" `T.isPrefixOf` appRoot (appSettings master) then "https://" @@ -206,28 +205,22 @@ instance YesodPersist App where instance YesodPersistRunner App where getDBRunner = defaultGetDBRunner appConnPool --- instance YesodAuth App where --- type AuthId App = UserId +instance YesodAuth App where + type AuthId App = Username - -- Where to send a user after successful login --- loginDest _ = HomeR - -- Where to send a user after logout --- logoutDest _ = HomeR + -- Where to send a user after successful login + loginDest _ = HomeR + -- Where to send a user after logout + logoutDest _ = HomeR --- getAuthId creds = runDB $ do --- x <- getBy $ UniqueUser $ credsIdent creds --- case x of --- Just (Entity uid _) -> return $ Just uid --- Nothing -> do --- fmap Just $ insert User --- { userIdent = credsIdent creds --- , userPassword = Nothing --- } + getAuthId = return . Just . credsIdent - -- You can add other plugins like BrowserID, email or OAuth here --- authPlugins _ = [authBrowserId def] + -- You can add other plugins like BrowserID, email or OAuth here + authPlugins _ = [hmacPlugin] --- authHttpManager = httpManager + authHttpManager = error "no HttpManager needed" + + maybeAuthId = lookupSession credsKey -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. @@ -244,3 +237,60 @@ instance RenderMessage App FormMessage where -- wiki: -- -- https://github.com/yesodweb/yesod/wiki/Sending-email + +instance YesodHmacKeccak (HmacPersistDB App User Token) App where + runHmacDB = runHmacPersistDB + +instance UserCredentials (Entity User) where + userUserName = userName . entityVal + userUserSalt = userSalt . entityVal + userUserSalted = userSalted . entityVal + userUserEmail = userEmail . entityVal + userUserActive = userActive . entityVal + +instance TokenData (Entity Token) where + tokenTokenKind = tokenKind . entityVal + tokenTokenUsername = tokenUsername . entityVal + tokenTokenToken = tokenToken . entityVal + +instance PersistUserCredentials User where + userUsernameF = UserName + userUserSaltF = UserSalt + userUserSaltedF = UserSalted + userUserEmailF = UserEmail + userUserActiveF = UserActive + uniqueUsername = UniqueUser + + userCreate name email salt = User name name email salt "" [] False (-1) False + +instance PersistToken Token where + tokenTokenTokenF = TokenToken + tokenTokenKindF = TokenKind + tokenTokenUsernameF = TokenUsername + uniqueToken = UniqueToken + + tokenCreate t u k = Token t k u + +instance HmacSendMail App where + sendVerifyEmail username email url = + sendMail email "Please activate your account!" $ + [shamlet| +

Hello #{username} and welcome to Eidolon! +To complete your signup process, please activate your account by visiting the +following link: +#{url} + +See you soon! + |] + + sendReactivateEmail username email url = do + muser <- runDB $ getBy $ UniqueUser username + let user = entityVal $ fromJust muser + sendMail email "Reset your password" $ + [shamlet| +

Welcome again to Eidolon #{userSlug user} +To reset your password visit the following link: +#{url} + +See you soon! + |] diff --git a/Handler/Activate.hs b/Handler/Activate.hs index 3cde985..156dd2d 100755 --- a/Handler/Activate.hs +++ b/Handler/Activate.hs @@ -15,171 +15,186 @@ -- along with this program. If not, see . module Handler.Activate where -import Import as I hiding (returnJson) -import Data.Text -import Data.Text.Encoding -import Data.Maybe -import System.Directory -import System.FilePath - -import qualified Data.ByteString.Char8 as BC - -import Handler.Login - -getActivateR :: Text -> Handler Html -getActivateR token = do - t <- runDB $ selectFirst [ActivatorToken ==. token] [] - (activateRawWidget, _) <- generateFormPost $ - renderBootstrap3 BootstrapBasicForm activateForm - case t of - Nothing -> do - mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] - case mToken of - Just (Entity _ uToken) -> do - user <- runDB $ getJust (fromJust $ tokenUser uToken) - let hexSalt = toHex $ userSalt user - master <- getYesod - let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) - defaultLayout $ do - setTitle "Activate your account" - $(widgetFile "activate") - _ -> do - setMessage "Invalid token!" - redirect HomeR - Just (Entity _ activator) -> do - let uSalt = userSalt $ activatorUser activator - mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] - case mToken of - Just (Entity _ _) -> do - let hexSalt = toHex uSalt - master <- getYesod - let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) - defaultLayout $ - $(widgetFile "activate") - _ -> do - setMessage "Invalid token!" - redirect HomeR - -postActivateR :: Text -> Handler RepJson -postActivateR token = do - msalted <- fromJust <$> lookupPostParam "salted" - let salted = fromHex' $ unpack msalted - mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] - case mToken of - Just (Entity uTokenId uToken) -> - if - isNothing (tokenUser uToken) - then do - newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] - case newUser of - Just (Entity aId activ) -> do - namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] [] - if - I.null namesakes - then do - -- putting user in active state - uId <- runDB $ insert $ activatorUser activ - runDB $ update uId [UserSalted =. 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] - else do - -- cleanup - runDB $ delete aId - runDB $ delete uTokenId - returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String) - Nothing -> - returnJsonError ("Invalid token" :: String) - else do - runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] - -- cleanup - runDB $ delete uTokenId - setSession "userId" (extractKey $ fromJust $ tokenUser uToken) - welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender - returnJson ["welcome" .= welcomeLink] - _ -> - returnJsonError ("Invalid activation token!" :: String) - -data ActivateFormRes = ActivateFormRes - { pass1 :: Text - , pass2 :: Text - } - -activateForm :: AForm Handler ActivateFormRes -activateForm = ActivateFormRes - <$> areq passwordField (bfs ("Password" :: Text)) Nothing - <*> areq passwordField (bfs ("Repeat Password" :: Text)) Nothing - <* bootstrapSubmit ("Activate" :: BootstrapSubmit Text) - -postActivateRawR :: Text -> Handler Html -postActivateRawR token = do - ((res, _), _) <- runFormPost $ - renderBootstrap3 BootstrapBasicForm activateForm - case res of - FormSuccess pwd -> do - if pass1 pwd == pass2 pwd - then do - mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] - case mToken of - Just (Entity uTokenId uToken) -> - if - isNothing (tokenUser uToken) - then do - newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] - case newUser of - Just (Entity aId activ) -> do - namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] [] - if - I.null namesakes - then do - let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt $ activatorUser activ) (encodeUtf8 $ pass1 pwd) - -- putting user in active state - uId <- runDB $ insert $ activatorUser activ - runDB $ update uId [UserSalted =. 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) - setMessage "Successfully activated" - redirect $ ProfileR uId - else do - -- cleanup - runDB $ delete aId - runDB $ delete uTokenId - setMessage "Somebody already activated your username. Your token has been deleted" - redirect HomeR - Nothing -> do - setMessage "Invalid token" - redirect HomeR - else do - uuser <- runDB $ getJust $ fromJust $ tokenUser uToken - let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt uuser) (encodeUtf8 $ pass1 pwd) - runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] - -- cleanup - runDB $ delete uTokenId - setSession "userId" (extractKey $ fromJust $ tokenUser uToken) - setMessage "Successfully activated" - redirect $ ProfileR (fromJust $ tokenUser uToken) - Nothing -> do - setMessage "Invalid activation token!" - redirect HomeR - else do - setMessage "Passwords must match!" - redirect $ ActivateR token - _ -> do - setMessage "Activation error" - redirect HomeR +-- import Import as I hiding (returnJson) +-- import Data.Text +-- import Data.Text.Encoding +-- import Data.Maybe +-- import System.Directory +-- import System.FilePath +-- +-- import qualified Data.ByteString.Char8 as BC +-- +-- import Handler.Login +-- +-- -- getActivateR :: Text -> Handler Html +-- getActivateR token = do +-- t <- runDB $ getBy $ UniqueToken token +-- case t of +-- Nothing -> do +-- setMessage "Invalid token!" +-- redirect HomeR +-- Just (Entity tId token) -> do +-- master <- getYesod +-- (Entity uId user) <- +-- runDB $ getJust <$> getBy $ UniqueUser $ tokenUsername token +-- let hexSalt = toHex $ userSalt user +-- addWarn = "http://" `isPrefixOf` appRoot (appSettings master) +-- defaultLayout $ do +-- setTitle "Activate your account" +-- $(widgetFile "activate") +-- +-- t <- runDB $ selectFirst [ActivatorToken ==. token] [] +-- (activateRawWidget, _) <- generateFormPost $ +-- renderBootstrap3 BootstrapBasicForm activateForm +-- case t of +-- Nothing -> do +-- mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] +-- case mToken of +-- Just (Entity _ uToken) -> do +-- user <- runDB $ getBy $ UniqueUser $ tokenUsername uToken +-- let hexSalt = toHex $ userSalt user +-- master <- getYesod +-- let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) +-- defaultLayout $ do +-- setTitle "Activate your account" +-- $(widgetFile "activate") +-- _ -> do +-- setMessage "Invalid token!" +-- redirect HomeR +-- Just (Entity _ activator) -> do +-- let uSalt = userSalt $ activatorUser activator +-- mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] +-- case mToken of +-- Just (Entity _ _) -> do +-- let hexSalt = toHex uSalt +-- master <- getYesod +-- let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) +-- defaultLayout $ +-- $(widgetFile "activate") +-- _ -> do +-- setMessage "Invalid token!" +-- redirect HomeR +-- +-- postActivateR :: Text -> Handler RepJson +-- postActivateR token = do +-- msalted <- fromJust <$> lookupPostParam "salted" +-- let salted = fromHex' $ unpack msalted +-- mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] +-- case mToken of +-- Just (Entity uTokenId uToken) -> +-- if +-- isNothing (tokenUser uToken) +-- then do +-- newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] +-- case newUser of +-- Just (Entity aId activ) -> do +-- namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] [] +-- if +-- I.null namesakes +-- then do +-- -- putting user in active state +-- uId <- runDB $ insert $ activatorUser activ +-- runDB $ update uId [UserSalted =. 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] +-- else do +-- -- cleanup +-- runDB $ delete aId +-- runDB $ delete uTokenId +-- returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String) +-- Nothing -> +-- returnJsonError ("Invalid token" :: String) +-- else do +-- runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] +-- -- cleanup +-- runDB $ delete uTokenId +-- setSession "userId" (extractKey $ fromJust $ tokenUser uToken) +-- welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender +-- returnJson ["welcome" .= welcomeLink] +-- _ -> +-- returnJsonError ("Invalid activation token!" :: String) +-- +-- data ActivateFormRes = ActivateFormRes +-- { pass1 :: Text +-- , pass2 :: Text +-- } +-- +-- activateForm :: AForm Handler ActivateFormRes +-- activateForm = ActivateFormRes +-- <$> areq passwordField (bfs ("Password" :: Text)) Nothing +-- <*> areq passwordField (bfs ("Repeat Password" :: Text)) Nothing +-- <* bootstrapSubmit ("Activate" :: BootstrapSubmit Text) +-- +-- postActivateRawR :: Text -> Handler Html +-- postActivateRawR token = do +-- ((res, _), _) <- runFormPost $ +-- renderBootstrap3 BootstrapBasicForm activateForm +-- case res of +-- FormSuccess pwd -> do +-- if pass1 pwd == pass2 pwd +-- then do +-- mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] +-- case mToken of +-- Just (Entity uTokenId uToken) -> +-- if +-- isNothing (tokenUser uToken) +-- then do +-- newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] +-- case newUser of +-- Just (Entity aId activ) -> do +-- namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] [] +-- if +-- I.null namesakes +-- then do +-- let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt $ activatorUser activ) (encodeUtf8 $ pass1 pwd) +-- -- putting user in active state +-- uId <- runDB $ insert $ activatorUser activ +-- runDB $ update uId [UserSalted =. 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) +-- setMessage "Successfully activated" +-- redirect $ ProfileR uId +-- else do +-- -- cleanup +-- runDB $ delete aId +-- runDB $ delete uTokenId +-- setMessage "Somebody already activated your username. Your token has been deleted" +-- redirect HomeR +-- Nothing -> do +-- setMessage "Invalid token" +-- redirect HomeR +-- else do +-- uuser <- runDB $ getJust $ fromJust $ tokenUser uToken +-- let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt uuser) (encodeUtf8 $ pass1 pwd) +-- runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] +-- -- cleanup +-- runDB $ delete uTokenId +-- setSession "userId" (extractKey $ fromJust $ tokenUser uToken) +-- setMessage "Successfully activated" +-- redirect $ ProfileR (fromJust $ tokenUser uToken) +-- Nothing -> do +-- setMessage "Invalid activation token!" +-- redirect HomeR +-- else do +-- setMessage "Passwords must match!" +-- redirect $ ActivateR token +-- _ -> do +-- setMessage "Activation error" +-- redirect HomeR -- returnJson :: (Monad m, a ~ Value) => -- [(Text, a)] -> m RepJson diff --git a/Handler/AdminProfileSettings.hs b/Handler/AdminProfileSettings.hs index 1131e26..cb49343 100755 --- a/Handler/AdminProfileSettings.hs +++ b/Handler/AdminProfileSettings.hs @@ -139,6 +139,7 @@ adminProfileForm owner = User <*> pure (userAlbums owner) <*> areq boolField (bfs ("Admin" :: T.Text)) (Just $ userAdmin owner) <*> areq (selectField licenses) (bfs ("Default licence" :: T.Text)) (Just $ userDefaultLicence owner) + <*> pure (userActive owner) <* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text) where licenses = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] diff --git a/Handler/AlbumSettings.hs b/Handler/AlbumSettings.hs index 0e7578e..e9c5460 100755 --- a/Handler/AlbumSettings.hs +++ b/Handler/AlbumSettings.hs @@ -49,7 +49,7 @@ getAlbumSettingsR albumId = do redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to change settings" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This album does not exist" redirect HomeR @@ -121,7 +121,7 @@ postAlbumSettingsR albumId = do redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to change settings" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This album does not exist" redirect HomeR @@ -160,7 +160,7 @@ getAlbumDeleteR albumId = do redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to delete albums" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This album does not exist" redirect HomeR @@ -220,7 +220,7 @@ postAlbumDeleteR albumId = do redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to delete albums" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This album does not exist" redirect HomeR diff --git a/Handler/Commons.hs b/Handler/Commons.hs index 09ca94a..39c313d 100755 --- a/Handler/Commons.hs +++ b/Handler/Commons.hs @@ -51,7 +51,7 @@ loginIsAdmin = do else return $ Left ("You have no admin rights", HomeR) Nothing -> - return $ Left ("You are not logged in", LoginR) + return $ Left ("You are not logged in", AuthR LoginR) profileCheck :: IsString t => UserId -> Handler (Either (t, Route App) User) profileCheck userId = do @@ -69,7 +69,7 @@ profileCheck userId = do else return $ Left ("You can only change your own profile settings", UserR $ userName user) Nothing -> - return $ Left ("You nedd to be logged in to change settings", LoginR) + return $ Left ("You nedd to be logged in to change settings", AuthR LoginR) Nothing -> return $ Left ("This user does not exist", HomeR) @@ -93,7 +93,7 @@ mediumCheck mediumId = do else return $ Left ("You must own this medium to change its settings", MediumR mediumId) Nothing -> - return $ Left ("You must be logged in to change settings", LoginR) + return $ Left ("You must be logged in to change settings", AuthR LoginR) Nothing -> return $ Left ("This medium does not exist", HomeR) diff --git a/Handler/Login.hs b/Handler/Login.hs index 94a2b67..d7203c3 100755 --- a/Handler/Login.hs +++ b/Handler/Login.hs @@ -52,12 +52,12 @@ postLoginR = do mHexResponse <- lookupPostParam "response" case (mUserName, mHexToken, mHexResponse) of (Just userName, Nothing, Nothing) -> do - tempUser <- runDB $ selectFirst [UserName ==. userName] [] + tempUser <- runDB $ getBy $ UniqueUser userName case tempUser of Just (Entity userId user) -> do let salt = userSalt user token <- liftIO makeRandomToken - runDB $ insert_ $ Token (encodeUtf8 token) "login" (Just userId) + runDB $ insert_ $ Token (encodeUtf8 token) "login" userName returnJson ["salt" .= toHex salt, "token" .= toHex (encodeUtf8 token)] Nothing -> returnJsonError ("No such user" :: T.Text) @@ -67,16 +67,17 @@ postLoginR = do savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] [] case savedToken of Just (Entity tokenId token) -> do - let savedUserId = tokenUser token - queriedUser <- runDB $ getJust (fromJust savedUserId) - let salted = userSalted queriedUser - let hexSalted = toHex salted - let expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted) + let savedUserName = tokenUsername token + mqueriedUser <- runDB $ getBy $ UniqueUser savedUserName + let queriedUser = entityVal $ fromJust mqueriedUser + salted = userSalted queriedUser + hexSalted = toHex salted + expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted) if encodeUtf8 hexResponse == expected then do -- Success!! runDB $ delete tokenId - return $ Right savedUserId + return $ Right $ (entityKey $ fromJust mqueriedUser) else return $ Left ("Wrong password" :: T.Text) Nothing -> @@ -85,9 +86,9 @@ postLoginR = do Left msg -> returnJsonError msg Right userId -> do - setSession "userId" $ extractKey (fromJust userId) + setSession "userId" $ extractKey userId setMessage "Succesfully logged in" - welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender + welcomeLink <- ($ProfileR userId) <$> getUrlRender returnJson ["welcome" .= welcomeLink] _ -> returnJsonError ("Protocol error" :: T.Text) diff --git a/Handler/Medium.hs b/Handler/Medium.hs index 30c180c..fbc1c22 100755 --- a/Handler/Medium.hs +++ b/Handler/Medium.hs @@ -107,7 +107,7 @@ postMediumR mediumId = do redirect $ MediumR mediumId Nothing -> do setMessage "You need to be looged in to comment on media" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This image does not exist" redirect HomeR @@ -141,7 +141,7 @@ getCommentReplyR commentId = do $(widgetFile "commentReply") Nothing -> do setMessage "You need to be logged in to comment on media" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This comment does not Exist" redirect HomeR @@ -198,7 +198,7 @@ postCommentReplyR commentId = do redirect $ CommentReplyR commentId Nothing -> do setMessage "You need to be logged in to post replies" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This comment does not exist!" redirect HomeR @@ -223,7 +223,7 @@ getCommentDeleteR commentId = do redirect $ MediumR $ commentOrigin comment Nothing -> do setMessage "You must be logged in to delete comments" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This comment does not exist" redirect HomeR @@ -261,7 +261,7 @@ postCommentDeleteR commentId = do redirect $ MediumR $ commentOrigin comment Nothing -> do setMessage "You must be logged in to delete comments" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This comment does not exist" redirect HomeR diff --git a/Handler/NewAlbum.hs b/Handler/NewAlbum.hs index ac38d96..840cc49 100755 --- a/Handler/NewAlbum.hs +++ b/Handler/NewAlbum.hs @@ -37,7 +37,7 @@ getNewAlbumR = do $(widgetFile "newAlbum") Nothing -> do setMessage "You need to be logged in" - redirect LoginR + redirect $ AuthR LoginR postNewAlbumR :: Handler Html postNewAlbumR = do @@ -74,7 +74,7 @@ postNewAlbumR = do redirect NewAlbumR Nothing -> do setMessage "You must be logged in to create albums" - redirect LoginR + redirect $ AuthR LoginR albumForm :: UserId -> AForm Handler Album albumForm userId = Album diff --git a/Handler/ProfileSettings.hs b/Handler/ProfileSettings.hs index 1421ed0..0916d25 100755 --- a/Handler/ProfileSettings.hs +++ b/Handler/ProfileSettings.hs @@ -70,6 +70,7 @@ profileSettingsForm user = User <*> pure (userAdmin user) <*> areq (selectField licences) (bfs ("Default licence for media" :: T.Text)) (Just $ userDefaultLicence user) + <*> pure (userActive user) <* bootstrapSubmit ("Change settings" :: BootstrapSubmit Text) where licences = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] diff --git a/Handler/Reactivate.hs b/Handler/Reactivate.hs index cdda1e8..ea00dd8 100755 --- a/Handler/Reactivate.hs +++ b/Handler/Reactivate.hs @@ -37,7 +37,7 @@ postReactivateR = do then do userTokens <- foldM (\userTokens (Entity userId user) -> do token <- liftIO $ generateString - _ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (Just userId) + _ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (userName user) return $ (user, token) : userTokens ) [] users _ <- foldM (\sent (user, token) -> diff --git a/Handler/Signup.hs b/Handler/Signup.hs index 436fd37..e0b6c41 100755 --- a/Handler/Signup.hs +++ b/Handler/Signup.hs @@ -64,7 +64,7 @@ postSignupR = do let newUser = User newUserName newUserName (fromJust mEmail) salt "" [] False (fromEnum AllRightsReserved) activatorText <- liftIO generateString _ <- runDB $ insert $ Activator activatorText newUser - _ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing + _ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" newUserName activateLink <- ($ ActivateR activatorText) <$> getUrlRender sendMail (userEmail newUser) "Please activate your account!" $ [shamlet| diff --git a/Handler/Upload.hs b/Handler/Upload.hs index 5cb14eb..2c98347 100755 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -61,7 +61,7 @@ getDirectUploadR albumId = do redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to upload" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "This album does not exist" redirect HomeR @@ -168,7 +168,7 @@ getUploadR = do $(widgetFile "bulkUpload") Nothing -> do setMessage "You need to be logged in" - redirect LoginR + redirect $ AuthR LoginR bulkUploadForm :: UserId -> User -> AForm Handler FileBulk bulkUploadForm userId user = (\a b c d e f g h -> FileBulk b c d e f g a h) @@ -234,4 +234,4 @@ postUploadR = do redirect UploadR Nothing -> do setMessage "You need to be logged in" - redirect LoginR + redirect $ AuthR LoginR diff --git a/Import.hs b/Import.hs index 86f07d8..dffe4e7 100755 --- a/Import.hs +++ b/Import.hs @@ -21,6 +21,7 @@ module Import import Prelude as Import hiding (head, init, last, readFile, tail, writeFile) import Yesod as Import hiding (Route (..)) +import Yesod.Auth as Import import Yesod.Static as Import import Yesod.Form.Bootstrap3 as Import diff --git a/config/models b/config/models index c4224b1..90034ee 100755 --- a/config/models +++ b/config/models @@ -23,6 +23,7 @@ User albums [AlbumId] admin Bool defaultLicence Int default=-1 + active Bool default=True UniqueUser name deriving Typeable Eq Show Activator @@ -32,7 +33,8 @@ Activator Token token ByteString kind Text - user UserId Maybe + username Text + UniqueToken token deriving Eq Show Album title Text diff --git a/config/routes b/config/routes index 08c586f..161ffa5 100755 --- a/config/routes +++ b/config/routes @@ -15,18 +15,20 @@ -- along with this program. If not, see . /static StaticR Static appStatic +/auth AuthR Auth getAuth /favicon.ico FaviconR GET /robots.txt RobotsR GET / HomeR GET /page/#Int PageR GET -/signup SignupR GET POST -/login LoginR GET POST -/loginraw LoginRawR POST -/logout LogoutR GET -/activate/#T.Text ActivateR GET POST -/activateraw/#T.Text ActivateRawR POST +-- /signup SignupR GET POST +-- /login LoginR GET POST +-- /loginraw LoginRawR POST +-- /logout LogoutR GET +-- /activate/#T.Text ActivateR GET POST +-- /activateraw/#T.Text ActivateRawR POST +-- /reactivate ReactivateR GET POST /profile/#UserId ProfileR GET /user/#T.Text UserR GET /user/#T.Text/album/#T.Text BeautyAlbumR GET @@ -42,7 +44,6 @@ /medium/#MediumId/move MediumMoveR GET POST /comment/#CommentId/reply CommentReplyR GET POST /comment/#CommentId/delcom CommentDeleteR GET POST -/reactivate ReactivateR GET POST /profile/#UserId/settings ProfileSettingsR GET POST /profile/#UserId/delete ProfileDeleteR GET POST diff --git a/eidolon.cabal b/eidolon.cabal index 29eefc9..78fe7d9 100755 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -31,9 +31,10 @@ library Settings.StaticFiles Settings.Development Handler.Home - Handler.Signup - Handler.Login - Handler.Activate + -- Handler.Signup + -- Handler.Login + -- Handler.Activate + -- Handler.Reactivate Handler.Profile Handler.Upload Handler.NewAlbum @@ -41,7 +42,6 @@ library Handler.Medium Handler.AlbumSettings Handler.MediumSettings - Handler.Reactivate Handler.ProfileSettings Handler.ProfileDelete Handler.Admin @@ -142,6 +142,8 @@ library , yesod-form >= 1.4.7 , magic , texmath < 0.9 + , yesod-auth + , yesod-auth-hmac-keccak executable eidolon if flag(library-only) diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index cf8b175..f8b3a6a 100755 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -5,7 +5,7 @@
  • Home - $maybe _ <- msu + $maybe username <- musername
  • @@ -22,20 +22,19 @@ Upload images
  • - + Logout - $maybe admin <- madmin - $if admin -
  • - - Administration + $if admin +
  • + + Administration $nothing
  • - + Login $if block == False
  • - + Signup