From 4b81a5450339f8f585e7b6e1278362b7b9dcf95c Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 27 Dec 2014 23:09:51 +0100 Subject: [PATCH] condensing code in admin interface --- Application.hs | 1 + Handler/Admin.hs | 26 ++- Handler/AdminAlbumSettings.hs | 253 +++++++++++++---------------- Handler/AdminComments.hs | 77 ++++----- Handler/AdminMediumSettings.hs | 187 +++++++++------------ Handler/AdminProfileSettings.hs | 279 ++++++++++++++------------------ Handler/Commons.hs | 20 +++ eidolon.cabal | 1 + 8 files changed, 372 insertions(+), 472 deletions(-) create mode 100644 Handler/Commons.hs diff --git a/Application.hs b/Application.hs index fc5a340..8b707e3 100644 --- a/Application.hs +++ b/Application.hs @@ -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 diff --git a/Handler/Admin.hs b/Handler/Admin.hs index 367dafe..9b88255 100644 --- a/Handler/Admin.hs +++ b/Handler/Admin.hs @@ -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 diff --git a/Handler/AdminAlbumSettings.hs b/Handler/AdminAlbumSettings.hs index d3feee3..54afd53 100644 --- a/Handler/AdminAlbumSettings.hs +++ b/Handler/AdminAlbumSettings.hs @@ -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 diff --git a/Handler/AdminComments.hs b/Handler/AdminComments.hs index cc034e3..fc61479 100644 --- a/Handler/AdminComments.hs +++ b/Handler/AdminComments.hs @@ -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 diff --git a/Handler/AdminMediumSettings.hs b/Handler/AdminMediumSettings.hs index afc5d82..d42da76 100644 --- a/Handler/AdminMediumSettings.hs +++ b/Handler/AdminMediumSettings.hs @@ -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 diff --git a/Handler/AdminProfileSettings.hs b/Handler/AdminProfileSettings.hs index 0e6f061..1100fa4 100644 --- a/Handler/AdminProfileSettings.hs +++ b/Handler/AdminProfileSettings.hs @@ -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 diff --git a/Handler/Commons.hs b/Handler/Commons.hs new file mode 100644 index 0000000..73e4041 --- /dev/null +++ b/Handler/Commons.hs @@ -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) diff --git a/eidolon.cabal b/eidolon.cabal index 6ff7163..06be562 100644 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -41,6 +41,7 @@ library Handler.AdminComments Handler.Tag Handler.RootFeed + Handler.Commons if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT