eidolon/Handler/Commons.hs

152 lines
5.2 KiB
Haskell
Raw Normal View History

2015-01-18 19:44:41 +00:00
-- eidolon -- A simple gallery in Haskell and Yesod
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
2015-01-21 09:00:18 +00:00
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-01-18 19:44:41 +00:00
2014-12-28 00:08:35 +00:00
module Handler.Commons where
import Import
import qualified Data.Text as T
2014-12-28 00:08:35 +00:00
import Data.String
import qualified Data.List as L
import System.FilePath as FP
import System.Directory
2014-12-28 00:08:35 +00:00
loginIsAdmin :: IsString t => Handler (Either (t, Route App) ())
loginIsAdmin = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
2015-09-14 16:54:46 +00:00
let userId = getUserIdFromText tempUserId
2014-12-28 00:08:35 +00:00
user <- runDB $ getJust userId
2015-09-14 16:54:46 +00:00
if
userAdmin user
then
2014-12-28 00:08:35 +00:00
return $ Right ()
2015-09-14 16:54:46 +00:00
else
2014-12-28 00:08:35 +00:00
return $ Left ("You have no admin rights", HomeR)
Nothing ->
return $ Left ("You are not logged in", LoginR)
profileCheck :: IsString t => UserId -> Handler (Either (t, Route App) User)
profileCheck userId = do
tempUser <- runDB $ get userId
case tempUser of
Just user -> do
msu <- lookupSession "userId"
case msu of
Just tempLoginId -> do
2015-09-14 16:54:46 +00:00
let loginId = getUserIdFromText tempLoginId
if
loginId == userId
then
2014-12-28 00:08:35 +00:00
return $ Right user
2015-09-14 16:54:46 +00:00
else
2014-12-28 00:08:35 +00:00
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)
Nothing ->
return $ Left ("This user does not exist", HomeR)
mediumCheck :: IsString t => MediumId -> Handler (Either (t, Route App) Medium)
mediumCheck mediumId = do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
2015-09-14 16:54:46 +00:00
let ownerId = mediumOwner medium
2014-12-28 00:08:35 +00:00
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
2015-09-14 16:54:46 +00:00
let userId = getUserIdFromText tempUserId
2014-12-28 00:08:35 +00:00
album <- runDB $ getJust $ mediumAlbum medium
2015-09-14 16:54:46 +00:00
let presence = userId == ownerId
let albumOwnerPresence = userId == albumOwner album
if
presence || albumOwnerPresence
then
2014-12-28 00:08:35 +00:00
return $ Right medium
2015-09-14 16:54:46 +00:00
else
2014-12-28 00:08:35 +00:00
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)
Nothing ->
return $ Left ("This medium does not exist", HomeR)
insertMedium :: Medium -> AlbumId -> Handler ()
insertMedium medium aId = do
mId <- runDB $ insert medium
inAlbum <- runDB $ getJust aId
let newMediaList = mId : albumContent inAlbum
runDB $ update aId [AlbumContent =. newMediaList]
deleteMedium :: MediumId -> Medium -> Handler ()
deleteMedium mId medium = do
commEnts <- runDB $ selectList [CommentOrigin ==. mId] []
-- delete comments first
mapM_ (runDB . delete . entityKey) commEnts
-- remove reference
removeReference mId $ mediumAlbum medium
-- delete Files
mapM_ (liftIO . removeFile . normalise . L.tail)
[ mediumPath medium
, mediumThumb medium
, mediumPreview medium
]
-- delete database entry
runDB $ delete mId
moveMedium :: Medium -> MediumId -> AlbumId -> Handler ()
moveMedium med mId destId = do
2016-10-22 22:18:13 +00:00
$(logError) "getting destination"
dest <- runDB $ getJust destId
-- remove reference
2016-10-22 22:18:13 +00:00
$(logError) "removing reference"
removeReference mId $ mediumAlbum med
-- move physical Files
let filen = show $ length (albumContent dest) + 1
ext = takeExtension $ mediumPath med
2016-10-22 22:18:13 +00:00
prefix = "static" </> "data" </> T.unpack (extractKey $ albumOwner dest) </> T.unpack (extractKey destId)
nPath = prefix </> filen ++ ext
nThumb = prefix </> takeBaseName nPath ++ "_thumb.jpg"
nPrev = prefix </> takeBaseName nPath ++ "_preview.jpg"
$(logError) $ T.pack $ "copyFile" ++ nPath
liftIO $ copyFile (L.tail $ mediumPath med) nPath
liftIO $ copyFile (L.tail $ mediumThumb med) nThumb
liftIO $ copyFile (L.tail $ mediumPreview med) nPrev
-- remove physical files
$(logError) "removeFile"
mapM_ (liftIO . removeFile . normalise . L.tail)
[ mediumPath med
, mediumThumb med
, mediumPreview med
]
-- chenge filenames in database
runDB $ update mId
[ MediumPath =. '/' : nPath
, MediumThumb =. '/' : nThumb
, MediumPreview =. '/' : nPrev
2016-10-22 22:18:13 +00:00
, MediumAlbum =. destId
]
-- create new references
let newMediaList = mId : albumContent dest
runDB $ update destId [AlbumContent =. newMediaList]
removeReference :: MediumId -> AlbumId -> Handler ()
removeReference mId aId = do
-- delete references next
album <- runDB $ getJust aId
let newMediaList = removeItem mId $ albumContent album
-- update reference list
runDB $ update aId [AlbumContent =. newMediaList]