albums can now be shared with other users

Handler/AdminAlbumSettings.hs

@@ -63,7 +63,9 @@ getAdminAlbumSettingsR albumId = do
           tempAlbum <- runDB $ get albumId
           case tempAlbum of
             Just album -> do
-              (adminAlbumSettingsWidget, enctype) <- generateFormPost $ adminAlbumSettingsForm album albumId
+              entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
+              users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
+              (adminAlbumSettingsWidget, enctype) <- generateFormPost $ adminAlbumSettingsForm album albumId users
               defaultLayout $ do
                 setTitle "Administration: Album settings"
                 $(widgetFile "adminAlbumSet")
@@ -89,11 +91,14 @@ postAdminAlbumSettingsR albumId = do
           tempAlbum <- runDB $ get albumId
           case tempAlbum of
             Just album -> do
-              ((res, adminAlbumSettingsWidget), enctype) <- runFormPost $ adminAlbumSettingsForm album albumId
+              entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
+              users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
+              ((res, adminAlbumSettingsWidget), enctype) <- runFormPost $ adminAlbumSettingsForm album albumId users
               case res of
                 FormSuccess temp -> do
                   aId <- runDB $ update albumId
                     [ AlbumTitle =. albumTitle temp
+                    , AlbumShares =. albumShares temp
                     , AlbumSamplePic =. albumSamplePic temp
                     ]
                   setMessage "Album settings changed successfully"
@@ -111,16 +116,20 @@ postAdminAlbumSettingsR albumId = do
       setMessage "You must be logged in"
       redirect $ LoginR
 
-adminAlbumSettingsForm :: Album -> AlbumId -> Form Album
+adminAlbumSettingsForm :: Album -> AlbumId -> [(Text, UserId)] -> Form Album
-adminAlbumSettingsForm album albumId = renderDivs $ Album
+adminAlbumSettingsForm album albumId users = renderDivs $ Album
   <$> areq textField "Title" (Just $ albumTitle album)
   <*> pure (albumOwner album)
+  <*> areq (userField users) "This album shared with" (Just $ albumShares album)
   <*> pure (albumContent album)
   <*> aopt (selectField media) "Sample picture" (Just $ albumSamplePic album)
   where
     media = do
       entities <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTitle]
       optionsPairs $ map (\med -> (mediumTitle $ entityVal med, mediumPath (entityVal med))) entities
+--    userNames =
+--      let entities = runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
+--      in map (\ent -> (userName $ entityVal ent, entityKey ent)) entities
 
 getAdminAlbumDeleteR :: AlbumId -> Handler Html
 getAdminAlbumDeleteR albumId = do

Handler/Album.hs

@@ -15,9 +15,9 @@ getAlbumR albumId = do
       presence <- case msu of
         Just tempUserId -> do
           userId <- return $ getUserIdFromText tempUserId
-          return (userId == ownerId)
+          return $ (userId == ownerId) || (userId `elem` (albumShares album))
         Nothing ->
-         return False
+          return False
 --      media <- mapM (\a -> runDB $ getJust a) (albumContent album)
       media <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime]
       defaultLayout $ do

Handler/AlbumSettings.hs

@@ -17,10 +17,13 @@ getAlbumSettingsR albumId = do
       case msu of
         Just tempUserId -> do
           userId <- return $ getUserIdFromText tempUserId
-          presence <- return (userId == ownerId)
+          ownerPresence <- return (userId == ownerId)
-          case presence of
+          presence <- return $ userId `elem` (albumShares album)
+          case ownerPresence || presence of
             True -> do
-              (albumSettingsWidget, enctype) <- generateFormPost $ albumSettingsForm album albumId
+              entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
+              users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
+              (albumSettingsWidget, enctype) <- generateFormPost $ albumSettingsForm album albumId users
               defaultLayout $ do
                 setTitle "Eidolon :: Album Settings"
                 $(widgetFile "albumSettings")
@@ -46,14 +49,18 @@ postAlbumSettingsR albumId = do
       case msu of
         Just tempUserId -> do
           userId <- return $ getUserIdFromText tempUserId
-          presence <- return (userId == ownerId)
+          ownerPresence <- return (userId == ownerId)
-          case presence of
+          presence <- return $ userId `elem` (albumShares album)
+          case ownerPresence || presence of
             True -> do
-              ((result, albumSettingsWidget), enctype) <- runFormPost $ albumSettingsForm album albumId
+              entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
+              users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
+              ((result, albumSettingsWidget), enctype) <- runFormPost $ albumSettingsForm album albumId users
               case result of
                 FormSuccess temp -> do
                   aId <- runDB $ update albumId 
                     [ AlbumTitle =. albumTitle temp
+                    , AlbumShares =. albumShares temp
                     , AlbumSamplePic =. albumSamplePic temp
                     ]
                   setMessage "Album settings changed succesfully"
@@ -71,16 +78,20 @@ postAlbumSettingsR albumId = do
       setMessage "This album does not exist"
       redirect $ HomeR
 
-albumSettingsForm :: Album -> AlbumId -> Form Album
+albumSettingsForm :: Album -> AlbumId -> [(Text, UserId)]-> Form Album
-albumSettingsForm album albumId = renderDivs $ Album
+albumSettingsForm album albumId users = renderDivs $ Album
   <$> areq textField "Title" (Just $ albumTitle album)
   <*> pure (albumOwner album)
+  <*> areq (userField users) "Share this album with" (Just $ albumShares album)
   <*> pure (albumContent album)
   <*> aopt (selectField media) "Sample picture" (Just $ albumSamplePic album)
   where
     media = do
       entities <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTitle]
       optionsPairs $ map (\med -> (mediumTitle $ entityVal med, mediumThumb (entityVal med))) entities
+--    users = do
+--      entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
+--      return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
 
 getAlbumDeleteR :: AlbumId -> Handler Html
 getAlbumDeleteR albumId = do

Handler/NewAlbum.hs

@@ -52,4 +52,5 @@ albumForm userId = renderDivs $ Album
   <$> areq textField "Title" Nothing
   <*> pure userId
   <*> pure []
+  <*> pure []
   <*> pure Nothing

Handler/Profile.hs

@@ -11,6 +11,13 @@ getProfileR ownerId = do
     Just owner -> do
       ownerSlug <- lift $ pure $ userSlug owner
       userAlbs <- runDB $ selectList [AlbumOwner ==. ownerId] [Asc AlbumTitle]
+      allAlbs <- runDB $ selectList [] [Asc AlbumTitle]
+      almostAlbs <- mapM (\alb -> do
+        case ownerId `elem` (albumShares $ entityVal alb) of
+          True -> return $ Just alb
+          False -> return Nothing
+        ) allAlbs
+      sharedAlbs <- return $ removeItem Nothing almostAlbs
       recentMedia <- (runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTime])
       msu <- lookupSession "userId"
       presence <- case msu of

Handler/Upload.hs

@@ -2,6 +2,7 @@ module Handler.Upload where
 
 import Import as I
 import Data.Time
+import Data.Maybe
 import qualified Data.Text as T
 import qualified System.FilePath as FP
 import qualified Filesystem.Path as FSP
@@ -89,8 +90,8 @@ getDirectUploadR albumId = do
       case msu of -- is anybody logged in
         Just tempUserId -> do
           userId <- return $ getUserIdFromText tempUserId
-          presence <- return (userId == ownerId)
+          presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album))
-          case presence of -- is the owner present
+          case presence of -- is the owner present or a user with whom the album is shared
             True -> do
               (dUploadWidget, enctype) <- generateFormPost $ dUploadForm userId albumId
               defaultLayout $ do
@@ -118,8 +119,8 @@ postDirectUploadR albumId = do
       case msu of -- is anybody logged in
         Just tempUserId -> do
           userId <- return $ getUserIdFromText tempUserId
-          presence <- return (userId == ownerId)
+          presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album))
-          case presence of -- is the logged in user the owner
+          case presence of -- is the logged in user the owner or is the album shared with him
             True -> do
               ((result, dUploadWidget), enctype) <- runFormPost (dUploadForm userId albumId)
               case result of
@@ -193,18 +194,27 @@ writeOnDrive fil userId albumId = do
   return path
 
 uploadForm :: UserId -> Form TempMedium
-uploadForm userId = renderDivs $ TempMedium
+uploadForm userId = renderDivs $ (\a b c d e f g -> TempMedium b c d e f g a)
-  <$> areq textField "Title" Nothing
+  <$> areq (selectField albums) "Album" Nothing
+  <*> areq textField "Title" Nothing
   <*> areq fileField "Select file" Nothing
   <*> lift (liftIO getCurrentTime)
   <*> pure userId
   <*> areq textareaField "Description" Nothing
   <*> areq tagField "Enter tags" Nothing
-  <*> areq (selectField albums) "Album" Nothing
   where
 --    albums :: GHandler App App (OptionList AlbumId)
     albums = do
-      entities <- runDB $ selectList [AlbumOwner ==. userId] [Desc AlbumTitle]
+      allEnts <- runDB $ selectList [] [Desc AlbumTitle]
+      entities <- return $
+        map fromJust $
+        removeItem Nothing $ map
+          (\ent -> do
+            case (userId == (albumOwner $ entityVal ent)) || (userId `elem` (albumShares $ entityVal ent)) of
+              True -> Just ent
+              False -> Nothing
+            ) allEnts
+--      entities <- runDB $ selectList [AlbumOwner ==. userId] [Desc AlbumTitle]
       optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities
 
 dUploadForm :: UserId -> AlbumId -> Form TempMedium

