nek0/eidolon
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

login and signup via plugin work now

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

8
Application.hs
View file

@ -48,9 +48,10 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
import Handler.Home import Handler.Home
import Handler.Signup -- import Handler.Signup
import Handler.Login -- import Handler.Login
import Handler.Activate -- import Handler.Activate
-- import Handler.Reactivate
import Handler.Profile import Handler.Profile
import Handler.Upload import Handler.Upload
import Handler.NewAlbum import Handler.NewAlbum
@ -58,7 +59,6 @@ import Handler.Album
import Handler.Medium import Handler.Medium
import Handler.AlbumSettings import Handler.AlbumSettings
import Handler.MediumSettings import Handler.MediumSettings
import Handler.Reactivate
import Handler.ProfileSettings import Handler.ProfileSettings
import Handler.ProfileDelete import Handler.ProfileDelete
import Handler.Admin import Handler.Admin

128
Foundation.hs
View file

@ -14,6 +14,8 @@
-- You should have received a copy of the GNU Affero General Public License -- 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/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE FlexibleInstances #-}
module Foundation where module Foundation where
import Prelude import Prelude
@ -31,8 +33,12 @@ import Yesod.Core.Types
-- costom imports -- costom imports
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding import Data.Text.Encoding
import Data.Maybe (fromJust)
import Network.Wai 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 -- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
@ -68,28 +74,20 @@ renderLayout widget = do
master <- getYesod master <- getYesod
route <- getCurrentRoute route <- getCurrentRoute
mmsg <- getMessage mmsg <- getMessage
msu <- lookupSession "userId" -- msu <- lookupSession "userId"
username <- case msu of musername <- maybeAuthId
Just a -> do slug <- case musername of
let uId = getUserIdFromText a Just name -> do
user <- runDB $ getJust uId user <- runDB $ getBy $ UniqueUser name
return $ userName user return $ userSlug $ entityVal $ fromJust user
Nothing -> Nothing ->
return ("" :: T.Text) return ("" :: T.Text)
slug <- case msu of admin <- case musername of
Just a -> do Just name -> do
let uId = getUserIdFromText a user <- runDB $ getBy $ UniqueUser name
user <- runDB $ getJust uId return $ userAdmin $ entityVal $ fromJust user
return $ userSlug user
Nothing -> Nothing ->
return ("" :: T.Text) return False
madmin <- case msu of
Just a -> do
let uId = getUserIdFromText a
user <- runDB $ getJust uId
return $ Just $ userAdmin user
Nothing ->
return Nothing
let block = appSignupBlocked $ appSettings master let block = appSignupBlocked $ appSettings master
-- We break up the default layout into two components: -- We break up the default layout into two components:
@ -114,6 +112,7 @@ renderLayout widget = do
pc <- widgetToPageContent $ do pc <- widgetToPageContent $ do
mapM_ addScript $ map StaticR mapM_ addScript $ map StaticR
[ js_picturefill_js [ js_picturefill_js
, js_jquery_min_js
] ]
mapM_ addStylesheet $ map StaticR mapM_ addStylesheet $ map StaticR
[ css_bootstrap_min_css [ css_bootstrap_min_css
@ -131,7 +130,7 @@ approotRequest master req =
Nothing -> appRoot $ appSettings master Nothing -> appRoot $ appSettings master
where where
prefix = prefix =
if if
"https://" `T.isPrefixOf` appRoot (appSettings master) "https://" `T.isPrefixOf` appRoot (appSettings master)
then then
"https://" "https://"
@ -206,28 +205,22 @@ instance YesodPersist App where
instance YesodPersistRunner App where instance YesodPersistRunner App where
getDBRunner = defaultGetDBRunner appConnPool getDBRunner = defaultGetDBRunner appConnPool
-- instance YesodAuth App where instance YesodAuth App where
-- type AuthId App = UserId type AuthId App = Username
-- Where to send a user after successful login -- Where to send a user after successful login
-- loginDest _ = HomeR loginDest _ = HomeR
-- Where to send a user after logout -- Where to send a user after logout
-- logoutDest _ = HomeR logoutDest _ = HomeR
-- getAuthId creds = runDB $ do getAuthId = return . Just . credsIdent
-- 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
-- }
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here
-- authPlugins _ = [authBrowserId def] authPlugins _ = [hmacPlugin]
-- authHttpManager = httpManager authHttpManager = error "no HttpManager needed"
maybeAuthId = lookupSession credsKey
-- This instance is required to use forms. You can modify renderMessage to -- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages. -- achieve customized and internationalized form validation messages.
@ -244,3 +237,60 @@ instance RenderMessage App FormMessage where
-- wiki: -- wiki:
-- --
-- https://github.com/yesodweb/yesod/wiki/Sending-email -- 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!
|]

