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