-- yammat - Yet Another MateMAT -- 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 . module Handler.Avatar where import Import import Data.Conduit.Binary import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Base64 import Graphics.ImageMagick.MagickWand import qualified Crypto.Hash.SHA3 as SHA3 getAvatarR :: Handler Html getAvatarR = do avatars <- runDB $ selectList [] [Asc AvatarIdent] defaultLayout $ $(widgetFile "avatars") getNewAvatarR :: Handler Html getNewAvatarR = do (newAvatarWidget, enctype) <- generateFormPost avatarNewForm defaultLayout $ $(widgetFile "newAvatar") postNewAvatarR :: Handler Html postNewAvatarR = do ((res, _), _) <- runFormPost avatarNewForm case res of FormSuccess na -> do raw <- runResourceT $ fileSource (avatarNewFile na) $$ sinkLbs (thumb, hash) <- generateThumb $ B.concat $ L.toChunks raw runDB $ insert_ $ Avatar (avatarNewIdent na) thumb hash setMessageI MsgAvatarUploadSuccessfull redirect HomeR _ -> do setMessageI MsgErrorOccured redirect NewAvatarR avatarNewForm :: Form AvatarNew avatarNewForm = renderDivs $ AvatarNew <$> areq textField (fieldSettingsLabel MsgAvatarIdent) Nothing <*> areq fileField (fieldSettingsLabel MsgAvatarFile) Nothing data AvatarNew = AvatarNew { avatarNewIdent :: Text , avatarNewFile :: FileInfo } getModifyAvatarR :: AvatarId -> Handler Html getModifyAvatarR aId = do ma <- runDB $ get aId case ma of Just avatar -> do (avatarModifyWidget, enctype) <- generateFormPost $ avatarModForm avatar defaultLayout $ $(widgetFile "modifyAvatar") Nothing -> do setMessageI MsgAvatarUnknown redirect AvatarR postModifyAvatarR :: AvatarId -> Handler Html postModifyAvatarR aId = do ma <- runDB $ get aId case ma of Just avatar -> do ((res, _), _) <- runFormPost $ avatarModForm avatar case res of FormSuccess md -> do updateAvatar aId md setMessageI MsgAvatarUpdateSuccessfull redirect AvatarR _ -> do setMessageI MsgErrorOccured redirect $ ModifyAvatarR aId Nothing -> do setMessageI MsgAvatarUnknown redirect HomeR avatarModForm :: Avatar -> Form AvatarMod avatarModForm a = renderDivs $ AvatarMod <$> areq textField (fieldSettingsLabel MsgAvatarIdent) (Just $ avatarIdent a) <*> aopt fileField (fieldSettingsLabel MsgAvatarFileChange) Nothing data AvatarMod = AvatarMod { avatarModIdent :: Text , avatarModFile :: Maybe FileInfo } updateAvatar :: AvatarId -> AvatarMod -> Handler () updateAvatar aId (AvatarMod ident Nothing) = runDB $ update aId [AvatarIdent =. ident] updateAvatar aId (AvatarMod ident (Just fi)) = do raw <- runResourceT $ fileSource fi $$ sinkLbs (thumb, hash) <- generateThumb $ B.concat $ L.toChunks raw runDB $ update aId [ AvatarIdent =. ident , AvatarData =. thumb , AvatarHash =. hash ] generateThumb :: ByteString -> Handler (ByteString, ByteString) generateThumb raw = do thumb <- liftIO $ withMagickWandGenesis $ do (_, w) <- magickWand readImageBlob w raw w1 <- getImageWidth w h1 <- getImageHeight w let h2 = 140 :: Int let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double) :: Int resizeImage w w2 h2 lanczosFilter 1 setImageCompressionQuality w 95 setImageFormat w "png" getImageBlob w let h = encode (SHA3.hash 32 thumb) return (thumb, h) getGetAvatarR :: AvatarId -> Handler TypedContent getGetAvatarR aId = do avatar <- runDB $ get404 aId setEtag $ decodeUtf8 $ avatarHash avatar return $ TypedContent typePng $ toContent $ avatarData avatar getAvatarDeleteR :: AvatarId -> Handler Html getAvatarDeleteR aId = do ma <- runDB $ get aId case ma of Just _ -> do c <- runDB $ selectList [UserAvatar ==. Just aId] [] d <- runDB $ selectList [BeverageAvatar ==. Just aId] [] e <- runDB $ selectList [SupplierAvatar ==. Just aId] [] if null c && null d && null e then do runDB $ delete aId setMessageI MsgAvatarDeleted redirect HomeR else do setMessageI MsgAvatarInUseError redirect AvatarR Nothing -> do setMessageI MsgAvatarUnknown redirect AvatarR