345
Handler/Activate.hs
View file

@ -15,171 +15,186 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Handler.Activate where module Handler.Activate where
import Import as I hiding (returnJson) -- import Import as I hiding (returnJson)
import Data.Text -- import Data.Text
import Data.Text.Encoding -- import Data.Text.Encoding
import Data.Maybe -- import Data.Maybe
import System.Directory -- import System.Directory
import System.FilePath -- import System.FilePath
--
import qualified Data.ByteString.Char8 as BC -- import qualified Data.ByteString.Char8 as BC
--
import Handler.Login -- import Handler.Login
--
getActivateR :: Text -> Handler Html -- -- getActivateR :: Text -> Handler Html
getActivateR token = do -- getActivateR token = do
t <- runDB $ selectFirst [ActivatorToken ==. token] [] -- t <- runDB $ getBy $ UniqueToken token
(activateRawWidget, _) <- generateFormPost $ -- case t of
renderBootstrap3 BootstrapBasicForm activateForm -- Nothing -> do
case t of -- setMessage "Invalid token!"
Nothing -> do -- redirect HomeR
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] -- Just (Entity tId token) -> do
case mToken of -- master <- getYesod
Just (Entity _ uToken) -> do -- (Entity uId user) <-
user <- runDB $ getJust (fromJust $ tokenUser uToken) -- runDB $ getJust <$> getBy $ UniqueUser $ tokenUsername token
let hexSalt = toHex $ userSalt user -- let hexSalt = toHex $ userSalt user
master <- getYesod -- addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) -- defaultLayout $ do
defaultLayout $ do -- setTitle "Activate your account"
setTitle "Activate your account" -- $(widgetFile "activate")
$(widgetFile "activate") --
_ -> do -- t <- runDB $ selectFirst [ActivatorToken ==. token] []
setMessage "Invalid token!" -- (activateRawWidget, _) <- generateFormPost $
redirect HomeR -- renderBootstrap3 BootstrapBasicForm activateForm
Just (Entity _ activator) -> do -- case t of
let uSalt = userSalt $ activatorUser activator -- Nothing -> do
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] -- mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
case mToken of -- case mToken of
Just (Entity _ _) -> do -- Just (Entity _ uToken) -> do
let hexSalt = toHex uSalt -- user <- runDB $ getBy $ UniqueUser $ tokenUsername uToken
master <- getYesod -- let hexSalt = toHex $ userSalt user
let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) -- master <- getYesod
defaultLayout $ -- let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
$(widgetFile "activate") -- defaultLayout $ do
_ -> do -- setTitle "Activate your account"
setMessage "Invalid token!" -- $(widgetFile "activate")
redirect HomeR -- _ -> do
-- setMessage "Invalid token!"
postActivateR :: Text -> Handler RepJson -- redirect HomeR
postActivateR token = do -- Just (Entity _ activator) -> do
msalted <- fromJust <$> lookupPostParam "salted" -- let uSalt = userSalt $ activatorUser activator
let salted = fromHex' $ unpack msalted -- mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] -- case mToken of
case mToken of -- Just (Entity _ _) -> do
Just (Entity uTokenId uToken) -> -- let hexSalt = toHex uSalt
if -- master <- getYesod
isNothing (tokenUser uToken) -- let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
then do -- defaultLayout $
newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] -- $(widgetFile "activate")
case newUser of -- _ -> do
Just (Entity aId activ) -> do -- setMessage "Invalid token!"
namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] [] -- redirect HomeR
if --
I.null namesakes -- postActivateR :: Text -> Handler RepJson
then do -- postActivateR token = do
-- putting user in active state -- msalted <- fromJust <$> lookupPostParam "salted"
uId <- runDB $ insert $ activatorUser activ -- let salted = fromHex' $ unpack msalted
runDB $ update uId [UserSalted =. salted] -- mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
-- create user directory -- case mToken of
liftIO $ createDirectoryIfMissing True $ -- Just (Entity uTokenId uToken) ->
"static" </> "data" </> unpack (extractKey uId) -- if
-- cleanup -- isNothing (tokenUser uToken)
runDB $ delete aId -- then do
runDB $ delete uTokenId -- newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
-- login and redirect -- case newUser of
setSession "userId" (extractKey uId) -- Just (Entity aId activ) -> do
welcomeLink <- ($ ProfileR uId) <$> getUrlRender -- namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
returnJson ["welcome" .= welcomeLink] -- if
else do -- I.null namesakes
-- cleanup -- then do
runDB $ delete aId -- -- putting user in active state
runDB $ delete uTokenId -- uId <- runDB $ insert $ activatorUser activ
returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String) -- runDB $ update uId [UserSalted =. salted]
Nothing -> -- -- create user directory
returnJsonError ("Invalid token" :: String) -- liftIO $ createDirectoryIfMissing True $
else do -- "static" </> "data" </> unpack (extractKey uId)
runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] -- -- cleanup
-- cleanup -- runDB $ delete aId
runDB $ delete uTokenId -- runDB $ delete uTokenId
setSession "userId" (extractKey $ fromJust $ tokenUser uToken) -- -- login and redirect
welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender -- setSession "userId" (extractKey uId)
returnJson ["welcome" .= welcomeLink] -- welcomeLink <- ($ ProfileR uId) <$> getUrlRender
_ -> -- returnJson ["welcome" .= welcomeLink]
returnJsonError ("Invalid activation token!" :: String) -- else do
-- -- cleanup
data ActivateFormRes = ActivateFormRes -- runDB $ delete aId
{ pass1 :: Text -- runDB $ delete uTokenId
, pass2 :: Text -- returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String)
} -- Nothing ->
-- returnJsonError ("Invalid token" :: String)
activateForm :: AForm Handler ActivateFormRes -- else do
activateForm = ActivateFormRes -- runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
<$> areq passwordField (bfs ("Password" :: Text)) Nothing -- -- cleanup
<*> areq passwordField (bfs ("Repeat Password" :: Text)) Nothing -- runDB $ delete uTokenId
<* bootstrapSubmit ("Activate" :: BootstrapSubmit Text) -- setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
-- welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender
postActivateRawR :: Text -> Handler Html -- returnJson ["welcome" .= welcomeLink]
postActivateRawR token = do -- _ ->
((res, _), _) <- runFormPost $ -- returnJsonError ("Invalid activation token!" :: String)
renderBootstrap3 BootstrapBasicForm activateForm --
case res of -- data ActivateFormRes = ActivateFormRes
FormSuccess pwd -> do -- { pass1 :: Text
if pass1 pwd == pass2 pwd -- , pass2 :: Text
then do -- }
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] --
case mToken of -- activateForm :: AForm Handler ActivateFormRes
Just (Entity uTokenId uToken) -> -- activateForm = ActivateFormRes
if -- <$> areq passwordField (bfs ("Password" :: Text)) Nothing
isNothing (tokenUser uToken) -- <*> areq passwordField (bfs ("Repeat Password" :: Text)) Nothing
then do -- <* bootstrapSubmit ("Activate" :: BootstrapSubmit Text)
newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] --
case newUser of -- postActivateRawR :: Text -> Handler Html
Just (Entity aId activ) -> do -- postActivateRawR token = do
namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] [] -- ((res, _), _) <- runFormPost $
if -- renderBootstrap3 BootstrapBasicForm activateForm
I.null namesakes -- case res of
then do -- FormSuccess pwd -> do
let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt $ activatorUser activ) (encodeUtf8 $ pass1 pwd) -- if pass1 pwd == pass2 pwd
-- putting user in active state -- then do
uId <- runDB $ insert $ activatorUser activ -- mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
runDB $ update uId [UserSalted =. salted] -- case mToken of
-- create user directory -- Just (Entity uTokenId uToken) ->
liftIO $ createDirectoryIfMissing True $ -- if
"static" </> "data" </> unpack (extractKey uId) -- isNothing (tokenUser uToken)
-- cleanup -- then do
runDB $ delete aId -- newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
runDB $ delete uTokenId -- case newUser of
-- login and redirect -- Just (Entity aId activ) -> do
setSession "userId" (extractKey uId) -- namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
setMessage "Successfully activated" -- if
redirect $ ProfileR uId -- I.null namesakes
else do -- then do
-- cleanup -- let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt $ activatorUser activ) (encodeUtf8 $ pass1 pwd)
runDB $ delete aId -- -- putting user in active state
runDB $ delete uTokenId -- uId <- runDB $ insert $ activatorUser activ
setMessage "Somebody already activated your username. Your token has been deleted" -- runDB $ update uId [UserSalted =. salted]
redirect HomeR -- -- create user directory
Nothing -> do -- liftIO $ createDirectoryIfMissing True $
setMessage "Invalid token" -- "static" </> "data" </> unpack (extractKey uId)
redirect HomeR -- -- cleanup
else do -- runDB $ delete aId
uuser <- runDB $ getJust $ fromJust $ tokenUser uToken -- runDB $ delete uTokenId
let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt uuser) (encodeUtf8 $ pass1 pwd) -- -- login and redirect
runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] -- setSession "userId" (extractKey uId)
-- cleanup -- setMessage "Successfully activated"
runDB $ delete uTokenId -- redirect $ ProfileR uId
setSession "userId" (extractKey $ fromJust $ tokenUser uToken) -- else do
setMessage "Successfully activated" -- -- cleanup
redirect $ ProfileR (fromJust $ tokenUser uToken) -- runDB $ delete aId
Nothing -> do -- runDB $ delete uTokenId
setMessage "Invalid activation token!" -- setMessage "Somebody already activated your username. Your token has been deleted"
redirect HomeR -- redirect HomeR
else do -- Nothing -> do
setMessage "Passwords must match!" -- setMessage "Invalid token"
redirect $ ActivateR token -- redirect HomeR
_ -> do -- else do
setMessage "Activation error" -- uuser <- runDB $ getJust $ fromJust $ tokenUser uToken
redirect HomeR -- 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) => -- returnJson :: (Monad m, a ~ Value) =>
-- [(Text, a)] -> m RepJson -- [(Text, a)] -> m RepJson

