1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Upload 3 ( uploadStart 4 , uploadChunk 5 , testChunk 6 -- * for testing 7 , createUploadSetSize 8 , UploadStartRequest(..) 9 , writeChunk 10 ) where 11 12 import Control.Exception (bracket) 13 import Control.Monad ((<=<)) 14 import Control.Monad.IO.Class (liftIO) 15 import Control.Monad.Trans.Class (lift) 16 import qualified Data.ByteString as BS 17 import qualified Data.ByteString.Unsafe as BSU 18 import Data.ByteString.Lazy.Internal (defaultChunkSize) 19 import Data.Int (Int64) 20 import Data.Maybe (isJust) 21 import Data.Word (Word64) 22 import Foreign.C.Types (CSize(..)) 23 import Foreign.Marshal.Array (allocaArray, peekArray) 24 import Foreign.Ptr (castPtr) 25 import Network.HTTP.Types (ok200, noContent204, badRequest400) 26 import qualified Network.Wai as Wai 27 import System.IO (SeekMode(AbsoluteSeek)) 28 import System.Posix.FilePath (RawFilePath) 29 import System.Posix.Files.ByteString (setFdSize) 30 import System.Posix.IO.ByteString (openFd, OpenMode(ReadOnly, WriteOnly), defaultFileFlags, exclusive, closeFd, fdSeek, fdWriteBuf, fdReadBuf) 31 import System.Posix.Types (COff(..)) 32 33 import Has (view, peek, peeks, focusIO, MonadHas) 34 import qualified JSON 35 import Service.DB (MonadDB) 36 import Service.Entropy (Entropy) 37 import Service.Log 38 import Model.Id 39 import Model.Identity (MonadHasIdentity) 40 import Model.Permission 41 import Model.Volume 42 import Model.Format 43 import Model.Token 44 import Store.Upload 45 import Store.Types (MonadStorage) 46 import Store.Asset 47 import HTTP.Form.Deform 48 import HTTP.Path.Parser 49 import Action.Response 50 import Action 51 import Controller.Paths 52 import Controller.Form 53 import Controller.Volume 54 55 fileSizeForm :: DeformHandler f Int64 56 fileSizeForm = deformCheck "Invalid file size." (0 <) =<< deform 57 58 data UploadStartRequest = 59 UploadStartRequest BS.ByteString Int64 60 61 uploadStart :: ActionRoute (Id Volume) 62 uploadStart = action POST (pathJSON >/> pathId </< "upload") $ \vi -> withAuth $ do 63 vol <- getVolume PermissionEDIT vi 64 uploadStartRequest <- runForm Nothing $ UploadStartRequest 65 <$> ("filename" .:> (deformCheck "File format not supported." (isJust . getFormatByFilename) =<< deform)) 66 <*> ("size" .:> (deformCheck "File too large." ((maxAssetSize >=) . fromIntegral) =<< fileSizeForm)) 67 tok <- createUploadSetSize vol uploadStartRequest 68 return $ okResponse [] $ unId (view tok :: Id Token) 69 70 createUploadSetSize :: (MonadHas Entropy c m, MonadDB c m, MonadHasIdentity c m, MonadStorage c m) => Volume -> UploadStartRequest -> m Upload 71 createUploadSetSize vol (UploadStartRequest filename size) = do 72 tok <- createUpload vol filename size 73 file <- peeks $ uploadFile tok 74 liftIO $ bracket 75 (openFd file WriteOnly (Just 0o640) defaultFileFlags{ exclusive = True }) 76 closeFd 77 (`setFdSize` COff size) 78 pure tok 79 80 -- TODO: use this very soon 81 -- data UploadStartResponse = UploadStartResponse { unwrap :: Id Token } 82 83 data UploadChunkRequest = 84 UploadChunkRequest (Id Token) BS.ByteString Int64 Int64 Int64 Int64 Int64 85 86 chunkForm :: DeformHandler f (Upload, Int64, Word64) 87 chunkForm = do 88 csrfForm 89 up <- "flowIdentifier" .:> (lift . (maybeAction <=< lookupUpload) =<< deform) 90 let z = uploadSize up 91 "flowFilename" .:> (deformGuard "Filename mismatch." . (uploadFilename up ==) =<< deform) 92 "flowTotalSize" .:> (deformGuard "File size mismatch." . (z ==) =<< fileSizeForm) 93 c <- "flowChunkSize" .:> (deformCheck "Chunk size too small." (256 <=) =<< deform) 94 n <- "flowTotalChunks" .:> (deformCheck "Chunk count mismatch." ((1 >=) . abs . (pred z `div` c -)) =<< deform) 95 i <- "flowChunkNumber" .:> (deformCheck "Chunk number out of range." (\i -> 0 <= i && i < n) =<< pred <$> deform) 96 let o = c * i 97 l <- "flowCurrentChunkSize" .:> (deformCheck "Current chunk size out of range." (\l -> (c == l || i == pred n) && o + l <= z) =<< deform) 98 -- TODO: populate filename, total size from request 99 let _ = UploadChunkRequest ((tokenId . accountToken . uploadAccountToken) up) (uploadFilename up) z c n i l 100 return (up, o, fromIntegral l) 101 102 uploadChunk :: ActionRoute () 103 uploadChunk = action POST (pathJSON </< "upload") $ \() -> withAuth $ do 104 (up, off, len) <- runForm Nothing chunkForm 105 file <- peeks $ uploadFile up 106 let checkLength n 107 | n /= len = do 108 t <- peek 109 focusIO $ logMsg t ("uploadChunk: wrong size " ++ show n ++ "/" ++ show len) 110 result $ response badRequest400 [] ("Incorrect content length: file being uploaded may have moved or changed" :: JSON.Value) 111 | otherwise = return () 112 bl <- peeks Wai.requestBodyLength 113 case bl of 114 Wai.KnownLength l -> checkLength l 115 _ -> return () 116 rb <- peeks Wai.requestBody 117 n <- liftIO (writeChunk off len file rb) 118 checkLength n -- TODO: clear block (maybe wait for calloc) 119 return $ emptyResponse noContent204 [] 120 121 -- | Write one contiguous block of data to a file 122 writeChunk 123 :: Int64 -- ^ Offset to start writing block into 124 -> Word64 -- ^ Length of block to be written 125 -> RawFilePath -- ^ The target file to write into 126 -> IO BS.ByteString -- ^ The data source that provides chunks of data for writing 127 -> IO Word64 -- ^ number of bytes written 128 writeChunk off len file rb = bracket 129 (openFd file WriteOnly Nothing defaultFileFlags) 130 (\f -> putStrLn "closeFd..." >> closeFd f) $ \h -> do 131 _ <- fdSeek h AbsoluteSeek (COff off) 132 let block n = do 133 b <- rb 134 if BS.null b 135 then 136 return n 137 else do 138 let n' = n + fromIntegral (BS.length b) 139 write b' = do 140 w <- BSU.unsafeUseAsCStringLen b' $ \(buf, siz) -> fdWriteBuf h (castPtr buf) (fromIntegral siz) 141 if w < fromIntegral (BS.length b') 142 then 143 write $! BS.drop (fromIntegral w) b' 144 else 145 block n' 146 if n' > len 147 then 148 return n' 149 else 150 write b 151 block 0 152 153 testChunk :: ActionRoute () 154 testChunk = action GET (pathJSON </< "upload") $ \() -> withAuth $ do 155 (up, off, len) <- runForm Nothing chunkForm 156 file <- peeks $ uploadFile up 157 r <- liftIO $ bracket 158 (openFd file ReadOnly Nothing defaultFileFlags) 159 closeFd $ \h -> do 160 _ <- fdSeek h AbsoluteSeek (COff off) 161 allocaArray bufsiz $ \buf -> do 162 let block 0 = return False 163 block n = do 164 r <- fdReadBuf h buf $ n `min` fromIntegral bufsiz 165 a <- peekArray (fromIntegral r) buf 166 if r == 0 167 then return False -- really should be error 168 else if any (0 /=) a 169 then return True 170 else block $! n - r 171 block (CSize len) 172 return $ emptyResponse (if r then ok200 else noContent204) [] 173 where 174 bufsiz = fromIntegral defaultChunkSize