mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-15 01:23:09 +03:00
42 lines
1.2 KiB
Haskell
42 lines
1.2 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Keter.TempFolder
|
|
( TempFolder
|
|
, setup
|
|
, getFolder
|
|
) where
|
|
|
|
import Keter.Prelude
|
|
import Data.Word (Word)
|
|
import Keter.Postgres (Appname)
|
|
import qualified Data.IORef as I
|
|
import System.Posix.Files.ByteString (setOwnerAndGroup)
|
|
import System.Posix.Types (UserID, GroupID)
|
|
import qualified Filesystem.Path.CurrentOS as F
|
|
|
|
data TempFolder = TempFolder
|
|
{ tfRoot :: FilePath
|
|
, tfCounter :: IORef Word
|
|
}
|
|
|
|
setup :: FilePath -> KIO (Either SomeException TempFolder)
|
|
setup fp = liftIO $ do
|
|
e <- isDirectory fp
|
|
when e $ removeTree fp
|
|
createTree fp
|
|
c <- I.newIORef minBound
|
|
return $ TempFolder fp c
|
|
|
|
getFolder :: Maybe (UserID, GroupID) -> TempFolder -> Appname -> KIO (Either SomeException FilePath)
|
|
getFolder muid TempFolder {..} appname = do
|
|
!i <- atomicModifyIORef tfCounter $ \i -> (succ i, i)
|
|
let fp = tfRoot </> fromText (appname ++ "-" ++ show i)
|
|
liftIO $ do
|
|
createTree fp
|
|
case muid of
|
|
Nothing -> return ()
|
|
Just (uid, gid) -> setOwnerAndGroup (F.encode fp) uid gid
|
|
return fp
|