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 Data.Tuple.Extra (both)
  16 import Control.Exception
  17 import Control.Lens (view)
  18 import Control.Monad.Reader (MonadReader)
  19 import Control.Monad.Random.Class (MonadRandom)
  20 import Data.Text (Text)
  21 import qualified Data.Text             as Text
  22 import GHC.IO (FilePath)
  23 import System.Directory (createDirectoryIfMissing)
  24 import qualified System.Directory as SD
  25 import System.IO.Error
  26 import System.Random (newStdGen)
  27 import qualified System.Random.Shuffle as SRS
  28
  29 import Gargantext.Prelude.Config
  30 import Gargantext.Prelude.Crypto.Hash
  31 import Gargantext.Database.Prelude (HasConfig(..))
  32 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
  33 import Gargantext.Prelude
  34
  35 --------------------------------------------------------------------------
  36 shuffle :: MonadRandom m => [a] -> m [a]
  37 shuffle ns = SRS.shuffleM ns
  38
  39 --------------------------------------------------------------------------
  40 data NodeToHash = NodeToHash { nodeType :: NodeType
  41                              , nodeId   :: NodeId
  42                              }
  43 -------------------------------------------------------------------
  44 type FolderPath = FilePath
  45 type FileName   = FilePath
  46
  47 -- | toPath' example of use:
  48 {-
  49 >>> toPath' (1,2) ("","helloword")
  50 ("/he","lloword")
  51
  52 >>> toPath' (2,2) ("","helloword")
  53 ("/he/ll","oword")
  54
  55 >>> toPath' (2,3) ("","helloword")
  56 ("/hel/low","ord")
  57 -}
  58
  59 toPath :: Int -> Text -> (FolderPath, FileName)
  60 toPath n tx = both Text.unpack $ toPath' (2,n) ("", tx)
  61
  62 toPath' :: (Int,Int) -> (Text,Text) -> (Text,Text)
  63 toPath' (n,m) (t,x) = foldl' (\tx _ -> toPath'' m tx) (t,x) [1..n]
  64
  65 toPath'' :: Int -> (Text, Text) -> (Text, Text)
  66 toPath'' n (fp,fn) = (fp'',fn')
  67   where
  68     (fp',fn') = Text.splitAt n fn
  69     fp''       = Text.intercalate "/" [fp,fp']
  70
  71 -------------------------------------------------------------------
  72 -------------------------------------------------------------------
  73 class SaveFile a where
  74   saveFile' :: FilePath -> a -> IO ()
  75
  76 class ReadFile a where
  77   readFile' :: FilePath -> IO a
  78
  79
  80 folderFilePath :: (MonadReader env m, MonadBase IO m) => m (FolderPath, FileName)
  81 folderFilePath = do
  82   (foldPath, fileName)  <- liftBase $ (toPath 3) . hash . show <$> newStdGen
  83
  84   pure (foldPath, fileName)
  85
  86
  87 writeFile :: (MonadReader env m, MonadBase IO m, HasConfig env, SaveFile a)
  88           => a -> m FilePath
  89 writeFile a = do
  90   dataPath <- view $ hasConfig . gc_datafilepath
  91
  92   (foldPath, fileName) <- folderFilePath
  93
  94   let filePath = foldPath <> "/" <> fileName
  95       dataFoldPath = dataPath <> "/" <> foldPath
  96       dataFileName = dataPath <> "/" <> filePath
  97
  98   _ <- liftBase $ createDirectoryIfMissing True dataFoldPath
  99   _ <- liftBase $ saveFile' dataFileName a
 100
 101   pure filePath
 102
 103
 104 readFile :: (MonadReader env m, MonadBase IO m, HasConfig env, ReadFile a)
 105          => FilePath -> m a
 106 readFile fp = do
 107   dataPath <- view $ hasConfig . gc_datafilepath
 108   liftBase $ readFile' $ dataPath <> "/" <> fp
 109
 110 removeFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
 111            => FilePath -> m ()
 112 removeFile fp = do
 113   dataPath <- view $ hasConfig . gc_datafilepath
 114   liftBase $ SD.removeFile (dataPath <> "/" <> fp) `catch` handleExists
 115     where
 116       handleExists e
 117         | isDoesNotExistError e = return ()
 118         | otherwise = throwIO e