From edc307a01ffce7afbcc2caa9fd06599439d263d7 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 16 Apr 2015 02:12:03 +0200 Subject: [PATCH] first toying around with avatars. --- Application.hs | 1 + Handler/Avatar.hs | 115 ++++++++++++++++++++++++++++++++ Handler/Modify.hs | 5 ++ Handler/NewUser.hs | 5 ++ Handler/Restock.hs | 5 ++ Handler/Summary.hs | 41 ++++++++---- config/models | 6 ++ config/routes | 4 ++ messages/cz.msg | 3 + messages/de.msg | 11 +++ messages/en.msg | 3 + messages/pl.msg | 3 + static/css/main.css | 8 ++- templates/avatars.hamlet | 18 +++++ templates/default-layout.hamlet | 2 + templates/modifyAvatar.hamlet | 8 +++ templates/newAvatar.hamlet | 8 +++ yammat.cabal | 2 + 18 files changed, 235 insertions(+), 13 deletions(-) create mode 100644 Handler/Avatar.hs create mode 100644 templates/avatars.hamlet create mode 100644 templates/modifyAvatar.hamlet create mode 100644 templates/newAvatar.hamlet diff --git a/Application.hs b/Application.hs index cb95dc5..a1ee869 100644 --- a/Application.hs +++ b/Application.hs @@ -35,6 +35,7 @@ import Handler.Payout import Handler.Summary import Handler.Modify import Handler.CashCheck +import Handler.Avatar -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the diff --git a/Handler/Avatar.hs b/Handler/Avatar.hs new file mode 100644 index 0000000..e8178da --- /dev/null +++ b/Handler/Avatar.hs @@ -0,0 +1,115 @@ +module Handler.Avatar where + +import Import +import Data.Conduit +import Data.Conduit.Binary +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Graphics.ImageMagick.MagickWand + +getAvatarR :: Handler Html +getAvatarR = do + avatars <- runDB $ selectList [] [Asc AvatarIdent] + defaultLayout $ do + $(widgetFile "avatars") + +getNewAvatarR :: Handler Html +getNewAvatarR = do + (newAvatarWidget, enctype) <- generateFormPost $ avatarNewForm + defaultLayout $ do + $(widgetFile "newAvatar") + +postNewAvatarR :: Handler Html +postNewAvatarR = do + ((res, _), _) <- runFormPost $ avatarNewForm + case res of + FormSuccess na -> do + raw <- runResourceT $ fileSource (avatarNewFile na) $$ sinkLbs + thumb <- generateThumb $ B.concat $ L.toChunks raw + runDB $ insert_ $ Avatar (avatarNewIdent na) thumb + 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 $ do + $(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) = do + runDB $ update aId [AvatarIdent =. ident] +updateAvatar aId (AvatarMod ident (Just fi)) = do + raw <- runResourceT $ fileSource fi $$ sinkLbs + thumb <- generateThumb $ B.concat $ L.toChunks raw + runDB $ update aId + [ AvatarIdent =. ident + , AvatarData =. thumb + ] + +generateThumb :: ByteString -> Handler ByteString +generateThumb raw = do + thumb <- liftIO $ withMagickWandGenesis $ do + (_, w) <- magickWand + readImageBlob w raw + w1 <- getImageWidth w + h1 <- getImageHeight w + h2 <- return 140 + w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2) :: Double) + resizeImage w w2 h2 lanczosFilter 1 + setImageCompressionQuality w 95 + setImageFormat w "png" + getImageBlob w + return thumb + +getGetAvatarR :: AvatarId -> Handler TypedContent +getGetAvatarR aId = do + avatar <- runDB $ get404 aId + return $ TypedContent typePng $ toContent $ avatarData avatar diff --git a/Handler/Modify.hs b/Handler/Modify.hs index 4cc4cac..d8fa0eb 100644 --- a/Handler/Modify.hs +++ b/Handler/Modify.hs @@ -44,6 +44,11 @@ modifyForm bev = renderDivs $ Beverage <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just $ beveragePrice bev) <*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev) <*> areq amountField (fieldSettingsLabel MsgAnnouncedStock) (Just $ beverageAlertAmount bev) + <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ beverageAvatar bev) + where + avatars = do + ents <- runDB $ selectList [] [Asc AvatarIdent] + optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents getDeleteBeverageR :: BeverageId -> Handler Html getDeleteBeverageR bId = do diff --git a/Handler/NewUser.hs b/Handler/NewUser.hs index 57bb7fd..b39f35b 100644 --- a/Handler/NewUser.hs +++ b/Handler/NewUser.hs @@ -33,6 +33,11 @@ newUserForm secs = renderDivs $ User <*> pure 0 <*> pure secs <*> aopt emailField (fieldSettingsLabel MsgEmailNotify) Nothing + <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) Nothing + where + avatars = do + ents <- runDB $ selectList [] [Asc AvatarIdent] + optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents data UserConf = UserConf { userConfEmail :: Maybe Text diff --git a/Handler/Restock.hs b/Handler/Restock.hs index d45c659..389c41d 100644 --- a/Handler/Restock.hs +++ b/Handler/Restock.hs @@ -72,3 +72,8 @@ newArticleForm = renderDivs $ Beverage <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just 100) <*> areq amountField (fieldSettingsLabel MsgAmount) (Just 0) <*> areq amountField (fieldSettingsLabel MsgAmountWarning) (Just 0) + <*> aopt (selectField albums) (fieldSettingsLabel MsgSelectAvatar) Nothing + where + albums = do + ents <- runDB $ selectList [] [Asc AvatarIdent] + optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents diff --git a/Handler/Summary.hs b/Handler/Summary.hs index 4e2a85e..7b59d4a 100644 --- a/Handler/Summary.hs +++ b/Handler/Summary.hs @@ -26,8 +26,15 @@ getSummaryJsonR = do ] ) bevs -instance ToJSON Beverage where - toJSON (Beverage ident price amount alertAmount) = +data BevStore = BevStore + { bevStoreIdent :: Text + , bevStorePrice :: Int + , bevStoreAmount :: Int + , bevStoreAlertAmount :: Int + } + +instance ToJSON BevStore where + toJSON (BevStore ident price amount alertAmount) = object [ "name" .= ident , "price" .= price @@ -35,8 +42,8 @@ instance ToJSON Beverage where , "alertAt" .= alertAmount ] -instance FromJSON Beverage where - parseJSON (Object o) = Beverage +instance FromJSON BevStore where + parseJSON (Object o) = BevStore <$> o .: "name" <*> o .: "price" <*> o .: "amount" @@ -49,7 +56,12 @@ getInventoryJsonR = do bevs <- runDB $ selectList [] [Asc BeverageIdent] return $ repJson $ array $ - map (\(Entity _ bev) -> toJSON bev) bevs + map (\(Entity _ bev) -> toJSON $ BevStore + (beverageIdent bev) + (beveragePrice bev) + (beverageAmount bev) + (beverageAlertAmount bev) + ) bevs getUploadInventoryJsonR :: Handler Html getUploadInventoryJsonR = do @@ -65,7 +77,7 @@ postUploadInventoryJsonR = do case fileContentType file == "application/json" of True -> do source <- runResourceT $ fileSource file $$ sinkLbs - bevs <- return $ fromMaybe [] $ (decode source :: Maybe [Beverage]) + bevs <- return $ fromMaybe [] $ (decode source :: Maybe [BevStore]) _ <- return $ map insOrUpd bevs setMessageI MsgRestoreSuccess redirect $ HomeR @@ -80,15 +92,20 @@ uploadJsonForm :: Form FileInfo uploadJsonForm = renderDivs $ areq fileField (fieldSettingsLabel MsgSelectFile) Nothing -insOrUpd :: Beverage -> Handler () +insOrUpd :: BevStore -> Handler () insOrUpd bev = do - meb <- runDB $ getBy $ UniqueBeverage $ beverageIdent bev + meb <- runDB $ getBy $ UniqueBeverage $ bevStoreIdent bev case meb of Just eb -> do runDB $ update (entityKey eb) - [ BeveragePrice =. beveragePrice bev - , BeverageAmount =. beverageAmount bev - , BeverageAlertAmount =. beverageAlertAmount bev + [ BeveragePrice =. bevStorePrice bev + , BeverageAmount =. bevStoreAmount bev + , BeverageAlertAmount =. bevStoreAlertAmount bev ] Nothing -> do - runDB $ insert_ bev + runDB $ insert_ $ Beverage + (bevStoreIdent bev) + (bevStorePrice bev) + (bevStoreAmount bev) + (bevStoreAlertAmount bev) + Nothing diff --git a/config/models b/config/models index fb79c9c..2e1bd65 100644 --- a/config/models +++ b/config/models @@ -3,6 +3,7 @@ User balance Int timestamp Int email Text Maybe + avatar AvatarId Maybe UniqueUser ident deriving Typeable Show Beverage @@ -10,6 +11,7 @@ Beverage price Int amount Int alertAmount Int + avatar AvatarId Maybe UniqueBeverage ident deriving Typeable Show Transaction @@ -25,5 +27,9 @@ CashCheck balance Int time UTCTime deriving Typeable Show +Avatar + ident Text + data ByteString + deriving Typeable Show -- By default this file is used in Model.hs (which is imported by Foundation.hs) diff --git a/config/routes b/config/routes index 9713584..dcabcfc 100644 --- a/config/routes +++ b/config/routes @@ -25,3 +25,7 @@ /cashcheck CashCheckR GET POST /backup UploadInventoryJsonR GET POST /backup/inventory.json InventoryJsonR GET +/avatars AvatarR GET +/avatar/#AvatarId GetAvatarR GET +/avatar/#AvatarId/modify ModifyAvatarR GET POST +/newavatar NewAvatarR GET POST diff --git a/messages/cz.msg b/messages/cz.msg index f4c0af7..abadd22 100644 --- a/messages/cz.msg +++ b/messages/cz.msg @@ -83,3 +83,6 @@ RestoreFromBackup: Nahrát záĺohu NegativeRecharge: Nelze nabít negativní obnos Increment: ++ Decrement: -- +SelectAvatar: Vyber avatar +NoAvatars: žádné avatary +ModifyAvatar: Modify avatar diff --git a/messages/de.msg b/messages/de.msg index 56d081b..8106443 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -83,3 +83,14 @@ RestoreFromBackup: Inventar wiederherstellen NegativeRecharge: Keine negativen Beträge aufladen Increment: ++ Decrement: -- +SelectAvatar: Avatar auswählen +Avatars: Avatare +NoAvatars: Keine Avatare +ModifyAvatar: Avatar bearbeiten +AvatarUnknown: Unbekannter Avatar +AvatarUpdateSuccessfull: Avatar erfolgreich aktualisiert +AvatarIdent: Avtarname +AvatarFileChange: Datei auswählen um Avatar zu ändern +AvatarFile: Datei für den Avatar +NewAvatar: Neuer Avatar +AvatarUploadSuccessfull: Avatar erfolgreich hochgeladen diff --git a/messages/en.msg b/messages/en.msg index c29a7e4..f6f02fa 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -83,3 +83,6 @@ RestoreFromBackup: Restore from backup NegativeRecharge: You can not recharge negative amounts Increment: ++ Decrement: -- +SelectAvatar: Select avatar +NoAvatars: No avatars +ModifyAvatar: Modify avatar diff --git a/messages/pl.msg b/messages/pl.msg index af80977..db38b9d 100644 --- a/messages/pl.msg +++ b/messages/pl.msg @@ -83,3 +83,6 @@ RestoreFromBackup: przywróć z kopii zapasowej NegativeRecharge: You can not recharge negative amounts Increment: ++ Decrement: -- +SelectAvatar: SelectAvatar +NoAvatars: No avatars +ModifyAvatar: Modify avatar diff --git a/static/css/main.css b/static/css/main.css index 203d48b..6e637fb 100644 --- a/static/css/main.css +++ b/static/css/main.css @@ -31,7 +31,13 @@ article#func.article { overflow: hidden; } -.article p { +.article a img { + position: relative; + top: -7.75em; + text-align: left; +} + +.article a p { display: inline-block; vertical-align: middle; line-height: normal; diff --git a/templates/avatars.hamlet b/templates/avatars.hamlet new file mode 100644 index 0000000..486fe1c --- /dev/null +++ b/templates/avatars.hamlet @@ -0,0 +1,18 @@ +$doctype 5 + +

+ Avatars + +$if null avatars +

+ _{MsgNoAvatars} +$else + $forall (Entity aId avatar) <- avatars +

+ +

#{avatarIdent avatar} + + +