Helper.hs

@@ -8,6 +8,7 @@ module Helper
   , makeRandomToken
   , generateSalt
   , tagField
+  , userField
   , sendMail
   , generateString
   , removeItem
@@ -79,7 +80,7 @@ makeRandomToken = (T.pack . take 16 . randoms) `fmap` newStdGen
 generateSalt :: IO B.ByteString
 generateSalt = (B.pack . take 8 . randoms) <$> getStdGen
 
--- tagField :: Field Handler [T.Text]
+tagField :: Monad m => Field m [T.Text]
 tagField = Field
   { fieldParse = \rawVals _ -> do
       case rawVals of
@@ -92,6 +93,26 @@ tagField = Field
   , fieldEnctype = UrlEncoded
   }
 
+userField :: Monad m => [(T.Text, UserId)] -> Field m [UserId]
+userField users = Field
+  { fieldParse = \rawVals _ -> do
+      case rawVals of
+        [x] -> case x == "" of
+          False ->
+            -- clean = removeItem "" $ T.splitOn " " x
+            let ids = map (\u -> lookup u users) (removeItem "" $ T.splitOn " " x)
+            in case Nothing `elem` ids of
+                False -> return $ Right $ Just $ map fromJust ids
+                True -> return $ Left $ error "Invalid username list"
+          True -> return $ Right $ Just $ []
+        _ -> return $ Left $ error "unexpected username list"
+  , fieldView = \idAttr nameAttr val eResult isReq ->
+      [whamlet|<input id=#{idAttr} type="text" name=#{nameAttr} value=#{either id (getUsersFromResult users) eResult}>|]
+  , fieldEnctype = UrlEncoded
+  }
+
+getUsersFromResult users res = T.intercalate " " $ map (\x -> fromMaybe "" $ reverseLookup x users) res
+
 sendMail :: MonadIO m => T.Text -> T.Text -> Html -> m ()
 sendMail toEmail subject body =
   liftIO $ renderSendMail
@@ -119,5 +140,11 @@ removeItem x (y:ys)
   | x == y    = removeItem x ys
   | otherwise = y : removeItem x ys
 
+reverseLookup :: Eq b => b -> [(a, b)] -> Maybe a
+reverseLookup s ((x, y):zs)
+  | s == y    = Just x
+  | s /= y    = reverseLookup s zs
+  | otherwise = Nothing
+
 acceptedTypes :: [T.Text]
 acceptedTypes = ["image/jpeg", "image/jpg", "image/png", "image/x-ms-bmp", "image/x-bmp", "image/bmp", "image/tiff", "image/tiff-fx"]

config/models

@@ -19,6 +19,7 @@ Token
 Album
     title Text
     owner UserId
+    shares [UserId]
     content [MediumId]
     samplePic FilePath Maybe
     deriving Eq Show

templates/albumSettings.hamlet

@@ -5,5 +5,5 @@ $newline always
   ^{albumSettingsWidget}
   <div>
     <input type=submit value="Change settings">
-
+$if ownerPresence == True
-<a href=@{AlbumDeleteR albumId}>Delete this album
+  <a href=@{AlbumDeleteR albumId}>Delete this album

templates/dUpload.hamlet

@@ -1,4 +1,4 @@
-<h3>Image upload
+<h3>Image upload to album #{albumTitle album}
 
 Here you can upload your image.
 

templates/profile.hamlet

@@ -4,9 +4,7 @@ $if presence == True
   <a href=@{ProfileSettingsR ownerId}>Change your profile settings
 
 $if null userAlbs
-  <ul class="noalbum">
+  <p>This user has no albums yet
-    <li>
-      This user has no albums yet
 $else
   <p>Albums of this user:
   <ul>
@@ -20,6 +18,20 @@ $else
               <img src=#{T.pack $ fromJust $ albumSamplePic album}>
             <figcaption>#{albumTitle album}
 
+$if null sharedAlbs
+$else
+  <p>Albums shared with this user:
+  <ul>
+    $forall Just (Entity albumId album) <- sharedAlbs
+      <li>
+        <a href=@{AlbumR albumId}>
+          <figure class="thumbnail">
+            $if (albumSamplePic album) == Nothing
+              <img src="/static/img/album.jpg"><br>
+            $else
+              <img src=#{T.pack $ fromJust $ albumSamplePic album}>
+            <figcaption>#{albumTitle album}
+
 $if null recentMedia
   This user has not uploaded any images
 $else