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 Database.Persist.Sql (runMigration)
import Network.HTTP.Client.Conduit (newManager) import Network.HTTP.Client.Conduit (newManager)
import Control.Monad import Control.Monad
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize) import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, toLogStr)
import Data.Default (def) import Data.Default (def)
import Yesod.Core.Types (loggerSet) import Yesod.Core.Types (loggerSet)
@ -44,7 +44,6 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..), IPAddrSource (..),
OutputFormat (..), destination, OutputFormat (..), destination,
mkRequestLogger, outputFormat) mkRequestLogger, outputFormat)
import System.Log.FastLogger (toLogStr)
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- 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 -- costom imports
import Data.Text as T import Data.Text as T
import Data.Text.Encoding import Data.Text.Encoding
import Control.Applicative ((<$>))
import Network.Wai import Network.Wai
import Helper import Helper
@ -71,19 +72,19 @@ renderLayout widget = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
username <- case msu of username <- case msu of
Just a -> do Just a -> do
uId <- return $ getUserIdFromText a let uId = getUserIdFromText a
user <- runDB $ getJust uId user <- runDB $ getJust uId
return $ userName user return $ userName user
Nothing -> do Nothing ->
return ("" :: T.Text) return ("" :: T.Text)
slug <- case msu of slug <- case msu of
Just a -> do Just a -> do
uId <- return $ getUserIdFromText a let uId = getUserIdFromText a
user <- runDB $ getJust uId user <- runDB $ getJust uId
return $ userSlug user return $ userSlug user
Nothing -> do Nothing ->
return ("" :: T.Text) return ("" :: T.Text)
block <- return $ appSignupBlocked $ appSettings master let block = appSignupBlocked $ appSettings master
-- We break up the default layout into two components: -- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and -- 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 -- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout. -- you to use normal widget features in default-layout.
copyrightWidget <- widgetToPageContent $ do copyrightWidget <- widgetToPageContent $
$(widgetFile "copyrightFooter") $(widgetFile "copyrightFooter")
wc <- widgetToPageContent widget wc <- widgetToPageContent widget
@ -114,7 +115,7 @@ renderLayout widget = do
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
formLayout :: Widget -> Handler Html formLayout :: Widget -> Handler Html
formLayout widget = do formLayout widget =
renderLayout $(widgetFile "form-widget") renderLayout $(widgetFile "form-widget")
approotRequest :: App -> Request -> T.Text approotRequest :: App -> Request -> T.Text
@ -124,9 +125,12 @@ approotRequest master req =
Nothing -> appRoot $ appSettings master Nothing -> appRoot $ appSettings master
where where
prefix = prefix =
case "https://" `T.isPrefixOf` (appRoot $ appSettings master) of if
True -> "https://" "https://" `isPrefixOf` appRoot (appSettings master)
False -> "http://" then
"https://"
else
"http://"
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- 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, -- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes -- default session idle timeout is 120 minutes
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend makeSessionBackend _ = Just <$> defaultClientSessionBackend
120 -- timeout in minutes 120 -- timeout in minutes
"config/client_session_key.aes" "config/client_session_key.aes"
defaultLayout widget = do defaultLayout widget =
renderLayout $(widgetFile "default-widget") renderLayout $(widgetFile "default-widget")
-- This is done to provide an optimization for serving static files from -- 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] [] t <- runDB $ selectFirst [ActivatorToken ==. token] []
case t of case t of
Nothing -> do Nothing -> do
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
case mToken of case mToken of
Just (Entity _ uToken) -> do Just (Entity _ uToken) -> do
user <- runDB $ getJust (fromJust $ tokenUser uToken) user <- runDB $ getJust (fromJust $ tokenUser uToken)
hexSalt <- return $ toHex $ userSalt user let hexSalt = toHex $ userSalt user
formLayout $ do formLayout $ do
setTitle "Activate your account" setTitle "Activate your account"
$(widgetFile "activate") $(widgetFile "activate")
_ -> do _ -> do
setMessage "Invalid token!" setMessage "Invalid token!"
redirect $ HomeR redirect HomeR
Just (Entity _ activator) -> do Just (Entity _ activator) -> do
uSalt <- return $ userSalt $ activatorUser activator let uSalt = userSalt $ activatorUser activator
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
case mToken of case mToken of
Just (Entity _ _) -> do Just (Entity _ _) -> do
hexSalt <- return $ toHex uSalt let hexSalt = toHex uSalt
formLayout $ do formLayout $
$(widgetFile "activate") $(widgetFile "activate")
_ -> do _ -> do
setMessage "Invalid token!" setMessage "Invalid token!"
redirect $ HomeR redirect HomeR
postActivateR :: Text -> Handler RepJson postActivateR :: Text -> Handler RepJson
postActivateR token = do postActivateR token = do
msalted <- fromJust <$> lookupPostParam "salted" msalted <- fromJust <$> lookupPostParam "salted"
salted <- return $ fromHex' $ unpack msalted let salted = fromHex' $ unpack msalted
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
case mToken of case mToken of
Just (Entity uTokenId uToken) -> do Just (Entity uTokenId uToken) ->
case tokenUser uToken == Nothing of if
True -> do isNothing (tokenUser uToken)
then do
newUser <- runDB $ selectFirst [ActivatorToken ==. token] [] newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
case newUser of case newUser of
Just (Entity aId activ) -> do Just (Entity aId activ) -> do
namesakes <- runDB $ selectList [UserName ==. (userName $ activatorUser activ)] [] namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
case namesakes == [] of if
True -> do I.null namesakes
then do
-- putting user in active state -- putting user in active state
uId <- runDB $ insert $ activatorUser activ uId <- runDB $ insert $ activatorUser activ
runDB $ update uId [UserSalted =. salted] runDB $ update uId [UserSalted =. salted]
-- create user directory -- create user directory
liftIO $ createDirectoryIfMissing True $ liftIO $ createDirectoryIfMissing True $
"static" </> "data" </> (unpack $ extractKey uId) "static" </> "data" </> unpack (extractKey uId)
-- cleanup -- cleanup
runDB $ delete aId runDB $ delete aId
runDB $ delete uTokenId runDB $ delete uTokenId
@ -78,21 +80,21 @@ postActivateR token = do
setSession "userId" (extractKey uId) setSession "userId" (extractKey uId)
welcomeLink <- ($ ProfileR uId) <$> getUrlRender welcomeLink <- ($ ProfileR uId) <$> getUrlRender
returnJson ["welcome" .= welcomeLink] returnJson ["welcome" .= welcomeLink]
False -> do else do
-- cleanup -- cleanup
runDB $ delete aId runDB $ delete aId
runDB $ delete uTokenId runDB $ delete uTokenId
returnJsonError "Somebody already activated your username. Your token has been deleted" returnJsonError "Somebody already activated your username. Your token has been deleted"
Nothing -> do Nothing ->
returnJsonError "Invalid token" returnJsonError "Invalid token"
False -> do else do
runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
-- cleanup -- cleanup
runDB $ delete uTokenId runDB $ delete uTokenId
setSession "userId" (extractKey $ fromJust $ tokenUser uToken) setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender
returnJson ["welcome" .= welcomeLink] returnJson ["welcome" .= welcomeLink]
_ -> do _ ->
returnJsonError "Invalid activation token!" returnJsonError "Invalid activation token!"
returnJson :: (Monad m, ToJSON a, a ~ Value) => returnJson :: (Monad m, ToJSON a, a ~ Value) =>

4
Handler/Admin.hs
View file

@ -23,10 +23,10 @@ getAdminR :: Handler Html
getAdminR = do getAdminR = do
adminCheck <- loginIsAdmin adminCheck <- loginIsAdmin
case adminCheck of case adminCheck of
Right _ -> do Right _ ->
defaultLayout $ do defaultLayout $ do
setTitle "Administration: Menu" setTitle "Administration: Menu"
$(widgetFile "adminBase") $(widgetFile "adminBase")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route

42
Handler/AdminAlbumSettings.hs
View file

