now with bulk upload

Handler/Upload.hs

@@ -4,86 +4,11 @@ import Import as I
 import Data.Time
 import Data.Maybe
 import qualified Data.Text as T
+import Data.List as L
 import qualified System.FilePath as FP
 import Filesystem.Path.CurrentOS
 import Graphics.ImageMagick.MagickWand
-
+import Text.Blaze.Internal
-data TempMedium = TempMedium
-  { tempMediumTitle :: Text
-  , tempMediumFile :: FileInfo
-  , tempMediumTime :: UTCTime
-  , tempMediumOwner :: UserId
-  , tempMediumDesc :: Textarea
-  , tempMediumTags :: [Text]
-  , tempMediumAlbum :: AlbumId
-  }
-
-getUploadR :: Handler Html
-getUploadR = do
-  msu <- lookupSession "userId"
-  case msu of
-    Just tempUserId -> do
-      userId <- return $ getUserIdFromText tempUserId
-      user <- runDB $ getJust userId
-      albums <- return $ userAlbums user
-      case I.null albums of
-        False -> do
-          (uploadWidget, enctype) <- generateFormPost (uploadForm userId)
-          formLayout $ do
-            setTitle "Eidolon :: Upload Medium"
-            $(widgetFile "upload")
-        True -> do
-          setMessage "Please create an album first"
-          redirect $ NewAlbumR
-    Nothing -> do
-      setMessage "You need to be logged in"
-      redirect $ LoginR
-
-postUploadR :: Handler Html
-postUploadR = do
-  msu <- lookupSession "userId"
-  case msu of
-    Just tempUserId -> do
-      userId <- lift $ pure $ getUserIdFromText tempUserId
-      ((result, _), _) <- runFormPost (uploadForm userId)
-      case result of
-        FormSuccess temp -> do
-          fil <- return $ tempMediumFile temp
-          mime <- return $ (fileContentType fil)
-          case mime `elem` acceptedTypes of
-            True -> do
-              albRef <- runDB $ getJust (tempMediumAlbum temp)
-              ownerId <- return $ albumOwner albRef
-              path <- writeOnDrive fil ownerId (tempMediumAlbum temp)
-              (thumbPath, iWidth, tWidth) <- generateThumb path ownerId (tempMediumAlbum temp)
-              inAlbumId <- return $ tempMediumAlbum temp
-              medium <- return $ Medium
-                (tempMediumTitle temp)
-                ('/' : path)
-                ('/' : thumbPath)
-                mime
-                (tempMediumTime temp)
-                (tempMediumOwner temp)
-                (tempMediumDesc temp)
-                (tempMediumTags temp)
-                iWidth
-                tWidth
-                inAlbumId
-              mId <- runDB $ I.insert medium
-              inAlbum <- runDB $ getJust inAlbumId
-              newMediaList <- return $ mId : (albumContent inAlbum)
-              runDB $ update inAlbumId [AlbumContent =. newMediaList]
-              setMessage "Image succesfully uploaded"
-              redirect $ HomeR
-            _ -> do
-              setMessage "This filetype is not supported"
-              redirect $ UploadR
-        _ -> do
-          setMessage "There was an error uploading the file"
-          redirect $ UploadR
-    Nothing -> do
-      setMessage "You need to be logged in"
-      redirect $ LoginR
 
 getDirectUploadR :: AlbumId -> Handler Html
 getDirectUploadR albumId = do
@@ -128,35 +53,48 @@ postDirectUploadR albumId = do
               ((result, _), _) <- runFormPost (dUploadForm userId albumId)
               case result of
                 FormSuccess temp -> do
