condensing code in admin interface

This commit is contained in:
nek0 2014-12-27 23:09:51 +01:00
parent 70ca625585
commit 4b81a54503
8 changed files with 372 additions and 472 deletions

View file

@ -60,6 +60,7 @@ import Handler.AdminMediumSettings
import Handler.AdminComments
import Handler.Tag
import Handler.RootFeed
import Handler.Commons
-- 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

View file

@ -1,22 +1,16 @@
module Handler.Admin where
import Import
import Handler.Commons
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
setTitle "Administration: Menu"
$(widgetFile "adminBase")
False -> do
setMessage "You have no admin rights"
redirect $ HomeR
Nothing -> do
setMessage "You are not logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
defaultLayout $ do
setTitle "Administration: Menu"
$(widgetFile "adminBase")
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route

View file

@ -1,6 +1,7 @@
module Handler.AdminAlbumSettings where
import Import
import Handler.Commons
import qualified Data.Text as T
import qualified Data.List as L
import System.FilePath
@ -8,114 +9,86 @@ import System.Directory
getAdminAlbumsR :: Handler Html
getAdminAlbumsR = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
albums <- runDB $ selectList [] [Asc AlbumTitle]
defaultLayout $ do
setTitle "Administration: Albums"
$(widgetFile "adminAlbums")
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
albums <- runDB $ selectList [] [Asc AlbumTitle]
defaultLayout $ do
setTitle "Administration: Albums"
$(widgetFile "adminAlbums")
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
getAdminAlbumMediaR :: AlbumId -> Handler Html
getAdminAlbumMediaR albumId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempAlbum <- runDB $ get albumId
case tempAlbum of
Just album -> do
media <- runDB $ selectList [MediumAlbum ==. albumId] [Asc MediumTitle]
defaultLayout $ do
setTitle "Administration: Album media"
$(widgetFile "adminAlbumMedia")
Nothing -> do
setMessage "This album does not exist"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempAlbum <- runDB $ get albumId
case tempAlbum of
Just album -> do
media <- runDB $ selectList [MediumAlbum ==. albumId] [Asc MediumTitle]
defaultLayout $ do
setTitle "Administration: Album media"
$(widgetFile "adminAlbumMedia")
Nothing -> do
setMessage "This album does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
getAdminAlbumSettingsR :: AlbumId -> Handler Html
getAdminAlbumSettingsR albumId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempAlbum <- runDB $ get albumId
case tempAlbum of
Just album -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
(adminAlbumSettingsWidget, enctype) <- generateFormPost $ adminAlbumSettingsForm album albumId users
defaultLayout $ do
setTitle "Administration: Album settings"
$(widgetFile "adminAlbumSet")
Nothing -> do
setMessage "This album does not exist"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempAlbum <- runDB $ get albumId
case tempAlbum of
Just album -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
(adminAlbumSettingsWidget, enctype) <- generateFormPost $ adminAlbumSettingsForm album albumId users
defaultLayout $ do
setTitle "Administration: Album settings"
$(widgetFile "adminAlbumSet")
Nothing -> do
setMessage "This album does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
postAdminAlbumSettingsR :: AlbumId -> Handler Html
postAdminAlbumSettingsR albumId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempAlbum <- runDB $ get albumId
case tempAlbum of
Just album -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
((res, adminAlbumSettingsWidget), enctype) <- runFormPost $ adminAlbumSettingsForm album albumId users
case res of
FormSuccess temp -> do
aId <- runDB $ update albumId
[ AlbumTitle =. albumTitle temp
, AlbumShares =. albumShares temp
, AlbumSamplePic =. albumSamplePic temp
]
setMessage "Album settings changed successfully"
redirect $ AdminR
_ -> do
setMessage "There was an error while changing the settings"
redirect $ AdminAlbumSettingsR albumId
Nothing -> do
setMessage "This album does not exist"
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempAlbum <- runDB $ get albumId
case tempAlbum of
Just album -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
((res, adminAlbumSettingsWidget), enctype) <- runFormPost $ adminAlbumSettingsForm album albumId users
case res of
FormSuccess temp -> do
aId <- runDB $ update albumId
[ AlbumTitle =. albumTitle temp
, AlbumShares =. albumShares temp
, AlbumSamplePic =. albumSamplePic temp
]
setMessage "Album settings changed successfully"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
_ -> do
setMessage "There was an error while changing the settings"
redirect $ AdminAlbumSettingsR albumId
Nothing -> do
setMessage "This album does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
adminAlbumSettingsForm :: Album -> AlbumId -> [(Text, UserId)] -> Form Album
adminAlbumSettingsForm album albumId users = renderDivs $ Album
@ -128,53 +101,43 @@ adminAlbumSettingsForm album albumId users = renderDivs $ Album
media = do
entities <- runDB $ selectList [MediumAlbum ==. albumId] [Asc MediumTitle]
optionsPairs $ map (\med -> (mediumTitle $ entityVal med, mediumThumb (entityVal med))) entities
-- userNames =
-- let entities = runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
-- in map (\ent -> (userName $ entityVal ent, entityKey ent)) entities
getAdminAlbumDeleteR :: AlbumId -> Handler Html
getAdminAlbumDeleteR albumId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempAlbum <- runDB $ get albumId
case tempAlbum of
Just album -> do
-- remove reference from owner
ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId
albumList <- return $ userAlbums owner
newAlbumList <- return $ removeItem albumId albumList
runDB $ update ownerId [UserAlbums =. newAlbumList]
-- delete album content and its comments
mapM (\a -> do
-- delete files
medium <- runDB $ getJust a
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. a] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete album database entry
runDB $ delete a
) (albumContent album)
-- delete album
runDB $ delete albumId
-- delete files
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> (T.unpack $ extractKey ownerId) </> (T.unpack $ extractKey albumId)
-- outro
setMessage "Album deleted successfully"
redirect $ AdminR
Nothing -> do
setMessage "This album dies not exist"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempAlbum <- runDB $ get albumId
case tempAlbum of
Just album -> do
-- remove reference from owner
ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId
albumList <- return $ userAlbums owner
newAlbumList <- return $ removeItem albumId albumList
runDB $ update ownerId [UserAlbums =. newAlbumList]
-- delete album content and its comments
mapM (\a -> do
-- delete files
medium <- runDB $ getJust a
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. a] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete album database entry
runDB $ delete a
) (albumContent album)
-- delete album
runDB $ delete albumId
-- delete files
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> (T.unpack $ extractKey ownerId) </> (T.unpack $ extractKey albumId)
-- outro
setMessage "Album deleted successfully"
redirect $ AdminR
Nothing -> do
setMessage "This album dies not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route