@ -35,7 +35,7 @@ getAdminAlbumsR = do
$(widgetFile "adminAlbums") $(widgetFile "adminAlbums")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
getAdminAlbumMediaR :: AlbumId -> Handler Html getAdminAlbumMediaR :: AlbumId -> Handler Html
getAdminAlbumMediaR albumId = do getAdminAlbumMediaR albumId = do
@ -51,10 +51,10 @@ getAdminAlbumMediaR albumId = do
$(widgetFile "adminAlbumMedia") $(widgetFile "adminAlbumMedia")
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
getAdminAlbumSettingsR :: AlbumId -> Handler Html getAdminAlbumSettingsR :: AlbumId -> Handler Html
getAdminAlbumSettingsR albumId = do getAdminAlbumSettingsR albumId = do
@ -64,18 +64,18 @@ getAdminAlbumSettingsR albumId = do
tempAlbum <- runDB $ get albumId tempAlbum <- runDB $ get albumId
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] 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
(adminAlbumSettingsWidget, enctype) <- generateFormPost $ adminAlbumSettingsForm album albumId users (adminAlbumSettingsWidget, enctype) <- generateFormPost $ adminAlbumSettingsForm album albumId users
formLayout $ do formLayout $ do
setTitle "Administration: Album settings" setTitle "Administration: Album settings"
$(widgetFile "adminAlbumSet") $(widgetFile "adminAlbumSet")
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
postAdminAlbumSettingsR :: AlbumId -> Handler Html postAdminAlbumSettingsR :: AlbumId -> Handler Html
postAdminAlbumSettingsR albumId = do postAdminAlbumSettingsR albumId = do
@ -85,12 +85,12 @@ postAdminAlbumSettingsR albumId = do
tempAlbum <- runDB $ get albumId tempAlbum <- runDB $ get albumId
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] 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
((res, _), _) <- runFormPost $ adminAlbumSettingsForm album albumId users ((res, _), _) <- runFormPost $ adminAlbumSettingsForm album albumId users
case res of case res of
FormSuccess temp -> do FormSuccess temp -> do
width <- getThumbWidth $ Just $ L.tail $ fromMaybe ['a'] $ albumSamplePic temp width <- getThumbWidth $ Just $ L.tail $ fromMaybe "a" $ albumSamplePic temp
_ <- runDB $ update albumId _ <- runDB $ update albumId
[ AlbumTitle =. albumTitle temp [ AlbumTitle =. albumTitle temp
, AlbumShares =. albumShares temp , AlbumShares =. albumShares temp
@ -98,16 +98,16 @@ postAdminAlbumSettingsR albumId = do
, AlbumSampleWidth =. width , AlbumSampleWidth =. width
] ]
setMessage "Album settings changed successfully" setMessage "Album settings changed successfully"
redirect $ AdminR redirect AdminR
_ -> do _ -> do
setMessage "There was an error while changing the settings" setMessage "There was an error while changing the settings"
redirect $ AdminAlbumSettingsR albumId redirect $ AdminAlbumSettingsR albumId
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
adminAlbumSettingsForm :: Album -> AlbumId -> [(Text, UserId)] -> Form Album adminAlbumSettingsForm :: Album -> AlbumId -> [(Text, UserId)] -> Form Album
adminAlbumSettingsForm album albumId users = renderDivs $ Album adminAlbumSettingsForm album albumId users = renderDivs $ Album
@ -131,10 +131,10 @@ getAdminAlbumDeleteR albumId = do
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
-- remove reference from owner -- remove reference from owner
ownerId <- return $ albumOwner album let ownerId = albumOwner album
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
albumList <- return $ userAlbums owner let albumList = userAlbums owner
newAlbumList <- return $ removeItem albumId albumList let newAlbumList = removeItem albumId albumList
runDB $ update ownerId [UserAlbums =. newAlbumList] runDB $ update ownerId [UserAlbums =. newAlbumList]
-- delete album content and its comments -- delete album content and its comments
_ <- mapM (\a -> do _ <- mapM (\a -> do
@ -144,20 +144,20 @@ getAdminAlbumDeleteR albumId = do
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. a] [] commEnts <- runDB $ selectList [CommentOrigin ==. a] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (runDB . delete . entityKey) commEnts
-- delete album database entry -- delete album database entry
runDB $ delete a runDB $ delete a
) (albumContent album) ) (albumContent album)
-- delete album -- delete album
runDB $ delete albumId runDB $ delete albumId
-- delete files -- 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 -- outro
setMessage "Album deleted successfully" setMessage "Album deleted successfully"
redirect $ AdminR redirect AdminR
Nothing -> do Nothing -> do
setMessage "This album dies not exist" setMessage "This album dies not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route

12
Handler/AdminComments.hs
View file

@ -35,7 +35,7 @@ getAdminCommentR = do
$(widgetFile "adminComments") $(widgetFile "adminComments")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
getAdminCommentDeleteR :: CommentId -> Handler Html getAdminCommentDeleteR :: CommentId -> Handler Html
getAdminCommentDeleteR commentId = do getAdminCommentDeleteR commentId = do
@ -46,15 +46,15 @@ getAdminCommentDeleteR commentId = do
case tempComment of case tempComment of
Just _ -> do Just _ -> do
-- delete comment children -- delete comment children
children <- runDB $ selectList [CommentParent ==. (Just commentId)] [] children <- runDB $ selectList [CommentParent ==. Just commentId] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) children _ <- mapM (runDB . delete . entityKey) children
-- delete comment itself -- delete comment itself
runDB $ delete commentId runDB $ delete commentId
setMessage "Comment deleted succesfully" setMessage "Comment deleted succesfully"
redirect $ AdminR redirect AdminR
Nothing -> do Nothing -> do
setMessage "This comment does not exist" setMessage "This comment does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route

26
Handler/AdminMediumSettings.hs
View file

@ -34,7 +34,7 @@ getAdminMediaR = do
$(widgetFile "adminMedia") $(widgetFile "adminMedia")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
getAdminMediumSettingsR :: MediumId -> Handler Html getAdminMediumSettingsR :: MediumId -> Handler Html
getAdminMediumSettingsR mediumId = do getAdminMediumSettingsR mediumId = do
@ -50,10 +50,10 @@ getAdminMediumSettingsR mediumId = do
$(widgetFile "adminMediumSet") $(widgetFile "adminMediumSet")
Nothing -> do Nothing -> do
setMessage "This medium does not exist" setMessage "This medium does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
postAdminMediumSettingsR :: MediumId -> Handler Html postAdminMediumSettingsR :: MediumId -> Handler Html
postAdminMediumSettingsR mediumId = do postAdminMediumSettingsR mediumId = do
@ -72,16 +72,16 @@ postAdminMediumSettingsR mediumId = do
, MediumTags =. mediumTags temp , MediumTags =. mediumTags temp
] ]
setMessage "Medium settings changed successfully" setMessage "Medium settings changed successfully"
redirect $ AdminR redirect AdminR
_ -> do _ -> do
setMessage "There was an error while changing the settings" setMessage "There was an error while changing the settings"
redirect $ AdminMediumSettingsR mediumId redirect $ AdminMediumSettingsR mediumId
Nothing -> do Nothing -> do
setMessage "This medium does not exist" setMessage "This medium does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
adminMediumSetForm :: Medium -> Form Medium adminMediumSetForm :: Medium -> Form Medium
adminMediumSetForm medium = renderDivs $ Medium adminMediumSetForm medium = renderDivs $ Medium
@ -106,14 +106,14 @@ getAdminMediumDeleteR mediumId = do
case tempMedium of case tempMedium of
Just medium -> do Just medium -> do
-- remove reference from album -- remove reference from album
albumId <- return $ mediumAlbum medium let albumId = mediumAlbum medium
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
mediaList <- return $ albumContent album let mediaList = albumContent album
newMediaList <- return $ removeItem mediumId mediaList let newMediaList = removeItem mediumId mediaList
runDB $ update albumId [AlbumContent =. newMediaList] runDB $ update albumId [AlbumContent =. newMediaList]
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] [] commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (runDB . delete . entityKey) commEnts
-- delete medium -- delete medium
runDB $ delete mediumId runDB $ delete mediumId
-- delete files -- delete files
@ -121,10 +121,10 @@ getAdminMediumDeleteR mediumId = do
liftIO $ removeFile (normalise $ tail $ mediumThumb medium) liftIO $ removeFile (normalise $ tail $ mediumThumb medium)
-- outro -- outro
setMessage "Medium deleted successfully" setMessage "Medium deleted successfully"
redirect $ AdminR redirect AdminR
Nothing -> do Nothing -> do
setMessage "This medium does not exist" setMessage "This medium does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route

44
Handler/AdminProfileSettings.hs
View file

@ -35,7 +35,7 @@ getAdminProfilesR = do
$(widgetFile "adminProfiles") $(widgetFile "adminProfiles")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
getAdminUserAlbumsR :: UserId -> Handler Html getAdminUserAlbumsR :: UserId -> Handler Html
getAdminUserAlbumsR ownerId = do getAdminUserAlbumsR ownerId = do
@ -51,10 +51,10 @@ getAdminUserAlbumsR ownerId = do
$(widgetFile "adminUserAlbums") $(widgetFile "adminUserAlbums")
Nothing -> do Nothing -> do
setMessage "This user does not exist" setMessage "This user does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
getAdminUserMediaR :: UserId -> Handler Html getAdminUserMediaR :: UserId -> Handler Html
getAdminUserMediaR ownerId = do getAdminUserMediaR ownerId = do
@ -70,10 +70,10 @@ getAdminUserMediaR ownerId = do
$(widgetFile "adminUserMedia") $(widgetFile "adminUserMedia")
Nothing -> do Nothing -> do
setMessage "This user does not exist" setMessage "This user does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
getAdminProfileSettingsR :: UserId -> Handler Html getAdminProfileSettingsR :: UserId -> Handler Html
getAdminProfileSettingsR ownerId = do getAdminProfileSettingsR ownerId = do
@ -84,17 +84,17 @@ getAdminProfileSettingsR ownerId = do
case tempOwner of case tempOwner of
Just owner -> do Just owner -> do
tempUserId <- lookupSession "userId" tempUserId <- lookupSession "userId"
userId <- return $ getUserIdFromText $ fromJust tempUserId let userId = getUserIdFromText $ fromJust tempUserId
(adminProfileSetWidget, enctype) <- generateFormPost $ adminProfileForm owner (adminProfileSetWidget, enctype) <- generateFormPost $ adminProfileForm owner
formLayout $ do formLayout $ do
setTitle "Administration: Profile settings" setTitle "Administration: Profile settings"
$(widgetFile "adminProfileSettings") $(widgetFile "adminProfileSettings")
Nothing -> do Nothing -> do
setMessage "This user does not exist" setMessage "This user does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
postAdminProfileSettingsR :: UserId -> Handler Html postAdminProfileSettingsR :: UserId -> Handler Html
postAdminProfileSettingsR ownerId = do postAdminProfileSettingsR ownerId = do
@ -108,22 +108,22 @@ postAdminProfileSettingsR ownerId = do
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
runDB $ update ownerId runDB $ update ownerId
[ UserName =. (userName temp) [ UserName =. userName temp
, UserSlug =. (userSlug temp) , UserSlug =. userSlug temp
, UserEmail =. (userEmail temp) , UserEmail =. userEmail temp
, UserAdmin =. (userAdmin temp) , UserAdmin =. userAdmin temp
] ]
setMessage "User data updated successfully" setMessage "User data updated successfully"
redirect $ AdminR redirect AdminR
_ -> do _ -> do
setMessage "There was an error" setMessage "There was an error"
redirect $ AdminProfileSettingsR ownerId redirect $ AdminProfileSettingsR ownerId
Nothing -> do Nothing -> do
setMessage "This user does not exist" setMessage "This user does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
adminProfileForm :: User -> Form User adminProfileForm :: User -> Form User
@ -144,14 +144,14 @@ getAdminProfileDeleteR ownerId = do
tempOwner <- runDB $ get ownerId tempOwner <- runDB $ get ownerId
case tempOwner of case tempOwner of
Just owner -> do Just owner -> do
albumList <- return $ userAlbums owner let albumList = userAlbums owner
_ <- mapM (\albumId -> do _ <- mapM (\albumId -> do
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
mediaList <- return $ albumContent album let mediaList = albumContent album
_ <- mapM (\med -> do _ <- mapM (\med -> do
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. med] [] commEnts <- runDB $ selectList [CommentOrigin ==. med] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (runDB . delete . entityKey) commEnts
-- delete media files -- delete media files
medium <- runDB $ getJust med medium <- runDB $ getJust med
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
@ -162,12 +162,12 @@ getAdminProfileDeleteR ownerId = do
runDB $ delete albumId runDB $ delete albumId
) albumList ) albumList
runDB $ delete ownerId runDB $ delete ownerId
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> (T.unpack $ extractKey ownerId) liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey ownerId)
setMessage "User successfully deleted" setMessage "User successfully deleted"
redirect $ AdminR redirect AdminR
Nothing -> do Nothing -> do
setMessage "This user does not exist" setMessage "This user does not exist"
redirect $ AdminR redirect AdminR
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route

14
Handler/Album.hs
View file

