{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Mismi.S3.Internal (
f'
, (+/)
, calculateChunks
, calculateChunksCapped
, bytesRange
, sinkChan
, sinkChanWithDelay
, sinkQueue
, waitForNResults
, withFileSafe
) where
import Control.Concurrent (Chan, readChan, threadDelay, writeChan)
import Control.Monad.Catch (MonadCatch, onException)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Conduit (ConduitT, runConduit, (.|))
import qualified Data.Conduit.List as DC
import qualified Data.Text as T
import Data.UUID (toString)
import Data.UUID.V4 (nextRandom)
import P
import Prelude (ceiling, (/))
import Mismi (AWS, rawRunAWS)
import Mismi.Amazonka (Env)
import Mismi.S3.Data
import Network.AWS.S3 (BucketName (..), ObjectKey (..))
import Mismi.S3.Internal.Queue (Queue, writeQueue)
import System.Directory (renameFile, removeFile)
import System.IO (IO)
import System.FilePath (FilePath, takeDirectory, takeFileName)
f' :: (BucketName -> ObjectKey -> a) -> Address -> a
f' f (Address (Bucket b) k) =
BucketName b `f` ObjectKey (unKey k)
(+/) :: Text -> Text
(+/) k
| T.null k = ""
| T.isSuffixOf "/" k = k
| otherwise = k <> "/"
calculateChunksCapped :: Int -> Int -> Int -> [(Int, Int, Int)]
calculateChunksCapped size chunk' capped =
calculateChunks size cappedChunk
where
minChunk = ceiling $ size' / capped'
cappedChunk = max chunk' minChunk
size' :: Double
size' = fromIntegral size
capped' :: Double
capped' = fromIntegral capped
calculateChunks :: Int -> Int -> [(Int, Int, Int)]
calculateChunks size chunk' =
let chunk = max 1 chunk'
go :: Int -> Int -> [(Int, Int, Int)]
go !index offset =
let !offset' = (offset + chunk) in
if (offset' < size)
then
(offset, chunk, index) : go (index + 1) offset'
else
let !c' = (size - offset) in
[(offset, c', index)]
in
go 1 0
bytesRange :: Int -> Int -> Text
bytesRange start end =
T.pack $ "bytes=" <> show start <> "-" <> show end
sinkChan :: MonadIO m => ConduitT () a m () -> Chan a -> m Int
sinkChan source c =
sinkChanWithDelay 0 source c
sinkChanWithDelay :: MonadIO m => Int -> ConduitT () a m () -> Chan a -> m Int
sinkChanWithDelay delay source c =
runConduit $ source .| DC.foldM (\i v -> liftIO $ threadDelay delay >> writeChan c v >> pure (i + 1)) 0
sinkQueue :: Env -> ConduitT () a AWS () -> Queue a -> IO ()
sinkQueue e source q =
rawRunAWS e (runConduit $ source .| DC.mapM_ (liftIO . writeQueue q))
waitForNResults :: Int -> Chan a -> IO [a]
waitForNResults i c = do
let waitForDone acc =
if (length acc == i)
then pure acc
else do
r <- readChan c
waitForDone (r : acc)
waitForDone []
withFileSafe :: (MonadCatch m, MonadIO m) => FilePath -> (FilePath -> m a) -> m a
withFileSafe f1 run = do
uuid <- liftIO nextRandom >>= return . toString
let f2 = takeDirectory f1 <> "/" <> "." <> takeFileName f1 <> "." <> uuid
onException
(run f2 >>= \a -> liftIO (renameFile f2 f1) >> return a)
(liftIO $ removeFile f2)