module Store.Service
( Storage
, initStorage
, StorageLocationConfig (..)
) where
import Control.Monad (unless, foldM_)
import Data.Maybe (catMaybes)
import System.Directory (getTemporaryDirectory, createDirectoryIfMissing)
import System.IO.Error (mkIOError, doesNotExistErrorType, illegalOperationErrorType)
import System.Posix.FilePath (addTrailingPathSeparator)
import System.Posix.Files.ByteString (isDirectory, deviceID, getFileStatus)
import System.Posix.Types (DeviceID)
import Files
import Store.Types
data StorageLocationConfig = StorageLocationConfig
{ storageLocTemp :: Maybe RawFilePath
, storageLocMaster :: RawFilePath
, storageLocUpload :: RawFilePath
, storageLocCache :: Maybe RawFilePath
, storageLocStage :: Maybe RawFilePath
, storageLocFallback :: Maybe RawFilePath
}
initStorage
:: Either String StorageLocationConfig
-> IO (Maybe Transcoder)
-> IO Storage
initStorage (Left e) _ = return $ error $ "Storage unavailable: " ++ e
initStorage (Right StorageLocationConfig {..}) initTc = do
temp <- maybe (rawFilePath =<< getTemporaryDirectory) pure storageLocTemp
foldM_
checkDirs
Nothing
([storageLocMaster, temp, storageLocUpload]
++ catMaybes [storageLocStage]
)
mapM_ initCache storageLocCache
tempPath <- initTemp temp
tc <- initTc
pure Storage
{ storageMaster = storageLocMaster
, storageFallback = storageLocFallback
, storageTemp = tempPath
, storageUpload = storageLocUpload
, storageCache = storageLocCache
, storageStage = storageLocStage
, storageTranscoder = tc
}
where
checkDirs :: Maybe DeviceID -> RawFilePath -> IO (Maybe DeviceID)
checkDirs dev f = do
s <- getFileStatus f
f' <- unRawFilePath f
unless (isDirectory s) $ ioError $ mkIOError
doesNotExistErrorType
"storage directory"
Nothing
(Just f')
let d = deviceID s
unless (all (d ==) dev) $ ioError $ mkIOError
illegalOperationErrorType
"storage filesystem"
Nothing
(Just f')
return $ Just d
initCache :: RawFilePath -> IO ()
initCache c = do
let tmp = c </> "tmp"
tmpPath <- unRawFilePath tmp
createDirectoryIfMissing False tmpPath
initTemp :: RawFilePath -> IO RawFilePath
initTemp t = do
let tempPath = addTrailingPathSeparator t
unTempPath <- unRawFilePath tempPath
createDirectoryIfMissing
False
(getStorageTempParticipantUpload' unTempPath)
pure tempPath