diff --git a/Application.hs b/Application.hs index d556031..1b9d815 100644 --- a/Application.hs +++ b/Application.hs @@ -28,7 +28,7 @@ import Yesod.Default.Handlers import Database.Persist.Sql (runMigration) import Network.HTTP.Client.Conduit (newManager) import Control.Monad -import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize) +import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, toLogStr) import Data.Default (def) import Yesod.Core.Types (loggerSet) @@ -44,7 +44,6 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, mkRequestLogger, outputFormat) -import System.Log.FastLogger (toLogStr) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! diff --git a/Foundation.hs b/Foundation.hs index 28faa47..789f85b 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -31,6 +31,7 @@ import Yesod.Core.Types -- costom imports import Data.Text as T import Data.Text.Encoding +import Control.Applicative ((<$>)) import Network.Wai import Helper @@ -71,19 +72,19 @@ renderLayout widget = do msu <- lookupSession "userId" username <- case msu of Just a -> do - uId <- return $ getUserIdFromText a + let uId = getUserIdFromText a user <- runDB $ getJust uId return $ userName user - Nothing -> do + Nothing -> return ("" :: T.Text) slug <- case msu of Just a -> do - uId <- return $ getUserIdFromText a + let uId = getUserIdFromText a user <- runDB $ getJust uId return $ userSlug user - Nothing -> do + Nothing -> return ("" :: T.Text) - block <- return $ appSignupBlocked $ appSettings master + let block = appSignupBlocked $ appSettings master -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and @@ -91,7 +92,7 @@ renderLayout widget = do -- value passed to hamletToRepHtml cannot be a widget, this allows -- you to use normal widget features in default-layout. - copyrightWidget <- widgetToPageContent $ do + copyrightWidget <- widgetToPageContent $ $(widgetFile "copyrightFooter") wc <- widgetToPageContent widget @@ -114,7 +115,7 @@ renderLayout widget = do withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") formLayout :: Widget -> Handler Html -formLayout widget = do +formLayout widget = renderLayout $(widgetFile "form-widget") approotRequest :: App -> Request -> T.Text @@ -124,9 +125,12 @@ approotRequest master req = Nothing -> appRoot $ appSettings master where prefix = - case "https://" `T.isPrefixOf` (appRoot $ appSettings master) of - True -> "https://" - False -> "http://" + if + "https://" `isPrefixOf` appRoot (appSettings master) + then + "https://" + else + "http://" -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. @@ -139,11 +143,11 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes - makeSessionBackend _ = fmap Just $ defaultClientSessionBackend + makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 -- timeout in minutes "config/client_session_key.aes" - defaultLayout widget = do + defaultLayout widget = renderLayout $(widgetFile "default-widget") -- This is done to provide an optimization for serving static files from diff --git a/Handler/Activate.hs b/Handler/Activate.hs index 8ce58db..13ac7ee 100644 --- a/Handler/Activate.hs +++ b/Handler/Activate.hs @@ -27,50 +27,52 @@ getActivateR token = do t <- runDB $ selectFirst [ActivatorToken ==. token] [] case t of Nothing -> do - mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] + mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] case mToken of Just (Entity _ uToken) -> do user <- runDB $ getJust (fromJust $ tokenUser uToken) - hexSalt <- return $ toHex $ userSalt user + let hexSalt = toHex $ userSalt user formLayout $ do setTitle "Activate your account" $(widgetFile "activate") _ -> do setMessage "Invalid token!" - redirect $ HomeR + redirect HomeR Just (Entity _ activator) -> do - uSalt <- return $ userSalt $ activatorUser activator - mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] + let uSalt = userSalt $ activatorUser activator + mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] case mToken of Just (Entity _ _) -> do - hexSalt <- return $ toHex uSalt - formLayout $ do + let hexSalt = toHex uSalt + formLayout $ $(widgetFile "activate") _ -> do setMessage "Invalid token!" - redirect $ HomeR + redirect HomeR postActivateR :: Text -> Handler RepJson postActivateR token = do msalted <- fromJust <$> lookupPostParam "salted" - salted <- return $ fromHex' $ unpack msalted - mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] + let salted = fromHex' $ unpack msalted + mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] case mToken of - Just (Entity uTokenId uToken) -> do - case tokenUser uToken == Nothing of - True -> do + Just (Entity uTokenId uToken) -> + if + isNothing (tokenUser uToken) + then do newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] case newUser of Just (Entity aId activ) -> do - namesakes <- runDB $ selectList [UserName ==. (userName $ activatorUser activ)] [] - case namesakes == [] of - True -> do + namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] [] + if + I.null namesakes + then do -- putting user in active state uId <- runDB $ insert $ activatorUser activ runDB $ update uId [UserSalted =. salted] -- create user directory liftIO $ createDirectoryIfMissing True $ - "static" "data" (unpack $ extractKey uId) + "static" "data" unpack (extractKey uId) -- cleanup runDB $ delete aId runDB $ delete uTokenId @@ -78,21 +80,21 @@ postActivateR token = do setSession "userId" (extractKey uId) welcomeLink <- ($ ProfileR uId) <$> getUrlRender returnJson ["welcome" .= welcomeLink] - False -> do + else do -- cleanup runDB $ delete aId runDB $ delete uTokenId returnJsonError "Somebody already activated your username. Your token has been deleted" - Nothing -> do + Nothing -> returnJsonError "Invalid token" - False -> do + else do runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] -- cleanup runDB $ delete uTokenId setSession "userId" (extractKey $ fromJust $ tokenUser uToken) welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender returnJson ["welcome" .= welcomeLink] - _ -> do + _ -> returnJsonError "Invalid activation token!" returnJson :: (Monad m, ToJSON a, a ~ Value) => diff --git a/Handler/Admin.hs b/Handler/Admin.hs index d8a9bdf..1c0d5da 100644 --- a/Handler/Admin.hs +++ b/Handler/Admin.hs @@ -23,10 +23,10 @@ getAdminR :: Handler Html getAdminR = do adminCheck <- loginIsAdmin case adminCheck of - Right _ -> do + Right _ -> defaultLayout $ do setTitle "Administration: Menu" $(widgetFile "adminBase") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route diff --git a/Handler/AdminAlbumSettings.hs b/Handler/AdminAlbumSettings.hs index 7a6f7cb..c1fb5d7 100644 --- a/Handler/AdminAlbumSettings.hs +++ b/Handler/AdminAlbumSettings.hs @@ -35,7 +35,7 @@ getAdminAlbumsR = do $(widgetFile "adminAlbums") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route getAdminAlbumMediaR :: AlbumId -> Handler Html getAdminAlbumMediaR albumId = do @@ -51,10 +51,10 @@ getAdminAlbumMediaR albumId = do $(widgetFile "adminAlbumMedia") Nothing -> do setMessage "This album does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route getAdminAlbumSettingsR :: AlbumId -> Handler Html getAdminAlbumSettingsR albumId = do @@ -64,18 +64,18 @@ getAdminAlbumSettingsR albumId = 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 + entities <- runDB $ selectList [UserId !=. albumOwner album] [Desc UserName] + let users = map (\u -> (userName $ entityVal u, entityKey u)) entities (adminAlbumSettingsWidget, enctype) <- generateFormPost $ adminAlbumSettingsForm album albumId users formLayout $ do setTitle "Administration: Album settings" $(widgetFile "adminAlbumSet") Nothing -> do setMessage "This album does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route postAdminAlbumSettingsR :: AlbumId -> Handler Html postAdminAlbumSettingsR albumId = do @@ -85,12 +85,12 @@ postAdminAlbumSettingsR albumId = 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 + entities <- runDB $ selectList [UserId !=. albumOwner album] [Desc UserName] + let users = map (\u -> (userName $ entityVal u, entityKey u)) entities ((res, _), _) <- runFormPost $ adminAlbumSettingsForm album albumId users case res of FormSuccess temp -> do - width <- getThumbWidth $ Just $ L.tail $ fromMaybe ['a'] $ albumSamplePic temp + width <- getThumbWidth $ Just $ L.tail $ fromMaybe "a" $ albumSamplePic temp _ <- runDB $ update albumId [ AlbumTitle =. albumTitle temp , AlbumShares =. albumShares temp @@ -98,16 +98,16 @@ postAdminAlbumSettingsR albumId = do , AlbumSampleWidth =. width ] setMessage "Album settings changed successfully" - redirect $ AdminR + 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 + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route adminAlbumSettingsForm :: Album -> AlbumId -> [(Text, UserId)] -> Form Album adminAlbumSettingsForm album albumId users = renderDivs $ Album @@ -131,10 +131,10 @@ getAdminAlbumDeleteR albumId = do case tempAlbum of Just album -> do -- remove reference from owner - ownerId <- return $ albumOwner album + let ownerId = albumOwner album owner <- runDB $ getJust ownerId - albumList <- return $ userAlbums owner - newAlbumList <- return $ removeItem albumId albumList + let albumList = userAlbums owner + let newAlbumList = removeItem albumId albumList runDB $ update ownerId [UserAlbums =. newAlbumList] -- delete album content and its comments _ <- mapM (\a -> do @@ -144,20 +144,20 @@ getAdminAlbumDeleteR albumId = do liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) -- delete comments commEnts <- runDB $ selectList [CommentOrigin ==. a] [] - _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts + _ <- mapM (runDB . delete . entityKey) 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) + liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey ownerId) T.unpack (extractKey albumId) -- outro setMessage "Album deleted successfully" - redirect $ AdminR + redirect AdminR Nothing -> do setMessage "This album dies not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route diff --git a/Handler/AdminComments.hs b/Handler/AdminComments.hs index 36cf9ca..49a0351 100644 --- a/Handler/AdminComments.hs +++ b/Handler/AdminComments.hs @@ -35,7 +35,7 @@ getAdminCommentR = do $(widgetFile "adminComments") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route getAdminCommentDeleteR :: CommentId -> Handler Html getAdminCommentDeleteR commentId = do @@ -46,15 +46,15 @@ getAdminCommentDeleteR commentId = do case tempComment of Just _ -> do -- delete comment children - children <- runDB $ selectList [CommentParent ==. (Just commentId)] [] - _ <- mapM (\ent -> runDB $ delete $ entityKey ent) children + children <- runDB $ selectList [CommentParent ==. Just commentId] [] + _ <- mapM (runDB . delete . entityKey) children -- delete comment itself runDB $ delete commentId setMessage "Comment deleted succesfully" - redirect $ AdminR + redirect AdminR Nothing -> do setMessage "This comment does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route diff --git a/Handler/AdminMediumSettings.hs b/Handler/AdminMediumSettings.hs index c63cc24..5d6a5ee 100644 --- a/Handler/AdminMediumSettings.hs +++ b/Handler/AdminMediumSettings.hs @@ -34,7 +34,7 @@ getAdminMediaR = do $(widgetFile "adminMedia") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route getAdminMediumSettingsR :: MediumId -> Handler Html getAdminMediumSettingsR mediumId = do @@ -50,10 +50,10 @@ getAdminMediumSettingsR mediumId = do $(widgetFile "adminMediumSet") Nothing -> do setMessage "This medium does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route postAdminMediumSettingsR :: MediumId -> Handler Html postAdminMediumSettingsR mediumId = do @@ -72,16 +72,16 @@ postAdminMediumSettingsR mediumId = do , MediumTags =. mediumTags temp ] setMessage "Medium settings changed successfully" - redirect $ AdminR + 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 + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route adminMediumSetForm :: Medium -> Form Medium adminMediumSetForm medium = renderDivs $ Medium @@ -106,14 +106,14 @@ getAdminMediumDeleteR mediumId = do case tempMedium of Just medium -> do -- remove reference from album - albumId <- return $ mediumAlbum medium + let albumId = mediumAlbum medium album <- runDB $ getJust albumId - mediaList <- return $ albumContent album - newMediaList <- return $ removeItem mediumId mediaList + let mediaList = albumContent album + let newMediaList = removeItem mediumId mediaList runDB $ update albumId [AlbumContent =. newMediaList] -- delete comments commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] [] - _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts + _ <- mapM (runDB . delete . entityKey) commEnts -- delete medium runDB $ delete mediumId -- delete files @@ -121,10 +121,10 @@ getAdminMediumDeleteR mediumId = do liftIO $ removeFile (normalise $ tail $ mediumThumb medium) -- outro setMessage "Medium deleted successfully" - redirect $ AdminR + redirect AdminR Nothing -> do setMessage "This medium does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route diff --git a/Handler/AdminProfileSettings.hs b/Handler/AdminProfileSettings.hs index 902e3aa..49dc39d 100644 --- a/Handler/AdminProfileSettings.hs +++ b/Handler/AdminProfileSettings.hs @@ -35,7 +35,7 @@ getAdminProfilesR = do $(widgetFile "adminProfiles") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route getAdminUserAlbumsR :: UserId -> Handler Html getAdminUserAlbumsR ownerId = do @@ -51,10 +51,10 @@ getAdminUserAlbumsR ownerId = do $(widgetFile "adminUserAlbums") Nothing -> do setMessage "This user does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route getAdminUserMediaR :: UserId -> Handler Html getAdminUserMediaR ownerId = do @@ -70,10 +70,10 @@ getAdminUserMediaR ownerId = do $(widgetFile "adminUserMedia") Nothing -> do setMessage "This user does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route getAdminProfileSettingsR :: UserId -> Handler Html getAdminProfileSettingsR ownerId = do @@ -84,17 +84,17 @@ getAdminProfileSettingsR ownerId = do case tempOwner of Just owner -> do tempUserId <- lookupSession "userId" - userId <- return $ getUserIdFromText $ fromJust tempUserId + let userId = getUserIdFromText $ fromJust tempUserId (adminProfileSetWidget, enctype) <- generateFormPost $ adminProfileForm owner formLayout $ do setTitle "Administration: Profile settings" $(widgetFile "adminProfileSettings") Nothing -> do setMessage "This user does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route postAdminProfileSettingsR :: UserId -> Handler Html postAdminProfileSettingsR ownerId = do @@ -108,22 +108,22 @@ postAdminProfileSettingsR ownerId = do case result of FormSuccess temp -> do runDB $ update ownerId - [ UserName =. (userName temp) - , UserSlug =. (userSlug temp) - , UserEmail =. (userEmail temp) - , UserAdmin =. (userAdmin temp) + [ UserName =. userName temp + , UserSlug =. userSlug temp + , UserEmail =. userEmail temp + , UserAdmin =. userAdmin temp ] setMessage "User data updated successfully" - redirect $ AdminR + redirect AdminR _ -> do setMessage "There was an error" redirect $ AdminProfileSettingsR ownerId Nothing -> do setMessage "This user does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route adminProfileForm :: User -> Form User @@ -144,14 +144,14 @@ getAdminProfileDeleteR ownerId = do tempOwner <- runDB $ get ownerId case tempOwner of Just owner -> do - albumList <- return $ userAlbums owner + let albumList = userAlbums owner _ <- mapM (\albumId -> do album <- runDB $ getJust albumId - mediaList <- return $ albumContent album + let mediaList = albumContent album _ <- mapM (\med -> do -- delete comments commEnts <- runDB $ selectList [CommentOrigin ==. med] [] - _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts + _ <- mapM (runDB . delete . entityKey) commEnts -- delete media files medium <- runDB $ getJust med liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) @@ -162,12 +162,12 @@ getAdminProfileDeleteR ownerId = do runDB $ delete albumId ) albumList runDB $ delete ownerId - liftIO $ removeDirectoryRecursive $ "static" "data" (T.unpack $ extractKey ownerId) + liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey ownerId) setMessage "User successfully deleted" - redirect $ AdminR + redirect AdminR Nothing -> do setMessage "This user does not exist" - redirect $ AdminR + redirect AdminR Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route diff --git a/Handler/Album.hs b/Handler/Album.hs index 0fe1d03..3069d16 100644 --- a/Handler/Album.hs +++ b/Handler/Album.hs @@ -25,22 +25,22 @@ getAlbumR albumId = do tempAlbum <- runDB $ get albumId case tempAlbum of Just album -> do - ownerId <- return $ albumOwner album + let ownerId = albumOwner album owner <- runDB $ getJust ownerId - ownerName <- return $ userName owner - ownerSlug <- return $ userSlug owner + let ownerName = userName owner + let ownerSlug = userSlug owner msu <- lookupSession "userId" presence <- case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - return $ (userId == ownerId) || (userId `elem` (albumShares album)) + let userId = getUserIdFromText tempUserId + return $ (userId == ownerId) || (userId `elem` albumShares album) Nothing -> return False -- media <- mapM (\a -> runDB $ getJust a) (albumContent album) media <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime] defaultLayout $ do - setTitle $ toHtml ("Eidolon :: Album " `T.append` (albumTitle album)) + setTitle $ toHtml ("Eidolon :: Album " `T.append` albumTitle album) $(widgetFile "album") Nothing -> do setMessage "This album does not exist" - redirect $ HomeR + redirect HomeR diff --git a/Handler/AlbumSettings.hs b/Handler/AlbumSettings.hs index 2b3e552..e72d838 100644 --- a/Handler/AlbumSettings.hs +++ b/Handler/AlbumSettings.hs @@ -28,17 +28,17 @@ getAlbumSettingsR albumId = do tempAlbum <- runDB $ get albumId case tempAlbum of Just album -> do - ownerId <- return $ albumOwner album + let ownerId = albumOwner album msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - ownerPresence <- return (userId == ownerId) - presence <- return $ userId `elem` (albumShares album) + let userId = getUserIdFromText tempUserId + let ownerPresence = userId == ownerId + let presence = userId `elem` (albumShares album) case ownerPresence || presence of True -> do entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] - users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities + let users = map (\u -> (userName $ entityVal u, entityKey u)) entities (albumSettingsWidget, enctype) <- generateFormPost $ albumSettingsForm album albumId users formLayout $ do setTitle "Eidolon :: Album Settings" @@ -48,46 +48,48 @@ getAlbumSettingsR albumId = do redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to change settings" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This album does not exist" - redirect $ HomeR + redirect HomeR postAlbumSettingsR :: AlbumId -> Handler Html postAlbumSettingsR albumId = do tempAlbum <- runDB $ get albumId case tempAlbum of Just album -> do - ownerId <- return $ albumOwner album + let ownerId = albumOwner album owner <- runDB $ getJust ownerId - ownerName <- return $ userName owner + let ownerName = userName owner msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - ownerPresence <- return (userId == ownerId) - presence <- return $ userId `elem` (albumShares album) - case ownerPresence || presence of - True -> do + let userId = getUserIdFromText tempUserId + let ownerPresence = userId == ownerId + let presence = userId `elem` albumShares album + if + ownerPresence || presence + then do entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] - users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities + let users = map (\u -> (userName $ entityVal u, entityKey u)) entities ((result, _), _) <- runFormPost $ albumSettingsForm album albumId users case result of FormSuccess temp -> do - newShares <- return (L.sort $ albumShares temp) - oldShares <- return (L.sort $ albumShares album) - _ <- case newShares /= oldShares of - True -> do + let newShares = L.sort $ albumShares temp + let oldShares = L.sort $ albumShares album + _ <- if + newShares /= oldShares + then do link <- ($ AlbumR albumId) <$> getUrlRender - rcptIds <- return $ L.nub $ newShares L.\\ oldShares + let rcptIds = L.nub $ newShares L.\\ oldShares mapM (\uId -> do -- update userAlbums user <- runDB $ getJust uId - oldAlbs <- return $ userAlbums user - newAlbs <- return $ albumId : oldAlbs + let oldAlbs = userAlbums user + let newAlbs = albumId : oldAlbs _ <- runDB $ update uId [UserAlbums =. newAlbs] -- send notification - addr <- return $ userEmail user + let addr = userEmail user sendMail addr "A new album was shared with you" $ [shamlet|