View file

@ -1,57 +1,44 @@
module Handler.AdminComments where
import Import
import Handler.Commons
import Data.Maybe
import Data.Time
import System.Locale
getAdminCommentR :: Handler Html
getAdminCommentR = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
media <- runDB $ selectList [] [Desc MediumTime]
comments <- runDB $ selectList [CommentParent ==. Nothing] [Desc CommentTime]
replies <- runDB $ selectList [CommentParent !=. Nothing] [Desc CommentTime]
defaultLayout $ do
setTitle "Administration: Comments"
$(widgetFile "adminComments")
False -> do
setMessage "You have no admin rights"
redirect $ HomeR
Nothing -> do
setMessage "You are not logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
media <- runDB $ selectList [] [Desc MediumTime]
comments <- runDB $ selectList [CommentParent ==. Nothing] [Desc CommentTime]
replies <- runDB $ selectList [CommentParent !=. Nothing] [Desc CommentTime]
defaultLayout $ do
setTitle "Administration: Comments"
$(widgetFile "adminComments")
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
getAdminCommentDeleteR :: CommentId -> Handler Html
getAdminCommentDeleteR commentId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempComment <- runDB $ get commentId
case tempComment of
Just comment -> do
-- delete comment children
children <- runDB $ selectList [CommentParent ==. (Just commentId)] []
mapM (\ent -> runDB $ delete $ entityKey ent) children
-- delete comment itself
runDB $ delete commentId
setMessage "Comment deleted succesfully"
redirect $ AdminR
Nothing -> do
setMessage "This comment does not exist"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempComment <- runDB $ get commentId
case tempComment of
Just comment -> do
-- delete comment children
children <- runDB $ selectList [CommentParent ==. (Just commentId)] []
mapM (\ent -> runDB $ delete $ entityKey ent) children
-- delete comment itself
runDB $ delete commentId
setMessage "Comment deleted succesfully"
redirect $ AdminR
Nothing -> do
setMessage "This comment does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route