@ -25,22 +25,22 @@ getAlbumR albumId = do
tempAlbum <- runDB $ get albumId tempAlbum <- runDB $ get albumId
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
ownerId <- return $ albumOwner album let ownerId = albumOwner album
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner let ownerName = userName owner
ownerSlug <- return $ userSlug owner let ownerSlug = userSlug owner
msu <- lookupSession "userId" msu <- lookupSession "userId"
presence <- case msu of presence <- case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
return $ (userId == ownerId) || (userId `elem` (albumShares album)) return $ (userId == ownerId) || (userId `elem` albumShares album)
Nothing -> Nothing ->
return False return False
-- media <- mapM (\a -> runDB $ getJust a) (albumContent album) -- media <- mapM (\a -> runDB $ getJust a) (albumContent album)
media <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime] media <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime]
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Album " `T.append` (albumTitle album)) setTitle $ toHtml ("Eidolon :: Album " `T.append` albumTitle album)
$(widgetFile "album") $(widgetFile "album")
Nothing -> do Nothing -> do
setMessage "This album does not exist" 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 tempAlbum <- runDB $ get albumId
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
ownerId <- return $ albumOwner album let ownerId = albumOwner album
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
ownerPresence <- return (userId == ownerId) let ownerPresence = userId == ownerId
presence <- return $ userId `elem` (albumShares album) let presence = userId `elem` (albumShares album)
case ownerPresence || presence of case ownerPresence || presence of
True -> do True -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] 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 (albumSettingsWidget, enctype) <- generateFormPost $ albumSettingsForm album albumId users
formLayout $ do formLayout $ do
setTitle "Eidolon :: Album Settings" setTitle "Eidolon :: Album Settings"
@ -48,46 +48,48 @@ getAlbumSettingsR albumId = do
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to change settings" setMessage "You must be logged in to change settings"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect $ HomeR redirect HomeR
postAlbumSettingsR :: AlbumId -> Handler Html postAlbumSettingsR :: AlbumId -> Handler Html
postAlbumSettingsR albumId = do postAlbumSettingsR albumId = do
tempAlbum <- runDB $ get albumId tempAlbum <- runDB $ get albumId
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
ownerId <- return $ albumOwner album let ownerId = albumOwner album
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner let ownerName = userName owner
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
ownerPresence <- return (userId == ownerId) let ownerPresence = userId == ownerId
presence <- return $ userId `elem` (albumShares album) let presence = userId `elem` albumShares album
case ownerPresence || presence of if
True -> do ownerPresence || presence
then do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] 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 ((result, _), _) <- runFormPost $ albumSettingsForm album albumId users
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
newShares <- return (L.sort $ albumShares temp) let newShares = L.sort $ albumShares temp
oldShares <- return (L.sort $ albumShares album) let oldShares = L.sort $ albumShares album
_ <- case newShares /= oldShares of _ <- if
True -> do newShares /= oldShares
then do
link <- ($ AlbumR albumId) <$> getUrlRender link <- ($ AlbumR albumId) <$> getUrlRender
rcptIds <- return $ L.nub $ newShares L.\\ oldShares let rcptIds = L.nub $ newShares L.\\ oldShares
mapM (\uId -> do mapM (\uId -> do
-- update userAlbums -- update userAlbums
user <- runDB $ getJust uId user <- runDB $ getJust uId
oldAlbs <- return $ userAlbums user let oldAlbs = userAlbums user
newAlbs <- return $ albumId : oldAlbs let newAlbs = albumId : oldAlbs
_ <- runDB $ update uId [UserAlbums =. newAlbs] _ <- runDB $ update uId [UserAlbums =. newAlbs]
-- send notification -- send notification
addr <- return $ userEmail user let addr = userEmail user
sendMail addr "A new album was shared with you" $ sendMail addr "A new album was shared with you" $
[shamlet| [shamlet|
<h1>Hello #{userSlug user}! <h1>Hello #{userSlug user}!
@ -98,7 +100,7 @@ postAlbumSettingsR albumId = do
. .
|] |]
) rcptIds ) rcptIds
False -> do else do
return [()] return [()]
-- nothing to do here -- nothing to do here
width <- getThumbWidth $ Just $ L.tail $ fromMaybe ['a'] $ albumSamplePic temp width <- getThumbWidth $ Just $ L.tail $ fromMaybe ['a'] $ albumSamplePic temp
@ -113,15 +115,15 @@ postAlbumSettingsR albumId = do
_ -> do _ -> do
setMessage "There was an error while changing the settings" setMessage "There was an error while changing the settings"
redirect $ AlbumSettingsR albumId redirect $ AlbumSettingsR albumId
False -> do else do
setMessage "You must own this album to change its settings" setMessage "You must own this album to change its settings"
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to change settings" setMessage "You must be logged in to change settings"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect $ HomeR redirect HomeR
albumSettingsForm :: Album -> AlbumId -> [(Text, UserId)]-> Form Album albumSettingsForm :: Album -> AlbumId -> [(Text, UserId)]-> Form Album
albumSettingsForm album albumId users = renderDivs $ Album albumSettingsForm album albumId users = renderDivs $ Album
@ -144,47 +146,47 @@ getAlbumDeleteR albumId = do
tempAlbum <- runDB $ get albumId tempAlbum <- runDB $ get albumId
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
ownerId <- return $ albumOwner album let ownerId = albumOwner album
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
presence <- return (userId == ownerId) if
case presence of userId == ownerId
True -> do then do
formLayout $ do formLayout $ do
setTitle $ toHtml ("Eidolon :: Delete album" `T.append` (albumTitle album)) setTitle $ toHtml ("Eidolon :: Delete album" `T.append` (albumTitle album))
$(widgetFile "albumDelete") $(widgetFile "albumDelete")
False -> do else do
setMessage "You must own this album to delete it" setMessage "You must own this album to delete it"
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete albums" setMessage "You must be logged in to delete albums"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect $ HomeR redirect HomeR
postAlbumDeleteR :: AlbumId -> Handler Html postAlbumDeleteR :: AlbumId -> Handler Html
postAlbumDeleteR albumId = do postAlbumDeleteR albumId = do
tempAlbum <- runDB $ get albumId tempAlbum <- runDB $ get albumId
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
ownerId <- return $ albumOwner album let ownerId = albumOwner album
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
presence <- return (userId == ownerId) if
case presence of userId == ownerId
True -> do then do
confirm <- lookupPostParam "confirm" confirm <- lookupPostParam "confirm"
case confirm of case confirm of
Just "confirm" -> do Just "confirm" -> do
-- remove album reference from user -- remove album reference from user
albumList <- return $ userAlbums owner let albumList = userAlbums owner
newAlbumList <- return $ removeItem albumId albumList let newAlbumList = removeItem albumId albumList
runDB $ update ownerId [UserAlbums =. newAlbumList] runDB $ update ownerId [UserAlbums =. newAlbumList]
-- delete album content and its comments -- delete album content and its comments
_ <- mapM (\a -> do _ <- mapM (\a -> do
@ -194,25 +196,25 @@ postAlbumDeleteR albumId = do
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. a] [] commEnts <- runDB $ selectList [CommentOrigin ==. a] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (runDB . delete . entityKey) commEnts
runDB $ delete a runDB $ delete a
) (albumContent album) ) (albumContent album)
-- delete album -- delete album
runDB $ delete albumId runDB $ delete albumId
-- delete files -- 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 -- outro
setMessage "Album deleted succesfully" setMessage "Album deleted succesfully"
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessage "You must confirm the deletion" setMessage "You must confirm the deletion"
redirect $ AlbumSettingsR albumId redirect $ AlbumSettingsR albumId
_ -> do else do
setMessage "You must own this album to delete it" setMessage "You must own this album to delete it"
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete albums" setMessage "You must be logged in to delete albums"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" 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" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
user <- runDB $ getJust userId user <- runDB $ getJust userId
case userAdmin user of if
True -> userAdmin user
then
return $ Right () return $ Right ()
False -> else
return $ Left ("You have no admin rights", HomeR) return $ Left ("You have no admin rights", HomeR)
Nothing -> Nothing ->
return $ Left ("You are not logged in", LoginR) return $ Left ("You are not logged in", LoginR)
@ -42,11 +43,12 @@ profileCheck userId = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempLoginId -> do Just tempLoginId -> do
loginId <- return $ getUserIdFromText tempLoginId let loginId = getUserIdFromText tempLoginId
case loginId == userId of if
True -> loginId == userId
then
return $ Right user return $ Right user
False -> else
return $ Left ("You can only change your own profile settings", UserR $ userName user) return $ Left ("You can only change your own profile settings", UserR $ userName user)
Nothing -> Nothing ->
return $ Left ("You nedd to be logged in to change settings", LoginR) return $ Left ("You nedd to be logged in to change settings", LoginR)
@ -58,18 +60,19 @@ mediumCheck mediumId = do
tempMedium <- runDB $ get mediumId tempMedium <- runDB $ get mediumId
case tempMedium of case tempMedium of
Just medium -> do Just medium -> do
ownerId <- return $ mediumOwner medium let ownerId = mediumOwner medium
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
album <- runDB $ getJust $ mediumAlbum medium album <- runDB $ getJust $ mediumAlbum medium
presence <- return (userId == ownerId) let presence = userId == ownerId
albumOwnerPresence <- return (userId == (albumOwner album)) let albumOwnerPresence = userId == albumOwner album
case presence || albumOwnerPresence of if
True -> presence || albumOwnerPresence
then
return $ Right medium return $ Right medium
False -> else
return $ Left ("You must own this medium to change its settings", MediumR mediumId) return $ Left ("You must own this medium to change its settings", MediumR mediumId)
Nothing -> Nothing ->
return $ Left ("You must be logged in to change settings", LoginR) 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 getHomeR = do
recentMedia <- runDB $ selectList [] [Desc MediumTime, LimitTo 30] recentMedia <- runDB $ selectList [] [Desc MediumTime, LimitTo 30]
nextMediaQuery <- runDB $ selectList [] [Desc MediumTime, LimitTo 1, OffsetBy 30] nextMediaQuery <- runDB $ selectList [] [Desc MediumTime, LimitTo 1, OffsetBy 30]
nextMedia <- return $ not $ L.null nextMediaQuery let nextMedia = not $ L.null nextMediaQuery
widgetLayout <- return $ widgetFile "default-widget"
defaultLayout $ do defaultLayout $ do
setTitle "Eidolon :: Home" setTitle "Eidolon :: Home"
$(widgetFile "home") $(widgetFile "home")
@ -36,8 +35,7 @@ getPageR :: Int -> Handler Html
getPageR page = do getPageR page = do
pageMedia <- runDB $ selectList [] [Desc MediumTime, LimitTo 30, OffsetBy (page*30)] pageMedia <- runDB $ selectList [] [Desc MediumTime, LimitTo 30, OffsetBy (page*30)]
nextMediaQuery <- runDB $ selectList [] [Desc MediumTime, LimitTo 1, OffsetBy ((page + 1) * 30)] nextMediaQuery <- runDB $ selectList [] [Desc MediumTime, LimitTo 1, OffsetBy ((page + 1) * 30)]
nextMedia <- return $ not $ L.null nextMediaQuery let nextMedia = not $ L.null nextMediaQuery
widgetLayout <- return $ widgetFile "default-widget"
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Page " `T.append` (T.pack $ show page)) setTitle $ toHtml ("Eidolon :: Page " `T.append` T.pack (show page))
$(widgetFile "page") $(widgetFile "page")

31
Handler/Login.hs
View file

