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