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