GargDB.hs 5.77 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14
{-|
Module      : Gargantext.Prelude.GargDB
Description : Useful Tools near Prelude of the project
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

TODO_1: qualitative  tests (human)
TODO_2: quantitative tests (coded)

-}

Alexandre Delanoë's avatar
Alexandre Delanoë committed
15
module Gargantext.Database.GargDB
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
  where

import Control.Exception
import Control.Lens (view)
import Control.Monad.Reader (MonadReader)
import Data.Aeson (ToJSON, toJSON)
import Data.Text (Text)
import Data.Tuple.Extra (both)
import GHC.IO (FilePath)
import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config
import Gargantext.Prelude.Crypto.Hash
import System.Directory (createDirectoryIfMissing)
import System.IO.Error
import System.Random (newStdGen)
import qualified Data.Text             as Text
import qualified System.Directory      as SD

-------------------------------------------------------------------
-- | Main Class to use (just declare needed functions)
class GargDB a where
  write :: a        -> IO ()
  read  :: FilePath -> IO a

  rm    :: (a, FilePath) -> IO ()
  mv    :: (a, FilePath) -> FilePath -> IO ()


-- | Why not this class too ?
class ToJSON parameters => GargDB' parameters gargdata where
  write' :: parameters -> gargdata -> IO ()
  read'  :: parameters -> IO gargdata

  rm'    :: gargdata -> parameters -> IO ()
  mv'    :: gargdata -> parameters -> parameters -> IO ()

-------------------------------------------------------------------
-- | Deprecated Class, use GargDB instead
class SaveFile a where
  saveFile' :: FilePath -> a -> IO ()

class ReadFile a where
  readFile' :: FilePath -> IO a

-------------------------------------------------------------------
-------------------------------------------------------------------
type GargFilePath = (FolderPath, FileName)
-- where
type FolderPath = FilePath
type FileName   = FilePath

           --------------------------------

dataFilePath :: (ToJSON a) => a -> GargFilePath
dataFilePath = toPath . hash . show . toJSON

randomFilePath :: ( MonadReader  env m
                  , MonadBase IO     m
                  )
               => m GargFilePath
randomFilePath = do
  (foldPath, fileName)  <- liftBase
                         $ toPath
                         . hash
                         . show
                         <$> newStdGen
  pure (foldPath, fileName)


-- | toPath' : how to hash text to path
{- example of use:
>>> toPath' (1,2) ("","helloword")
("/he","lloword")

>>> toPath' (2,2) ("","helloword")
("/he/ll","oword")

>>> toPath' (2,3) ("","helloword")
("/hel/low","ord")
-}
toPath :: Text -> (FolderPath, FileName)
toPath tx = both Text.unpack $ toPath' (2,3) ("", tx)

toPath' :: (Int,Int) -> (Text,Text) -> (Text,Text)
toPath' (n,m) (t,x) = foldl' (\tx _ -> toPath'' m tx) (t,x) [1..n]

toPath'' :: Int -> (Text, Text) -> (Text, Text)
toPath'' n (fp,fn) = (fp'',fn')
  where
    (fp',fn') = Text.splitAt n fn
    fp''      = Text.intercalate "/" [fp,fp']

-------------------------------------------------------------------
type DataPath   = FilePath
toFilePath :: FilePath -> FilePath -> FilePath
toFilePath fp1 fp2 = fp1 <> "/" <> fp2

-------------------------------------------------------------------

-- | Disk operations
-- | For example, this write file with a random filepath
118
-- better use a hash of json of Type used to parameter as input
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
-- the functions
writeFile :: ( MonadReader env m
             , HasConfig   env
             , MonadBase IO    m
             , SaveFile        a
             )
          => a -> m FilePath
writeFile a = do
  dataPath <- view $ hasConfig . gc_datafilepath

  (foldPath, fileName) <- randomFilePath

  let filePath     = toFilePath foldPath fileName
      dataFoldPath = toFilePath dataPath foldPath
      dataFileName = toFilePath dataPath filePath

  _ <- liftBase $ createDirectoryIfMissing True dataFoldPath
  _ <- liftBase $ saveFile' dataFileName a

  pure filePath

---

142
-- | Example to read a file with Type
143
readGargFile :: ( MonadReader  env m
144 145 146 147 148
            , HasConfig    env
            , MonadBase IO     m
            , ReadFile         a
            )
         => FilePath -> m a
149
readGargFile fp = do
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
  dataPath <- view $ hasConfig . gc_datafilepath
  liftBase $ readFile' $ toFilePath dataPath fp

---

rmFile :: ( MonadReader env m
              , MonadBase IO m
              , HasConfig env
              )
           => FilePath -> m ()
rmFile = onDisk_1 SD.removeFile

cpFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
           => FilePath -> FilePath -> m ()
cpFile = onDisk_2 SD.copyFile

---

mvFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
       => FilePath -> FilePath -> m ()
mvFile fp1 fp2 = do
  cpFile fp1 fp2
  rmFile fp1
  pure ()

------------------------------------------------------------------------
onDisk_1 :: ( MonadReader env m
              , MonadBase IO m
              , HasConfig env
              )
        => (FilePath -> IO ()) -> FilePath -> m ()
onDisk_1 action fp = do
  dataPath <- view $ hasConfig . gc_datafilepath
  liftBase $ action (toFilePath dataPath fp) `catch` handleExists
    where
      handleExists e
        | isDoesNotExistError e = return ()
        | otherwise = throwIO e


onDisk_2 :: ( MonadReader env m
              , MonadBase IO m
              , HasConfig env
              )
        => (FilePath -> FilePath -> IO ())
        -> FilePath
        -> FilePath
        -> m ()
onDisk_2 action fp1 fp2 = do
  dataPath <- view $ hasConfig . gc_datafilepath
  let fp1' = toFilePath dataPath fp1
      fp2' = toFilePath dataPath fp2
  liftBase $ action fp1' fp2' `catch` handleExists
    where
      handleExists e
        | isDoesNotExistError e = return ()
        | otherwise = throwIO e
------------------------------------------------------------------------