-                  fil <- return $ tempMediumFile temp
+                  fils <- return $ fileBulkFiles temp
-                  mime <- return $ fileContentType fil
+                  indFils <- return $ zip [1..] fils
+                  errNames <- mapM
+                    (\(index, file) -> do
+                      mime <- return $ fileContentType file
                       case mime `elem` acceptedTypes of
                         True -> do
-                      albRef <- runDB $ getJust (tempMediumAlbum temp)
+                          albRef <- runDB $ getJust albumId
-                      refOwnerId <- return $ albumOwner albRef
+                          ownerId <- return $ albumOwner albRef
-                      path <- writeOnDrive fil refOwnerId albumId
+                          path <- writeOnDrive file ownerId albumId
                           (thumbPath, iWidth, tWidth) <- generateThumb path ownerId albumId
+                          tempName <- return $ ((fileBulkPrefix temp) `T.append` " " `T.append` (T.pack (show index)) `T.append` " of " `T.append` (T.pack (show (length indFils))))
                           medium <- return $ Medium
-                        (tempMediumTitle temp)
+                            tempName
                             ('/' : path)
                             ('/' : thumbPath)
                             mime
-                        (tempMediumTime temp)
+                            (fileBulkTime temp)
-                        (tempMediumOwner temp)
+                            (fileBulkOwner temp)
-                        (tempMediumDesc temp)
+                            (fileBulkDesc temp)
-                        (tempMediumTags temp)
+                            (fileBulkTags temp)
                             iWidth
                             tWidth
                             albumId
-                      mId <- runDB $ insert medium
+                          mId <- runDB $ I.insert medium
-                      inAlbum <- runDB $ getJust albumId
+                          inALbum <- runDB $ getJust albumId
-                      newMediaList <- return $ mId : (albumContent inAlbum)
+                          newMediaList <- return $ mId : (albumContent inALbum)
                           runDB $ update albumId [AlbumContent =. newMediaList]
-                      setMessage "Image successfully uploaded"
+                          return Nothing
-                      redirect $ AlbumR albumId
+                        False -> do
-                    _ -> do
+                          return $ Just $ fileName file
-                      setMessage "This filetype is not supported"
+                      ) indFils
-                      redirect $ DirectUploadR albumId
+                  onlyErrNames <- return $ removeItem Nothing errNames
+                  case L.null onlyErrNames of
+                    True -> do
+                      setMessage "All images succesfully uploaded"
+                      redirect $ HomeR
+                    False -> do
+                      justErrNames <- return $ map fromJust onlyErrNames
+                      msg <- return $ Content $ Text $ "File type not supported of: " `T.append` (T.intercalate ", " justErrNames)
+                      setMessage msg
+                      redirect $ HomeR
                 _ -> do
                   setMessage "There was an error uploading the file"
                   redirect $ DirectUploadR albumId
@@ -203,17 +141,57 @@ writeOnDrive fil userId albumId = do
   liftIO $ fileMove fil path
   return path
 
-uploadForm :: UserId -> Form TempMedium
+dUploadForm :: UserId -> AlbumId -> Form FileBulk
-uploadForm userId = renderDivs $ (\a b c d e f g -> TempMedium b c d e f g a)
+dUploadForm userId albumId = renderDivs $ FileBulk
+  <$> areq textField "Title" Nothing
+  <*> areq multiFileField "Select file(s)" Nothing
+  <*> lift (liftIO getCurrentTime)
+  <*> pure userId
+  <*> areq textareaField "Description" Nothing
+  <*> areq tagField "Enter tags" Nothing
+  <*> pure albumId
+
+data FileBulk = FileBulk
+  { fileBulkPrefix :: Text
+  , fileBulkFiles :: [FileInfo]
+  , fileBulkTime :: UTCTime
+  , fileBulkOwner :: UserId
+  , fileBulkDesc :: Textarea
+  , fileBulkTags :: [Text]
+  , fileBulkAlbum :: AlbumId
+  }
+
+getUploadR :: Handler Html
+getUploadR = do
+  msu <- lookupSession "userId"
+  case msu of
+    Just tempUserId -> do
+      userId <- return $ getUserIdFromText tempUserId
+      user <- runDB $ getJust userId
+      albums <- return $ userAlbums user
+      case I.null albums of
+        False -> do
+          (uploadWidget, enctype) <- generateFormPost (bulkUploadForm userId)
+          formLayout $ do
+            setTitle "Eidolon :: Upload Medium"
+            $(widgetFile "bulkUpload")
+        True -> do
+          setMessage "Please create an album first"
+          redirect $ NewAlbumR
+    Nothing -> do
+      setMessage "You need to be logged in"
+      redirect $ LoginR
+
+bulkUploadForm :: UserId -> Form FileBulk
+bulkUploadForm userId = renderDivs $ (\a b c d e f g -> FileBulk b c d e f g a)
   <$> areq (selectField albums) "Album" Nothing
   <*> areq textField "Title" Nothing
