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