View file

@ -1,90 +1,70 @@
module Handler.AdminMediumSettings where
import Import
import Handler.Commons
import System.FilePath
import System.Directory
import Data.List (tail)
getAdminMediaR :: Handler Html
getAdminMediaR = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
media <- runDB $ selectList [] [Asc MediumTitle]
defaultLayout $ do
setTitle "Administration: Media"
$(widgetFile "adminMedia")
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
media <- runDB $ selectList [] [Asc MediumTitle]
defaultLayout $ do
setTitle "Administration: Media"
$(widgetFile "adminMedia")
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
getAdminMediumSettingsR :: MediumId -> Handler Html
getAdminMediumSettingsR mediumId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
(adminMediumSetWidget, enctype) <- generateFormPost $ adminMediumSetForm medium
defaultLayout $ do
setTitle "Administration: Medium Settings"
$(widgetFile "adminMediumSet")
Nothing -> do
setMessage "This medium does not exist"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
(adminMediumSetWidget, enctype) <- generateFormPost $ adminMediumSetForm medium
defaultLayout $ do
setTitle "Administration: Medium Settings"
$(widgetFile "adminMediumSet")
Nothing -> do
setMessage "This medium does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
postAdminMediumSettingsR :: MediumId -> Handler Html
postAdminMediumSettingsR mediumId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
((res, adminMediumSetWidget), enctype) <- runFormPost $ adminMediumSetForm medium
case res of
FormSuccess temp -> do
runDB $ update mediumId
[ MediumTitle =. mediumTitle temp
, MediumDescription =. mediumDescription temp
, MediumTags =. mediumTags temp
]
setMessage "Medium settings changed successfully"
redirect $ AdminR
_ -> do
setMessage "There was an error while changing the settings"
redirect $ AdminMediumSettingsR mediumId
Nothing -> do
setMessage "This medium does not exist"
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
((res, adminMediumSetWidget), enctype) <- runFormPost $ adminMediumSetForm medium
case res of
FormSuccess temp -> do
runDB $ update mediumId
[ MediumTitle =. mediumTitle temp
, MediumDescription =. mediumDescription temp
, MediumTags =. mediumTags temp
]
setMessage "Medium settings changed successfully"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
_ -> do
setMessage "There was an error while changing the settings"
redirect $ AdminMediumSettingsR mediumId
Nothing -> do
setMessage "This medium does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
adminMediumSetForm :: Medium -> Form Medium
adminMediumSetForm medium = renderDivs $ Medium
@ -100,39 +80,32 @@ adminMediumSetForm medium = renderDivs $ Medium
getAdminMediumDeleteR :: MediumId -> Handler Html
getAdminMediumDeleteR mediumId = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True -> do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
-- remove reference from album
albumId <- return $ mediumAlbum medium
album <- runDB $ getJust albumId
mediaList <- return $ albumContent album
newMediaList <- return $ removeItem mediumId mediaList
runDB $ update albumId [AlbumContent =. newMediaList]
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete medium
runDB $ delete mediumId
-- delete files
liftIO $ removeFile (normalise $ tail $ mediumPath medium)
liftIO $ removeFile (normalise $ tail $ mediumPath medium)
-- outro
setMessage "Medium deleted successfully"
redirect $ AdminR
Nothing -> do
setMessage "This medium does not exist"
redirect $ AdminR
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
-- remove reference from album
albumId <- return $ mediumAlbum medium
album <- runDB $ getJust albumId
mediaList <- return $ albumContent album
newMediaList <- return $ removeItem mediumId mediaList
runDB $ update albumId [AlbumContent =. newMediaList]
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete medium
runDB $ delete mediumId
-- delete files
liftIO $ removeFile (normalise $ tail $ mediumPath medium)
liftIO $ removeFile (normalise $ tail $ mediumPath medium)
-- outro
setMessage "Medium deleted successfully"
redirect $ AdminR
Nothing -> do
setMessage "This medium does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route