-  <*> areq fileField "Select file" Nothing
+  <*> areq multiFileField "Select file(s)" Nothing
   <*> lift (liftIO getCurrentTime)
   <*> pure userId
   <*> areq textareaField "Description" Nothing
   <*> areq tagField "Enter tags" Nothing
   where
---    albums :: GHandler App App (OptionList AlbumId)
     albums = do
       allEnts <- runDB $ selectList [] [Desc AlbumTitle]
       entities <- return $
@@ -224,15 +202,65 @@ uploadForm userId = renderDivs $ (\a b c d e f g -> TempMedium b c d e f g a)
               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
+postUploadR :: Handler Html
-dUploadForm userId albumId = renderDivs $ TempMedium
+postUploadR = do
-  <$> areq textField "Title" Nothing
+  msu <- lookupSession "userId"
-  <*> areq fileField "Select file" Nothing
+  case msu of
-  <*> lift (liftIO getCurrentTime)
+    Just tempUserId -> do
-  <*> pure userId
+      userId <- lift $ pure $ getUserIdFromText tempUserId
-  <*> areq textareaField "Description" Nothing
+      ((result, _), _) <- runFormPost (bulkUploadForm userId)
-  <*> areq tagField "Enter tags" Nothing
+      case result of
-  <*> pure albumId
+        FormSuccess temp -> do
+          fils <- return $ fileBulkFiles temp
+          indFils <- return $ zip [1..] fils
+          errNames <- mapM
+            (\(index, file) -> do
+              mime <- return $ fileContentType file
+              case mime `elem` acceptedTypes of
+                True -> do
+                  inAlbumId <- return $ fileBulkAlbum temp
+                  albRef <- runDB $ getJust inAlbumId
+                  ownerId <- return $ albumOwner albRef
+                  path <- writeOnDrive file ownerId inAlbumId
+                  (thumbPath, iWidth, tWidth) <- generateThumb path ownerId inAlbumId
+                  tempName <- case length indFils == 1 of
+                    False -> return $ ((fileBulkPrefix temp) `T.append` " " `T.append` (T.pack (show index)) `T.append` " of " `T.append` (T.pack (show (length indFils))))
+                    True -> return $ fileBulkPrefix temp
+                  medium <- return $ Medium
+                    tempName
+                    ('/' : path)
+                    ('/' : thumbPath)
+                    mime
+                    (fileBulkTime temp)
+                    (fileBulkOwner temp)
+                    (fileBulkDesc temp)
+                    (fileBulkTags temp)
+                    iWidth
+                    tWidth
+                    inAlbumId
+                  mId <- runDB $ I.insert medium
+                  inALbum <- runDB $ getJust inAlbumId
+                  newMediaList <- return $ mId : (albumContent inALbum)
+                  runDB $ update inAlbumId [AlbumContent =. newMediaList]
+                  return Nothing
+                False -> do
+                  return $ Just $ fileName file
+              ) indFils
+          onlyErrNames <- return $ removeItem Nothing errNames
+          case L.null onlyErrNames of
+            True -> do
+              setMessage "All images succesfully uploaded"
+              redirect $ HomeR
+            False -> do
+              justErrNames <- return $ map fromJust onlyErrNames
+              msg <- return $ Content $ Text $ "File type not supported of: " `T.append` (T.intercalate ", " justErrNames)
+              setMessage msg
+              redirect $ HomeR
+        _ -> do
+          setMessage "There was an error uploading the file"
+          redirect $ UploadR
+    Nothing -> do
+      setMessage "You need to be logged in"
+      redirect $ LoginR

Helper.hs

@@ -168,3 +168,15 @@ getThumbWidth path
                         (_, w) <- magickWand
                         readImage w (decodeString $ fromJust path)
                         getImageWidth w
+
+multiFileField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m [FileInfo]
+multiFileField = Field
+    { fieldParse = \_ files -> return $
+        case files of
+            [] -> Right Nothing
+            file:_ -> Right $ Just files
+    , fieldView = \id' name attrs _ isReq -> toWidget [hamlet|
+            <input id=#{id'} name=#{name} *{attrs} type=file :isReq:required multiple="" enctype="multipart/form-data">
+        |]
+    , fieldEnctype = Multipart
+    }

eidolon.cabal

@@ -113,6 +113,7 @@ library
                  , resourcet
                  , yesod-markdown                >= 0.8
                  , blaze-builder
+                 , blaze-markup
                  , either
 
 executable         eidolon