nek0/eidolon
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

linted

Browse source
This commit is contained in:
nek0 2015-09-14 18:54:46 +02:00
parent 325045cfec
commit 68f39fbeb4
24 changed files with 400 additions and 415 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Application.hs
View file

@ -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!

28
Foundation.hs
View file

@ -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

44
Handler/Activate.hs
View file

@ -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) =>

4
Handler/Admin.hs
View file

@ -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

42
Handler/AdminAlbumSettings.hs
View file

@ -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

12
Handler/AdminComments.hs
View file

@ -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

26
Handler/AdminMediumSettings.hs
View file

@ -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

44
Handler/AdminProfileSettings.hs
View file

@ -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

14
Handler/Album.hs
View file

@ -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

98
Handler/AlbumSettings.hs
View file

@ -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|
<h1>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

33
Handler/Commons.hs
View file

@ -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)

8
Handler/Home.hs
View file

@ -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")

31
Handler/Login.hs
View file

@ -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

88
Handler/Medium.hs
View file

@ -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

20
Handler/MediumSettings.hs
View file

@ -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

16
Handler/NewAlbum.hs
View file

@ -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

23
Handler/Profile.hs
View file

@ -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

21
Handler/ProfileDelete.hs
View file

@ -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
when (albumOwner album == userId) $ do
let mediaList = albumContent album
_ <- mapM (\med -> do
commEnts <- runDB $ selectList [CommentOrigin ==. med] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
_ <- 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
False -> return ()
) 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

10
Handler/ProfileSettings.hs
View file

@ -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

7
Handler/Reactivate.hs
View file

@ -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

2
Handler/RootFeed.hs
View file

@ -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

22
Handler/Signup.hs
View file

@ -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
<a href="#{activateLink}">#{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 =

10
Handler/Tag.hs
View file

@ -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")

193
Handler/Upload.hs
View file

@ -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