starting out

Generalizing some functions and start of implementation to move media
between albums.

Handler/AdminMediumSettings.hs

@@ -109,28 +109,29 @@ getAdminMediumDeleteR mediumId = do
       tempMedium <- runDB $ get mediumId
       case tempMedium of
         Just medium -> do
-          -- remove reference from album
+          -- -- remove reference from album
-          let albumId = mediumAlbum medium
+          -- let albumId = mediumAlbum medium
-          album <- runDB $ getJust albumId
+          -- album <- runDB $ getJust albumId
-          let mediaList = albumContent album
+          -- let mediaList = albumContent album
-          let newMediaList = removeItem mediumId mediaList
+          -- let newMediaList = removeItem mediumId mediaList
-          runDB $ update albumId [AlbumContent =. newMediaList]
+          -- runDB $ update albumId [AlbumContent =. newMediaList]
-          -- delete comments
+          -- -- delete comments
-          commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
+          -- commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
-          _ <- mapM (\ent -> do
+          -- _ <- mapM (\ent -> do
-            children <- runDB $ selectList [CommentParent ==. (Just $ entityKey ent)] []
+          --   children <- runDB $ selectList [CommentParent ==. (Just $ entityKey ent)] []
-            _ <- mapM (\child -> do
+          --   _ <- mapM (\child -> do
-              -- delete comment children
+          --     -- delete comment children
-              runDB $ delete $ entityKey child
+          --     runDB $ delete $ entityKey child
-              ) children
+          --     ) children
-            runDB $ delete $ entityKey ent) commEnts
+          --   runDB $ delete $ entityKey ent) commEnts
-          -- delete medium
+          -- -- delete medium
-          runDB $ delete mediumId
+          -- runDB $ delete mediumId
-          -- delete files
+          -- -- delete files
-          liftIO $ removeFile (normalise $ tail $ mediumPath medium)
+          -- liftIO $ removeFile (normalise $ tail $ mediumPath medium)
-          liftIO $ removeFile (normalise $ tail $ mediumThumb medium)
+          -- liftIO $ removeFile (normalise $ tail $ mediumThumb medium)
-          liftIO $ removeFile (normalise $ tail $ mediumPreview medium)
+          -- liftIO $ removeFile (normalise $ tail $ mediumPreview medium)
           -- outro
+          deleteMedium mediumId medium
           setMessage "Medium deleted successfully"
           redirect AdminR
         Nothing -> do

Handler/Commons.hs

@@ -17,7 +17,11 @@
 module Handler.Commons where
 
 import Import
+import qualified Data.Text as T
 import Data.String
+import qualified Data.List as L
+import System.FilePath as FP
+import System.Directory
 
 loginIsAdmin :: IsString t => Handler (Either (t, Route App)  ())
 loginIsAdmin = do
@@ -78,3 +82,58 @@ mediumCheck mediumId = do
           return $ Left ("You must be logged in to change settings", LoginR)
     Nothing ->
       return $ Left ("This medium does not exist", HomeR)
+
+insertMedium :: Medium -> AlbumId -> Handler ()
+insertMedium medium aId = do
+  mId <- runDB $ insert medium
+  inAlbum <- runDB $ getJust aId
+  let newMediaList = mId : albumContent inAlbum
+  runDB $ update aId [AlbumContent =. newMediaList]
+
+deleteMedium :: MediumId -> Medium -> Handler ()
+deleteMedium mId medium = do
+  commEnts <- runDB $ selectList [CommentOrigin ==. mId] []
+  -- delete comments first
+  mapM_ (runDB . delete . entityKey) commEnts
+  -- remove reference
+  removeReference mId $ mediumAlbum medium
+  -- delete Files
+  mapM_ (liftIO . removeFile . normalise . L.tail)
+    [ mediumPath medium
+    , mediumThumb medium
+    , mediumPreview medium
+    ]
+  -- delete database entry
+  runDB $ delete mId
+
+moveMedium :: Medium -> MediumId -> AlbumId -> Handler ()
+moveMedium med mId destId = do
+  dest <- runDB $ getJust destId
+  -- remove reference
+  removeReference mId $ mediumAlbum med
+  -- move physical Files
+  let filen = show $ length (albumContent dest) + 1
+      ext   = takeExtension $ mediumPath med
+      nPath = "static" </> "data" </> T.unpack (extractKey $ albumOwner dest) </> T.unpack (extractKey destId) </> filen ++ ext
+      nThumb = takeBaseName nPath ++ "_thumb.jpg"
+      nPrev = takeBaseName nPath ++ "_preview.jpg"
+  liftIO $ renameFile (mediumPath med) nPath
+  liftIO $ renameFile (mediumThumb med) nThumb
+  liftIO $ renameFile (mediumPreview med) nPrev
+  -- chenge filenames in database
+  runDB $ update mId
+    [ MediumPath =. '/' : nPath
+    , MediumThumb =. '/' : nThumb
+    , MediumPreview =. '/' : nPrev
+    ]
+  -- create new references
+  let newMediaList = mId : albumContent dest
+  runDB $ update destId [AlbumContent =. newMediaList]
+
+removeReference :: MediumId -> AlbumId -> Handler ()
+removeReference mId aId = do
+  -- delete references next
+  album <- runDB $ getJust aId
+  let newMediaList = removeItem mId $ albumContent album
+  -- update reference list
+  runDB $ update aId [AlbumContent =. newMediaList]

Handler/MediumSettings.hs

@@ -96,20 +96,21 @@ postMediumDeleteR mediumId = do
       confirm <- lookupPostParam "confirm"
       case confirm of
         Just "confirm" -> do