1
Handler/AdminProfileSettings.hs
View file

@ -139,6 +139,7 @@ adminProfileForm owner = User
<*> pure (userAlbums owner) <*> pure (userAlbums owner)
<*> areq boolField (bfs ("Admin" :: T.Text)) (Just $ userAdmin owner) <*> areq boolField (bfs ("Admin" :: T.Text)) (Just $ userAdmin owner)
<*> areq (selectField licenses) (bfs ("Default licence" :: T.Text)) (Just $ userDefaultLicence owner) <*> areq (selectField licenses) (bfs ("Default licence" :: T.Text)) (Just $ userDefaultLicence owner)
<*> pure (userActive owner)
<* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text) <* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
where where
licenses = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licenses = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]

8
Handler/AlbumSettings.hs
View file

@ -49,7 +49,7 @@ getAlbumSettingsR albumId = do
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to change settings" setMessage "You must be logged in to change settings"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect HomeR redirect HomeR
@ -121,7 +121,7 @@ postAlbumSettingsR albumId = do
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to change settings" setMessage "You must be logged in to change settings"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect HomeR redirect HomeR
@ -160,7 +160,7 @@ getAlbumDeleteR albumId = do
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete albums" setMessage "You must be logged in to delete albums"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect HomeR redirect HomeR
@ -220,7 +220,7 @@ postAlbumDeleteR albumId = do
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete albums" setMessage "You must be logged in to delete albums"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect HomeR redirect HomeR