@ -33,8 +33,7 @@ data Credentials = Credentials
deriving Show deriving Show
getLoginR :: Handler Html getLoginR :: Handler Html
getLoginR = do getLoginR =
-- (loginWidget, enctype) <- generateFormPost loginForm
formLayout $ do formLayout $ do
setTitle "Eidolon :: Login" setTitle "Eidolon :: Login"
$(widgetFile "login") $(widgetFile "login")
@ -45,36 +44,35 @@ postLoginR = do
mUserName <- lookupPostParam "username" mUserName <- lookupPostParam "username"
mHexToken <- lookupPostParam "token" mHexToken <- lookupPostParam "token"
mHexResponse <- lookupPostParam "response" mHexResponse <- lookupPostParam "response"
case (mUserName, mHexToken, mHexResponse) of case (mUserName, mHexToken, mHexResponse) of
(Just userName, Nothing, Nothing) -> do (Just userName, Nothing, Nothing) -> do
tempUser <- runDB $ selectFirst [UserName ==. userName] [] tempUser <- runDB $ selectFirst [UserName ==. userName] []
case tempUser of case tempUser of
Just (Entity userId user) -> do Just (Entity userId user) -> do
salt <- return $ userSalt user let salt = userSalt user
token <- liftIO makeRandomToken token <- liftIO makeRandomToken
_ <- runDB $ insert $ Token (encodeUtf8 token) "login" (Just userId) runDB $ insert_ $ Token (encodeUtf8 token) "login" (Just userId)
returnJson ["salt" .= (toHex salt), "token" .= (toHex $ encodeUtf8 token)] returnJson ["salt" .= toHex salt, "token" .= toHex (encodeUtf8 token)]
Nothing -> Nothing ->
returnJsonError ("No such user" :: T.Text) returnJsonError ("No such user" :: T.Text)
(Nothing, Just hexToken, Just hexResponse) -> do (Nothing, Just hexToken, Just hexResponse) -> do
response <- do response <- do
tempToken <- return $ fromHex' $ T.unpack hexToken let tempToken = fromHex' $ T.unpack hexToken
savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] [] savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] []
case savedToken of case savedToken of
Just (Entity tokenId token) -> do Just (Entity tokenId token) -> do
savedUserId <- return $ tokenUser token let savedUserId = tokenUser token
queriedUser <- runDB $ getJust (fromJust savedUserId) queriedUser <- runDB $ getJust (fromJust savedUserId)
salted <- return $ userSalted queriedUser let salted = userSalted queriedUser
hexSalted <- return $ toHex salted let hexSalted = toHex salted
expected <- return $ hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted) let expected = hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted)
case (fromHex' $ T.unpack hexResponse) == expected of if
True -> do fromHex' (T.unpack hexResponse) == expected
then do
-- Success!! -- Success!!
runDB $ delete tokenId runDB $ delete tokenId
return $ Right savedUserId return $ Right savedUserId
_ -> else
return $ Left ("Wrong password" :: T.Text) return $ Left ("Wrong password" :: T.Text)
Nothing -> Nothing ->
return $ Left "Invalid token" return $ Left "Invalid token"
@ -86,7 +84,6 @@ postLoginR = do
setMessage "Succesfully logged in" setMessage "Succesfully logged in"
welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender
returnJson ["welcome" .= welcomeLink] returnJson ["welcome" .= welcomeLink]
_ -> _ ->
returnJsonError ("Protocol error" :: T.Text) returnJsonError ("Protocol error" :: T.Text)
@ -100,7 +97,7 @@ getLogoutR :: Handler Html
getLogoutR = do getLogoutR = do
deleteSession "userId" deleteSession "userId"
setMessage "Succesfully logged out" setMessage "Succesfully logged out"
redirect $ HomeR redirect HomeR
returnJson :: Monad m => [Pair] -> m RepJson returnJson :: Monad m => [Pair] -> m RepJson
returnJson = return . repJson . object returnJson = return . repJson . object

88
Handler/Medium.hs
View file

@ -29,14 +29,14 @@ getMediumR mediumId = do
tempMedium <- runDB $ get mediumId tempMedium <- runDB $ get mediumId
case tempMedium of case tempMedium of
Just medium -> do Just medium -> do
ownerId <- return $ mediumOwner medium let ownerId = mediumOwner medium
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner let ownerName = userName owner
albumId <- return $ mediumAlbum medium let albumId = mediumAlbum medium
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
msu <- lookupSession "userId" msu <- lookupSession "userId"
userId <- case msu of userId <- case msu of
Just tempUserId -> do Just tempUserId ->
return $ Just $ getUserIdFromText tempUserId return $ Just $ getUserIdFromText tempUserId
Nothing -> Nothing ->
return Nothing return Nothing
@ -46,10 +46,16 @@ getMediumR mediumId = do
return $ Just $ userSlug u return $ Just $ userSlug u
Nothing -> Nothing ->
return 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 (commentWidget, enctype) <- generateFormPost $ commentForm userId userSl mediumId Nothing
comments <- runDB $ selectList [CommentOrigin ==. mediumId, CommentParent ==. Nothing] [Desc CommentTime] comments <- runDB $ selectList
replies <- runDB $ selectList [CommentOrigin ==. mediumId, CommentParent !=. Nothing] [Desc CommentTime] [ CommentOrigin ==. mediumId
, CommentParent ==. Nothing ]
[ Desc CommentTime ]
replies <- runDB $ selectList
[ CommentOrigin ==. mediumId
, CommentParent !=. Nothing ]
[ Desc CommentTime ]
dataWidth <- case mediumWidth medium >= 850 of dataWidth <- case mediumWidth medium >= 850 of
True -> return 850 True -> return 850
False -> return $ (mediumWidth medium) False -> return $ (mediumWidth medium)
@ -58,7 +64,7 @@ getMediumR mediumId = do
$(widgetFile "medium") $(widgetFile "medium")
Nothing -> do Nothing -> do
setMessage "This image does not exist" setMessage "This image does not exist"
redirect $ HomeR redirect HomeR
postMediumR :: MediumId -> Handler Html postMediumR :: MediumId -> Handler Html
postMediumR mediumId = do postMediumR mediumId = do
@ -68,10 +74,10 @@ postMediumR mediumId = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ Just $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
u <- runDB $ getJust $ fromJust userId u <- runDB $ getJust userId
userSl <- return $ Just $ userSlug u let userSl = Just $ userSlug u
((res, _), _) <- runFormPost $ commentForm userId userSl mediumId Nothing ((res, _), _) <- runFormPost $ commentForm (Just userId) userSl mediumId Nothing
case res of case res of
FormSuccess temp -> do FormSuccess temp -> do
_ <- runDB $ insert temp _ <- runDB $ insert temp
@ -98,7 +104,7 @@ postMediumR mediumId = do
redirect LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This image does not exist" setMessage "This image does not exist"
redirect $ HomeR redirect HomeR
commentForm :: Maybe UserId -> Maybe Text -> MediumId -> Maybe CommentId -> Form Comment commentForm :: Maybe UserId -> Maybe Text -> MediumId -> Maybe CommentId -> Form Comment
commentForm authorId authorSlug originId parentId = renderDivs $ Comment commentForm authorId authorSlug originId parentId = renderDivs $ Comment
@ -117,20 +123,20 @@ getCommentReplyR commentId = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ Just $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
u <- runDB $ getJust $ fromJust userId u <- runDB $ getJust userId
userSl <- return $ Just $ userSlug u let userSl = Just $ userSlug u
mediumId <- return $ commentOrigin comment let mediumId = commentOrigin comment
(replyWidget, enctype) <- generateFormPost $ commentForm userId userSl mediumId (Just commentId) (replyWidget, enctype) <- generateFormPost $ commentForm (Just userId) userSl mediumId (Just commentId)
formLayout $ do formLayout $ do
setTitle "Eidolon :: Reply to comment" setTitle "Eidolon :: Reply to comment"
$(widgetFile "commentReply") $(widgetFile "commentReply")
Nothing -> do Nothing -> do
setMessage "You need to be logged in to comment on media" setMessage "You need to be logged in to comment on media"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This comment does not Exist" setMessage "This comment does not Exist"
redirect $ HomeR redirect HomeR
postCommentReplyR :: CommentId -> Handler Html postCommentReplyR :: CommentId -> Handler Html
postCommentReplyR commentId = do postCommentReplyR commentId = do
@ -140,11 +146,11 @@ postCommentReplyR commentId = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ Just $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
u <- runDB $ getJust $ fromJust userId u <- runDB $ getJust userId
userSl <- return $ Just $ userSlug u let userSl = Just $ userSlug u
mediumId <- return $ commentOrigin comment let mediumId = commentOrigin comment
((res, _), _) <- runFormPost $ commentForm userId userSl mediumId (Just commentId) ((res, _), _) <- runFormPost $ commentForm (Just userId) userSl mediumId (Just commentId)
case res of case res of
FormSuccess temp -> do FormSuccess temp -> do
_ <- runDB $ insert temp _ <- runDB $ insert temp
@ -182,10 +188,10 @@ postCommentReplyR commentId = do
redirect $ CommentReplyR commentId redirect $ CommentReplyR commentId
Nothing -> do Nothing -> do
setMessage "You need to be logged in to post replies" setMessage "You need to be logged in to post replies"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This comment does not exist!" setMessage "This comment does not exist!"
redirect $ HomeR redirect HomeR
getCommentDeleteR :: CommentId -> Handler Html getCommentDeleteR :: CommentId -> Handler Html
getCommentDeleteR commentId = do getCommentDeleteR commentId = do
@ -195,22 +201,22 @@ getCommentDeleteR commentId = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
presence <- return $ (Just userId) == (commentAuthor comment) if
case presence of Just userId == commentAuthor comment
True -> do then do
formLayout $ do formLayout $ do
setTitle "Eidolon :: Delete comment" setTitle "Eidolon :: Delete comment"
$(widgetFile "commentDelete") $(widgetFile "commentDelete")
False -> do else do
setMessage "You must be the author of this comment to delete it" setMessage "You must be the author of this comment to delete it"
redirect $ MediumR $ commentOrigin comment redirect $ MediumR $ commentOrigin comment
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete comments" setMessage "You must be logged in to delete comments"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This comment does not exist" setMessage "This comment does not exist"
redirect $ HomeR redirect HomeR
postCommentDeleteR :: CommentId -> Handler Html postCommentDeleteR :: CommentId -> Handler Html
postCommentDeleteR commentId = do postCommentDeleteR commentId = do
@ -220,10 +226,10 @@ postCommentDeleteR commentId = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
presence <- return $ (Just userId) == (commentAuthor comment) if
case presence of Just userId == commentAuthor comment
True -> do then do
confirm <- lookupPostParam "confirm" confirm <- lookupPostParam "confirm"
case confirm of case confirm of
Just "confirm" -> do Just "confirm" -> do
@ -238,12 +244,12 @@ postCommentDeleteR commentId = do
_ -> do _ -> do
setMessage "You must confirm the deletion" setMessage "You must confirm the deletion"
redirect $ MediumR $ commentOrigin comment redirect $ MediumR $ commentOrigin comment
False -> do else do
setMessage "You must be the author of this comment to delete it" setMessage "You must be the author of this comment to delete it"
redirect $ MediumR $ commentOrigin comment redirect $ MediumR $ commentOrigin comment
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete comments" setMessage "You must be logged in to delete comments"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This comment does not exist" 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") $(widgetFile "mediumSettings")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
postMediumSettingsR :: MediumId -> Handler Html postMediumSettingsR :: MediumId -> Handler Html
postMediumSettingsR mediumId = do postMediumSettingsR mediumId = do
@ -56,7 +56,7 @@ postMediumSettingsR mediumId = do
redirect $ MediumSettingsR mediumId redirect $ MediumSettingsR mediumId
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
mediumSettingsForm :: Medium -> Form Medium mediumSettingsForm :: Medium -> Form Medium
mediumSettingsForm medium = renderDivs $ Medium mediumSettingsForm medium = renderDivs $ Medium
@ -76,13 +76,13 @@ getMediumDeleteR :: MediumId -> Handler Html
getMediumDeleteR mediumId = do getMediumDeleteR mediumId = do
checkRes <- mediumCheck mediumId checkRes <- mediumCheck mediumId
case checkRes of case checkRes of
Right medium -> do Right medium ->
formLayout $ do formLayout $ do
setTitle "Eidolon :: Delete Medium" setTitle "Eidolon :: Delete Medium"
$(widgetFile "mediumDelete") $(widgetFile "mediumDelete")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
postMediumDeleteR :: MediumId -> Handler Html postMediumDeleteR :: MediumId -> Handler Html
postMediumDeleteR mediumId = do postMediumDeleteR mediumId = do
@ -94,22 +94,22 @@ postMediumDeleteR mediumId = do
Just "confirm" -> do Just "confirm" -> do
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] [] commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (runDB . delete . entityKey) commEnts
-- delete references first -- delete references first
albumId <- return $ mediumAlbum medium let albumId = mediumAlbum medium
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
mediaList <- return $ albumContent album let mediaList = albumContent album
newMediaList <- return $ removeItem mediumId mediaList let newMediaList = removeItem mediumId mediaList
-- update reference List -- update reference List
runDB $ update albumId [AlbumContent =. newMediaList] runDB $ update albumId [AlbumContent =. newMediaList]
liftIO $ removeFile (normalise $ tail $ mediumPath medium) liftIO $ removeFile (normalise $ tail $ mediumPath medium)
liftIO $ removeFile (normalise $ tail $ mediumThumb medium) liftIO $ removeFile (normalise $ tail $ mediumThumb medium)
runDB $ delete mediumId runDB $ delete mediumId
setMessage "Medium succesfully deleted" setMessage "Medium succesfully deleted"
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessage "You must confirm the deletion" setMessage "You must confirm the deletion"
redirect $ MediumSettingsR mediumId redirect $ MediumSettingsR mediumId
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route