-          -- delete comments
+          -- -- delete comments
-          commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
+          -- commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
-          _ <- mapM (runDB . delete . entityKey) commEnts
+          -- _ <- mapM (runDB . delete . entityKey) commEnts
-          -- delete references first
+          -- -- delete references first
-          let albumId = mediumAlbum medium
+          -- let albumId = mediumAlbum medium
-          album <- runDB $ getJust albumId
+          -- album <- runDB $ getJust albumId
-          let mediaList = albumContent album
+          -- let mediaList = albumContent album
-          let newMediaList = removeItem mediumId mediaList
+          -- let newMediaList = removeItem mediumId mediaList
-          -- update reference List
+          -- -- update reference List
-          runDB $ update albumId [AlbumContent =. newMediaList]
+          -- runDB $ update albumId [AlbumContent =. newMediaList]
-          liftIO $ removeFile (normalise $ tail $ mediumPath medium)
+          -- liftIO $ removeFile (normalise $ tail $ mediumPath medium)
-          liftIO $ removeFile (normalise $ tail $ mediumThumb medium)
+          -- liftIO $ removeFile (normalise $ tail $ mediumThumb medium)
-          liftIO $ removeFile (normalise $ tail $ mediumPreview medium)
+          -- liftIO $ removeFile (normalise $ tail $ mediumPreview medium)
-          runDB $ delete mediumId
+          -- runDB $ delete mediumId
+          deleteMedium mediumId medium
           setMessage "Medium succesfully deleted"
           redirect HomeR
         _ -> do
@@ -118,3 +119,42 @@ postMediumDeleteR mediumId = do
     Left (errorMsg, route) -> do
       setMessage errorMsg
       redirect route
+
+getMediumMoveR :: MediumId -> Handler Html
+getMediumMoveR mId = do
+  checkRes <- mediumCheck mId
+  case checkRes of
+    Right medium ->
+      (mediumSettingsWidget, enctype) <- generateFormPost $
+        renderBootstrap3 BootstrapBasicForm $
+        mediumMoveForm medium
+    Left (err, route) -> do
+      setMessage err
+      redirect route
+
+postMediumMoveR :: MediumOd -> Handler Html
+postMediumMoveR mId = do
+  checkRes <- mediumCheck mId
+  case checkres of
+    Right medium -> do
+      ((res, _), _) <- runFormPost $
+        renderBootstrap3 BootstrapBasicForm $
+        mediumMoveForm medium
+      case res of
+        FormSuccess aId ->
+          moveMedium medium mId aId
+
+mediumMoveForm :: Medium -> AForm Handler AlbumId
+mediumMoveForm medium = id
+  <$> areq (selectField albums) (bfs ("Destination album" :: T.Text)) (mediumAlbum medium)
+  <*  bootstrapSubmit ("Move medium" :: BootstrapSubmit Text)
+  where
+    albums = do
+      allEnts <- runDB $ selectList [] [Asc AlbumTitle]
+      let ents = catMaybes $ map (\ent ->
+        if uId == albumOwner (entityVal ent) || uId `elem` albumShares (entityVal nt)
+          then Just ent
+          else Nothing
+        ) allEnts
+      optionsPairs $ map (\alb -> ((albumTitle $ entityVal alb), entityKey alb) ents
+    uId = mediumOwner medium

Handler/Upload.hs

@@ -17,6 +17,7 @@
 module Handler.Upload where
 
 import Import as I
+import Handler.Commons
 import Data.Time
 import Data.Maybe
 import qualified Data.Text as T
@@ -89,10 +90,11 @@ postDirectUploadR albumId = do
                                 then return $ fileBulkPrefix temp
                                 else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
                               let medium = Medium tempName ('/' : path) ('/' : metaThumbPath meta) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) albumId ('/' : metaPreviewPath meta)
-                              mId <- runDB $ I.insert medium
+                              -- mId <- runDB $ I.insert medium
-                              inALbum <- runDB $ getJust albumId
+                              -- inALbum <- runDB $ getJust albumId
-                              let newMediaList = mId : albumContent inALbum
+                              -- let newMediaList = mId : albumContent inALbum
-                              runDB $ update albumId [AlbumContent =. newMediaList]
+                              -- runDB $ update albumId [AlbumContent =. newMediaList]
+                              insertMedium medium albumId
                               return Nothing
                           else do
                             liftIO $ removeFile (FP.normalise path)
@@ -251,7 +253,7 @@ bulkUploadForm userId = (\a b c d e f g -> FileBulk b c d e f g a)
   where
     albums = do
       allEnts <- runDB $ selectList [] [Desc AlbumTitle]
-      let entities = map fromJust $ removeItem Nothing $ map (\ent ->
+      let entities = catMaybes $ map (\ent ->
             if
               userId == albumOwner (entityVal ent) || userId `elem` albumShares (entityVal ent)
               then Just ent
@@ -294,10 +296,11 @@ postUploadR = do
                             " of " `T.append`
                             T.pack (show (length indFils)))
                       let medium = Medium tempName ('/' : path) ('/' : metaThumbPath meta) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) inAlbumId ('/' : metaPreviewPath meta)
-                      mId <- runDB $ I.insert medium
+                      -- mId <- runDB $ I.insert medium
-                      inALbum <- runDB $ getJust inAlbumId
+                      -- inALbum <- runDB $ getJust inAlbumId
-                      let newMediaList = mId : albumContent inALbum
+                      -- let newMediaList = mId : albumContent inALbum
-                      runDB $ update inAlbumId [AlbumContent =. newMediaList]
+                      -- runDB $ update inAlbumId [AlbumContent =. newMediaList]
+                      insertMedium medium inAlbumId
                       return Nothing
                     else do
                       liftIO $ removeFile (FP.normalise path)