eidolon/Handler/MediumSettings.hs

--  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
--  along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Handler.MediumSettings where

import Import
import Yesod.Text.Markdown
import Handler.Commons
import System.FilePath
import qualified Data.Text as T
import Data.Maybe
import Text.Markdown
import Control.Monad (when)

getMediumSettingsR :: MediumId -> Handler Html
getMediumSettingsR mediumId = do
  checkRes <- mediumCheck mediumId
  case checkRes of
    Right medium -> do
      (mediumSettingsWidget, enctype) <- generateFormPost $
        renderBootstrap3 BootstrapBasicForm $
        mediumSettingsForm medium
      defaultLayout $ do
        setTitle "Eidolon :: Medium Settings"
        $(widgetFile "mediumSettings")
    Left (errorMsg, route) -> do
      setMessage errorMsg
      redirect route

postMediumSettingsR :: MediumId -> Handler Html
postMediumSettingsR mediumId = do
  checkRes <- mediumCheck mediumId
  case checkRes of
    Right medium -> do
      ((result, _), _) <- runFormPost $
        renderBootstrap3 BootstrapBasicForm $
        mediumSettingsForm medium
      case result of
        FormSuccess temp -> do
          _ <- runDB $ update mediumId
            [ MediumTitle =. msTitle temp
            , MediumDescription =. msDescription temp
            , MediumTags =. msTags temp
            , MediumLicence =. msLicence temp
            ]
          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
      redirect route

data MediumSettings = MediumSettings
  { msTitle       :: T.Text
  , msData        :: Maybe FileInfo
  , msDescription :: Maybe Markdown
  , msTags        :: [T.Text]
  , msLicence     :: Licence
  }

mediumSettingsForm :: Medium -> AForm Handler MediumSettings
mediumSettingsForm medium = MediumSettings
  <$> areq textField (bfs ("Title" :: T.Text)) (Just $ mediumTitle medium)
  <*> aopt fileField (bfs ("Update medium" :: T.Text)) (Nothing)
  <*> aopt markdownField (bfs ("Description" :: T.Text)) (Just $ mediumDescription medium)
  <*> areq tagField (bfs ("Tags" :: T.Text)) (Just $ mediumTags medium)
  <*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium)
  <*  bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
  where
    licences = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
      [minBound..maxBound]

getMediumDeleteR :: MediumId -> Handler Html
getMediumDeleteR mediumId = do
  checkRes <- mediumCheck mediumId
  case checkRes of
    Right medium ->
      defaultLayout $ do
        setTitle "Eidolon :: Delete Medium"
        $(widgetFile "mediumDelete")
    Left (errorMsg, route) -> do
      setMessage errorMsg
      redirect route

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"
          redirect HomeR
        _ -> do
          setMessage "You must confirm the deletion"
          redirect $ MediumSettingsR mediumId
    Left (errorMsg, route) -> do
      setMessage errorMsg
      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
        _ -> do
          setMessage "Error moving image"
          redirect $ MediumR mId
    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