first toying around with avatars.

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

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

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

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

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

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

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)

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

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

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

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

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

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;

templates/avatars.hamlet

@@ -0,0 +1,18 @@
+$doctype 5
+
+<h3>
+  Avatars
+
+$if null avatars
+  <p>
+    _{MsgNoAvatars}
+$else
+  $forall (Entity aId avatar) <- avatars
+    <article .article>
+      <a href=@{ModifyAvatarR aId}>
+        <p>#{avatarIdent avatar}
+        <img src=@{GetAvatarR aId}>
+
+<ul>
+  <li>
+    <a href=@{NewAvatarR}>_{MsgNewAvatar}

templates/default-layout.hamlet

@@ -26,3 +26,5 @@
       <a href=@{JournalR}>_{MsgJournal}
     <span>
       <a href=@{SummaryR}>_{MsgSummary}
+    <span>
+      <a href=@{AvatarR}>_{MsgAvatars}

templates/modifyAvatar.hamlet

@@ -0,0 +1,8 @@
+$doctype 5
+
+<h3>_{MsgModifyAvatar}
+
+<form method=post enctype=#{enctype}>
+  ^{avatarModifyWidget}
+  <div>
+    <input type=submit value=_{MsgSubmit}>

templates/newAvatar.hamlet

@@ -0,0 +1,8 @@
+$doctype 5
+
+<h3>_{MsgNewAvatar}
+
+<form method=post enctype=#{enctype}>
+  ^{newAvatarWidget}
+  <div>
+    <input type=submit value=_{MsgSubmit}>

yammat.cabal

@@ -30,6 +30,7 @@ library
                      Handler.Summary
                      Handler.Modify
                      Handler.CashCheck
+                     Handler.Avatar
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -96,6 +97,7 @@ library
                  , blaze-builder                 < 0.4.0.0
                  , split
                  , conduit-extra
+                 , imagemagick
 
 executable         yammat
     if flag(library-only)