yammat/Handler/Avatar.hs

178 lines
5.6 KiB
Haskell
Raw Normal View History

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
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]
2015-09-14 22:49:13 +00:00
defaultLayout $
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
2015-09-14 22:49:13 +00:00
defaultLayout $
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
2015-09-14 22:49:13 +00:00
defaultLayout $
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
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
runDB $ delete aId
setMessageI MsgAvatarDeleted
2015-09-14 22:49:13 +00:00
redirect HomeR
else do
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