16
Handler/NewAlbum.hs
View file

@ -33,14 +33,14 @@ getNewAlbumR = do
$(widgetFile "newAlbum") $(widgetFile "newAlbum")
Nothing -> do Nothing -> do
setMessage "You need to be logged in" setMessage "You need to be logged in"
redirect $ LoginR redirect LoginR
postNewAlbumR :: Handler Html postNewAlbumR :: Handler Html
postNewAlbumR = do postNewAlbumR = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
((result, _), _) <- runFormPost (albumForm userId) ((result, _), _) <- runFormPost (albumForm userId)
case result of case result of
FormSuccess album -> do FormSuccess album -> do
@ -48,20 +48,20 @@ postNewAlbumR = do
albumId <- runDB $ insert album albumId <- runDB $ insert album
-- add album reference in user -- add album reference in user
user <- runDB $ getJust userId user <- runDB $ getJust userId
albumList <- return $ userAlbums user let albumList = userAlbums user
newAlbumList <- return $ albumId : albumList let newAlbumList = albumId : albumList
runDB $ update userId [UserAlbums =. newAlbumList] runDB $ update userId [UserAlbums =. newAlbumList]
-- create folder -- create folder
liftIO $ createDirectory $ "static" </> "data" </> (unpack $ extractKey userId) </> (unpack $ extractKey albumId) liftIO $ createDirectory $ "static" </> "data" </> unpack (extractKey userId) </> unpack (extractKey albumId)
-- outro -- outro
setMessage $ "Album successfully created" setMessage "Album successfully created"
redirect $ ProfileR userId redirect $ ProfileR userId
_ -> do _ -> do
setMessage "There was an error creating the album" setMessage "There was an error creating the album"
redirect $ NewAlbumR redirect NewAlbumR
Nothing -> do Nothing -> do
setMessage "You must be logged in to create albums" setMessage "You must be logged in to create albums"
redirect $ LoginR redirect LoginR
albumForm :: UserId -> Form Album albumForm :: UserId -> Form Album
albumForm userId = renderDivs $ Album albumForm userId = renderDivs $ Album

23
Handler/Profile.hs
View file

@ -26,29 +26,30 @@ getProfileR ownerId = do
tempOwner <- runDB $ get ownerId tempOwner <- runDB $ get ownerId
case tempOwner of case tempOwner of
Just owner -> do Just owner -> do
ownerSlug <- lift $ pure $ userSlug owner let ownerSlug = userSlug owner
userAlbs <- runDB $ selectList [AlbumOwner ==. ownerId] [Asc AlbumTitle] userAlbs <- runDB $ selectList [AlbumOwner ==. ownerId] [Asc AlbumTitle]
allAlbs <- runDB $ selectList [] [Asc AlbumTitle] allAlbs <- runDB $ selectList [] [Asc AlbumTitle]
almostAlbs <- mapM (\alb -> do almostAlbs <- mapM (\alb ->
case ownerId `elem` (albumShares $ entityVal alb) of if
True -> return $ Just alb ownerId `elem` albumShares (entityVal alb)
False -> return Nothing then return $ Just alb
else return Nothing
) allAlbs ) allAlbs
sharedAlbs <- return $ removeItem Nothing almostAlbs let sharedAlbs = removeItem Nothing almostAlbs
recentMedia <- (runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTime]) recentMedia <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTime]
msu <- lookupSession "userId" msu <- lookupSession "userId"
presence <- case msu of presence <- case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- lift $ pure $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
return (userId == ownerId) return (userId == ownerId)
Nothing -> Nothing ->
return False return False
defaultLayout $ do 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") $(widgetFile "profile")
Nothing -> do Nothing -> do
setMessage "This profile does not exist" setMessage "This profile does not exist"
redirect $ HomeR redirect HomeR
getUserR :: Text -> Handler Html getUserR :: Text -> Handler Html
getUserR ownerName = do getUserR ownerName = do
@ -58,4 +59,4 @@ getUserR ownerName = do
getProfileR ownerId getProfileR ownerId
Nothing -> do Nothing -> do
setMessage "This user does not exist" 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 Import
import Handler.Commons import Handler.Commons
import Control.Monad (when)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.List as L import qualified Data.List as L
import System.Directory import System.Directory
@ -27,13 +28,13 @@ getProfileDeleteR :: UserId -> Handler Html
getProfileDeleteR userId = do getProfileDeleteR userId = do
checkRes <- profileCheck userId checkRes <- profileCheck userId
case checkRes of case checkRes of
Right user -> do Right user ->
formLayout $ do formLayout $ do
setTitle "Eidolon :: Delete user profile" setTitle "Eidolon :: Delete user profile"
$(widgetFile "profileDelete") $(widgetFile "profileDelete")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
postProfileDeleteR :: UserId -> Handler Html postProfileDeleteR :: UserId -> Handler Html
postProfileDeleteR userId = do postProfileDeleteR userId = do
@ -43,31 +44,29 @@ postProfileDeleteR userId = do
confirm <- lookupPostParam "confirm" confirm <- lookupPostParam "confirm"
case confirm of case confirm of
Just "confirm" -> do Just "confirm" -> do
albumList <- return $ userAlbums user let albumList = userAlbums user
_ <- mapM (\albumId -> do _ <- mapM (\albumId -> do
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
case (albumOwner album) == userId of when (albumOwner album == userId) $ do
True -> do let mediaList = albumContent album
mediaList <- return $ albumContent album
_ <- mapM (\med -> do _ <- mapM (\med -> do
commEnts <- runDB $ selectList [CommentOrigin ==. med] [] commEnts <- runDB $ selectList [CommentOrigin ==. med] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (runDB . delete . entityKey) commEnts
medium <- runDB $ getJust med medium <- runDB $ getJust med
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
runDB $ delete med runDB $ delete med
) mediaList ) mediaList
runDB $ delete albumId runDB $ delete albumId
False -> return ()
) albumList ) albumList
runDB $ delete userId runDB $ delete userId
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> (T.unpack $ extractKey userId) liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey userId)
deleteSession "userId" deleteSession "userId"
setMessage "User deleted successfully" setMessage "User deleted successfully"
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessage "You must confirm the deletion" setMessage "You must confirm the deletion"
redirect $ ProfileSettingsR userId redirect $ ProfileSettingsR userId
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route

10
Handler/ProfileSettings.hs
View file

