module Yesod.S3 (
uploadImage,
uploadFile,
getLink) where
import Data.ByteString.Lazy
import Yesod.Core.Types
import Data.Conduit
import Data.Conduit.Binary
import Network.URI
import Network.AWS.AWSConnection
import Network.AWS.AWSResult
import Network.AWS.S3Object
import qualified Data.Text as T
import Graphics.GD.ByteString.Lazy
import Data.Ratio
import Control.Monad.Error
import Control.Monad.Trans.Resource
extractFile :: FileInfo -> IO ByteString
extractFile f = runResourceT $ fileSourceRaw f $$ sinkLbs
data UploadError
= InvalidContentType
| ReqError ReqError
| StringError String
instance Error UploadError where
strMsg = StringError
uploadImage :: AWSConnection
-> FileInfo
-> String
-> String
-> [((Int,Int), Int, String)]
-> ErrorT UploadError IO [(String, String)]
uploadImage conn fi bucket name styles = do
bs <- liftIO $ extractFile fi
let ft = T.unpack $ fileContentType fi
img <- case ft of
"image/png" -> liftIO $ loadPngByteString bs
"image/jpg" -> liftIO $ loadJpegByteString bs
"image/gif" -> liftIO $ loadGifByteString bs
_ -> throwError InvalidContentType
(x,y) <- liftIO $ imageSize img
flip mapM styles $ \((x',y'),qual,style) -> do
let xscale = x' % x
yscale = y' % y
(x'',y'') = if xscale<yscale
then (x', floor $ fromIntegral y * xscale)
else (floor $ fromIntegral x * yscale, y')
img' <- liftIO $ resizeImage x'' y'' img
bs' <- liftIO $ saveJpegByteString qual img'
let name' = name ++ "-" ++ style
obj = S3Object bucket name' "image/jpg" [] bs'
res <- liftIO $ sendObjectMIC conn obj
case res of
Right () -> return (style, name')
Left err -> throwError $ ReqError err
uploadFile :: AWSConnection
-> FileInfo
-> String
-> String
-> ErrorT UploadError IO ()
uploadFile conn fi bucket name = do
bs <- liftIO $ extractFile fi
let obj = S3Object bucket name (T.unpack $ fileContentType fi) [] bs
res <- liftIO $ sendObjectMIC conn obj
case res of
Right () -> return ()
Left err -> throwError $ ReqError err
getLink :: AWSConnection
-> String
-> String
-> Integer
-> IO URI
getLink conn bucket name t = do
let obj = S3Object bucket name "" [] empty
publicUriForSeconds conn obj t