Hello #{userSlug user}! @@ -98,7 +100,7 @@ postAlbumSettingsR albumId = do . |] ) rcptIds - False -> do + else do return [()] -- nothing to do here width <- getThumbWidth $ Just $ L.tail $ fromMaybe ['a'] $ albumSamplePic temp @@ -113,15 +115,15 @@ postAlbumSettingsR albumId = do _ -> do setMessage "There was an error while changing the settings" redirect $ AlbumSettingsR albumId - False -> do + else do setMessage "You must own this album to change its settings" redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to change settings" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This album does not exist" - redirect $ HomeR + redirect HomeR albumSettingsForm :: Album -> AlbumId -> [(Text, UserId)]-> Form Album albumSettingsForm album albumId users = renderDivs $ Album @@ -144,47 +146,47 @@ getAlbumDeleteR albumId = do tempAlbum <- runDB $ get albumId case tempAlbum of Just album -> do - ownerId <- return $ albumOwner album + let ownerId = albumOwner album msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - presence <- return (userId == ownerId) - case presence of - True -> do + let userId = getUserIdFromText tempUserId + if + userId == ownerId + then do formLayout $ do setTitle $ toHtml ("Eidolon :: Delete album" `T.append` (albumTitle album)) $(widgetFile "albumDelete") - False -> do + else do setMessage "You must own this album to delete it" redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to delete albums" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This album does not exist" - redirect $ HomeR + redirect HomeR postAlbumDeleteR :: AlbumId -> Handler Html postAlbumDeleteR albumId = do tempAlbum <- runDB $ get albumId case tempAlbum of Just album -> do - ownerId <- return $ albumOwner album + let ownerId = albumOwner album owner <- runDB $ getJust ownerId msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - presence <- return (userId == ownerId) - case presence of - True -> do + let userId = getUserIdFromText tempUserId + if + userId == ownerId + then do confirm <- lookupPostParam "confirm" case confirm of Just "confirm" -> do -- remove album reference from user - albumList <- return $ userAlbums owner - newAlbumList <- return $ removeItem albumId albumList + let albumList = userAlbums owner + let newAlbumList = removeItem albumId albumList runDB $ update ownerId [UserAlbums =. newAlbumList] -- delete album content and its comments _ <- mapM (\a -> do @@ -194,25 +196,25 @@ postAlbumDeleteR albumId = do liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) -- delete comments commEnts <- runDB $ selectList [CommentOrigin ==. a] [] - _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts + _ <- mapM (runDB . delete . entityKey) commEnts runDB $ delete a ) (albumContent album) -- delete album runDB $ delete albumId -- delete files - liftIO $ removeDirectoryRecursive $ "static" "data" (T.unpack $ extractKey userId) (T.unpack $ extractKey albumId) + liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey userId) T.unpack (extractKey albumId) -- outro setMessage "Album deleted succesfully" - redirect $ HomeR + redirect HomeR _ -> do setMessage "You must confirm the deletion" redirect $ AlbumSettingsR albumId - _ -> do + else do setMessage "You must own this album to delete it" redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to delete albums" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This album does not exist" - redirect $ HomeR + redirect HomeR diff --git a/Handler/Commons.hs b/Handler/Commons.hs index 9c6b9d9..30f218f 100644 --- a/Handler/Commons.hs +++ b/Handler/Commons.hs @@ -24,12 +24,13 @@ loginIsAdmin = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId + let userId = getUserIdFromText tempUserId user <- runDB $ getJust userId - case userAdmin user of - True -> + if + userAdmin user + then return $ Right () - False -> + else return $ Left ("You have no admin rights", HomeR) Nothing -> return $ Left ("You are not logged in", LoginR) @@ -42,11 +43,12 @@ profileCheck userId = do msu <- lookupSession "userId" case msu of Just tempLoginId -> do - loginId <- return $ getUserIdFromText tempLoginId - case loginId == userId of - True -> + let loginId = getUserIdFromText tempLoginId + if + loginId == userId + then return $ Right user - False -> + else return $ Left ("You can only change your own profile settings", UserR $ userName user) Nothing -> return $ Left ("You nedd to be logged in to change settings", LoginR) @@ -58,18 +60,19 @@ mediumCheck mediumId = do tempMedium <- runDB $ get mediumId case tempMedium of Just medium -> do - ownerId <- return $ mediumOwner medium + let ownerId = mediumOwner medium msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId + let userId = getUserIdFromText tempUserId album <- runDB $ getJust $ mediumAlbum medium - presence <- return (userId == ownerId) - albumOwnerPresence <- return (userId == (albumOwner album)) - case presence || albumOwnerPresence of - True -> + let presence = userId == ownerId + let albumOwnerPresence = userId == albumOwner album + if + presence || albumOwnerPresence + then return $ Right medium - False -> + else return $ Left ("You must own this medium to change its settings", MediumR mediumId) Nothing -> return $ Left ("You must be logged in to change settings", LoginR) diff --git a/Handler/Home.hs b/Handler/Home.hs index d55aa81..bba7e7e 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -26,8 +26,7 @@ getHomeR :: Handler Html getHomeR = do recentMedia <- runDB $ selectList [] [Desc MediumTime, LimitTo 30] nextMediaQuery <- runDB $ selectList [] [Desc MediumTime, LimitTo 1, OffsetBy 30] - nextMedia <- return $ not $ L.null nextMediaQuery - widgetLayout <- return $ widgetFile "default-widget" + let nextMedia = not $ L.null nextMediaQuery defaultLayout $ do setTitle "Eidolon :: Home" $(widgetFile "home") @@ -36,8 +35,7 @@ getPageR :: Int -> Handler Html getPageR page = do pageMedia <- runDB $ selectList [] [Desc MediumTime, LimitTo 30, OffsetBy (page*30)] nextMediaQuery <- runDB $ selectList [] [Desc MediumTime, LimitTo 1, OffsetBy ((page + 1) * 30)] - nextMedia <- return $ not $ L.null nextMediaQuery - widgetLayout <- return $ widgetFile "default-widget" + let nextMedia = not $ L.null nextMediaQuery defaultLayout $ do - setTitle $ toHtml ("Eidolon :: Page " `T.append` (T.pack $ show page)) + setTitle $ toHtml ("Eidolon :: Page " `T.append` T.pack (show page)) $(widgetFile "page") diff --git a/Handler/Login.hs b/Handler/Login.hs index 36806f5..9c7f18c 100644 --- a/Handler/Login.hs +++ b/Handler/Login.hs @@ -33,8 +33,7 @@ data Credentials = Credentials deriving Show getLoginR :: Handler Html -getLoginR = do --- (loginWidget, enctype) <- generateFormPost loginForm +getLoginR = formLayout $ do setTitle "Eidolon :: Login" $(widgetFile "login") @@ -45,36 +44,35 @@ postLoginR = do mUserName <- lookupPostParam "username" mHexToken <- lookupPostParam "token" mHexResponse <- lookupPostParam "response" - case (mUserName, mHexToken, mHexResponse) of (Just userName, Nothing, Nothing) -> do tempUser <- runDB $ selectFirst [UserName ==. userName] [] case tempUser of Just (Entity userId user) -> do - salt <- return $ userSalt user + let salt = userSalt user token <- liftIO makeRandomToken - _ <- runDB $ insert $ Token (encodeUtf8 token) "login" (Just userId) - returnJson ["salt" .= (toHex salt), "token" .= (toHex $ encodeUtf8 token)] + runDB $ insert_ $ Token (encodeUtf8 token) "login" (Just userId) + returnJson ["salt" .= toHex salt, "token" .= toHex (encodeUtf8 token)] Nothing -> returnJsonError ("No such user" :: T.Text) - (Nothing, Just hexToken, Just hexResponse) -> do response <- do - tempToken <- return $ fromHex' $ T.unpack hexToken + let tempToken = fromHex' $ T.unpack hexToken savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] [] case savedToken of Just (Entity tokenId token) -> do - savedUserId <- return $ tokenUser token + let savedUserId = tokenUser token queriedUser <- runDB $ getJust (fromJust savedUserId) - salted <- return $ userSalted queriedUser - hexSalted <- return $ toHex salted - expected <- return $ hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted) - case (fromHex' $ T.unpack hexResponse) == expected of - True -> do + let salted = userSalted queriedUser + let hexSalted = toHex salted + let expected = hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted) + if + fromHex' (T.unpack hexResponse) == expected + then do -- Success!! runDB $ delete tokenId return $ Right savedUserId - _ -> + else return $ Left ("Wrong password" :: T.Text) Nothing -> return $ Left "Invalid token" @@ -86,7 +84,6 @@ postLoginR = do setMessage "Succesfully logged in" welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender returnJson ["welcome" .= welcomeLink] - _ -> returnJsonError ("Protocol error" :: T.Text) @@ -100,7 +97,7 @@ getLogoutR :: Handler Html getLogoutR = do deleteSession "userId" setMessage "Succesfully logged out" - redirect $ HomeR + redirect HomeR returnJson :: Monad m => [Pair] -> m RepJson returnJson = return . repJson . object diff --git a/Handler/Medium.hs b/Handler/Medium.hs index 5deef30..e283a84 100644 --- a/Handler/Medium.hs +++ b/Handler/Medium.hs @@ -29,14 +29,14 @@ getMediumR mediumId = do tempMedium <- runDB $ get mediumId case tempMedium of Just medium -> do - ownerId <- return $ mediumOwner medium + let ownerId = mediumOwner medium owner <- runDB $ getJust ownerId - ownerName <- return $ userName owner - albumId <- return $ mediumAlbum medium + let ownerName = userName owner + let albumId = mediumAlbum medium album <- runDB $ getJust albumId msu <- lookupSession "userId" userId <- case msu of - Just tempUserId -> do + Just tempUserId -> return $ Just $ getUserIdFromText tempUserId Nothing -> return Nothing @@ -46,10 +46,16 @@ getMediumR mediumId = do return $ Just $ userSlug u Nothing -> return Nothing - presence <- return $ (userId == (Just ownerId) || userId == Just (albumOwner album)) + let presence = userId == (Just ownerId) || userId == Just (albumOwner album) (commentWidget, enctype) <- generateFormPost $ commentForm userId userSl mediumId Nothing - comments <- runDB $ selectList [CommentOrigin ==. mediumId, CommentParent ==. Nothing] [Desc CommentTime] - replies <- runDB $ selectList [CommentOrigin ==. mediumId, CommentParent !=. Nothing] [Desc CommentTime] + comments <- runDB $ selectList + [ CommentOrigin ==. mediumId + , CommentParent ==. Nothing ] + [ Desc CommentTime ] + replies <- runDB $ selectList + [ CommentOrigin ==. mediumId + , CommentParent !=. Nothing ] + [ Desc CommentTime ] dataWidth <- case mediumWidth medium >= 850 of True -> return 850 False -> return $ (mediumWidth medium) @@ -58,7 +64,7 @@ getMediumR mediumId = do $(widgetFile "medium") Nothing -> do setMessage "This image does not exist" - redirect $ HomeR + redirect HomeR postMediumR :: MediumId -> Handler Html postMediumR mediumId = do @@ -68,10 +74,10 @@ postMediumR mediumId = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ Just $ getUserIdFromText tempUserId - u <- runDB $ getJust $ fromJust userId - userSl <- return $ Just $ userSlug u - ((res, _), _) <- runFormPost $ commentForm userId userSl mediumId Nothing + let userId = getUserIdFromText tempUserId + u <- runDB $ getJust userId + let userSl = Just $ userSlug u + ((res, _), _) <- runFormPost $ commentForm (Just userId) userSl mediumId Nothing case res of FormSuccess temp -> do _ <- runDB $ insert temp @@ -98,7 +104,7 @@ postMediumR mediumId = do redirect LoginR Nothing -> do setMessage "This image does not exist" - redirect $ HomeR + redirect HomeR commentForm :: Maybe UserId -> Maybe Text -> MediumId -> Maybe CommentId -> Form Comment commentForm authorId authorSlug originId parentId = renderDivs $ Comment @@ -117,20 +123,20 @@ getCommentReplyR commentId = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ Just $ getUserIdFromText tempUserId - u <- runDB $ getJust $ fromJust userId - userSl <- return $ Just $ userSlug u - mediumId <- return $ commentOrigin comment - (replyWidget, enctype) <- generateFormPost $ commentForm userId userSl mediumId (Just commentId) + let userId = getUserIdFromText tempUserId + u <- runDB $ getJust userId + let userSl = Just $ userSlug u + let mediumId = commentOrigin comment + (replyWidget, enctype) <- generateFormPost $ commentForm (Just userId) userSl mediumId (Just commentId) formLayout $ do setTitle "Eidolon :: Reply to comment" $(widgetFile "commentReply") Nothing -> do setMessage "You need to be logged in to comment on media" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This comment does not Exist" - redirect $ HomeR + redirect HomeR postCommentReplyR :: CommentId -> Handler Html postCommentReplyR commentId = do @@ -140,11 +146,11 @@ postCommentReplyR commentId = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ Just $ getUserIdFromText tempUserId - u <- runDB $ getJust $ fromJust userId - userSl <- return $ Just $ userSlug u - mediumId <- return $ commentOrigin comment - ((res, _), _) <- runFormPost $ commentForm userId userSl mediumId (Just commentId) + let userId = getUserIdFromText tempUserId + u <- runDB $ getJust userId + let userSl = Just $ userSlug u + let mediumId = commentOrigin comment + ((res, _), _) <- runFormPost $ commentForm (Just userId) userSl mediumId (Just commentId) case res of FormSuccess temp -> do _ <- runDB $ insert temp @@ -182,10 +188,10 @@ postCommentReplyR commentId = do redirect $ CommentReplyR commentId Nothing -> do setMessage "You need to be logged in to post replies" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This comment does not exist!" - redirect $ HomeR + redirect HomeR getCommentDeleteR :: CommentId -> Handler Html getCommentDeleteR commentId = do @@ -195,22 +201,22 @@ getCommentDeleteR commentId = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - presence <- return $ (Just userId) == (commentAuthor comment) - case presence of - True -> do + let userId = getUserIdFromText tempUserId + if + Just userId == commentAuthor comment + then do formLayout $ do setTitle "Eidolon :: Delete comment" $(widgetFile "commentDelete") - False -> do + else do setMessage "You must be the author of this comment to delete it" redirect $ MediumR $ commentOrigin comment Nothing -> do setMessage "You must be logged in to delete comments" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This comment does not exist" - redirect $ HomeR + redirect HomeR postCommentDeleteR :: CommentId -> Handler Html postCommentDeleteR commentId = do @@ -220,10 +226,10 @@ postCommentDeleteR commentId = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - presence <- return $ (Just userId) == (commentAuthor comment) - case presence of - True -> do + let userId = getUserIdFromText tempUserId + if + Just userId == commentAuthor comment + then do confirm <- lookupPostParam "confirm" case confirm of Just "confirm" -> do @@ -238,12 +244,12 @@ postCommentDeleteR commentId = do _ -> do setMessage "You must confirm the deletion" redirect $ MediumR $ commentOrigin comment - False -> do + else do setMessage "You must be the author of this comment to delete it" redirect $ MediumR $ commentOrigin comment Nothing -> do setMessage "You must be logged in to delete comments" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This comment does not exist" - redirect $ HomeR + redirect HomeR diff --git a/Handler/MediumSettings.hs b/Handler/MediumSettings.hs index b4f238e..34af5af 100644 --- a/Handler/MediumSettings.hs +++ b/Handler/MediumSettings.hs @@ -34,7 +34,7 @@ getMediumSettingsR mediumId = do $(widgetFile "mediumSettings") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route postMediumSettingsR :: MediumId -> Handler Html postMediumSettingsR mediumId = do @@ -56,7 +56,7 @@ postMediumSettingsR mediumId = do redirect $ MediumSettingsR mediumId Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route mediumSettingsForm :: Medium -> Form Medium mediumSettingsForm medium = renderDivs $ Medium @@ -76,13 +76,13 @@ getMediumDeleteR :: MediumId -> Handler Html getMediumDeleteR mediumId = do checkRes <- mediumCheck mediumId case checkRes of - Right medium -> do + Right medium -> formLayout $ do setTitle "Eidolon :: Delete Medium" $(widgetFile "mediumDelete") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route postMediumDeleteR :: MediumId -> Handler Html postMediumDeleteR mediumId = do @@ -94,22 +94,22 @@ postMediumDeleteR mediumId = do Just "confirm" -> do -- delete comments commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] [] - _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts + _ <- mapM (runDB . delete . entityKey) commEnts -- delete references first - albumId <- return $ mediumAlbum medium + let albumId = mediumAlbum medium album <- runDB $ getJust albumId - mediaList <- return $ albumContent album - newMediaList <- return $ removeItem mediumId mediaList + let mediaList = albumContent album + let newMediaList = removeItem mediumId mediaList -- update reference List runDB $ update albumId [AlbumContent =. newMediaList] liftIO $ removeFile (normalise $ tail $ mediumPath medium) liftIO $ removeFile (normalise $ tail $ mediumThumb medium) runDB $ delete mediumId setMessage "Medium succesfully deleted" - redirect $ HomeR + redirect HomeR _ -> do setMessage "You must confirm the deletion" redirect $ MediumSettingsR mediumId Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route diff --git a/Handler/NewAlbum.hs b/Handler/NewAlbum.hs index 8ea48fb..8959e47 100644 --- a/Handler/NewAlbum.hs +++ b/Handler/NewAlbum.hs @@ -33,14 +33,14 @@ getNewAlbumR = do $(widgetFile "newAlbum") Nothing -> do setMessage "You need to be logged in" - redirect $ LoginR + redirect LoginR postNewAlbumR :: Handler Html postNewAlbumR = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId + let userId = getUserIdFromText tempUserId ((result, _), _) <- runFormPost (albumForm userId) case result of FormSuccess album -> do @@ -48,20 +48,20 @@ postNewAlbumR = do albumId <- runDB $ insert album -- add album reference in user user <- runDB $ getJust userId - albumList <- return $ userAlbums user - newAlbumList <- return $ albumId : albumList + let albumList = userAlbums user + let newAlbumList = albumId : albumList runDB $ update userId [UserAlbums =. newAlbumList] -- create folder - liftIO $ createDirectory $ "static" "data" (unpack $ extractKey userId) (unpack $ extractKey albumId) + liftIO $ createDirectory $ "static" "data" unpack (extractKey userId) unpack (extractKey albumId) -- outro - setMessage $ "Album successfully created" + setMessage "Album successfully created" redirect $ ProfileR userId _ -> do setMessage "There was an error creating the album" - redirect $ NewAlbumR + redirect NewAlbumR Nothing -> do setMessage "You must be logged in to create albums" - redirect $ LoginR + redirect LoginR albumForm :: UserId -> Form Album albumForm userId = renderDivs $ Album diff --git a/Handler/Profile.hs b/Handler/Profile.hs index 35dd03c..17eb27a 100644 --- a/Handler/Profile.hs +++ b/Handler/Profile.hs @@ -26,29 +26,30 @@ getProfileR ownerId = do tempOwner <- runDB $ get ownerId case tempOwner of Just owner -> do - ownerSlug <- lift $ pure $ userSlug owner + let ownerSlug = userSlug owner userAlbs <- runDB $ selectList [AlbumOwner ==. ownerId] [Asc AlbumTitle] allAlbs <- runDB $ selectList [] [Asc AlbumTitle] - almostAlbs <- mapM (\alb -> do - case ownerId `elem` (albumShares $ entityVal alb) of - True -> return $ Just alb - False -> return Nothing + almostAlbs <- mapM (\alb -> + if + ownerId `elem` albumShares (entityVal alb) + then return $ Just alb + else return Nothing ) allAlbs - sharedAlbs <- return $ removeItem Nothing almostAlbs - recentMedia <- (runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTime]) + let sharedAlbs = removeItem Nothing almostAlbs + recentMedia <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTime] msu <- lookupSession "userId" presence <- case msu of Just tempUserId -> do - userId <- lift $ pure $ getUserIdFromText tempUserId + let userId = getUserIdFromText tempUserId return (userId == ownerId) Nothing -> return False defaultLayout $ do - setTitle $ toHtml ("Eidolon :: " `T.append` (userSlug owner) `T.append` "'s profile") + setTitle $ toHtml ("Eidolon :: " `T.append` userSlug owner `T.append` "'s profile") $(widgetFile "profile") Nothing -> do setMessage "This profile does not exist" - redirect $ HomeR + redirect HomeR getUserR :: Text -> Handler Html getUserR ownerName = do @@ -58,4 +59,4 @@ getUserR ownerName = do getProfileR ownerId Nothing -> do setMessage "This user does not exist" - redirect $ HomeR + redirect HomeR diff --git a/Handler/ProfileDelete.hs b/Handler/ProfileDelete.hs index c24bc31..339d71e 100644 --- a/Handler/ProfileDelete.hs +++ b/Handler/ProfileDelete.hs @@ -18,6 +18,7 @@ module Handler.ProfileDelete where import Import import Handler.Commons +import Control.Monad (when) import qualified Data.Text as T import qualified Data.List as L import System.Directory @@ -27,13 +28,13 @@ getProfileDeleteR :: UserId -> Handler Html getProfileDeleteR userId = do checkRes <- profileCheck userId case checkRes of - Right user -> do + Right user -> formLayout $ do setTitle "Eidolon :: Delete user profile" $(widgetFile "profileDelete") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route postProfileDeleteR :: UserId -> Handler Html postProfileDeleteR userId = do @@ -43,31 +44,29 @@ postProfileDeleteR userId = do confirm <- lookupPostParam "confirm" case confirm of Just "confirm" -> do - albumList <- return $ userAlbums user + let albumList = userAlbums user _ <- mapM (\albumId -> do album <- runDB $ getJust albumId - case (albumOwner album) == userId of - True -> do - mediaList <- return $ albumContent album - _ <- mapM (\med -> do - commEnts <- runDB $ selectList [CommentOrigin ==. med] [] - _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts - medium <- runDB $ getJust med - liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) - liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) - runDB $ delete med - ) mediaList - runDB $ delete albumId - False -> return () + when (albumOwner album == userId) $ do + let mediaList = albumContent album + _ <- mapM (\med -> do + commEnts <- runDB $ selectList [CommentOrigin ==. med] [] + _ <- mapM (runDB . delete . entityKey) commEnts + medium <- runDB $ getJust med + liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) + liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) + runDB $ delete med + ) mediaList + runDB $ delete albumId ) albumList runDB $ delete userId - liftIO $ removeDirectoryRecursive $ "static" "data" (T.unpack $ extractKey userId) + liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey userId) deleteSession "userId" setMessage "User deleted successfully" - redirect $ HomeR + redirect HomeR _ -> do setMessage "You must confirm the deletion" redirect $ ProfileSettingsR userId Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route diff --git a/Handler/ProfileSettings.hs b/Handler/ProfileSettings.hs index 304a964..027285d 100644 --- a/Handler/ProfileSettings.hs +++ b/Handler/ProfileSettings.hs @@ -30,7 +30,7 @@ getProfileSettingsR userId = do $(widgetFile "profileSettings") Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route postProfileSettingsR :: UserId -> Handler Html postProfileSettingsR userId = do @@ -41,9 +41,9 @@ postProfileSettingsR userId = do case result of FormSuccess temp -> do runDB $ update userId [ - UserName =. (userName temp) - , UserSlug =. (userSlug temp) - , UserEmail =. (userEmail temp) + UserName =. userName temp + , UserSlug =. userSlug temp + , UserEmail =. userEmail temp ] setMessage "Profile settings changed successfully" redirect $ UserR $ userName user @@ -52,7 +52,7 @@ postProfileSettingsR userId = do redirect $ ProfileSettingsR userId Left (errorMsg, route) -> do setMessage errorMsg - redirect $ route + redirect route profileSettingsForm :: User -> Form User diff --git a/Handler/Reactivate.hs b/Handler/Reactivate.hs index e061244..8abf52c 100644 --- a/Handler/Reactivate.hs +++ b/Handler/Reactivate.hs @@ -33,8 +33,9 @@ postReactivateR = do case result of FormSuccess temp -> do users <- runDB $ selectList [UserEmail ==. temp] [] - case null users of - True -> do + if + null users + then do userTokens <- foldM (\userTokens (Entity userId user) -> do token <- liftIO $ generateString _ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (Just userId) @@ -58,7 +59,7 @@ postReactivateR = do ) True userTokens setMessage "Your new password activation will arrive in your e-mail" redirect $ HomeR - False -> do + else do setMessage "No user mith this Email" redirect $ LoginR _ -> do diff --git a/Handler/RootFeed.hs b/Handler/RootFeed.hs index de28221..e7ca048 100644 --- a/Handler/RootFeed.hs +++ b/Handler/RootFeed.hs @@ -51,7 +51,7 @@ withXmlDecl c = c instance RepFeed RepAtom where renderFeed params items = do - image <- return $ pImage params + let image = pImage params url <- getUrlRender tz <- liftIO getCurrentTimeZone links <- case items of diff --git a/Handler/Signup.hs b/Handler/Signup.hs index b791718..5d8e62f 100644 --- a/Handler/Signup.hs +++ b/Handler/Signup.hs @@ -25,7 +25,7 @@ import Data.Maybe getSignupR :: Handler Html getSignupR = do master <- getYesod - block <- return $ appSignupBlocked $ appSettings master + let block = appSignupBlocked $ appSettings master case block of False -> do formLayout $ do @@ -38,7 +38,7 @@ getSignupR = do postSignupR :: Handler Html postSignupR = do master <- getYesod - block <- return $ appSignupBlocked $ appSettings master + let block = appSignupBlocked $ appSettings master case block of False -> do mUserName <- lookupPostParam "username" @@ -46,7 +46,7 @@ postSignupR = do True -> return $ fromJust $ mUserName False -> do setMessage "Invalid username" - redirect $ SignupR + redirect SignupR mEmail <- lookupPostParam "email" mTos1 <- lookupPostParam "tos-1" mTos2 <- lookupPostParam "tos-2" @@ -55,19 +55,13 @@ postSignupR = do return () _ -> do setMessage "You need to agree to our terms." - redirect $ SignupR + redirect SignupR -- create user namesakes <- runDB $ selectList [UserName ==. newUserName] [] case namesakes of [] -> do salt <- liftIO generateSalt - newUser <- return $ User newUserName - newUserName - (fromJust mEmail) - salt - "" - [] - False + let newUser = User newUserName newUserName (fromJust mEmail) salt "" [] False activatorText <- liftIO generateString _ <- runDB $ insert $ Activator activatorText newUser _ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing @@ -79,13 +73,13 @@ postSignupR = do #{activateLink} |] setMessage "User pending activation" - redirect $ HomeR + redirect HomeR _ -> do setMessage "This user already exists" - redirect $ SignupR + redirect SignupR True -> do setMessage "User signup is disabled" - redirect $ HomeR + redirect HomeR validateLen :: Text -> Bool validateLen a = diff --git a/Handler/Tag.hs b/Handler/Tag.hs index 6f31334..233b2c3 100644 --- a/Handler/Tag.hs +++ b/Handler/Tag.hs @@ -23,12 +23,12 @@ import System.FilePath getTagR :: Text -> Handler Html getTagR tag = do tempMedia <- runDB $ selectList [] [Desc MediumTitle] - almostMedia <- mapM (\a -> do - case tag `elem` (mediumTags $ entityVal a) of - True -> return (Just a) - False -> return Nothing + almostMedia <- mapM (\a -> + if tag `elem` mediumTags (entityVal a) + then return (Just a) + else return Nothing ) tempMedia - media <- return $ removeItem Nothing almostMedia + let media = removeItem Nothing almostMedia defaultLayout $ do setTitle $ toHtml ("Eidolon :: Tag " `T.append` tag) $(widgetFile "tagMedia") diff --git a/Handler/Upload.hs b/Handler/Upload.hs index 396fc02..9aa172c 100644 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -31,90 +31,84 @@ getDirectUploadR albumId = do tempAlbum <- runDB $ get albumId case tempAlbum of -- does the requested album exist Just album -> do - ownerId <- return $ albumOwner album + let ownerId = albumOwner album msu <- lookupSession "userId" case msu of -- is anybody logged in Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album)) - case presence of -- is the owner present or a user with whom the album is shared - True -> do + let userId = getUserIdFromText tempUserId + if + userId == ownerId || userId `elem` albumShares album + -- is the owner present or a user with whom the album is shared + then do (dUploadWidget, enctype) <- generateFormPost $ dUploadForm userId albumId formLayout $ do - setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` (albumTitle album)) + setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` albumTitle album) $(widgetFile "dUpload") - False -> do + else do setMessage "You must own this album to upload" redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to upload" - redirect $ LoginR + redirect LoginR Nothing -> do setMessage "This album does not exist" - redirect $ HomeR + redirect HomeR postDirectUploadR :: AlbumId -> Handler Html postDirectUploadR albumId = do tempAlbum <- runDB $ get albumId case tempAlbum of -- does the album exist Just album -> do - ownerId <- return $ albumOwner album + let ownerId = albumOwner album msu <- lookupSession "userId" case msu of -- is anybody logged in Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId - presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album)) - case presence of -- is the logged in user the owner or is the album shared with him - True -> do + let userId = getUserIdFromText tempUserId + if + userId == ownerId || userId `elem` albumShares album + -- is the logged in user the owner or is the album shared with him + then do ((result, _), _) <- runFormPost (dUploadForm userId albumId) case result of FormSuccess temp -> do - fils <- return $ fileBulkFiles temp - indFils <- return $ zip [1..] fils + let fils = fileBulkFiles temp + let indFils = zip [1..] fils errNames <- mapM (\(index, file) -> do - mime <- return $ fileContentType file - case mime `elem` acceptedTypes of - True -> do + let mime = fileContentType file + if + mime `elem` acceptedTypes + then do path <- writeOnDrive file ownerId albumId (thumbPath, iWidth, tWidth) <- generateThumb path ownerId albumId - tempName <- case length indFils == 1 of - False -> return $ ((fileBulkPrefix temp) `T.append` " " `T.append` (T.pack (show index)) `T.append` " of " `T.append` (T.pack (show (length indFils)))) - True -> return $ fileBulkPrefix temp - medium <- return $ Medium - tempName - ('/' : path) - ('/' : thumbPath) - mime - (fileBulkTime temp) - (fileBulkOwner temp) - (fileBulkDesc temp) - (fileBulkTags temp) - iWidth - tWidth - albumId + tempName <- if + length indFils == 1 + then return $ fileBulkPrefix temp + else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils))) + let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth albumId mId <- runDB $ I.insert medium inALbum <- runDB $ getJust albumId - newMediaList <- return $ mId : (albumContent inALbum) + let newMediaList = mId : albumContent inALbum runDB $ update albumId [AlbumContent =. newMediaList] return Nothing - False -> do + else return $ Just $ fileName file ) indFils - onlyErrNames <- return $ removeItem Nothing errNames - case L.null onlyErrNames of - True -> do + let onlyErrNames = removeItem Nothing errNames + if + L.null onlyErrNames + then do setMessage "All images succesfully uploaded" - redirect $ HomeR - False -> do - justErrNames <- return $ map fromJust onlyErrNames - msg <- return $ Content $ Text $ "File type not supported of: " `T.append` (T.intercalate ", " justErrNames) + redirect HomeR + else do + let justErrNames = map fromJust onlyErrNames + let msg = Content $ Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames setMessage msg - redirect $ HomeR + redirect HomeR _ -> do setMessage "There was an error uploading the file" redirect $ DirectUploadR albumId - False -> do -- owner is not present + else do -- owner is not present setMessage "You must own this album to upload" redirect $ AlbumR albumId Nothing -> do @@ -126,18 +120,15 @@ postDirectUploadR albumId = do generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler (FP.FilePath, Int, Int) generateThumb path userId albumId = do - newName <- return $ (FP.takeBaseName path) ++ "_thumb.jpg" - newPath <- return $ "static" FP. "data" - FP. (T.unpack $ extractKey userId) - FP. (T.unpack $ extractKey albumId) - FP. newName + let newName = FP.takeBaseName path ++ "_thumb.jpg" + let newPath = "static" FP. "data" FP. T.unpack (extractKey userId) FP. T.unpack (extractKey albumId) FP. newName (iWidth, tWidth) <- liftIO $ withMagickWandGenesis $ do (_ , w) <- magickWand readImage w (decodeString path) w1 <- getImageWidth w h1 <- getImageHeight w - h2 <- return 230 - w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2) :: Double) + let h2 = 230 + let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double) setImageAlphaChannel w deactivateAlphaChannel setImageFormat w "jpeg" resizeImage w w2 h2 lanczosFilter 1 @@ -150,12 +141,9 @@ writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath writeOnDrive fil userId albumId = do --filen <- return $ fileName fil album <- runDB $ getJust albumId - filen <- return $ show $ (length $ albumContent album) + 1 - ext <- return $ FP.takeExtension $ T.unpack $ fileName fil - path <- return $ "static" FP. "data" - FP. (T.unpack $ extractKey userId) - FP. (T.unpack $ extractKey albumId) - FP. filen ++ ext + let filen = show $ length (albumContent album) + 1 + let ext = FP.takeExtension $ T.unpack $ fileName fil + let path = "static" FP. "data" FP. T.unpack (extractKey userId) FP. T.unpack (extractKey albumId) FP. filen ++ ext liftIO $ fileMove fil path return path @@ -184,21 +172,22 @@ getUploadR = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- return $ getUserIdFromText tempUserId + let userId = getUserIdFromText tempUserId user <- runDB $ getJust userId - albums <- return $ userAlbums user - case I.null albums of - False -> do + let albums = userAlbums user + if + I.null albums + then do (uploadWidget, enctype) <- generateFormPost (bulkUploadForm userId) formLayout $ do setTitle "Eidolon :: Upload Medium" $(widgetFile "bulkUpload") - True -> do + else do setMessage "Please create an album first" - redirect $ NewAlbumR + redirect NewAlbumR Nothing -> do setMessage "You need to be logged in" - redirect $ LoginR + redirect LoginR bulkUploadForm :: UserId -> Form FileBulk bulkUploadForm userId = renderDivs $ (\a b c d e f g -> FileBulk b c d e f g a) @@ -212,13 +201,11 @@ bulkUploadForm userId = renderDivs $ (\a b c d e f g -> FileBulk b c d e f g a) where albums = do allEnts <- runDB $ selectList [] [Desc AlbumTitle] - entities <- return $ - map fromJust $ - removeItem Nothing $ map - (\ent -> do - case (userId == (albumOwner $ entityVal ent)) || (userId `elem` (albumShares $ entityVal ent)) of - True -> Just ent - False -> Nothing + let entities = map fromJust $ removeItem Nothing $ map (\ent -> + if + userId == albumOwner (entityVal ent) || userId `elem` albumShares (entityVal ent) + then Just ent + else Nothing ) allEnts optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities @@ -227,58 +214,50 @@ postUploadR = do msu <- lookupSession "userId" case msu of Just tempUserId -> do - userId <- lift $ pure $ getUserIdFromText tempUserId + let userId = getUserIdFromText tempUserId ((result, _), _) <- runFormPost (bulkUploadForm userId) case result of FormSuccess temp -> do - fils <- return $ fileBulkFiles temp - indFils <- return $ zip [1..] fils + let fils = fileBulkFiles temp + let indFils = zip [1..] fils errNames <- mapM (\(index, file) -> do - mime <- return $ fileContentType file - case mime `elem` acceptedTypes of - True -> do - inAlbumId <- return $ fileBulkAlbum temp + let mime = fileContentType file + if + mime `elem` acceptedTypes + then do + let inAlbumId = fileBulkAlbum temp albRef <- runDB $ getJust inAlbumId - ownerId <- return $ albumOwner albRef + let ownerId = albumOwner albRef path <- writeOnDrive file ownerId inAlbumId (thumbPath, iWidth, tWidth) <- generateThumb path ownerId inAlbumId - tempName <- case length indFils == 1 of - False -> return $ ((fileBulkPrefix temp) `T.append` " " `T.append` (T.pack (show index)) `T.append` " of " `T.append` (T.pack (show (length indFils)))) - True -> return $ fileBulkPrefix temp - medium <- return $ Medium - tempName - ('/' : path) - ('/' : thumbPath) - mime - (fileBulkTime temp) - (fileBulkOwner temp) - (fileBulkDesc temp) - (fileBulkTags temp) - iWidth - tWidth - inAlbumId + tempName <- if + length indFils == 1 + then return $ fileBulkPrefix temp + else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils))) + let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth inAlbumId mId <- runDB $ I.insert medium inALbum <- runDB $ getJust inAlbumId - newMediaList <- return $ mId : (albumContent inALbum) + let newMediaList = mId : albumContent inALbum runDB $ update inAlbumId [AlbumContent =. newMediaList] return Nothing - False -> do + else return $ Just $ fileName file ) indFils - onlyErrNames <- return $ removeItem Nothing errNames - case L.null onlyErrNames of - True -> do + let onlyErrNames = removeItem Nothing errNames + if + L.null onlyErrNames + then do setMessage "All images succesfully uploaded" - redirect $ HomeR - False -> do - justErrNames <- return $ map fromJust onlyErrNames - msg <- return $ Content $ Text $ "File type not supported of: " `T.append` (T.intercalate ", " justErrNames) + redirect HomeR + else do + let justErrNames = map fromJust onlyErrNames + let msg = Content $ Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames setMessage msg - redirect $ HomeR + redirect HomeR _ -> do setMessage "There was an error uploading the file" - redirect $ UploadR + redirect UploadR Nothing -> do setMessage "You need to be logged in" - redirect $ LoginR + redirect LoginR