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