eidolon/Handler/MediumSettings.hs

182 lines
6.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-08-30 18:25:08 +00:00
module Handler.MediumSettings where
import Import
import Yesod.Text.Markdown
import Handler.Commons
2014-08-30 19:19:41 +00:00
import System.FilePath
import qualified Data.Text as T
2017-03-09 17:30:40 +00:00
import Data.Maybe
import Text.Markdown
import Control.Monad (when)
2014-08-30 18:25:08 +00:00
getMediumSettingsR :: MediumId -> Handler Html
getMediumSettingsR mediumId = do
checkRes <- mediumCheck mediumId
case checkRes of
Right medium -> do
2015-10-19 06:32:47 +00:00
(mediumSettingsWidget, enctype) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm $
mediumSettingsForm medium
2016-09-07 15:32:56 +00:00
defaultLayout $ do
setTitle "Eidolon :: Medium Settings"
$(widgetFile "mediumSettings")
Left (errorMsg, route) -> do
setMessage errorMsg
2015-09-14 16:54:46 +00:00
redirect route
2014-08-30 18:25:08 +00:00
postMediumSettingsR :: MediumId -> Handler Html
postMediumSettingsR mediumId = do
checkRes <- mediumCheck mediumId
case checkRes of
Right medium -> do
2015-10-19 06:32:47 +00:00
((result, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm $
mediumSettingsForm medium
case result of
FormSuccess temp -> do
2014-12-28 06:12:25 +00:00
_ <- runDB $ update mediumId
2017-03-09 17:30:40 +00:00
[ MediumTitle =. msTitle temp
, MediumDescription =. msDescription temp
, MediumTags =. msTags temp
, MediumLicence =. msLicence temp
]
2017-03-09 17:30:40 +00:00
when (not $ isNothing $ msData temp) $ do
err <- handleUpload
1
(mediumAlbum medium)
(msTitle temp)
(mediumTime medium)
(mediumOwner medium)
(msDescription temp)
(msTags temp)
(msLicence temp)
(Replace mediumId)
(1, (fromJust $ msData temp))
when (not $ isNothing err) $ do
setMessage "There was an error uploading the File"
redirect $ MediumSettingsR mediumId
setMessage "Medium settings changed succesfully"
redirect $ MediumR mediumId
_ -> do
setMessage "There was an error changing the settings"
redirect $ MediumSettingsR mediumId
Left (errorMsg, route) -> do
setMessage errorMsg
2015-09-14 16:54:46 +00:00
redirect route
2014-08-30 18:25:08 +00:00
2017-03-09 17:30:40 +00:00
data MediumSettings = MediumSettings
{ msTitle :: T.Text
, msData :: Maybe FileInfo
, msDescription :: Maybe Markdown
, msTags :: [T.Text]
2017-08-06 02:42:31 +00:00
, msLicence :: Licence
2017-03-09 17:30:40 +00:00
}
mediumSettingsForm :: Medium -> AForm Handler MediumSettings
mediumSettingsForm medium = MediumSettings
2015-10-19 06:32:47 +00:00
<$> areq textField (bfs ("Title" :: T.Text)) (Just $ mediumTitle medium)
2017-03-09 17:30:40 +00:00
<*> aopt fileField (bfs ("Update medium" :: T.Text)) (Nothing)
<*> aopt markdownField (bfs ("Description" :: T.Text)) (Just $ mediumDescription medium)
2016-12-18 23:57:39 +00:00
<*> areq tagField (bfs ("Tags" :: T.Text)) (Just $ mediumTags medium)
<*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium)
2015-10-19 06:32:47 +00:00
<* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
2016-12-18 23:57:39 +00:00
where
2017-08-06 02:42:31 +00:00
licences = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
[minBound..maxBound]
2014-08-30 19:19:41 +00:00
getMediumDeleteR :: MediumId -> Handler Html
getMediumDeleteR mediumId = do
checkRes <- mediumCheck mediumId
case checkRes of
2015-09-14 16:54:46 +00:00
Right medium ->
2016-09-07 15:32:56 +00:00
defaultLayout $ do
setTitle "Eidolon :: Delete Medium"
$(widgetFile "mediumDelete")
Left (errorMsg, route) -> do
setMessage errorMsg
2015-09-14 16:54:46 +00:00
redirect route
2014-08-30 19:19:41 +00:00
postMediumDeleteR :: MediumId -> Handler Html
postMediumDeleteR mediumId = do
checkRes <- mediumCheck mediumId
case checkRes of
Right medium -> do
confirm <- lookupPostParam "confirm"
case confirm of
Just "confirm" -> do
deleteMedium mediumId medium
setMessage "Medium succesfully deleted"
2015-09-14 16:54:46 +00:00
redirect HomeR
_ -> do
setMessage "You must confirm the deletion"
redirect $ MediumSettingsR mediumId
Left (errorMsg, route) -> do
setMessage errorMsg
2015-09-14 16:54:46 +00:00
redirect route
getMediumMoveR :: MediumId -> Handler Html
getMediumMoveR mId = do
checkRes <- mediumCheck mId
case checkRes of
Right medium -> do
(mediumMoveWidget, enctype) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm $
mediumMoveForm medium
defaultLayout $ do
setTitle "Eidolon :: Move Medium"
$(widgetFile "mediumMove")
Left (err, route) -> do
setMessage err
redirect route
postMediumMoveR :: MediumId -> Handler Html
postMediumMoveR mId = do
checkRes <- mediumCheck mId
case checkRes of
Right medium -> do
((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm $
mediumMoveForm medium
case res of
FormSuccess aId -> do
moveMedium medium mId aId
setMessage "Medium successfully moved"
redirect $ MediumR mId
2016-10-23 00:32:25 +00:00
_ -> do
setMessage "Error moving image"
redirect $ MediumR mId
2016-10-22 22:18:13 +00:00
Left (err, route) -> do
setMessage err
redirect route
mediumMoveForm :: Medium -> AForm Handler AlbumId
mediumMoveForm medium = id
<$> areq (selectField albums) (bfs ("Destination album" :: T.Text)) (Just $ mediumAlbum medium)
<* bootstrapSubmit ("Move medium" :: BootstrapSubmit Text)
where
albums = do
allEnts <- runDB $ selectList [] [Asc AlbumTitle]
ents <- return $ catMaybes $ map (\ent ->
if uId == albumOwner (entityVal ent) || uId `elem` albumShares (entityVal ent)
then Just ent
else Nothing
) allEnts
optionsPairs $ map (\alb -> ((albumTitle $ entityVal alb), entityKey alb)) ents
uId = mediumOwner medium