condensing code in admin interface

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

Handler/Admin.hs

@@ -1,22 +1,16 @@
 module Handler.Admin where
 
 import Import
+import Handler.Commons
 
 getAdminR :: Handler Html
 getAdminR = do
-  msu <- lookupSession "userId"
+  adminCheck <- loginIsAdmin
-  case msu of
+  case adminCheck of
-    Just tempUserId -> do
+    Right _ -> do
-      userId <- return $ getUserIdFromText tempUserId
+      defaultLayout $ do
-      user <- runDB $ getJust userId
+        setTitle "Administration: Menu"
-      case userAdmin user of
+        $(widgetFile "adminBase")
-        True -> do
+    Left (errorMsg, route) -> do
-          defaultLayout $ do
+      setMessage errorMsg
-            setTitle "Administration: Menu"
+      redirect $ route
-            $(widgetFile "adminBase")
-        False -> do
-          setMessage "You have no admin rights"
-          redirect $ HomeR
-    Nothing -> do
-      setMessage "You are not logged in"
-      redirect $ LoginR

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

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

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

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"
+  adminCheck <- loginIsAdmin
-  case msu of
+  case adminCheck of
-    Just tempUserId -> do
+    Right _ -> do
-      userId <- return $ getUserIdFromText tempUserId
+      profiles <- runDB $ selectList [] [Desc UserName]
-      user <- runDB $ getJust userId
+      defaultLayout $ do
-      case userAdmin user of
+        setTitle "Administration: Profiles"
-        True -> do
+        $(widgetFile "adminProfiles")
-          profiles <- runDB $ selectList [] [Desc UserName]
+    Left (errorMsg, route) -> do
-          defaultLayout $ do
+      setMessage errorMsg
-            setTitle "Administration: Profiles"
+      redirect $ route
-            $(widgetFile "adminProfiles")
-        False -> do
-          setMessage "You are no admin"
-          redirect $ HomeR
-    Nothing -> do
-      setMessage "You must be logged in"
-      redirect $ LoginR
 
 getAdminUserAlbumsR :: UserId -> Handler Html
 getAdminUserAlbumsR ownerId = do
-  msu <- lookupSession "userId"
+  adminCheck <- loginIsAdmin
-  case msu of
+  case adminCheck of
-    Just tempUserId -> do
+    Right _ -> do
-      userId <- return $ getUserIdFromText tempUserId
+      tempOwner <- runDB $ get ownerId
-      user <- runDB $ getJust userId
+      case tempOwner of
-      case userAdmin user of
+        Just owner -> do
-        True -> do
+          albums <- runDB $ selectList [AlbumOwner ==. ownerId] [Desc AlbumTitle]
-          tempOwner <- runDB $ get ownerId
+          defaultLayout $ do
-          case tempOwner of
+            setTitle "Administration: User albums"
-            Just owner -> do
+            $(widgetFile "adminUserAlbums")
-              albums <- runDB $ selectList [AlbumOwner ==. ownerId] [Desc AlbumTitle]
+        Nothing -> do
-              defaultLayout $ do
+          setMessage "This user does not exist"
-                setTitle "Administration: User albums"
+          redirect $ AdminR
-                $(widgetFile "adminUserAlbums")
+    Left (errorMsg, route) -> do
-            Nothing -> do
+      setMessage errorMsg
-              setMessage "This user does not exist"
+      redirect $ route
-              redirect $ AdminR
-        False -> do
-          setMessage "You are no admin"
-          redirect $ HomeR
-    Nothing -> do
-      setMessage "You must be logged in"
-      redirect $ LoginR
 
 getAdminUserMediaR :: UserId -> Handler Html
 getAdminUserMediaR ownerId = do