6
Handler/Commons.hs
View file

@ -51,7 +51,7 @@ loginIsAdmin = do
else else
return $ Left ("You have no admin rights", HomeR) return $ Left ("You have no admin rights", HomeR)
Nothing -> 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 :: IsString t => UserId -> Handler (Either (t, Route App) User)
profileCheck userId = do profileCheck userId = do
@ -69,7 +69,7 @@ profileCheck userId = do
else else
return $ Left ("You can only change your own profile settings", UserR $ userName user) return $ Left ("You can only change your own profile settings", UserR $ userName user)
Nothing -> 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 -> Nothing ->
return $ Left ("This user does not exist", HomeR) return $ Left ("This user does not exist", HomeR)
@ -93,7 +93,7 @@ mediumCheck mediumId = do
else else
return $ Left ("You must own this medium to change its settings", MediumR mediumId) return $ Left ("You must own this medium to change its settings", MediumR mediumId)
Nothing -> 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 -> Nothing ->
return $ Left ("This medium does not exist", HomeR) return $ Left ("This medium does not exist", HomeR)

21
Handler/Login.hs
View file

@ -52,12 +52,12 @@ postLoginR = do
mHexResponse <- lookupPostParam "response" mHexResponse <- lookupPostParam "response"
case (mUserName, mHexToken, mHexResponse) of case (mUserName, mHexToken, mHexResponse) of
(Just userName, Nothing, Nothing) -> do (Just userName, Nothing, Nothing) -> do
tempUser <- runDB $ selectFirst [UserName ==. userName] [] tempUser <- runDB $ getBy $ UniqueUser userName
case tempUser of case tempUser of
Just (Entity userId user) -> do Just (Entity userId user) -> do
let salt = userSalt user let salt = userSalt user
token <- liftIO makeRandomToken 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)] returnJson ["salt" .= toHex salt, "token" .= toHex (encodeUtf8 token)]
Nothing -> Nothing ->
returnJsonError ("No such user" :: T.Text) returnJsonError ("No such user" :: T.Text)
@ -67,16 +67,17 @@ postLoginR = do
savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] [] savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] []
case savedToken of case savedToken of
Just (Entity tokenId token) -> do Just (Entity tokenId token) -> do
let savedUserId = tokenUser token let savedUserName = tokenUsername token
queriedUser <- runDB $ getJust (fromJust savedUserId) mqueriedUser <- runDB $ getBy $ UniqueUser savedUserName
let salted = userSalted queriedUser let queriedUser = entityVal $ fromJust mqueriedUser
let hexSalted = toHex salted salted = userSalted queriedUser
let expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted) hexSalted = toHex salted
expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted)
if encodeUtf8 hexResponse == expected if encodeUtf8 hexResponse == expected
then do then do
-- Success!! -- Success!!
runDB $ delete tokenId runDB $ delete tokenId
return $ Right savedUserId return $ Right $ (entityKey $ fromJust mqueriedUser)
else else
return $ Left ("Wrong password" :: T.Text) return $ Left ("Wrong password" :: T.Text)
Nothing -> Nothing ->
@ -85,9 +86,9 @@ postLoginR = do
Left msg -> Left msg ->
returnJsonError msg returnJsonError msg
Right userId -> do Right userId -> do
setSession "userId" $ extractKey (fromJust userId) setSession "userId" $ extractKey userId
setMessage "Succesfully logged in" setMessage "Succesfully logged in"
welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender welcomeLink <- ($ProfileR userId) <$> getUrlRender
returnJson ["welcome" .= welcomeLink] returnJson ["welcome" .= welcomeLink]
_ -> _ ->
returnJsonError ("Protocol error" :: T.Text) returnJsonError ("Protocol error" :: T.Text)

