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