@ -30,7 +30,7 @@ getProfileSettingsR userId = do
$(widgetFile "profileSettings") $(widgetFile "profileSettings")
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
postProfileSettingsR :: UserId -> Handler Html postProfileSettingsR :: UserId -> Handler Html
postProfileSettingsR userId = do postProfileSettingsR userId = do
@ -41,9 +41,9 @@ postProfileSettingsR userId = do
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
runDB $ update userId [ runDB $ update userId [
UserName =. (userName temp) UserName =. userName temp
, UserSlug =. (userSlug temp) , UserSlug =. userSlug temp
, UserEmail =. (userEmail temp) , UserEmail =. userEmail temp
] ]
setMessage "Profile settings changed successfully" setMessage "Profile settings changed successfully"
redirect $ UserR $ userName user redirect $ UserR $ userName user
@ -52,7 +52,7 @@ postProfileSettingsR userId = do
redirect $ ProfileSettingsR userId redirect $ ProfileSettingsR userId
Left (errorMsg, route) -> do Left (errorMsg, route) -> do
setMessage errorMsg setMessage errorMsg
redirect $ route redirect route
profileSettingsForm :: User -> Form User profileSettingsForm :: User -> Form User

7
Handler/Reactivate.hs
View file

@ -33,8 +33,9 @@ postReactivateR = do
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
users <- runDB $ selectList [UserEmail ==. temp] [] users <- runDB $ selectList [UserEmail ==. temp] []
case null users of if
True -> do null users
then do
userTokens <- foldM (\userTokens (Entity userId user) -> do userTokens <- foldM (\userTokens (Entity userId user) -> do
token <- liftIO $ generateString token <- liftIO $ generateString
_ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (Just userId) _ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (Just userId)
@ -58,7 +59,7 @@ postReactivateR = do
) True userTokens ) True userTokens
setMessage "Your new password activation will arrive in your e-mail" setMessage "Your new password activation will arrive in your e-mail"
redirect $ HomeR redirect $ HomeR
False -> do else do
setMessage "No user mith this Email" setMessage "No user mith this Email"
redirect $ LoginR redirect $ LoginR
_ -> do _ -> do

2
Handler/RootFeed.hs
View file

@ -51,7 +51,7 @@ withXmlDecl c = c
instance RepFeed RepAtom where instance RepFeed RepAtom where
renderFeed params items = do renderFeed params items = do
image <- return $ pImage params let image = pImage params
url <- getUrlRender url <- getUrlRender
tz <- liftIO getCurrentTimeZone tz <- liftIO getCurrentTimeZone
links <- case items of links <- case items of

22
Handler/Signup.hs
View file

@ -25,7 +25,7 @@ import Data.Maybe
getSignupR :: Handler Html getSignupR :: Handler Html
getSignupR = do getSignupR = do
master <- getYesod master <- getYesod
block <- return $ appSignupBlocked $ appSettings master let block = appSignupBlocked $ appSettings master
case block of case block of
False -> do False -> do
formLayout $ do formLayout $ do
@ -38,7 +38,7 @@ getSignupR = do
postSignupR :: Handler Html postSignupR :: Handler Html
postSignupR = do postSignupR = do
master <- getYesod master <- getYesod
block <- return $ appSignupBlocked $ appSettings master let block = appSignupBlocked $ appSettings master
case block of case block of
False -> do False -> do
mUserName <- lookupPostParam "username" mUserName <- lookupPostParam "username"
@ -46,7 +46,7 @@ postSignupR = do
True -> return $ fromJust $ mUserName True -> return $ fromJust $ mUserName
False -> do False -> do
setMessage "Invalid username" setMessage "Invalid username"
redirect $ SignupR redirect SignupR
mEmail <- lookupPostParam "email" mEmail <- lookupPostParam "email"
mTos1 <- lookupPostParam "tos-1" mTos1 <- lookupPostParam "tos-1"
mTos2 <- lookupPostParam "tos-2" mTos2 <- lookupPostParam "tos-2"
@ -55,19 +55,13 @@ postSignupR = do
return () return ()
_ -> do _ -> do
setMessage "You need to agree to our terms." setMessage "You need to agree to our terms."
redirect $ SignupR redirect SignupR
-- create user -- create user
namesakes <- runDB $ selectList [UserName ==. newUserName] [] namesakes <- runDB $ selectList [UserName ==. newUserName] []
case namesakes of case namesakes of
[] -> do [] -> do
salt <- liftIO generateSalt salt <- liftIO generateSalt
newUser <- return $ User newUserName let newUser = User newUserName newUserName (fromJust mEmail) salt "" [] False
newUserName
(fromJust mEmail)
salt
""
[]
False
activatorText <- liftIO generateString activatorText <- liftIO generateString
_ <- runDB $ insert $ Activator activatorText newUser _ <- runDB $ insert $ Activator activatorText newUser
_ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing _ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing
@ -79,13 +73,13 @@ postSignupR = do
<a href="#{activateLink}">#{activateLink} <a href="#{activateLink}">#{activateLink}
|] |]
setMessage "User pending activation" setMessage "User pending activation"
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessage "This user already exists" setMessage "This user already exists"
redirect $ SignupR redirect SignupR
True -> do True -> do
setMessage "User signup is disabled" setMessage "User signup is disabled"
redirect $ HomeR redirect HomeR
validateLen :: Text -> Bool validateLen :: Text -> Bool
validateLen a = validateLen a =

10
Handler/Tag.hs
View file

@ -23,12 +23,12 @@ import System.FilePath
getTagR :: Text -> Handler Html getTagR :: Text -> Handler Html
getTagR tag = do getTagR tag = do
tempMedia <- runDB $ selectList [] [Desc MediumTitle] tempMedia <- runDB $ selectList [] [Desc MediumTitle]
almostMedia <- mapM (\a -> do almostMedia <- mapM (\a ->
case tag `elem` (mediumTags $ entityVal a) of if tag `elem` mediumTags (entityVal a)
True -> return (Just a) then return (Just a)
False -> return Nothing else return Nothing
) tempMedia ) tempMedia
media <- return $ removeItem Nothing almostMedia let media = removeItem Nothing almostMedia
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Tag " `T.append` tag) setTitle $ toHtml ("Eidolon :: Tag " `T.append` tag)
$(widgetFile "tagMedia") $(widgetFile "tagMedia")

193
Handler/Upload.hs
View file

