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 TODO_1: qualitative  tests (human)
  11 TODO_2: quantitative tests (coded)
  12 -}
  13
  14 module Gargantext.Prelude.Utils
  15   where
  16
  17
  18 import Control.Exception
  19 import Control.Lens (view)
  20 import Control.Monad.Random.Class (MonadRandom)
  21 import Control.Monad.Reader (MonadReader)
  22 import Data.Aeson (ToJSON, toJSON)
  23 import Data.Text (Text)
  24 import Data.Tuple.Extra (both)
  25 import GHC.IO (FilePath)
  26 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
  27 import Gargantext.Database.Prelude (HasConfig(..))
  28 import Gargantext.Prelude
  29 import Gargantext.Prelude.Config
  30 import Gargantext.Prelude.Crypto.Hash
  31 import System.Directory (createDirectoryIfMissing)
  32 import System.IO.Error
  33 import System.Random (newStdGen)
  34 import qualified Data.Text             as Text
  35 import qualified System.Directory as SD
  36 import qualified System.Random.Shuffle as SRS
  37
  38 -------------------------------------------------------------------
  39 -- | Main Class to use (just declare needed functions)
  40 class GargDB a where
  41   write :: a        -> IO ()
  42   read  :: FilePath -> IO a
  43
  44   rm    :: (a, FilePath) -> IO ()
  45   mv    :: (a, FilePath) -> FilePath -> IO ()
  46
  47
  48 -- | Why not this class too ?
  49 class ToJSON parameters => GargDB' parameters gargdata where
  50   write' :: parameters -> gargdata -> IO ()
  51   read'  :: parameters -> IO gargdata
  52
  53   rm'    :: gargdata -> parameters -> IO ()
  54   mv'    :: gargdata -> parameters -> parameters -> IO ()
  55
  56 -------------------------------------------------------------------
  57 -- | Deprecated Class, use GargDB instead
  58 class SaveFile a where
  59   saveFile' :: FilePath -> a -> IO ()
  60
  61 class ReadFile a where
  62   readFile' :: FilePath -> IO a
  63
  64 -------------------------------------------------------------------
  65 -------------------------------------------------------------------
  66 type GargFilePath = (FolderPath, FileName)
  67 -- where
  68 type FolderPath = FilePath
  69 type FileName   = FilePath
  70
  71            --------------------------------
  72
  73 dataFilePath :: (ToJSON a) => a -> GargFilePath
  74 dataFilePath = toPath . hash . show . toJSON
  75
  76 randomFilePath :: ( MonadReader  env m
  77                   , MonadBase IO     m
  78                   )
  79                => m GargFilePath
  80 randomFilePath = do
  81   (foldPath, fileName)  <- liftBase
  82                          $ toPath
  83                          . hash
  84                          . show
  85                          <$> newStdGen
  86   pure (foldPath, fileName)
  87
  88
  89 -- | toPath' : how to hash text to path
  90 {- example of use:
  91 >>> toPath' (1,2) ("","helloword")
  92 ("/he","lloword")
  93
  94 >>> toPath' (2,2) ("","helloword")
  95 ("/he/ll","oword")
  96
  97 >>> toPath' (2,3) ("","helloword")
  98 ("/hel/low","ord")
  99 -}
 100 toPath :: Text -> (FolderPath, FileName)
 101 toPath tx = both Text.unpack $ toPath' (2,3) ("", tx)
 102
 103 toPath' :: (Int,Int) -> (Text,Text) -> (Text,Text)
 104 toPath' (n,m) (t,x) = foldl' (\tx _ -> toPath'' m tx) (t,x) [1..n]
 105
 106 toPath'' :: Int -> (Text, Text) -> (Text, Text)
 107 toPath'' n (fp,fn) = (fp'',fn')
 108   where
 109     (fp',fn') = Text.splitAt n fn
 110     fp''      = Text.intercalate "/" [fp,fp']
 111
 112 -------------------------------------------------------------------
 113 type DataPath   = FilePath
 114 toFilePath :: FilePath -> FilePath -> FilePath
 115 toFilePath fp1 fp2 = fp1 <> "/" <> fp2
 116
 117 -------------------------------------------------------------------
 118
 119 -- | Disk operations
 120 -- | For example, this write file with a random filepath
 121 -- better use a hash of json of Type used to parameter as input
 122 -- the functions
 123 writeFile :: ( MonadReader env m
 124              , HasConfig   env
 125              , MonadBase IO    m
 126              , SaveFile        a
 127              )
 128           => a -> m FilePath
 129 writeFile a = do
 130   dataPath <- view $ hasConfig . gc_datafilepath
 131
 132   (foldPath, fileName) <- randomFilePath
 133
 134   let filePath     = toFilePath foldPath fileName
 135       dataFoldPath = toFilePath dataPath foldPath
 136       dataFileName = toFilePath dataPath filePath
 137
 138   _ <- liftBase $ createDirectoryIfMissing True dataFoldPath
 139   _ <- liftBase $ saveFile' dataFileName a
 140
 141   pure filePath
 142
 143 ---
 144
 145 -- | Example to read a file with Type
 146 readFile :: ( MonadReader  env m
 147             , HasConfig    env
 148             , MonadBase IO     m
 149             , ReadFile         a
 150             )
 151          => FilePath -> m a
 152 readFile fp = do
 153   dataPath <- view $ hasConfig . gc_datafilepath
 154   liftBase $ readFile' $ toFilePath dataPath fp
 155
 156 ---
 157
 158 rmFile :: ( MonadReader env m
 159               , MonadBase IO m
 160               , HasConfig env
 161               )
 162            => FilePath -> m ()
 163 rmFile = onDisk_1 SD.removeFile
 164
 165 cpFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
 166            => FilePath -> FilePath -> m ()
 167 cpFile = onDisk_2 SD.copyFile
 168
 169 ---
 170
 171 mvFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
 172        => FilePath -> FilePath -> m ()
 173 mvFile fp1 fp2 = do
 174   cpFile fp1 fp2
 175   rmFile fp1
 176   pure ()
 177
 178 ------------------------------------------------------------------------
 179 onDisk_1 :: ( MonadReader env m
 180               , MonadBase IO m
 181               , HasConfig env
 182               )
 183         => (FilePath -> IO ()) -> FilePath -> m ()
 184 onDisk_1 action fp = do
 185   dataPath <- view $ hasConfig . gc_datafilepath
 186   liftBase $ action (toFilePath dataPath fp) `catch` handleExists
 187     where
 188       handleExists e
 189         | isDoesNotExistError e = return ()
 190         | otherwise = throwIO e
 191
 192
 193 onDisk_2 :: ( MonadReader env m
 194               , MonadBase IO m
 195               , HasConfig env
 196               )
 197         => (FilePath -> FilePath -> IO ())
 198         -> FilePath
 199         -> FilePath
 200         -> m ()
 201 onDisk_2 action fp1 fp2 = do
 202   dataPath <- view $ hasConfig . gc_datafilepath
 203   let fp1' = toFilePath dataPath fp1
 204       fp2' = toFilePath dataPath fp2
 205   liftBase $ action fp1' fp2' `catch` handleExists
 206     where
 207       handleExists e
 208         | isDoesNotExistError e = return ()
 209         | otherwise = throwIO e
 210 ------------------------------------------------------------------------
 211
 212 ------------------------------------------------------------------------
 213 -- | Misc Utils
 214 shuffle :: MonadRandom m => [a] -> m [a]
 215 shuffle ns = SRS.shuffleM ns
 216 --------------------------------------------------------------------------
 217
 218 -- TODO gargDB instance for NodeType
 219 data NodeToHash = NodeToHash { nodeType :: NodeType
 220                              , nodeId   :: NodeId
 221                              }
 222