10
Handler/Medium.hs
View file

@ -107,7 +107,7 @@ postMediumR mediumId = do
redirect $ MediumR mediumId redirect $ MediumR mediumId
Nothing -> do Nothing -> do
setMessage "You need to be looged in to comment on media" setMessage "You need to be looged in to comment on media"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This image does not exist" setMessage "This image does not exist"
redirect HomeR redirect HomeR
@ -141,7 +141,7 @@ getCommentReplyR commentId = do
$(widgetFile "commentReply") $(widgetFile "commentReply")
Nothing -> do Nothing -> do
setMessage "You need to be logged in to comment on media" setMessage "You need to be logged in to comment on media"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This comment does not Exist" setMessage "This comment does not Exist"
redirect HomeR redirect HomeR
@ -198,7 +198,7 @@ postCommentReplyR commentId = do
redirect $ CommentReplyR commentId redirect $ CommentReplyR commentId
Nothing -> do Nothing -> do
setMessage "You need to be logged in to post replies" setMessage "You need to be logged in to post replies"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This comment does not exist!" setMessage "This comment does not exist!"
redirect HomeR redirect HomeR
@ -223,7 +223,7 @@ getCommentDeleteR commentId = do
redirect $ MediumR $ commentOrigin comment redirect $ MediumR $ commentOrigin comment
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete comments" setMessage "You must be logged in to delete comments"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This comment does not exist" setMessage "This comment does not exist"
redirect HomeR redirect HomeR
@ -261,7 +261,7 @@ postCommentDeleteR commentId = do
redirect $ MediumR $ commentOrigin comment redirect $ MediumR $ commentOrigin comment
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete comments" setMessage "You must be logged in to delete comments"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This comment does not exist" setMessage "This comment does not exist"
redirect HomeR redirect HomeR

