UploadPhoto.hs

module HEyefi.UploadPhoto where

import           Codec.Archive.Tar (extract)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.State.Lazy (get)
import qualified Data.ByteString.Lazy as BL
import           HEyefi.Constant (multipartBodyBoundary)
import           HEyefi.Log (logDebug, logInfo)
import           HEyefi.Prelude
import           HEyefi.Soap (mkResponse)
import           HEyefi.SoapResponse (soapResponse, uploadPhotoResponse)
import           HEyefi.Types (uploadDirectory, HEyefiM, HEyefiApplication)
import           Network.Multipart (
    parseMultipartBody
  , MultiPart (..)
  , BodyPart (..) )
import           System.Directory (copyFile, getDirectoryContents)
import           System.FilePath.Posix ((</>))
import           System.IO (hClose)
import           System.IO.Temp (withSystemTempFile, withSystemTempDirectory)
import           System.Posix.Files (
    setOwnerAndGroup
  , fileOwner
  , fileGroup
  , getFileStatus
  , FileStatus )



copyMatchingOwnership :: FileStatus -> FilePath -> FilePath -> IO FilePath
copyMatchingOwnership fs from to = do
  copyFile from to
  setOwnerAndGroup to (fileOwner fs) (fileGroup fs)
  return to

changeOwnershipAndCopy :: FilePath -> FilePath -> IO FilePath
changeOwnershipAndCopy uploadDir extractionDir = do
  s <- getFileStatus uploadDir
  names <- getDirectoryContents extractionDir
  paths <- mapM (processName s) (properNames names)
  return (head paths)
  where
    properNames = filter (`notElem` [".", ".."])
    processName s n =
      copyMatchingOwnership s (extractionDir </> n) (uploadDir </> n)

-- TODO: handle case where uploaded file has a bad format
-- TODO: handle case where temp file is not created
writeTarFile :: BL.ByteString -> HEyefiM FilePath
writeTarFile file = do
  config <- get
  let uploadDir = uploadDirectory config
  liftIO (withSystemTempFile "heyefi.tar" (handleFile uploadDir))
  where
    handleFile uploadDir filePath handle =
      withSystemTempDirectory "heyefi_extracted" (handleDir uploadDir filePath handle)
    handleDir uploadDir tempFile tempFileHandle extractionDir = do
      BL.hPut tempFileHandle file
      hClose tempFileHandle
      extract extractionDir tempFile
      changeOwnershipAndCopy uploadDir extractionDir

handleUpload :: BL.ByteString -> HEyefiApplication
handleUpload body _ f = do
  logDebug gotUploadRequest
  let MultiPart bodyParts = parseMultipartBody (unpack multipartBodyBoundary) body
  logDebug (tshow (length bodyParts))
  lBP bodyParts

  let [  BodyPart _ soapEnvelope
       , BodyPart _ file
       , BodyPart _ digest
       ] = bodyParts

  outputPath <- writeTarFile file
  logInfo (uploadedTo (pack outputPath))

  logDebug (tshow soapEnvelope)
  logDebug (tshow digest)
  let responseBody = soapResponse uploadPhotoResponse
  logDebug responseBody
  r <- mkResponse responseBody
  liftIO (f r)

  where
    lBP [] = return ()
    lBP (BodyPart headers _ : xs) = do
      logDebug (tshow headers)
      lBP xs
      return ()