@ -31,90 +31,84 @@ getDirectUploadR albumId = do
tempAlbum <- runDB $ get albumId tempAlbum <- runDB $ get albumId
case tempAlbum of -- does the requested album exist case tempAlbum of -- does the requested album exist
Just album -> do Just album -> do
ownerId <- return $ albumOwner album let ownerId = albumOwner album
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of -- is anybody logged in case msu of -- is anybody logged in
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album)) if
case presence of -- is the owner present or a user with whom the album is shared userId == ownerId || userId `elem` albumShares album
True -> do -- is the owner present or a user with whom the album is shared
then do
(dUploadWidget, enctype) <- generateFormPost $ dUploadForm userId albumId (dUploadWidget, enctype) <- generateFormPost $ dUploadForm userId albumId
formLayout $ do formLayout $ do
setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` (albumTitle album)) setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` albumTitle album)
$(widgetFile "dUpload") $(widgetFile "dUpload")
False -> do else do
setMessage "You must own this album to upload" setMessage "You must own this album to upload"
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to upload" setMessage "You must be logged in to upload"
redirect $ LoginR redirect LoginR
Nothing -> do Nothing -> do
setMessage "This album does not exist" setMessage "This album does not exist"
redirect $ HomeR redirect HomeR
postDirectUploadR :: AlbumId -> Handler Html postDirectUploadR :: AlbumId -> Handler Html
postDirectUploadR albumId = do postDirectUploadR albumId = do
tempAlbum <- runDB $ get albumId tempAlbum <- runDB $ get albumId
case tempAlbum of -- does the album exist case tempAlbum of -- does the album exist
Just album -> do Just album -> do
ownerId <- return $ albumOwner album let ownerId = albumOwner album
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of -- is anybody logged in case msu of -- is anybody logged in
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album)) if
case presence of -- is the logged in user the owner or is the album shared with him userId == ownerId || userId `elem` albumShares album
True -> do -- is the logged in user the owner or is the album shared with him
then do
((result, _), _) <- runFormPost (dUploadForm userId albumId) ((result, _), _) <- runFormPost (dUploadForm userId albumId)
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
fils <- return $ fileBulkFiles temp let fils = fileBulkFiles temp
indFils <- return $ zip [1..] fils let indFils = zip [1..] fils
errNames <- mapM errNames <- mapM
(\(index, file) -> do (\(index, file) -> do
mime <- return $ fileContentType file let mime = fileContentType file
case mime `elem` acceptedTypes of if
True -> do mime `elem` acceptedTypes
then do
path <- writeOnDrive file ownerId albumId path <- writeOnDrive file ownerId albumId
(thumbPath, iWidth, tWidth) <- generateThumb path ownerId albumId (thumbPath, iWidth, tWidth) <- generateThumb path ownerId albumId
tempName <- case length indFils == 1 of tempName <- if
False -> return $ ((fileBulkPrefix temp) `T.append` " " `T.append` (T.pack (show index)) `T.append` " of " `T.append` (T.pack (show (length indFils)))) length indFils == 1
True -> return $ fileBulkPrefix temp then return $ fileBulkPrefix temp
medium <- return $ Medium else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
tempName let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth albumId
('/' : path)
('/' : thumbPath)
mime
(fileBulkTime temp)
(fileBulkOwner temp)
(fileBulkDesc temp)
(fileBulkTags temp)
iWidth
tWidth
albumId
mId <- runDB $ I.insert medium mId <- runDB $ I.insert medium
inALbum <- runDB $ getJust albumId inALbum <- runDB $ getJust albumId
newMediaList <- return $ mId : (albumContent inALbum) let newMediaList = mId : albumContent inALbum
runDB $ update albumId [AlbumContent =. newMediaList] runDB $ update albumId [AlbumContent =. newMediaList]
return Nothing return Nothing
False -> do else
return $ Just $ fileName file return $ Just $ fileName file
) indFils ) indFils
onlyErrNames <- return $ removeItem Nothing errNames let onlyErrNames = removeItem Nothing errNames
case L.null onlyErrNames of if
True -> do L.null onlyErrNames
then do
setMessage "All images succesfully uploaded" setMessage "All images succesfully uploaded"
redirect $ HomeR redirect HomeR
False -> do else do
justErrNames <- return $ map fromJust onlyErrNames let justErrNames = map fromJust onlyErrNames
msg <- return $ Content $ Text $ "File type not supported of: " `T.append` (T.intercalate ", " justErrNames) let msg = Content $ Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames
setMessage msg setMessage msg
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessage "There was an error uploading the file" setMessage "There was an error uploading the file"
redirect $ DirectUploadR albumId redirect $ DirectUploadR albumId
False -> do -- owner is not present else do -- owner is not present
setMessage "You must own this album to upload" setMessage "You must own this album to upload"
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
@ -126,18 +120,15 @@ postDirectUploadR albumId = do
generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler (FP.FilePath, Int, Int) generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler (FP.FilePath, Int, Int)
generateThumb path userId albumId = do generateThumb path userId albumId = do
newName <- return $ (FP.takeBaseName path) ++ "_thumb.jpg" let newName = FP.takeBaseName path ++ "_thumb.jpg"
newPath <- return $ "static" FP.</> "data" let newPath = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> newName
FP.</> (T.unpack $ extractKey userId)
FP.</> (T.unpack $ extractKey albumId)
FP.</> newName
(iWidth, tWidth) <- liftIO $ withMagickWandGenesis $ do (iWidth, tWidth) <- liftIO $ withMagickWandGenesis $ do
(_ , w) <- magickWand (_ , w) <- magickWand
readImage w (decodeString path) readImage w (decodeString path)
w1 <- getImageWidth w w1 <- getImageWidth w
h1 <- getImageHeight w h1 <- getImageHeight w
h2 <- return 230 let h2 = 230
w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2) :: Double) let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double)
setImageAlphaChannel w deactivateAlphaChannel setImageAlphaChannel w deactivateAlphaChannel
setImageFormat w "jpeg" setImageFormat w "jpeg"
resizeImage w w2 h2 lanczosFilter 1 resizeImage w w2 h2 lanczosFilter 1
@ -150,12 +141,9 @@ writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath
writeOnDrive fil userId albumId = do writeOnDrive fil userId albumId = do
--filen <- return $ fileName fil --filen <- return $ fileName fil
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
filen <- return $ show $ (length $ albumContent album) + 1 let filen = show $ length (albumContent album) + 1
ext <- return $ FP.takeExtension $ T.unpack $ fileName fil let ext = FP.takeExtension $ T.unpack $ fileName fil
path <- return $ "static" FP.</> "data" let path = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> filen ++ ext
FP.</> (T.unpack $ extractKey userId)
FP.</> (T.unpack $ extractKey albumId)
FP.</> filen ++ ext
liftIO $ fileMove fil path liftIO $ fileMove fil path
return path return path
@ -184,21 +172,22 @@ getUploadR = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
user <- runDB $ getJust userId user <- runDB $ getJust userId
albums <- return $ userAlbums user let albums = userAlbums user
case I.null albums of if
False -> do I.null albums
then do
(uploadWidget, enctype) <- generateFormPost (bulkUploadForm userId) (uploadWidget, enctype) <- generateFormPost (bulkUploadForm userId)
formLayout $ do formLayout $ do
setTitle "Eidolon :: Upload Medium" setTitle "Eidolon :: Upload Medium"
$(widgetFile "bulkUpload") $(widgetFile "bulkUpload")
True -> do else do
setMessage "Please create an album first" setMessage "Please create an album first"
redirect $ NewAlbumR redirect NewAlbumR
Nothing -> do Nothing -> do
setMessage "You need to be logged in" setMessage "You need to be logged in"
redirect $ LoginR redirect LoginR
bulkUploadForm :: UserId -> Form FileBulk bulkUploadForm :: UserId -> Form FileBulk
bulkUploadForm userId = renderDivs $ (\a b c d e f g -> FileBulk b c d e f g a) 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 where
albums = do albums = do
allEnts <- runDB $ selectList [] [Desc AlbumTitle] allEnts <- runDB $ selectList [] [Desc AlbumTitle]
entities <- return $ let entities = map fromJust $ removeItem Nothing $ map (\ent ->
map fromJust $ if
removeItem Nothing $ map userId == albumOwner (entityVal ent) || userId `elem` albumShares (entityVal ent)
(\ent -> do then Just ent
case (userId == (albumOwner $ entityVal ent)) || (userId `elem` (albumShares $ entityVal ent)) of else Nothing
True -> Just ent
False -> Nothing
) allEnts ) allEnts
optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities
@ -227,58 +214,50 @@ postUploadR = do
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- lift $ pure $ getUserIdFromText tempUserId let userId = getUserIdFromText tempUserId
((result, _), _) <- runFormPost (bulkUploadForm userId) ((result, _), _) <- runFormPost (bulkUploadForm userId)
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
fils <- return $ fileBulkFiles temp let fils = fileBulkFiles temp
indFils <- return $ zip [1..] fils let indFils = zip [1..] fils
errNames <- mapM errNames <- mapM
(\(index, file) -> do (\(index, file) -> do
mime <- return $ fileContentType file let mime = fileContentType file
case mime `elem` acceptedTypes of if
True -> do mime `elem` acceptedTypes
inAlbumId <- return $ fileBulkAlbum temp then do
let inAlbumId = fileBulkAlbum temp
albRef <- runDB $ getJust inAlbumId albRef <- runDB $ getJust inAlbumId
ownerId <- return $ albumOwner albRef let ownerId = albumOwner albRef
path <- writeOnDrive file ownerId inAlbumId path <- writeOnDrive file ownerId inAlbumId
(thumbPath, iWidth, tWidth) <- generateThumb path ownerId inAlbumId (thumbPath, iWidth, tWidth) <- generateThumb path ownerId inAlbumId
tempName <- case length indFils == 1 of tempName <- if
False -> return $ ((fileBulkPrefix temp) `T.append` " " `T.append` (T.pack (show index)) `T.append` " of " `T.append` (T.pack (show (length indFils)))) length indFils == 1
True -> return $ fileBulkPrefix temp then return $ fileBulkPrefix temp
medium <- return $ Medium else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
tempName let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth inAlbumId
('/' : path)
('/' : thumbPath)
mime
(fileBulkTime temp)
(fileBulkOwner temp)
(fileBulkDesc temp)
(fileBulkTags temp)
iWidth
tWidth
inAlbumId
mId <- runDB $ I.insert medium mId <- runDB $ I.insert medium
inALbum <- runDB $ getJust inAlbumId inALbum <- runDB $ getJust inAlbumId
newMediaList <- return $ mId : (albumContent inALbum) let newMediaList = mId : albumContent inALbum
runDB $ update inAlbumId [AlbumContent =. newMediaList] runDB $ update inAlbumId [AlbumContent =. newMediaList]
return Nothing return Nothing
False -> do else
return $ Just $ fileName file return $ Just $ fileName file
) indFils ) indFils
onlyErrNames <- return $ removeItem Nothing errNames let onlyErrNames = removeItem Nothing errNames
case L.null onlyErrNames of if
True -> do L.null onlyErrNames
then do
setMessage "All images succesfully uploaded" setMessage "All images succesfully uploaded"
redirect $ HomeR redirect HomeR
False -> do else do
justErrNames <- return $ map fromJust onlyErrNames let justErrNames = map fromJust onlyErrNames
msg <- return $ Content $ Text $ "File type not supported of: " `T.append` (T.intercalate ", " justErrNames) let msg = Content $ Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames
setMessage msg setMessage msg
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessage "There was an error uploading the file" setMessage "There was an error uploading the file"
redirect $ UploadR redirect UploadR
Nothing -> do Nothing -> do
setMessage "You need to be logged in" setMessage "You need to be logged in"
redirect $ LoginR redirect LoginR