admin interface added incl. profilemanipulation

This commit is contained in:
nek0 2014-09-06 08:56:36 +02:00
parent 4ff66317fa
commit f5f2ac336d
13 changed files with 196 additions and 1 deletions

View file

@ -41,6 +41,8 @@ import Handler.MediumSettings
import Handler.Reactivate import Handler.Reactivate
import Handler.ProfileSettings import Handler.ProfileSettings
import Handler.ProfileDelete import Handler.ProfileDelete
import Handler.Admin
import Handler.AdminProfileSettings
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

21
Handler/Admin.hs Normal file
View file

@ -0,0 +1,21 @@
module Handler.Admin where
import Import
getAdminR :: Handler Html
getAdminR = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
defaultLayout $ do
$(widgetFile "adminBase")
False -> do
setMessage "You have no admin rights"
redirect $ HomeR
Nothing -> do
setMessage "You are not logged in"
redirect $ LoginR

View file

@ -0,0 +1,132 @@
module Handler.AdminProfileSettings where
import Import
import qualified Data.Text as T
import System.Directory
import System.FilePath
getAdminProfiles :: Handler Html
getAdminProfiles = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
profiles <- runDB $ selectList [] [Desc UserName]
defaultLayout $ do
$(widgetFile "adminProfiles")
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
getAdminProfileSettingsR :: UserId -> Handler Html
getAdminProfileSettingsR ownerId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempOwner <- runDB $ get ownerId
case tempOwner of
Just owner -> do
(adminProfileSetWidget, enctype) <- generateFormPost $ adminProfileForm owner
defaultLayout $ do
$(widgetFile "adminProfileSettings")
Nothing -> do
setMessage "This user does not exist"
redirect $ AdminR
False -> do
setMessage "You are not an admin"
redirect $ HomeR
Nothing -> do
setMessage "You are not logged in"
redirect $ LoginR
postAdminProfileSettingsR :: UserId -> Handler Html
postAdminProfileSettingsR ownerId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempOwner <- runDB $ get ownerId
case tempOwner of
Just owner -> do
((result, adminProfileSetWidget), enctype) <- runFormPost $ adminProfileForm owner
case result of
FormSuccess temp -> do
runDB $ update ownerId
[ UserName =. (userName temp)
, UserSlug =. (userSlug temp)
, UserEmail =. (userEmail temp)
, UserAdmin =. (userAdmin temp)
]
setMessage "User data updated successfully"
redirect $ AdminR
_ -> do
setMessage "There was an error"
redirect $ AdminProfileSettingsR ownerId
Nothing -> do
setMessage "This user does not exist"
redirect $ AdminR
False -> do
setMessage "You are not an admin"
redirect $ HomeR
Nothing -> do
setMessage "You are not logged in"
redirect $ LoginR
adminProfileForm :: User -> Form User
adminProfileForm owner = renderDivs $ User
<$> areq textField "Username" (Just $ userName owner)
<*> areq textField "Userslug" (Just $ userSlug owner)
<*> areq emailField "Email" (Just $ userEmail owner)
<*> pure (userSalt owner)
<*> pure (userSalted owner)
<*> pure (userAlbums owner)
<*> areq boolField "Admin" (Just $ userAdmin owner)
getAdminProfileDeleteR :: UserId -> Handler Html
getAdminProfileDeleteR ownerId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempOwner <- runDB $ get ownerId
case tempOwner of
Just owner -> do
albumList <- return $ userAlbums owner
mapM (\albumId -> do
album <- runDB $ getJust albumId
mediaList <- return $ albumContent album
mapM (\med -> runDB $ delete med) mediaList
runDB $ delete albumId
) albumList
runDB $ delete ownerId
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> (T.unpack $ extractKey ownerId)
setMessage "User successfully deleted"
redirect $ AdminR
Nothing -> do
setMessage "This user does not exist"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR

View file

@ -71,3 +71,4 @@ profileSettingsForm user = renderDivs $ User
<*> pure (userSalt user) <*> pure (userSalt user)
<*> pure (userSalted user) <*> pure (userSalted user)
<*> pure (userAlbums user) <*> pure (userAlbums user)
<*> pure (userAdmin user)

View file

@ -39,7 +39,13 @@ postSignupR = do
case namesakes of case namesakes of
[] -> do [] -> do
salt <- liftIO generateSalt salt <- liftIO generateSalt
newUser <- return $ User newUserName newUserName (fromJust mEmail) salt "" [] newUser <- return $ User newUserName
newUserName
(fromJust mEmail)
salt
""
[]
False
activatorText <- liftIO generateString activatorText <- liftIO generateString
aId <- runDB $ insert $ Activator activatorText newUser aId <- runDB $ insert $ Activator activatorText newUser
tId <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing tId <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing

View file

@ -18,6 +18,7 @@ import Settings.StaticFiles as Import
-- custom imports -- custom imports
import Helper as Import import Helper as Import
import Data.Bool as Import
-- end custom imports -- end custom imports

View file

@ -6,6 +6,7 @@ import Database.Persist.Quasi
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.ByteString import Data.ByteString
import Data.Bool
import System.FilePath (FilePath) import System.FilePath (FilePath)
-- You can define all of your database entities in the entities file. -- You can define all of your database entities in the entities file.

View file

@ -5,6 +5,7 @@ User
salt ByteString salt ByteString
salted ByteString salted ByteString
albums [AlbumId] albums [AlbumId]
admin Bool
deriving Typeable deriving Typeable
Activator Activator
token Text token Text

View file

@ -22,3 +22,7 @@
/reactivate ReactivateR 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
/admin AdminR GET
/admin/profile AdminProfiles GET
/admin/profile/#UserId AdminProfileSettingsR GET POST
/admin/profile/#UserId/delete AdminProfileDeleteR GET

View file

@ -34,6 +34,8 @@ library
Handler.Reactivate Handler.Reactivate
Handler.ProfileSettings Handler.ProfileSettings
Handler.ProfileDelete Handler.ProfileDelete
Handler.Admin
Handler.AdminProfileSettings
if flag(dev) || flag(library-only) if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT

View file

@ -0,0 +1,5 @@
$newline always
<h3>Admin interface
<p>
Be careful with your actions here, every click will perform directly the advertised action.

View file

@ -0,0 +1,9 @@
$newline always
<h3>Profile settings
<form method="post" enctype=#{enctype}>
^{adminProfileSetWidget}
<div>
<input type=submit value="Change settings">
<a href=@{AdminProfileDeleteR userId}>Delete user

View file

@ -0,0 +1,10 @@
$newline always
<h3>User profiles
$if null profiles
There are no profiles yet (How can you even see this?)
$else
$forall (Entity uId u) <- profiles
<ul>
<li>
<a href=@{AdminProfileSettingsR uId}>#{userSlug u}