4
Handler/NewAlbum.hs
View file

@ -37,7 +37,7 @@ getNewAlbumR = do
$(widgetFile "newAlbum") $(widgetFile "newAlbum")
Nothing -> do Nothing -> do
setMessage "You need to be logged in" setMessage "You need to be logged in"
redirect LoginR redirect $ AuthR LoginR
postNewAlbumR :: Handler Html postNewAlbumR :: Handler Html
postNewAlbumR = do postNewAlbumR = do
@ -74,7 +74,7 @@ postNewAlbumR = do
redirect NewAlbumR redirect NewAlbumR
Nothing -> do Nothing -> do
setMessage "You must be logged in to create albums" setMessage "You must be logged in to create albums"
redirect LoginR redirect $ AuthR LoginR
albumForm :: UserId -> AForm Handler Album albumForm :: UserId -> AForm Handler Album
albumForm userId = Album albumForm userId = Album

1
Handler/ProfileSettings.hs
View file

@ -70,6 +70,7 @@ profileSettingsForm user = User
<*> pure (userAdmin user) <*> pure (userAdmin user)
<*> areq (selectField licences) (bfs ("Default licence for media" :: T.Text)) <*> areq (selectField licences) (bfs ("Default licence for media" :: T.Text))
(Just $ userDefaultLicence user) (Just $ userDefaultLicence user)
<*> pure (userActive user)
<* bootstrapSubmit ("Change settings" :: BootstrapSubmit Text) <* bootstrapSubmit ("Change settings" :: BootstrapSubmit Text)
where where
licences = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licences = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]

2
Handler/Reactivate.hs
View file

