linted
This commit is contained in:
parent
325045cfec
commit
68f39fbeb4
24 changed files with 400 additions and 415 deletions
|
@ -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!
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) =>
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -18,6 +18,7 @@ module Handler.ProfileDelete where
|
|||
|
||||
import Import
|
||||
import Handler.Commons
|
||||
import Control.Monad (when)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.List as L
|
||||
import System.Directory
|
||||
|
@ -27,13 +28,13 @@ getProfileDeleteR :: UserId -> Handler Html
|
|||
getProfileDeleteR userId = do
|
||||
checkRes <- profileCheck userId
|
||||
case checkRes of
|
||||
Right user -> do
|
||||
Right user ->
|
||||
formLayout $ do
|
||||
setTitle "Eidolon :: Delete user profile"
|
||||
$(widgetFile "profileDelete")
|
||||
Left (errorMsg, route) -> do
|
||||
setMessage errorMsg
|
||||
redirect $ route
|
||||
redirect route
|
||||
|
||||
postProfileDeleteR :: UserId -> Handler Html
|
||||
postProfileDeleteR userId = do
|
||||
|
@ -43,31 +44,29 @@ postProfileDeleteR userId = do
|
|||
confirm <- lookupPostParam "confirm"
|
||||
case confirm of
|
||||
Just "confirm" -> do
|
||||
albumList <- return $ userAlbums user
|
||||
let albumList = userAlbums user
|
||||
_ <- mapM (\albumId -> do
|
||||
album <- runDB $ getJust albumId
|
||||
case (albumOwner album) == userId of
|
||||
True -> do
|
||||
mediaList <- return $ albumContent album
|
||||
_ <- mapM (\med -> do
|
||||
commEnts <- runDB $ selectList [CommentOrigin ==. med] []
|
||||
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
|
||||
medium <- runDB $ getJust med
|
||||
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
|
||||
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
|
||||
runDB $ delete med
|
||||
) mediaList
|
||||
runDB $ delete albumId
|
||||
False -> return ()
|
||||
when (albumOwner album == userId) $ do
|
||||
let mediaList = albumContent album
|
||||
_ <- mapM (\med -> do
|
||||
commEnts <- runDB $ selectList [CommentOrigin ==. med] []
|
||||
_ <- mapM (runDB . delete . entityKey) commEnts
|
||||
medium <- runDB $ getJust med
|
||||
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
|
||||
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
|
||||
runDB $ delete med
|
||||
) mediaList
|
||||
runDB $ delete albumId
|
||||
) albumList
|
||||
runDB $ delete userId
|
||||
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> (T.unpack $ extractKey userId)
|
||||
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey userId)
|
||||
deleteSession "userId"
|
||||
setMessage "User deleted successfully"
|
||||
redirect $ HomeR
|
||||
redirect HomeR
|
||||
_ -> do
|
||||
setMessage "You must confirm the deletion"
|
||||
redirect $ ProfileSettingsR userId
|
||||
Left (errorMsg, route) -> do
|
||||
setMessage errorMsg
|
||||
redirect $ route
|
||||
redirect route
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue