1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.Store.Service
    3   ( Storage
    4   , initStorage
    5   ) where
    6 
    7 import Control.Monad (unless, foldM_, forM_)
    8 import Data.Maybe (catMaybes)
    9 import System.Directory (getTemporaryDirectory, createDirectoryIfMissing)
   10 import System.IO.Error (mkIOError, doesNotExistErrorType, illegalOperationErrorType)
   11 import System.Posix.FilePath (addTrailingPathSeparator)
   12 import System.Posix.Files.ByteString (isDirectory, deviceID, getFileStatus)
   13 
   14 import Databrary.Ops
   15 import qualified Databrary.Store.Config as C
   16 import Databrary.Files
   17 import Databrary.Store.Types
   18 import Databrary.Store.Transcoder
   19 
   20 initStorage :: C.Config -> IO Storage
   21 initStorage conf
   22   | Just down <- conf C.! "DOWN" = return $ error $ "Storage unavailable: " ++ down
   23   | otherwise = do
   24       fp <- getTemporaryDirectory
   25       temp <- fromMaybeM (rawFilePath fp) $ conf C.! "temp"
   26 
   27       foldM_ (\dev f -> do
   28         s <- getFileStatus f
   29         f' <- unRawFilePath f
   30         unless (isDirectory s)
   31           $ ioError $ mkIOError doesNotExistErrorType "storage directory" Nothing (Just f')
   32         let d = deviceID s
   33         unless (all (d ==) dev)
   34           $ ioError $ mkIOError illegalOperationErrorType "storage filesystem" Nothing (Just f')
   35         return $ Just d)
   36         Nothing $ catMaybes [Just master, Just temp, Just upload, stage]
   37 
   38       forM_ cache $ \c -> do
   39         let tmp = c </> "tmp"
   40         tmpPath <- unRawFilePath tmp
   41         createDirectoryIfMissing False tmpPath
   42 
   43       let tempPath = addTrailingPathSeparator temp
   44       unTempPath <- unRawFilePath tempPath
   45       createDirectoryIfMissing False (getStorageTempParticipantUpload' unTempPath)
   46 
   47       tc <- initTranscoder (conf C.! "transcode")
   48 
   49       return $ Storage
   50         { storageMaster = master
   51         , storageFallback = conf C.! "fallback"
   52         , storageTemp = tempPath
   53         , storageUpload = upload
   54         , storageCache = cache
   55         , storageStage = stage
   56         , storageTranscoder = tc
   57         }
   58   where
   59   master = conf C.! "master"
   60   upload = conf C.! "upload"
   61   cache = conf C.! "cache"
   62   stage = conf C.! "stage"