View file

@ -1,145 +1,113 @@
module Handler.AdminProfileSettings where
import Import
import Handler.Commons
import qualified Data.Text as T
import qualified Data.List as L
import Data.Maybe
import System.Directory
import System.FilePath
getAdminProfilesR :: Handler Html
getAdminProfilesR = 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
setTitle "Administration: Profiles"
$(widgetFile "adminProfiles")
False -> do
setMessage "You are no admin"
redirect $ HomeR
Nothing -> do
setMessage "You must be logged in"
redirect $ LoginR
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
profiles <- runDB $ selectList [] [Desc UserName]
defaultLayout $ do
setTitle "Administration: Profiles"
$(widgetFile "adminProfiles")
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
getAdminUserAlbumsR :: UserId -> Handler Html
getAdminUserAlbumsR 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
albums <- runDB $ selectList [AlbumOwner ==. ownerId] [Desc AlbumTitle]
defaultLayout $ do
setTitle "Administration: User albums"
$(widgetFile "adminUserAlbums")
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
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempOwner <- runDB $ get ownerId
case tempOwner of
Just owner -> do
albums <- runDB $ selectList [AlbumOwner ==. ownerId] [Desc AlbumTitle]
defaultLayout $ do
setTitle "Administration: User albums"
$(widgetFile "adminUserAlbums")
Nothing -> do
setMessage "This user does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
getAdminUserMediaR :: UserId -> Handler Html
getAdminUserMediaR 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
media <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTitle]
defaultLayout $ do
setTitle "Administration: User media"
$(widgetFile "adminUserMedia")
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
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempOwner <- runDB $ get ownerId
case tempOwner of
Just owner -> do
media <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTitle]
defaultLayout $ do
setTitle "Administration: User media"
$(widgetFile "adminUserMedia")
Nothing -> do
setMessage "This user does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
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
setTitle "Administration: Profile settings"
$(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
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> do
tempOwner <- runDB $ get ownerId
case tempOwner of
Just owner -> do
tempUserId <- lookupSession "userId"
userId <- return $ getUserIdFromText $ fromJust tempUserId
(adminProfileSetWidget, enctype) <- generateFormPost $ adminProfileForm owner
defaultLayout $ do
setTitle "Administration: Profile settings"
$(widgetFile "adminProfileSettings")
Nothing -> do
setMessage "This user does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
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"
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> 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
False -> do
setMessage "You are not an admin"
redirect $ HomeR
Nothing -> do
setMessage "You are not logged in"
redirect $ LoginR
_ -> do
setMessage "There was an error"
redirect $ AdminProfileSettingsR ownerId
Nothing -> do
setMessage "This user does not exist"
redirect $ AdminR
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route
adminProfileForm :: User -> Form User
@ -154,43 +122,36 @@ adminProfileForm owner = renderDivs $ User
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 -> do
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. med] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete media files
medium <- runDB $ getJust med
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete medium database entry
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
adminCheck <- loginIsAdmin
case adminCheck of
Right _ -> 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 -> do
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. med] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete media files
medium <- runDB $ getJust med
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete medium database entry
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
Left (errorMsg, route) -> do
setMessage errorMsg
redirect $ route

20
Handler/Commons.hs Normal file
View file

@ -0,0 +1,20 @@
module Handler.Commons where
import Import
import Yesod
import Data.String
loginIsAdmin :: IsString t => Handler (Either (t, Route App) ())
loginIsAdmin = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
user <- runDB $ getJust userId
case userAdmin user of
True ->
return $ Right ()
False ->
return $ Left ("You have no admin rights", HomeR)
Nothing ->
return $ Left ("You are not logged in", LoginR)

View file

@ -41,6 +41,7 @@ library
Handler.AdminComments
Handler.Tag
Handler.RootFeed
Handler.Commons
if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT