2015-08-09 19:16:33 +00:00
|
|
|
-- 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 <http://www.gnu.org/licenses/>.
|
2015-04-16 00:12:03 +00:00
|
|
|
module Handler.Avatar where
|
|
|
|
|
|
|
|
import Import
|
2015-10-22 21:57:27 +00:00
|
|
|
import Handler.Common
|
2015-04-16 00:12:03 +00:00
|
|
|
import Data.Conduit.Binary
|
|
|
|
import qualified Data.ByteString as B
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
2015-09-16 23:53:50 +00:00
|
|
|
import Data.ByteString.Base64
|
2016-05-08 22:03:17 +00:00
|
|
|
import Data.Maybe (fromJust)
|
2015-09-16 18:28:30 +00:00
|
|
|
import qualified Crypto.Hash.SHA3 as SHA3
|
2016-05-08 22:03:17 +00:00
|
|
|
import Codec.Picture
|
|
|
|
import Codec.Picture.Metadata as PM hiding (delete)
|
|
|
|
import Codec.Picture.ScaleDCT
|
2015-04-16 00:12:03 +00:00
|
|
|
|
|
|
|
getAvatarR :: Handler Html
|
|
|
|
getAvatarR = do
|
|
|
|
avatars <- runDB $ selectList [] [Asc AvatarIdent]
|
2018-09-04 16:06:12 +00:00
|
|
|
defaultLayout $ do
|
|
|
|
setTitleI MsgAvatars
|
2015-04-16 00:12:03 +00:00
|
|
|
$(widgetFile "avatars")
|
|
|
|
|
|
|
|
getNewAvatarR :: Handler Html
|
|
|
|
getNewAvatarR = do
|
2015-10-22 21:57:27 +00:00
|
|
|
(newAvatarWidget, enctype) <- generateFormPost
|
|
|
|
$ renderBootstrap3 BootstrapBasicForm $ avatarNewForm
|
2018-09-04 16:06:12 +00:00
|
|
|
defaultLayout $ do
|
|
|
|
setTitleI MsgNewAvatar
|
2015-04-16 00:12:03 +00:00
|
|
|
$(widgetFile "newAvatar")
|
|
|
|
|
|
|
|
postNewAvatarR :: Handler Html
|
|
|
|
postNewAvatarR = do
|
2015-10-22 21:57:27 +00:00
|
|
|
((res, _), _) <- runFormPost
|
|
|
|
$ renderBootstrap3 BootstrapBasicForm avatarNewForm
|
2015-04-16 00:12:03 +00:00
|
|
|
case res of
|
|
|
|
FormSuccess na -> do
|
|
|
|
raw <- runResourceT $ fileSource (avatarNewFile na) $$ sinkLbs
|
2016-05-08 22:03:17 +00:00
|
|
|
tdata <- generateThumb $ B.concat $ L.toChunks raw
|
|
|
|
runDB $ insert_ $ Avatar
|
|
|
|
(avatarNewIdent na)
|
|
|
|
(thumbContent tdata)
|
|
|
|
(thumbHash tdata)
|
2015-04-16 00:12:03 +00:00
|
|
|
setMessageI MsgAvatarUploadSuccessfull
|
2015-09-14 22:49:13 +00:00
|
|
|
redirect HomeR
|
2015-04-16 00:12:03 +00:00
|
|
|
_ -> do
|
|
|
|
setMessageI MsgErrorOccured
|
2015-09-14 22:49:13 +00:00
|
|
|
redirect NewAvatarR
|
2015-04-16 00:12:03 +00:00
|
|
|
|
2015-10-22 21:57:27 +00:00
|
|
|
avatarNewForm :: AForm Handler AvatarNew
|
|
|
|
avatarNewForm = AvatarNew
|
|
|
|
<$> areq textField (bfs MsgAvatarIdent) Nothing
|
|
|
|
<*> areq fileField (bfs MsgAvatarFile) Nothing
|
|
|
|
<* bootstrapSubmit (msgToBSSubmit MsgSubmit)
|
2015-04-16 00:12:03 +00:00
|
|
|
|
|
|
|
data AvatarNew = AvatarNew
|
|
|
|
{ avatarNewIdent :: Text
|
|
|
|
, avatarNewFile :: FileInfo
|
|
|
|
}
|
|
|
|
|
|
|
|
getModifyAvatarR :: AvatarId -> Handler Html
|
|
|
|
getModifyAvatarR aId = do
|
|
|
|
ma <- runDB $ get aId
|
|
|
|
case ma of
|
|
|
|
Just avatar -> do
|
2015-10-22 21:57:27 +00:00
|
|
|
(avatarModifyWidget, enctype) <- generateFormPost
|
|
|
|
$ renderBootstrap3 BootstrapBasicForm
|
|
|
|
$ avatarModForm avatar
|
2018-09-04 16:06:12 +00:00
|
|
|
defaultLayout $ do
|
|
|
|
setTitleI MsgModifyAvatar
|
2015-04-16 00:12:03 +00:00
|
|
|
$(widgetFile "modifyAvatar")
|
|
|
|
Nothing -> do
|
|
|
|
setMessageI MsgAvatarUnknown
|
2015-09-14 22:49:13 +00:00
|
|
|
redirect AvatarR
|
2015-04-16 00:12:03 +00:00
|
|
|
|
|
|
|
postModifyAvatarR :: AvatarId -> Handler Html
|
|
|
|
postModifyAvatarR aId = do
|
|
|
|
ma <- runDB $ get aId
|
|
|
|
case ma of
|
|
|
|
Just avatar -> do
|
2015-10-22 21:57:27 +00:00
|
|
|
((res, _), _) <- runFormPost
|
|
|
|
$ renderBootstrap3 BootstrapBasicForm
|
|
|
|
$ avatarModForm avatar
|
2015-04-16 00:12:03 +00:00
|
|
|
case res of
|
|
|
|
FormSuccess md -> do
|
|
|
|
updateAvatar aId md
|
|
|
|
setMessageI MsgAvatarUpdateSuccessfull
|
2015-09-14 22:49:13 +00:00
|
|
|
redirect AvatarR
|
2015-04-16 00:12:03 +00:00
|
|
|
_ -> do
|
|
|
|
setMessageI MsgErrorOccured
|
|
|
|
redirect $ ModifyAvatarR aId
|
|
|
|
Nothing -> do
|
|
|
|
setMessageI MsgAvatarUnknown
|
2015-09-14 22:49:13 +00:00
|
|
|
redirect HomeR
|
2015-04-16 00:12:03 +00:00
|
|
|
|
2015-10-22 21:57:27 +00:00
|
|
|
avatarModForm :: Avatar -> AForm Handler AvatarMod
|
|
|
|
avatarModForm a = AvatarMod
|
|
|
|
<$> areq textField (bfs MsgAvatarIdent) (Just $ avatarIdent a)
|
|
|
|
<*> aopt fileField (bfs MsgAvatarFileChange) Nothing
|
|
|
|
<* bootstrapSubmit (msgToBSSubmit MsgSubmit)
|
2015-04-16 00:12:03 +00:00
|
|
|
|
|
|
|
data AvatarMod = AvatarMod
|
|
|
|
{ avatarModIdent :: Text
|
|
|
|
, avatarModFile :: Maybe FileInfo
|
|
|
|
}
|
|
|
|
|
|
|
|
updateAvatar :: AvatarId -> AvatarMod -> Handler ()
|
2015-09-14 22:49:13 +00:00
|
|
|
updateAvatar aId (AvatarMod ident Nothing) =
|
2015-04-16 00:12:03 +00:00
|
|
|
runDB $ update aId [AvatarIdent =. ident]
|
|
|
|
updateAvatar aId (AvatarMod ident (Just fi)) = do
|
|
|
|
raw <- runResourceT $ fileSource fi $$ sinkLbs
|
2016-05-08 22:03:17 +00:00
|
|
|
tdata <- generateThumb $ B.concat $ L.toChunks raw
|
2015-04-16 00:12:03 +00:00
|
|
|
runDB $ update aId
|
|
|
|
[ AvatarIdent =. ident
|
2016-05-08 22:03:17 +00:00
|
|
|
, AvatarData =. thumbContent tdata
|
|
|
|
, AvatarHash =. thumbHash tdata
|
2015-04-16 00:12:03 +00:00
|
|
|
]
|
|
|
|
|
2016-05-08 22:03:17 +00:00
|
|
|
data ThumbData = ThumbData
|
|
|
|
{ thumbContent :: ByteString
|
|
|
|
, thumbHash :: ByteString
|
|
|
|
}
|
|
|
|
|
|
|
|
generateThumb :: ByteString -> Handler ThumbData
|
2015-09-16 18:28:30 +00:00
|
|
|
generateThumb raw = do
|
2016-05-08 22:03:17 +00:00
|
|
|
let eimg = decodeImageWithMetadata raw
|
|
|
|
case eimg of
|
|
|
|
Left e -> error e
|
|
|
|
Right (img, meta) ->
|
|
|
|
return $ ThumbData
|
|
|
|
{ thumbContent = ava
|
|
|
|
, thumbHash = h
|
|
|
|
}
|
|
|
|
where
|
|
|
|
w1 = fromIntegral $ fromJust $ PM.lookup Width meta :: Int
|
|
|
|
h1 = fromIntegral $ fromJust $ PM.lookup Height meta :: Int
|
|
|
|
h2 = 140 :: Int
|
|
|
|
w2 = floor ((fromIntegral w1 :: Double) / (fromIntegral h1 :: Double) * (fromIntegral h2 :: Double)) :: Int
|
|
|
|
scimg = scale (w2, h2) $ convertRGBA8 img
|
|
|
|
ava = (B.concat . L.toChunks) $ encodePng scimg
|
|
|
|
h = encode (SHA3.hash 32 ava)
|
2015-04-16 00:12:03 +00:00
|
|
|
|
|
|
|
getGetAvatarR :: AvatarId -> Handler TypedContent
|
|
|
|
getGetAvatarR aId = do
|
|
|
|
avatar <- runDB $ get404 aId
|
2015-09-16 18:28:30 +00:00
|
|
|
setEtag $ decodeUtf8 $ avatarHash avatar
|
2015-04-16 00:12:03 +00:00
|
|
|
return $ TypedContent typePng $ toContent $ avatarData avatar
|
2015-04-16 01:12:05 +00:00
|
|
|
|
|
|
|
getAvatarDeleteR :: AvatarId -> Handler Html
|
|
|
|
getAvatarDeleteR aId = do
|
|
|
|
ma <- runDB $ get aId
|
|
|
|
case ma of
|
|
|
|
Just _ -> do
|
2015-04-17 22:04:13 +00:00
|
|
|
c <- runDB $ selectList [UserAvatar ==. Just aId] []
|
2015-06-23 23:48:06 +00:00
|
|
|
d <- runDB $ selectList [BeverageAvatar ==. Just aId] []
|
2015-10-11 18:07:12 +00:00
|
|
|
e <- runDB $ selectList [SupplierAvatar ==. Just aId] []
|
|
|
|
if null c && null d && null e
|
2015-09-14 22:49:13 +00:00
|
|
|
then do
|
2015-04-17 22:04:13 +00:00
|
|
|
runDB $ delete aId
|
|
|
|
setMessageI MsgAvatarDeleted
|
2015-09-14 22:49:13 +00:00
|
|
|
redirect HomeR
|
|
|
|
else do
|
2015-04-17 22:04:13 +00:00
|
|
|
setMessageI MsgAvatarInUseError
|
2015-09-14 22:49:13 +00:00
|
|
|
redirect AvatarR
|
2015-04-16 01:12:05 +00:00
|
|
|
Nothing -> do
|
|
|
|
setMessageI MsgAvatarUnknown
|
2015-09-14 22:49:13 +00:00
|
|
|
redirect AvatarR
|