1 {-# LANGUAGE OverloadedStrings #-} 2 {-# LANGUAGE RecordWildCards #-} 3 module Store.Service 4 ( Storage 5 , initStorage 6 , StorageLocationConfig (..) 7 ) where 8 9 import Control.Monad (unless, foldM_) 10 import Data.Maybe (catMaybes) 11 import System.Directory (getTemporaryDirectory, createDirectoryIfMissing) 12 import System.IO.Error (mkIOError, doesNotExistErrorType, illegalOperationErrorType) 13 import System.Posix.FilePath (addTrailingPathSeparator) 14 import System.Posix.Files.ByteString (isDirectory, deviceID, getFileStatus) 15 import System.Posix.Types (DeviceID) 16 17 import Files 18 import Store.Types 19 20 -- | Locations used by Storage. This is almost /identical/ to 'Storage', except 21 -- in how it's used and what it represents. Future work might merge the two 22 -- types. 23 data StorageLocationConfig = StorageLocationConfig 24 { storageLocTemp :: Maybe RawFilePath 25 , storageLocMaster :: RawFilePath 26 , storageLocUpload :: RawFilePath 27 , storageLocCache :: Maybe RawFilePath 28 , storageLocStage :: Maybe RawFilePath 29 , storageLocFallback :: Maybe RawFilePath 30 } 31 32 -- | Initialize the configured storage location. It checks for the existence of 33 -- certain directories and adds subdirectories. Primarily, this allows us to 34 -- interface with third party services (NYU HPC) that have set up certain 35 -- directories for us to use. 36 -- 37 -- This may throw a variety of unchecked exceptions, which is probably the right 38 -- thing to do for initialization. 39 -- 40 -- TODO: 41 -- * Combine initCache and initTemp, which are doing the same thing with quite 42 -- different implementations: appending a subdirectory, and creating it if it 43 -- doesn't exist 44 -- * Commit to reordering execution steps, purifying the second arg 45 -- * Use throwIO instead of error 46 initStorage 47 :: Either String StorageLocationConfig 48 -- ^ Either the set of paths to use for storage, or a message explaining why 49 -- storage isn't available. This Either will collapse very soon, once use 50 -- sites of initStorage are rewritten. 51 -> IO (Maybe Transcoder) 52 -- ^ An action that might produce a transcoder. I kept this is IO to keep 53 -- the implementation identical, without reordering error messages. I highly 54 -- suspect that is overkill, and this will get moved out of IO. 55 -> IO Storage 56 -- ^ The 'Storage' resource (presuming no exceptions were thrown). 57 initStorage (Left e) _ = return $ error $ "Storage unavailable: " ++ e 58 initStorage (Right StorageLocationConfig {..}) initTc = do 59 temp <- maybe (rawFilePath =<< getTemporaryDirectory) pure storageLocTemp 60 foldM_ 61 checkDirs 62 Nothing 63 ([storageLocMaster, temp, storageLocUpload] 64 ++ catMaybes [storageLocStage] 65 ) 66 mapM_ initCache storageLocCache 67 tempPath <- initTemp temp 68 tc <- initTc 69 pure Storage 70 { storageMaster = storageLocMaster 71 , storageFallback = storageLocFallback 72 , storageTemp = tempPath 73 , storageUpload = storageLocUpload 74 , storageCache = storageLocCache 75 , storageStage = storageLocStage 76 , storageTranscoder = tc 77 } 78 where 79 -- Check the dir exists (2nd arg) and it's on the same device as the 1st 80 -- arg (if Just). 81 checkDirs :: Maybe DeviceID -> RawFilePath -> IO (Maybe DeviceID) 82 checkDirs dev f = do 83 s <- getFileStatus f 84 f' <- unRawFilePath f 85 unless (isDirectory s) $ ioError $ mkIOError 86 doesNotExistErrorType 87 "storage directory" 88 Nothing 89 (Just f') 90 let d = deviceID s 91 unless (all (d ==) dev) $ ioError $ mkIOError 92 illegalOperationErrorType 93 "storage filesystem" 94 Nothing 95 (Just f') 96 return $ Just d 97 -- @initCache x = mkdir -p "${x}/tmp"@ 98 initCache :: RawFilePath -> IO () 99 initCache c = do 100 let tmp = c </> "tmp" 101 tmpPath <- unRawFilePath tmp 102 createDirectoryIfMissing False tmpPath 103 -- @initTemp x = mkdir -p "${x}/participantUpload"@ 104 initTemp :: RawFilePath -> IO RawFilePath 105 initTemp t = do 106 let tempPath = addTrailingPathSeparator t 107 unTempPath <- unRawFilePath tempPath 108 createDirectoryIfMissing 109 False 110 (getStorageTempParticipantUpload' unTempPath) 111 pure tempPath