-  msu <- lookupSession "userId"
+  adminCheck <- loginIsAdmin
-  case msu of
+  case adminCheck of
-    Just tempUserId -> do
+    Right _ -> do
-      userId <- return $ getUserIdFromText tempUserId
+      tempOwner <- runDB $ get ownerId
-      user <- runDB $ getJust userId
+      case tempOwner of
-      case userAdmin user of
+        Just owner -> do
-        True -> do
+          media <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTitle]
-          tempOwner <- runDB $ get ownerId
+          defaultLayout $ do
-          case tempOwner of
+            setTitle "Administration: User media"
-            Just owner -> do
+            $(widgetFile "adminUserMedia")
-              media <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTitle]
+        Nothing -> do
-              defaultLayout $ do
+          setMessage "This user does not exist"
-                setTitle "Administration: User media"
+          redirect $ AdminR
-                $(widgetFile "adminUserMedia")
+    Left (errorMsg, route) -> do
-            Nothing -> do
+      setMessage errorMsg
-              setMessage "This user does not exist"
+      redirect $ route
-              redirect $ AdminR
-        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"
+  adminCheck <- loginIsAdmin
-  case msu of
+  case adminCheck of
-    Just tempUserId -> do
+    Right _ -> do
-      userId <- return $ getUserIdFromText tempUserId
+      tempOwner <- runDB $ get ownerId
-      user <- runDB $ getJust userId
+      case tempOwner of
-      case userAdmin user of
+        Just owner -> do
-        True -> do
+          tempUserId <- lookupSession "userId"
-          tempOwner <- runDB $ get ownerId
+          userId <- return $ getUserIdFromText $ fromJust tempUserId
-          case tempOwner of
+          (adminProfileSetWidget, enctype) <- generateFormPost $ adminProfileForm owner
-            Just owner -> do
+          defaultLayout $ do
-              (adminProfileSetWidget, enctype) <- generateFormPost $ adminProfileForm owner
+            setTitle "Administration: Profile settings"
-              defaultLayout $ do
+            $(widgetFile "adminProfileSettings")
-                setTitle "Administration: Profile settings"
+        Nothing -> do
-                $(widgetFile "adminProfileSettings")
+          setMessage "This user does not exist"
-            Nothing -> do
+          redirect $ AdminR
-              setMessage "This user does not exist"
+    Left (errorMsg, route) -> do
-              redirect $ AdminR
+      setMessage errorMsg
-        False -> do
+      redirect $ route
-          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"
+  adminCheck <- loginIsAdmin
-  case msu of
+  case adminCheck of
-    Just tempUserId -> do
+    Right _ -> do
-      userId <- return $ getUserIdFromText tempUserId
+      tempOwner <- runDB $ get ownerId
-      user <- runDB $ getJust userId
+      case tempOwner of
-      case userAdmin user of
+        Just owner -> do
-        True -> do
+          ((result, adminProfileSetWidget), enctype) <- runFormPost $ adminProfileForm owner
-          tempOwner <- runDB $ get ownerId
+          case result of
-          case tempOwner of
+            FormSuccess temp -> do
-            Just owner -> do
+              runDB $ update ownerId 
-              ((result, adminProfileSetWidget), enctype) <- runFormPost $ adminProfileForm owner
+                [ UserName =. (userName temp)
-              case result of
+                , UserSlug =. (userSlug temp)
-                FormSuccess temp -> do
+                , UserEmail =. (userEmail temp)
-                  runDB $ update ownerId 
+                , UserAdmin =. (userAdmin temp)
-                    [ UserName =. (userName temp)
+                ]
-                    , UserSlug =. (userSlug temp)
+              setMessage "User data updated successfully"
-                    , 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
+            _ -> do
-          setMessage "You are not an admin"
+              setMessage "There was an error"
-          redirect $ HomeR
+              redirect $ AdminProfileSettingsR ownerId
-    Nothing -> do
+        Nothing -> do
-      setMessage "You are not logged in"
+          setMessage "This user does not exist"
-      redirect $ LoginR
+          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"
+  adminCheck <- loginIsAdmin
-  case msu of
+  case adminCheck of
-    Just tempUserId -> do
+    Right _ -> do
-      userId <- return $ getUserIdFromText tempUserId
+      tempOwner <- runDB $ get ownerId
-      user <- runDB $ getJust userId
+      case tempOwner of
-      case userAdmin user of
+        Just owner -> do
-        True -> do
+          albumList <- return $ userAlbums owner
-          tempOwner <- runDB $ get ownerId
+          mapM (\albumId -> do
-          case tempOwner of
+            album <- runDB $ getJust albumId
-            Just owner -> do
+            mediaList <- return $ albumContent album
-              albumList <- return $ userAlbums owner
+            mapM (\med -> do
-              mapM (\albumId -> do
+              -- delete comments
-                album <- runDB $ getJust albumId
+              commEnts <- runDB $ selectList [CommentOrigin ==. med] []
-                mediaList <- return $ albumContent album
+              mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-                mapM (\med -> do
+              -- delete media files
-                  -- delete comments
+              medium <- runDB $ getJust med
-                  commEnts <- runDB $ selectList [CommentOrigin ==. med] []
+              liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
-                  mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
+              liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-                  -- delete media files
+              -- delete medium database entry
-                  medium <- runDB $ getJust med
+              runDB $ delete med
-                  liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
+              ) mediaList
-                  liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
+            runDB $ delete albumId
-                  -- delete medium database entry
+            ) albumList
-                  runDB $ delete med
+          runDB $ delete ownerId
-                  ) mediaList
+          liftIO $ removeDirectoryRecursive $ "static" </> "data" </> (T.unpack $ extractKey ownerId)
-                runDB $ delete albumId
+          setMessage "User successfully deleted"
-                ) albumList
+          redirect $ AdminR
-              runDB $ delete ownerId
+        Nothing -> do
-              liftIO $ removeDirectoryRecursive $ "static" </> "data" </> (T.unpack $ extractKey ownerId)
+          setMessage "This user does not exist"
-              setMessage "User successfully deleted"
+          redirect $ AdminR
-              redirect $ AdminR
+    Left (errorMsg, route) -> do
-            Nothing -> do
+      setMessage errorMsg
-              setMessage "This user does not exist"
+      redirect $ route
-              redirect $ AdminR
-        False -> do
-          setMessage "You are no admin"
-          redirect $ HomeR
-    Nothing -> do
-      setMessage "You must be logged in"
-      redirect $ LoginR

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)

eidolon.cabal

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