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"
-  case msu of
-    Just tempUserId -> do
-      userId <- return $ getUserIdFromText tempUserId
-      user <- runDB $ getJust userId
-      case userAdmin user of
-        True -> do
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> 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
+    Left (errorMsg, route) -> do
+      setMessage errorMsg
+      redirect $ route

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,33 +9,22 @@ 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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> 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
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempAlbum <- runDB $ get albumId
       case tempAlbum of
         Just album -> do
@@ -45,22 +35,15 @@ getAdminAlbumMediaR albumId = do
         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
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempAlbum <- runDB $ get albumId
       case tempAlbum of
         Just album -> do
@@ -73,22 +56,15 @@ getAdminAlbumSettingsR albumId = do
         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
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempAlbum <- runDB $ get albumId
       case tempAlbum of
         Just album -> do
@@ -110,12 +86,9 @@ postAdminAlbumSettingsR albumId = do
         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
+    Left (errorMsg, route) -> do
+      setMessage errorMsg
+      redirect $ route
 
 adminAlbumSettingsForm :: Album -> AlbumId -> [(Text, UserId)] -> Form Album
 adminAlbumSettingsForm album albumId users = renderDivs $ Album
@@ -128,19 +101,12 @@ 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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempAlbum <- runDB $ get albumId
       case tempAlbum of
         Just album -> do
@@ -172,9 +138,6 @@ getAdminAlbumDeleteR albumId = do
         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
+    Left (errorMsg, route) -> do
+      setMessage errorMsg
+      redirect $ route

Handler/AdminComments.hs

@@ -1,41 +1,31 @@
 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
+  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")
-        False -> do
-          setMessage "You have no admin rights"
-          redirect $ HomeR
-    Nothing -> do
-      setMessage "You are not logged in"
-      redirect $ LoginR
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempComment <- runDB $ get commentId
       case tempComment of
         Just comment -> do
@@ -49,9 +39,6 @@ getAdminCommentDeleteR commentId = do
         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
+    Left (errorMsg, route) -> do
+      setMessage errorMsg
+      redirect $ route

Handler/AdminMediumSettings.hs

@@ -1,39 +1,29 @@
 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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> 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
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempMedium <- runDB $ get mediumId
       case tempMedium of
         Just medium -> do
@@ -44,22 +34,15 @@ getAdminMediumSettingsR mediumId = do
         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
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempMedium <- runDB $ get mediumId
       case tempMedium of
         Just medium -> do
@@ -79,12 +62,9 @@ postAdminMediumSettingsR mediumId = do
         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
+    Left (errorMsg, route) -> do
+      setMessage errorMsg
+      redirect $ route
 
 adminMediumSetForm :: Medium -> Form Medium
 adminMediumSetForm medium = renderDivs $ Medium
@@ -100,13 +80,9 @@ 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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempMedium <- runDB $ get mediumId
       case tempMedium of
         Just medium -> do
@@ -130,9 +106,6 @@ getAdminMediumDeleteR mediumId = do
         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
+    Left (errorMsg, route) -> do
+      setMessage errorMsg
+      redirect $ route

Handler/AdminProfileSettings.hs

@@ -1,40 +1,31 @@
 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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> 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
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempOwner <- runDB $ get ownerId
       case tempOwner of
         Just owner -> do
@@ -45,22 +36,15 @@ getAdminUserAlbumsR ownerId = do
         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
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempOwner <- runDB $ get ownerId
       case tempOwner of
         Just owner -> do
@@ -71,25 +55,20 @@ getAdminUserMediaR ownerId = do
         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
+    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
+  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"
@@ -97,23 +76,15 @@ getAdminProfileSettingsR ownerId = do
         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
-      
+    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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempOwner <- runDB $ get ownerId
       case tempOwner of
         Just owner -> do
@@ -134,12 +105,9 @@ postAdminProfileSettingsR ownerId = do
         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
+    Left (errorMsg, route) -> do
+      setMessage errorMsg
+      redirect $ route
 
 
 adminProfileForm :: User -> Form User
@@ -154,13 +122,9 @@ 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
+  adminCheck <- loginIsAdmin
+  case adminCheck of
+    Right _ -> do
       tempOwner <- runDB $ get ownerId
       case tempOwner of
         Just owner -> do
@@ -188,9 +152,6 @@ getAdminProfileDeleteR ownerId = do
         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
+    Left (errorMsg, route) -> do
+      setMessage errorMsg
+      redirect $ route

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