src/Gargantext/Prelude/Utils.hs

   1 {-|
   2 Module      : Gargantext.Prelude.Utils
   3 Description : Useful Tools near Prelude of the project
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 module Gargantext.Prelude.Utils
  13   where
  14
  15 import Control.Exception
  16 import Control.Lens (view)
  17 import Control.Monad.Reader (ask, MonadReader)
  18 import Control.Monad.Random.Class (MonadRandom)
  19 import Data.Text (Text)
  20 import qualified Data.Text             as Text
  21 import GHC.IO (FilePath)
  22 import System.Directory (createDirectoryIfMissing)
  23 import qualified System.Directory as SD
  24 import System.IO.Error
  25 import System.Random (newStdGen)
  26 import qualified System.Random.Shuffle as SRS
  27
  28 import Gargantext.API.Admin.Types
  29 import Gargantext.Prelude.Config
  30 import Gargantext.Prelude.Crypto.Hash
  31 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
  32 import Gargantext.Prelude
  33
  34 --------------------------------------------------------------------------
  35 shuffle :: MonadRandom m => [a] -> m [a]
  36 shuffle ns = SRS.shuffleM ns
  37
  38 --------------------------------------------------------------------------
  39 data NodeToHash = NodeToHash { nodeType :: NodeType
  40                              , nodeId   :: NodeId
  41                              }
  42
  43 type FolderPath = FilePath
  44 type FileName   = FilePath
  45
  46 -- | toPath example of use:
  47 -- toPath 2 "gargantexthello"
  48 -- ("ga/rg","antexthello")
  49 --
  50 -- toPath 3 "gargantexthello"
  51 -- ("gar/gan","texthello")
  52
  53
  54 toPath :: Int -> Text -> (FolderPath, FileName)
  55 toPath n x = (Text.unpack $ Text.intercalate "/" [x1,x2], Text.unpack xs)
  56   where
  57     (x1,x') = Text.splitAt n x
  58     (x2,xs) = Text.splitAt n x'
  59
  60 class SaveFile a where
  61   saveFile' :: FilePath -> a -> IO ()
  62
  63 class ReadFile a where
  64   readFile' :: FilePath -> IO a
  65
  66
  67 folderFilePath :: (MonadReader env m, MonadBase IO m) => m (FolderPath, FileName)
  68 folderFilePath = do
  69   (foldPath, fileName)  <- liftBase $ (toPath 3) . hash . show <$> newStdGen
  70
  71   pure (foldPath, fileName)
  72
  73
  74 writeFile :: (MonadReader env m, MonadBase IO m, HasSettings env, SaveFile a)
  75           => a -> m FilePath
  76 writeFile a = do
  77   dataPath <- view (settings . config . gc_datafilepath) <$> ask
  78
  79   (foldPath, fileName) <- folderFilePath
  80
  81   let filePath = foldPath <> "/" <> fileName
  82       dataFoldPath = dataPath <> "/" <> foldPath
  83       dataFileName = dataPath <> "/" <> filePath
  84
  85   _ <- liftBase $ createDirectoryIfMissing True dataFoldPath
  86   _ <- liftBase $ saveFile' dataFileName a
  87
  88   pure filePath
  89
  90
  91 readFile :: (MonadReader env m, MonadBase IO m, HasSettings env, ReadFile a)
  92          => FilePath -> m a
  93 readFile fp = do
  94   dataPath <- view (settings . config . gc_datafilepath) <$> ask
  95   liftBase $ readFile' $ dataPath <> "/" <> fp
  96
  97 removeFile :: (MonadReader env m, MonadBase IO m, HasSettings env)
  98            => FilePath -> m ()
  99 removeFile fp = do
 100   dataPath <- view (settings . config . gc_datafilepath) <$> ask
 101   liftBase $ SD.removeFile (dataPath <> "/" <> fp) `catch` handleExists
 102     where
 103       handleExists e
 104         | isDoesNotExistError e = return ()
 105         | otherwise = throwIO e