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