src/Gargantext/Database/GargDB.hs

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