login and signup via plugin work now

This commit is contained in:
nek0 2017-04-24 07:46:34 +02:00
parent a379d8af45
commit be32449430
18 changed files with 331 additions and 258 deletions

View File

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

View File

@ -14,6 +14,8 @@
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# 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|
<h1>Hello #{username} and welcome to Eidolon!
To complete your signup process, please activate your account by visiting the
following link:
<a href=#{url}>#{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|
<h1>Welcome again to Eidolon #{userSlug user}
To reset your password visit the following link:
<a href=#{url}>#{url}
See you soon!
|]

View File

@ -15,171 +15,186 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -15,18 +15,20 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
/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

View File

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

View File

@ -5,7 +5,7 @@
<li>
<a href=@{HomeR}>
Home
$maybe _ <- msu
$maybe username <- musername
<li>
<label for="cb1">
<a>
@ -22,20 +22,19 @@
<a href=@{UploadR}>
Upload images
<li>
<a href=@{LogoutR}>
<a href=@{AuthR LogoutR}>
Logout
$maybe admin <- madmin
$if admin
<li>
<a href=@{AdminR} .red>
Administration
$if admin
<li>
<a href=@{AdminR} .red>
Administration
$nothing
<li>
<a href=@{LoginR}>
<a href=@{AuthR LoginR}>
Login
$if block == False
<li>
<a href=@{SignupR}>
<a href=@{AuthR newAccountR}>
Signup
<!--<div .col-md-3 .col-sm-6 #search>
^{pageBody searchWidget}-->