@ -37,7 +37,7 @@ postReactivateR = do
then do then do
userTokens <- foldM (\userTokens (Entity userId user) -> do userTokens <- foldM (\userTokens (Entity userId user) -> do
token <- liftIO $ generateString token <- liftIO $ generateString
_ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (Just userId) _ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (userName user)
return $ (user, token) : userTokens return $ (user, token) : userTokens
) [] users ) [] users
_ <- foldM (\sent (user, token) -> _ <- foldM (\sent (user, token) ->

2
Handler/Signup.hs
View file

@ -64,7 +64,7 @@ postSignupR = do
let newUser = User newUserName newUserName (fromJust mEmail) salt "" [] False (fromEnum AllRightsReserved) let newUser = User newUserName newUserName (fromJust mEmail) salt "" [] False (fromEnum AllRightsReserved)
activatorText <- liftIO generateString activatorText <- liftIO generateString
_ <- runDB $ insert $ Activator activatorText newUser _ <- runDB $ insert $ Activator activatorText newUser
_ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing _ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" newUserName
activateLink <- ($ ActivateR activatorText) <$> getUrlRender activateLink <- ($ ActivateR activatorText) <$> getUrlRender
sendMail (userEmail newUser) "Please activate your account!" $ sendMail (userEmail newUser) "Please activate your account!" $
[shamlet| [shamlet|

6
Handler/Upload.hs
View file

@ -61,7 +61,7 @@ getDirectUploadR albumId = do
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to upload" setMessage "You must be logged in to upload"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect HomeR redirect HomeR
@ -168,7 +168,7 @@ getUploadR = do
$(widgetFile "bulkUpload") $(widgetFile "bulkUpload")
Nothing -> do Nothing -> do
setMessage "You need to be logged in" setMessage "You need to be logged in"
redirect LoginR redirect $ AuthR LoginR
bulkUploadForm :: UserId -> User -> AForm Handler FileBulk 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) 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 redirect UploadR
Nothing -> do Nothing -> do
setMessage "You need to be logged in" setMessage "You need to be logged in"
redirect LoginR redirect $ AuthR LoginR

1
Import.hs
View file

@ -21,6 +21,7 @@ module Import
import Prelude as Import hiding (head, init, last, import Prelude as Import hiding (head, init, last,
readFile, tail, writeFile) readFile, tail, writeFile)
import Yesod as Import hiding (Route (..)) import Yesod as Import hiding (Route (..))
import Yesod.Auth as Import
import Yesod.Static as Import import Yesod.Static as Import
import Yesod.Form.Bootstrap3 as Import import Yesod.Form.Bootstrap3 as Import

4
config/models
View file

@ -23,6 +23,7 @@ User
albums [AlbumId] albums [AlbumId]
admin Bool admin Bool
defaultLicence Int default=-1 defaultLicence Int default=-1
active Bool default=True
UniqueUser name UniqueUser name
deriving Typeable Eq Show deriving Typeable Eq Show
Activator Activator
@ -32,7 +33,8 @@ Activator
Token Token
token ByteString token ByteString
kind Text kind Text
user UserId Maybe username Text
UniqueToken token
deriving Eq Show deriving Eq Show
Album Album
title Text title Text

15
config/routes
View file

@ -15,18 +15,20 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
/static StaticR Static appStatic /static StaticR Static appStatic
/auth AuthR Auth getAuth
/favicon.ico FaviconR GET /favicon.ico FaviconR GET
/robots.txt RobotsR GET /robots.txt RobotsR GET
/ HomeR GET / HomeR GET
/page/#Int PageR GET /page/#Int PageR GET
/signup SignupR GET POST -- /signup SignupR GET POST
/login LoginR GET POST -- /login LoginR GET POST
/loginraw LoginRawR POST -- /loginraw LoginRawR POST
/logout LogoutR GET -- /logout LogoutR GET
/activate/#T.Text ActivateR GET POST -- /activate/#T.Text ActivateR GET POST
/activateraw/#T.Text ActivateRawR POST -- /activateraw/#T.Text ActivateRawR POST
-- /reactivate ReactivateR GET POST
/profile/#UserId ProfileR GET /profile/#UserId ProfileR GET
/user/#T.Text UserR GET /user/#T.Text UserR GET
/user/#T.Text/album/#T.Text BeautyAlbumR GET /user/#T.Text/album/#T.Text BeautyAlbumR GET
@ -42,7 +44,6 @@
/medium/#MediumId/move MediumMoveR GET POST /medium/#MediumId/move MediumMoveR GET POST
/comment/#CommentId/reply CommentReplyR GET POST /comment/#CommentId/reply CommentReplyR GET POST
/comment/#CommentId/delcom CommentDeleteR GET POST /comment/#CommentId/delcom CommentDeleteR GET POST
/reactivate ReactivateR GET POST
/profile/#UserId/settings ProfileSettingsR GET POST /profile/#UserId/settings ProfileSettingsR GET POST
/profile/#UserId/delete ProfileDeleteR GET POST /profile/#UserId/delete ProfileDeleteR GET POST

10
eidolon.cabal
View file

@ -31,9 +31,10 @@ library
Settings.StaticFiles Settings.StaticFiles
Settings.Development Settings.Development
Handler.Home Handler.Home
Handler.Signup -- Handler.Signup
Handler.Login -- Handler.Login
Handler.Activate -- Handler.Activate
-- Handler.Reactivate
Handler.Profile Handler.Profile
Handler.Upload Handler.Upload
Handler.NewAlbum Handler.NewAlbum
@ -41,7 +42,6 @@ library
Handler.Medium Handler.Medium
Handler.AlbumSettings Handler.AlbumSettings
Handler.MediumSettings Handler.MediumSettings
Handler.Reactivate
Handler.ProfileSettings Handler.ProfileSettings
Handler.ProfileDelete Handler.ProfileDelete
Handler.Admin Handler.Admin
@ -142,6 +142,8 @@ library
, yesod-form >= 1.4.7 , yesod-form >= 1.4.7
, magic , magic
, texmath < 0.9 , texmath < 0.9
, yesod-auth
, yesod-auth-hmac-keccak
executable eidolon executable eidolon
if flag(library-only) if flag(library-only)

17
templates/default-layout.hamlet
View file

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